!----------------------------------------------------------------------- ! MODULE MODULE_PARENT_CHILD_CPL_COMP ! !----------------------------------------------------------------------- ! !*** This module contains the coupler that exchanges data between !*** NMM-B parent domains and their children. ! !----------------------------------------------------------------------- ! ! PROGRAM HISTORY LOG: ! ! 2008-06-12 Black - Module created. ! 2009-02-19 Black - Hydrostatic update of nest boundaries. ! 2010-01-20 Black - Enable parent tasks to update associations ! with nest boundary tasks throughout the ! integration. ! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, ! ESMF 5 series library and the the ! ESMF 3.1.0rp2 library. ! 2011-05-12 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. ! 2011-07-16 Black - Add moving nest capability. ! 2011-09-27 Yang - Modified for using the ESMF 5.2.0r library. ! 2012-07-20 Black - Add generational use of MPI tasks. ! !----------------------------------------------------------------------- ! ! USAGE: ! !----------------------------------------------------------------------- ! USE MPI USE ESMF ! USE module_KINDS ! USE module_DERIVED_TYPES,ONLY: BC_H & ,BC_V & ,BNDS_2D & ,CHILD_UPDATE_LINK & ,CTASK_LIMITS & ,HANDLE_CHILD_LIMITS & ,HANDLE_CHILD_TOPO_S & ,HANDLE_CHILD_TOPO_N & ,HANDLE_CHILD_TOPO_W & ,HANDLE_CHILD_TOPO_E & ,HANDLE_I_SW & ,HANDLE_J_SW & ,HANDLE_PACKET_S_H & ,HANDLE_PACKET_S_V & ,HANDLE_PACKET_N_H & ,HANDLE_PACKET_N_V & ,HANDLE_PACKET_W_H & ,HANDLE_PACKET_W_V & ,HANDLE_PACKET_E_H & ,HANDLE_PACKET_E_V & ,HANDLE_PARENT_DOM_LIMITS & ,HANDLE_PARENT_ITE & ,HANDLE_PARENT_ITS & ,HANDLE_PARENT_JTE & ,HANDLE_PARENT_JTS & ,INFO_SEND & ,INTEGER_DATA & ,INTEGER_DATA_2D & ,INTERIOR_DATA_FROM_PARENT & ,MIXED_DATA & ,MIXED_DATA_TASKS & ,MULTIDATA & ,REAL_DATA & ,REAL_DATA_TASKS & ,PTASK_LIMITS & ,REAL_DATA_2D & ,REAL_VBLS_3D ! USE module_CONTROL,ONLY: NUM_DOMAINS_MAX,TIMEF ! USE module_EXCHANGE,ONLY: HALO_EXCH ! USE module_VARS,ONLY: VAR ! USE module_NESTING,ONLY: CHECK_REAL & ,CHILD_2WAY_BOOKKEEPING & ,CHILD_RANKS & ,GENERATE_2WAY_DATA & ,HYPERBOLA & ,LAG_STEPS & ,MOVING_NEST_BOOKKEEPING & ,MOVING_NEST_RECV_DATA & ,PARENT_2WAY_BOOKKEEPING & ,PARENT_BOOKKEEPING_MOVING & ,PARENT_READS_MOVING_CHILD_TOPO & ,PARENT_UPDATES_HALOS & ,PARENT_UPDATES_MOVING & ,STENCIL_H_EVEN & ,STENCIL_V_EVEN & ,STENCIL_SFC_H_EVEN & ,STENCIL_SFC_V_EVEN & ,STENCIL_H_ODD & ,STENCIL_V_ODD & ,STENCIL_SFC_H_ODD & ,STENCIL_SFC_V_ODD ! USE module_CONSTANTS,ONLY: A,G,P608,R_D ! USE MODULE_MY_DOMAIN_SPECS, IDS_share=>IDS,IDE_share=>IDE & ,IMS_share=>IMS,IME_share=>IME & ,ITS_share=>ITS,ITE_share=>ITE & ,JDS_share=>JDS,JDE_share=>JDE & ,JMS_share=>JMS,JME_share=>JME & ,JTS_share=>JTS,JTE_share=>JTE & ! ,MPI_COMM_COMP_share=>MPI_COMM_COMP & ,MYPE_share=>MYPE & ,MY_NEB_share=>MY_NEB & ! ,LOCAL_ISTART_share=>LOCAL_ISTART & ,LOCAL_IEND_share =>LOCAL_IEND & ,LOCAL_JSTART_share=>LOCAL_JSTART & ,LOCAL_JEND_share =>LOCAL_JEND ! USE module_CLOCKTIMES,ONLY: cbcst_tim,pbcst_tim ! USE module_DIAGNOSE,ONLY: HMAXMIN,VMAXMIN ! USE module_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK ! !----------------------------------------------------------------------- ! IMPLICIT NONE ! !----------------------------------------------------------------------- ! PRIVATE ! PUBLIC :: PARENT_CHILD_CPL_REGISTER & ,PARENT_CHILD_COUPLER_SETUP & ,NSTEP_CHILD_RECV ! !----------------------------------------------------------------------- ! TYPE BOUNDARY_SIDES !<-- Hold the boundary blending region along each side of a domain REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SOUTH REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: NORTH REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEST REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: EAST END TYPE BOUNDARY_SIDES ! TYPE INTEGER_DATA_TASKS INTEGER(kind=KINT),DIMENSION(:),POINTER :: TASKS END TYPE INTEGER_DATA_TASKS ! TYPE SIDES_0D INTEGER(kind=KINT) :: SOUTH INTEGER(kind=KINT) :: NORTH INTEGER(kind=KINT) :: WEST INTEGER(kind=KINT) :: EAST END TYPE SIDES_0D ! TYPE SIDES_2D INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SOUTH INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: NORTH INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: WEST INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: EAST END TYPE SIDES_2D ! TYPE SAVE_TASK_IJ INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_LO_SOUTH INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_SOUTH INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_SOUTH_TRANSFER INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_LO_NORTH INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_NORTH INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_NORTH_TRANSFER INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_LO_WEST INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_WEST INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_WEST_TRANSFER INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_LO_EAST INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_EAST INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_EAST_TRANSFER END TYPE SAVE_TASK_IJ ! TYPE HANDLE_SEND INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_TO_RECV !<-- Parent MPI handles used when ISend'ing to each child task END TYPE HANDLE_SEND ! TYPE DATA_INFO REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: STRING INTEGER(kind=KINT) :: LENGTH INTEGER(kind=KINT) :: ID_SOURCE INTEGER(kind=KINT) :: INDX_START INTEGER(kind=KINT) :: INDX_END INTEGER(kind=KINT) :: INDX_END_EXP END TYPE DATA_INFO ! TYPE PARENT_DATA TYPE(DATA_INFO) :: SOUTH_H TYPE(DATA_INFO) :: SOUTH_V TYPE(DATA_INFO) :: NORTH_H TYPE(DATA_INFO) :: NORTH_V TYPE(DATA_INFO) :: WEST_H TYPE(DATA_INFO) :: WEST_V TYPE(DATA_INFO) :: EAST_H TYPE(DATA_INFO) :: EAST_V END TYPE PARENT_DATA ! TYPE PARENT_POINTS_SURROUND_H !<-- Indices of parent points around each child bndry H point INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_NBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_SBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_EBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_WBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_NBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_SBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_EBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_WBND END TYPE PARENT_POINTS_SURROUND_H ! TYPE PARENT_POINTS_SURROUND_V !<-- Indices of parent points around each child bndry V point INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_NBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_SBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_EBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_WBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_NBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_SBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_EBND INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_WBND END TYPE PARENT_POINTS_SURROUND_V ! TYPE PARENT_WEIGHTS_SURROUND_H !<-- Bilinear interpolation weights of the 4 parent points REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_NBND ! around each child boundary H point REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_SBND REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_EBND REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_WBND END TYPE PARENT_WEIGHTS_SURROUND_H ! TYPE PARENT_WEIGHTS_SURROUND_V !<-- Bilinear interpolation weights of the 4 parent points REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_NBND ! around each child boundary H point REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_SBND REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_EBND REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_WBND END TYPE PARENT_WEIGHTS_SURROUND_V ! !----------------------------------------------------------------------- !*** In 1-way nesting the MPI tasks lie on only one domain but !*** in 2-way nesting the tasks can lie on more than one domain. !*** The composite object holds quantities in the Parent-Child !*** coupler that vary depending on which domain they are on. !*** The composite object differentiates between the quantities !*** inside it. The tasks point into the proper element of the !*** object with unallocated pointers to access the quantities !*** for the desired domain. !----------------------------------------------------------------------- ! !----------------------------------- !*** The composite type definition !----------------------------------- ! TYPE COMPOSITE ! INTEGER(kind=KINT) :: NCYCLE_CHILD & ,NCYCLE_PARENT ! INTEGER(kind=KINT) :: COMM_TO_MY_PARENT INTEGER(kind=KINT) :: HANDLE_MOVE_FLAG INTEGER(kind=KINT) :: HANDLE_SEND_2WAY_SIGNAL INTEGER(kind=KINT) :: I_CENTER_CURRENT INTEGER(kind=KINT) :: I_SHIFT_CHILD INTEGER(kind=KINT) :: J_SHIFT_CHILD INTEGER(kind=KINT) :: I_SW_PARENT_CURRENT INTEGER(kind=KINT) :: I_SW_PARENT_NEW INTEGER(kind=KINT) :: J_CENTER_CURRENT INTEGER(kind=KINT) :: J_SW_PARENT_CURRENT INTEGER(kind=KINT) :: J_SW_PARENT_NEW INTEGER(kind=KINT) :: ITS,ITE,JTS,JTE,LM INTEGER(kind=KINT) :: IMS,IME,JMS,JME INTEGER(kind=KINT) :: IDS,IDE,JDS,JDE INTEGER(kind=KINT) :: IM_1,JM_1,JM INTEGER(kind=KINT) :: INPES,JNPES INTEGER(kind=KINT) :: INPES_PARENT,JNPES_PARENT INTEGER(kind=KINT) :: KOUNT_2WAY_CHILDREN INTEGER(kind=KINT) :: LAST_STEP_MOVED INTEGER(kind=KINT) :: MAX_SHIFT INTEGER(kind=KINT) :: MYPE INTEGER(kind=KINT) :: N_BLEND_H,N_BLEND_V INTEGER(kind=KINT) :: N_STENCIL_H,N_STENCIL_SFC_H INTEGER(kind=KINT) :: N_STENCIL_V,N_STENCIL_SFC_V INTEGER(kind=KINT) :: NEXT_MOVE_TIMESTEP INTEGER(kind=KINT) :: NHALO INTEGER(kind=KINT) :: NLEV_H INTEGER(kind=KINT) :: NLEV_V INTEGER(kind=KINT) :: NPHS INTEGER(kind=KINT) :: NTASKS_UPDATE_PARENT INTEGER(kind=KINT) :: NTIMESTEP_CHECK INTEGER(kind=KINT) :: NTIMESTEP_FINAL INTEGER(kind=KINT) :: NTIMESTEP_WAIT_PARENT INTEGER(kind=KINT) :: NTIMESTEP_WAIT_FORCED_PARENT INTEGER(kind=KINT) :: NTIMESTEPS_RESTART INTEGER(kind=KINT) :: NTOT_SFC INTEGER(kind=KINT) :: NTRACK INTEGER(kind=KINT) :: NUM_CHILDREN INTEGER(kind=KINT) :: NUM_2WAY_CHILDREN INTEGER(kind=KINT) :: NUM_MOVING_CHILDREN INTEGER(kind=KINT) :: NUM_PES_FCST INTEGER(kind=KINT) :: NUM_FCST_TASKS_PARENT INTEGER(kind=KINT) :: NUM_TASKS_PARENT INTEGER(kind=KINT) :: NUM_LEVELS_MOVE_3D_H INTEGER(kind=KINT) :: NUM_LEVELS_MOVE_3D_V INTEGER(kind=KINT) :: NUM_SPACE_RATIOS_MVG INTEGER(kind=KINT) :: NVARS_BC_2D_H INTEGER(kind=KINT) :: NVARS_BC_3D_H INTEGER(kind=KINT) :: NVARS_BC_4D_H INTEGER(kind=KINT) :: NVARS_BC_2D_V INTEGER(kind=KINT) :: NVARS_BC_3D_V INTEGER(kind=KINT) :: SPACE_RATIO_MY_PARENT INTEGER(kind=KINT) :: TIME_RATIO_MY_PARENT ! INTEGER(kind=KINT),DIMENSION(1:2) :: MY_FORCED_SHIFT INTEGER(kind=KINT),DIMENSION(1:2) :: STORM_CENTER INTEGER(kind=KINT),DIMENSION(1:3) :: PARENT_SHIFT INTEGER(kind=KINT),DIMENSION(1:4) :: MY_DOMAIN_LIMITS INTEGER(kind=KINT),DIMENSION(1:4) :: PARENT_DOMAIN_LIMITS INTEGER(kind=KINT),DIMENSION(1:8) :: MY_NEB ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: PARENT_CHILD_SPACE_RATIO INTEGER(kind=KINT),DIMENSION(:),POINTER :: TIME_RATIO_MY_CHILDREN INTEGER(kind=KINT),DIMENSION(:),POINTER :: IM_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: JM_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PARENT_SW INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_PARENT_SW INTEGER(kind=KINT),DIMENSION(:),POINTER :: ITE_PARENT INTEGER(kind=KINT),DIMENSION(:),POINTER :: ITS_PARENT INTEGER(kind=KINT),DIMENSION(:),POINTER :: JTE_PARENT INTEGER(kind=KINT),DIMENSION(:),POINTER :: JTS_PARENT INTEGER(kind=KINT),DIMENSION(:),POINTER :: LINK_MRANK_RATIO INTEGER(kind=KINT),DIMENSION(:),POINTER :: LIST_OF_RATIOS INTEGER(kind=KINT),DIMENSION(:),POINTER :: M_NEST_RATIO INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_BLEND_H_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_BLEND_V_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_H_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_SFC_H_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_V_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_SFC_V_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_UPDATE_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: NSTEP_CHILD_RECV INTEGER(kind=KINT),DIMENSION(:),POINTER :: INC_FIX INTEGER(kind=KINT),DIMENSION(:),POINTER :: COMM_TO_MY_CHILDREN INTEGER(kind=KINT),DIMENSION(:),POINTER :: ID_PARENTS INTEGER(kind=KINT),DIMENSION(:),POINTER :: ID_PARENT_UPDATE_TASKS INTEGER(kind=KINT),DIMENSION(:),POINTER :: MY_CHILDREN_ID INTEGER(kind=KINT),DIMENSION(:),POINTER :: RANK_2WAY_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: RANK_MOVING_CHILD INTEGER(kind=KINT),DIMENSION(:),POINTER :: FTASKS_DOMAIN INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_DOMAIN INTEGER(kind=KINT),DIMENSION(:),POINTER :: NPTS_UPDATE_ON_PARENT_TASKS INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_BC_UPDATE INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_PARENT_SHIFT INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_TIMESTEP INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_2WAY_DATA INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_2WAY_SFC INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_ALLCLEAR INTEGER(kind=KINT),DIMENSION(:),POINTER :: LBND_4D INTEGER(kind=KINT),DIMENSION(:),POINTER :: UBND_4D INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_ISTART INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_IEND INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_JSTART INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_JEND INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTIMESTEP_CHILD_MOVES INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_S INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_N INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_W INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_E INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_S INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_N INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_W INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_E INTEGER(kind=KINT),DIMENSION(:),POINTER :: SHIFT_INFO_MINE ! INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SHIFT_INFO_CHILDREN ! REAL(kind=KFPT) :: CENTERS_DISTANCE REAL(kind=KFPT) :: DLM REAL(kind=KFPT) :: DPH REAL(kind=KFPT) :: DYH REAL(kind=KFPT) :: PDTOP REAL(kind=KFPT) :: PT REAL(kind=KFPT) :: SB_1 REAL(kind=KFPT) :: WB_1 REAL(kind=KFPT) :: TPH0_1 REAL(kind=KFPT) :: TLM0_1 REAL(kind=KFPT) :: RECIP_DPH_1 REAL(kind=KFPT) :: RECIP_DLM_1 REAL(kind=KFPT) :: RECIP_PARENT_SPACE_RATIO ! REAL(kind=KFPT),DIMENSION(:),POINTER :: DT_DOMAIN REAL(kind=KFPT),DIMENSION(:),POINTER :: DXH REAL(kind=KFPT),DIMENSION(:),POINTER :: DSG2 REAL(kind=KFPT),DIMENSION(:),POINTER :: PDSG1 REAL(kind=KFPT),DIMENSION(:),POINTER :: PSGML1 REAL(kind=KFPT),DIMENSION(:),POINTER :: SG1 REAL(kind=KFPT),DIMENSION(:),POINTER :: SG2 REAL(kind=KFPT),DIMENSION(:),POINTER :: SGML2 ! REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_2WAY_WGT REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_PARENT_SPACE_RATIO ! REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_H REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_V REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_NORTH_H REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_NORTH_V REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_WEST_H REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_WEST_V REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_EAST_H REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_EAST_V ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS_CHILD_ON_PARENT REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLAT REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLON REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PD REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SM REAL(kind=KFPT),DIMENSION(:,:),POINTER :: U10 REAL(kind=KFPT),DIMENSION(:,:),POINTER :: V10 ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_S REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_N REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_W REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_E ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CW REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: PINT REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Q REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: T REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: U REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: V REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Z ! REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS ! CHARACTER(len=6),DIMENSION(:),POINTER :: STATIC_OR_MOVING ! LOGICAL(kind=KLOG) :: CALLED_CHILD_2WAY_BOOKKEEPING LOGICAL(kind=KLOG) :: CHILD_FORCES_MY_SHIFT LOGICAL(kind=KLOG) :: FIRST_CALL_RECV_2WAY LOGICAL(kind=KLOG) :: FIRST_CALL_RECV_BC LOGICAL(kind=KLOG) :: FORCED_PARENT_SHIFT LOGICAL(kind=KLOG) :: I_AM_ACTIVE LOGICAL(kind=KLOG) :: I_AM_LEAD_FCST_TASK LOGICAL(kind=KLOG) :: I_WANT_TO_MOVE LOGICAL(kind=KLOG) :: MOVE_FLAG_SENT LOGICAL(kind=KLOG) :: MY_PARENT_MOVES LOGICAL(kind=KLOG) :: PARENT_WANTS_TO_MOVE LOGICAL(kind=KLOG) :: STOP_MY_MOTION ! LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CHILD_ACTIVE LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: MOVE_FLAG LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SEND_CHILD_DATA LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: CALLED_PARENT_2WAY_BOOKKEEPING LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: SIGNAL_2WAY_SEND_READY LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: SKIP_2WAY_UPDATE ! TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_UPDATE TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_UPDATE TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_H TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_H TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_V TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_V ! TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_SOUTH TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_NORTH TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_WEST TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_EAST TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_SOUTH TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_NORTH TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_WEST TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_EAST ! TYPE(REAL_DATA),DIMENSION(:),POINTER :: UPDATE_PARENT_2WAY ! TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: CHILD_SFC_ON_PARENT TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_V_ON_PARENT ! TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_NORTH TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_WEST TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_EAST ! TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH_V TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_NORTH_V TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_WEST_V TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_EAST_V ! TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_SOUTH TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_NORTH TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_WEST TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_EAST ! TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_SOUTH TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_NORTH TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_WEST TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_EAST ! TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_SOUTH TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_NORTH TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_WEST TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_EAST ! TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_SOUTH TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_NORTH TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_WEST TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_EAST TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_SOUTH TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_NORTH TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_WEST TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_EAST ! TYPE(BC_H) :: MY_BC_VARS_H_S TYPE(BC_H) :: MY_BC_VARS_H_N TYPE(BC_H) :: MY_BC_VARS_H_W TYPE(BC_H) :: MY_BC_VARS_H_E ! TYPE(BC_V) :: MY_BC_VARS_V_S TYPE(BC_V) :: MY_BC_VARS_V_N TYPE(BC_V) :: MY_BC_VARS_V_W TYPE(BC_V) :: MY_BC_VARS_V_E ! TYPE(MIXED_DATA_TASKS),DIMENSION(:),POINTER :: MOVING_CHILD_UPDATE ! TYPE(BNDS_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT_BNDS ! TYPE(SIDES_0D) :: INDX_MAX_H,INDX_MAX_V TYPE(SIDES_0D) :: INDX_MIN_H,INDX_MIN_V TYPE(SIDES_0D) :: NUM_PARENT_TASKS_SENDING_H TYPE(SIDES_0D) :: NUM_PARENT_TASKS_SENDING_V ! TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_H_RANKS TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_V_RANKS ! TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_H_SAVE TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_V_SAVE ! TYPE(PARENT_POINTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_INDICES_H TYPE(PARENT_POINTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_INDICES_V ! TYPE(PARENT_WEIGHTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_H TYPE(PARENT_WEIGHTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_V ! TYPE(PARENT_DATA),DIMENSION(:),POINTER :: PARENT_TASK ! TYPE(CHILD_UPDATE_LINK),DIMENSION(:),POINTER :: TASK_UPDATE_SPECS & ,CHILD_TASKS_2WAY_UPDATE ! TYPE(HANDLE_SEND),DIMENSION(:),POINTER :: HANDLE_MOVE_DATA ! TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_SOUTH TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_NORTH TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_WEST TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_EAST TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_SOUTH TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_NORTH TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_WEST TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_EAST ! TYPE(ESMF_Config) :: CF_MINE TYPE(ESMF_Config) :: CF_PARENT TYPE(ESMF_Config),DIMENSION(:),POINTER :: CF ! TYPE(ESMF_FieldBundle) :: BUNDLE_2WAY TYPE(ESMF_FieldBundle) :: BUNDLE_NESTBC TYPE(ESMF_FieldBundle) :: MOVE_BUNDLE_H TYPE(ESMF_FieldBundle) :: MOVE_BUNDLE_V ! LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_PRESENT & ,I_AM_A_FCST_TASK & ,I_AM_A_PARENT & ,MY_DOMAIN_MOVES & ,RECV_ALL_CHILD_DATA ! REAL(kind=KDBL) :: cpl1_prelim_tim & ,cpl1_south_h_tim,cpl1_south_v_tim & ,cpl1_north_h_tim,cpl1_north_v_tim & ,cpl1_west_h_tim, cpl1_west_v_tim & ,cpl1_east_h_tim, cpl1_east_v_tim & ,cpl1_recv_tim ! REAL(kind=KDBL) :: cpl1_south_h_recv_tim & ,cpl1_south_h_undo_tim & ,cpl1_south_h_exp_tim & ,cpl1_south_v_recv_tim & ,cpl1_south_v_undo_tim & ,cpl1_south_v_exp_tim ! REAL(kind=KDBL) :: cpl2_comp_tim & ,cpl2_send_tim & ,cpl2_wait_tim ! REAL(kind=KDBL) :: moving_nest_bookkeep_tim & ,moving_nest_update_tim ! REAL(kind=KDBL) :: parent_bookkeep_moving_tim & ,parent_update_moving_tim & ,t0_recv_move_tim & ,read_moving_child_topo_tim & ,barrier_move_tim,pscd_tim,pscd1_tim & ,pscd2_tim,pscd3_tim,pscd4_tim ! REAL(kind=KDBL) :: ja1_tim,ja2_tim,ja3_tim,ja4_tim,jat_tim ! !*** The following are for moving nests. ! CHARACTER(len=32) :: MOVE_TYPE ! INTEGER(kind=KINT) :: I_EAST_M,I_WEST_M,J_NORTH_M,J_SOUTH_M INTEGER(kind=KINT) :: I_MAX,I_MIN,J_MAX,J_MIN INTEGER(kind=KINT) :: NPTS_NS,NPTS_WE ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PG,J_PG ! REAL(kind=KFPT) :: COEF REAL(kind=KFPT) :: ELAPSED_TIME_MIN REAL(kind=KFPT) :: RNPTS_HZ ! LOGICAL(kind=KLOG) :: FIRST_PASS_M LOGICAL(kind=KLOG) :: FIRST_STEP_2WAY LOGICAL(kind=KLOG) :: I_HOLD_CENTER_POINT ! LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: IN_WINDOW=>NULL() LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: I_HOLD_PG_POINT ! !*** The following are for prescribed moves ! INTEGER(kind=KINT) :: MOVE_INTERVAL_MINUTES INTEGER(kind=KINT) :: N_MOVES REAL(kind=KFPT),DIMENSION(:),POINTER :: MOVE_MINUTE INTEGER(kind=KINT),DIMENSION(:),POINTER :: MOVE_I_SW,MOVE_J_SW ! END TYPE COMPOSITE ! !----------------------------------------------------------------------- !*** Now declare the composite object. It will hold all of the !*** above quantities separately for each domain a task is on. !----------------------------------------------------------------------- ! TYPE(COMPOSITE),DIMENSION(:),POINTER,SAVE :: CPL_COMPOSITE !<-- Coupler's composite object of domain variables ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Declare generic pointers that will point into the composite !*** object. We want to be able to do this so that the standard !*** names of the generic pointers can be used where desired. !----------------------------------------------------------------------- ! INTEGER(kind=KINT),POINTER :: NCYCLE_CHILD & ,NCYCLE_PARENT ! INTEGER(kind=KINT),POINTER :: COMM_TO_MY_PARENT & ,HANDLE_MOVE_FLAG & ,HANDLE_SEND_2WAY_SIGNAL & ,I_CENTER_CURRENT & ,I_SHIFT_CHILD & ,J_SHIFT_CHILD & ,I_SW_PARENT_CURRENT & ,I_SW_PARENT_NEW & ,J_CENTER_CURRENT & ,J_SW_PARENT_CURRENT & ,J_SW_PARENT_NEW & ,ITS,ITE,JTS,JTE,LM & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE & ,IM_1,JM_1 & ,INPES,JNPES & ,INPES_PARENT,JNPES_PARENT & ,JM & ,KOUNT_2WAY_CHILDREN & ,LAST_STEP_MOVED & ,MAX_SHIFT & ,MYPE & ,N_BLEND_H,N_BLEND_V & ,N_STENCIL_H,N_STENCIL_SFC_H & ,N_STENCIL_V,N_STENCIL_SFC_V & ,NHALO & ,NLEV_H & ,NLEV_V & ,NPHS & ,NTASKS_UPDATE_PARENT & ,NTIMESTEP_CHECK & ,NTIMESTEP_FINAL & ,NTIMESTEP_WAIT_PARENT & ,NTIMESTEP_WAIT_FORCED_PARENT & ,NTIMESTEPS_RESTART & ,NTOT_SFC & ,NTRACK & ,NUM_CHILDREN & ,NUM_2WAY_CHILDREN & ,NUM_MOVING_CHILDREN & ,NUM_PES_FCST & ,NUM_FCST_TASKS_PARENT & ,NUM_TASKS_PARENT & ,NEXT_MOVE_TIMESTEP & ,NUM_LEVELS_MOVE_3D_H & ,NUM_LEVELS_MOVE_3D_V & ,NUM_SPACE_RATIOS_MVG & ,NVARS_BC_2D_H & ,NVARS_BC_3D_H & ,NVARS_BC_4D_H & ,NVARS_BC_2D_V & ,NVARS_BC_3D_V & ,SPACE_RATIO_MY_PARENT & ,TIME_RATIO_MY_PARENT ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: DOMAIN_ID_TO_RANK & ,MY_DOMAIN_LIMITS & ,MY_FORCED_SHIFT & ,MY_NEB & ,PARENT_DOMAIN_LIMITS & ,PARENT_SHIFT & ,STORM_CENTER ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: PARENT_CHILD_SPACE_RATIO & ,TIME_RATIO_MY_CHILDREN & ,IM_CHILD & ,JM_CHILD & ,I_PARENT_SW & ,J_PARENT_SW & ,ITE_PARENT & ,ITS_PARENT & ,JTE_PARENT & ,JTS_PARENT & ,LBND_4D & ,UBND_4D & ,LINK_MRANK_RATIO & ,LIST_OF_RATIOS & ,LOCAL_ISTART & ,LOCAL_IEND & ,LOCAL_JSTART & ,LOCAL_JEND & ,M_NEST_RATIO & ,N_BLEND_H_CHILD & ,N_BLEND_V_CHILD & ,N_STENCIL_H_CHILD & ,N_STENCIL_SFC_H_CHILD & ,N_STENCIL_V_CHILD & ,N_STENCIL_SFC_V_CHILD & ,NTASKS_UPDATE_CHILD & ,NSTEP_CHILD_RECV & ,INC_FIX & ,COMM_TO_MY_CHILDREN & ,ID_PARENTS & ,ID_PARENT_UPDATE_TASKS & ,MY_CHILDREN_ID & ,RANK_2WAY_CHILD & ,RANK_MOVING_CHILD & ,FTASKS_DOMAIN & ,NTASKS_DOMAIN & ,NPTS_UPDATE_ON_PARENT_TASKS & ,HANDLE_BC_UPDATE & ,HANDLE_PARENT_SHIFT & ,HANDLE_TIMESTEP & ,HANDLE_SEND_2WAY_DATA & ,HANDLE_SEND_2WAY_SFC & ,HANDLE_SEND_ALLCLEAR & ,NTIMESTEP_CHILD_MOVES & ,NUM_TASKS_SEND_H_S & ,NUM_TASKS_SEND_H_N & ,NUM_TASKS_SEND_H_W & ,NUM_TASKS_SEND_H_E & ,NUM_TASKS_SEND_V_S & ,NUM_TASKS_SEND_V_N & ,NUM_TASKS_SEND_V_W & ,NUM_TASKS_SEND_V_E & ,SHIFT_INFO_MINE ! INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SHIFT_INFO_CHILDREN ! REAL(kind=KFPT),POINTER :: CENTERS_DISTANCE & ,DLM & ,DPH & ,DYH & ,PDTOP & ,PT & ,SB_1 & ,WB_1 & ,TPH0_1 & ,TLM0_1 & ,RECIP_DPH_1 & ,RECIP_DLM_1 & ,RECIP_PARENT_SPACE_RATIO ! REAL(kind=KFPT),DIMENSION(:),POINTER :: DT_DOMAIN & ,DXH & ,DSG2 & ,PDSG1 & ,PSGML1 & ,SG1 & ,SG2 & ,SGML2 ! REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_2WAY_WGT & ,CHILD_PARENT_SPACE_RATIO ! REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_H & ,BOUND_1D_SOUTH_V & ,BOUND_1D_NORTH_H & ,BOUND_1D_NORTH_V & ,BOUND_1D_WEST_H & ,BOUND_1D_WEST_V & ,BOUND_1D_EAST_H & ,BOUND_1D_EAST_V ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS & ,FIS_CHILD_ON_PARENT & ,GLAT & ,GLON & ,PD & ,SM & ,U10 & ,V10 ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_S & ,PDB_N & ,PDB_W & ,PDB_E ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CW & ,PINT & ,Q & ,T & ,U & ,V & ,Z ! REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS ! CHARACTER(len=6),DIMENSION(:),POINTER,SAVE :: STATIC_OR_MOVING ! LOGICAL(kind=KLOG),POINTER :: CALLED_CHILD_2WAY_BOOKKEEPING LOGICAL(kind=KLOG),POINTER :: CHILD_FORCES_MY_SHIFT LOGICAL(kind=KLOG),POINTER :: FIRST_CALL_RECV_2WAY LOGICAL(kind=KLOG),POINTER :: FIRST_CALL_RECV_BC LOGICAL(kind=KLOG),POINTER :: FORCED_PARENT_SHIFT LOGICAL(kind=KLOG),POINTER :: I_AM_ACTIVE LOGICAL(kind=KLOG),POINTER :: I_AM_LEAD_FCST_TASK LOGICAL(kind=KLOG),POINTER :: I_WANT_TO_MOVE LOGICAL(kind=KLOG),POINTER :: MOVE_FLAG_SENT LOGICAL(kind=KLOG),POINTER :: MY_PARENT_MOVES LOGICAL(kind=KLOG),POINTER :: PARENT_WANTS_TO_MOVE LOGICAL(kind=KLOG),POINTER :: STOP_MY_MOTION ! LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CALLED_PARENT_2WAY_BOOKKEEPING LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CHILD_ACTIVE LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: MOVE_FLAG LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SEND_CHILD_DATA LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SIGNAL_2WAY_SEND_READY LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SKIP_2WAY_UPDATE ! TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_UPDATE & ,J_2WAY_UPDATE & ,I_2WAY_H & ,J_2WAY_H & ,I_2WAY_V & ,J_2WAY_V ! TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_SOUTH & ,WORDS_BOUND_H_NORTH & ,WORDS_BOUND_H_WEST & ,WORDS_BOUND_H_EAST & ,WORDS_BOUND_V_SOUTH & ,WORDS_BOUND_V_NORTH & ,WORDS_BOUND_V_WEST & ,WORDS_BOUND_V_EAST ! TYPE(REAL_DATA),DIMENSION(:),POINTER :: UPDATE_PARENT_2WAY ! TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: CHILD_SFC_ON_PARENT TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_V_ON_PARENT ! TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH & ,PD_B_NORTH & ,PD_B_WEST & ,PD_B_EAST & ! ,PD_B_SOUTH_V & ,PD_B_NORTH_V & ,PD_B_WEST_V & ,PD_B_EAST_V & ! ,FIS_CHILD_SOUTH & ,FIS_CHILD_NORTH & ,FIS_CHILD_WEST & ,FIS_CHILD_EAST ! TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_SOUTH & ,CHILD_BOUND_H_NORTH & ,CHILD_BOUND_H_WEST & ,CHILD_BOUND_H_EAST & ,CHILD_BOUND_V_SOUTH & ,CHILD_BOUND_V_NORTH & ,CHILD_BOUND_V_WEST & ,CHILD_BOUND_V_EAST ! TYPE(BC_H),POINTER :: MY_BC_VARS_H_S & ,MY_BC_VARS_H_N & ,MY_BC_VARS_H_W & ,MY_BC_VARS_H_E ! TYPE(BC_V),POINTER :: MY_BC_VARS_V_S & ,MY_BC_VARS_V_N & ,MY_BC_VARS_V_W & ,MY_BC_VARS_V_E ! TYPE(MIXED_DATA_TASKS),DIMENSION(:),POINTER :: MOVING_CHILD_UPDATE ! TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_SOUTH & ,BND_VAR_H_NORTH & ,BND_VAR_H_WEST & ,BND_VAR_H_EAST & ,BND_VAR_V_SOUTH & ,BND_VAR_V_NORTH & ,BND_VAR_V_WEST & ,BND_VAR_V_EAST ! TYPE(BNDS_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT_BNDS ! TYPE(SIDES_0D),POINTER :: INDX_MAX_H,INDX_MAX_V TYPE(SIDES_0D),POINTER :: INDX_MIN_H,INDX_MIN_V TYPE(SIDES_0D),POINTER :: NUM_PARENT_TASKS_SENDING_H TYPE(SIDES_0D),POINTER :: NUM_PARENT_TASKS_SENDING_V ! TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_H_RANKS TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_V_RANKS ! TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_H_SAVE TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_V_SAVE ! TYPE(PARENT_POINTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_INDICES_H TYPE(PARENT_POINTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_INDICES_V ! TYPE(PARENT_WEIGHTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_H TYPE(PARENT_WEIGHTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_V ! TYPE(PARENT_DATA),DIMENSION(:),POINTER :: PARENT_TASK ! TYPE(CHILD_UPDATE_LINK),DIMENSION(:),POINTER :: TASK_UPDATE_SPECS & ,CHILD_TASKS_2WAY_UPDATE ! TYPE(HANDLE_SEND),DIMENSION(:),POINTER :: HANDLE_MOVE_DATA ! TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_SOUTH & ,HANDLE_H_NORTH & ,HANDLE_H_WEST & ,HANDLE_H_EAST & ,HANDLE_V_SOUTH & ,HANDLE_V_NORTH & ,HANDLE_V_WEST & ,HANDLE_V_EAST ! TYPE(ESMF_Config),POINTER :: CF_MINE TYPE(ESMF_Config),POINTER :: CF_PARENT TYPE(ESMF_Config),DIMENSION(:),POINTER :: CF ! TYPE(ESMF_FieldBundle),POINTER :: BUNDLE_2WAY & ,BUNDLE_NESTBC & ,MOVE_BUNDLE_H & ,MOVE_BUNDLE_V ! LOGICAL(kind=KLOG),POINTER :: ALLCLEAR_SIGNAL_PRESENT & ,I_AM_A_FCST_TASK & ,I_AM_A_PARENT & ,MY_DOMAIN_MOVES & ,RECV_ALL_CHILD_DATA ! REAL(kind=KDBL),POINTER :: cpl1_prelim_tim & ,cpl1_south_h_tim,cpl1_south_v_tim & ,cpl1_north_h_tim,cpl1_north_v_tim & ,cpl1_west_h_tim, cpl1_west_v_tim & ,cpl1_east_h_tim, cpl1_east_v_tim & ,cpl1_recv_tim ! REAL(kind=KDBL),POINTER :: cpl1_south_h_recv_tim & ,cpl1_south_h_undo_tim & ,cpl1_south_h_exp_tim & ,cpl1_south_v_recv_tim & ,cpl1_south_v_undo_tim & ,cpl1_south_v_exp_tim ! REAL(kind=KDBL),POINTER :: cpl2_comp_tim & ,cpl2_send_tim & ,cpl2_wait_tim ! REAL(kind=KDBL),POINTER :: moving_nest_bookkeep_tim & ,moving_nest_update_tim ! REAL(kind=KDBL),POINTER :: parent_bookkeep_moving_tim & ,parent_update_moving_tim & ,t0_recv_move_tim & ,read_moving_child_topo_tim & ,barrier_move_tim,pscd_tim,pscd1_tim & ,pscd2_tim,pscd3_tim,pscd4_tim REAL(kind=KDBL),POINTER :: ja1_tim,ja2_tim,ja3_tim,ja4_tim,jat_tim ! !----------------------------------------- !*** The following are for moving nests. !----------------------------------------- ! CHARACTER(len=32),POINTER :: MOVE_TYPE INTEGER(kind=KINT),POINTER :: I_EAST_M,I_WEST_M & ,I_MAX,I_MIN & ,J_NORTH_M,J_SOUTH_M & ,J_MAX,J_MIN & ,NPTS_NS,NPTS_WE ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PG,J_PG ! REAL(kind=KFPT),POINTER :: COEF REAL(kind=KFPT),POINTER :: ELAPSED_TIME_MIN REAL(kind=KFPT),POINTER :: RNPTS_HZ ! LOGICAL(kind=KLOG),POINTER :: FIRST_PASS_M LOGICAL(kind=KLOG),POINTER :: FIRST_STEP_2WAY LOGICAL(kind=KLOG),POINTER :: I_HOLD_CENTER_POINT ! LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: IN_WINDOW LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: I_HOLD_PG_POINT ! INTEGER(kind=KINT),POINTER :: MOVE_INTERVAL_MINUTES INTEGER(kind=KINT),POINTER :: N_MOVES REAL(kind=KFPT),DIMENSION(:),POINTER :: MOVE_MINUTE INTEGER(kind=KINT),DIMENSION(:),POINTER :: MOVE_I_SW,MOVE_J_SW ! !----------------------------------------------------------------------- !*** Quantities not associated with the composite object. !----------------------------------------------------------------------- ! INTEGER(kind=KINT),PARAMETER :: INDX_SW=1 & ,INDX_SE=2 & ,INDX_NW=3 & ,INDX_NE=4 ! INTEGER(kind=KINT),SAVE :: MOVE_TAG=1111 & !<-- Arbitrary tag used for child's move ,MOVING_BC_TAG=1112 & !<-- Arbitrary tag used for moving nests' BC updates ,PARENT_SHIFT_TAG=1E6 !<-- Arbitrary tag used for parent's move. ! INTEGER(kind=KINT),SAVE :: MAX_FORCED_SHIFT !<-- # parent points a child forces its parent to shift ! INTEGER(kind=KINT),SAVE :: CHILD_ID & ,COMM_FCST_TASKS & ,INDX_CW,INDX_Q & ,NHOURS_FCST & ,NLEV_2WAY & ,NROWS_P_UPD_E & ,NROWS_P_UPD_N & ,NROWS_P_UPD_S & ,NROWS_P_UPD_W & ,NUM_FIELDS_MOVE & ,NUM_FIELDS_MOVE_2D_H_I & ,NUM_FIELDS_MOVE_2D_X_I & ,NUM_FIELDS_MOVE_2D_H_R & ,NUM_FIELDS_MOVE_2D_X_R & ,NUM_FIELDS_MOVE_3D_H & ,NUM_FIELDS_MOVE_2D_V & ,NUM_FIELDS_MOVE_3D_V & ,NVARS_2WAY_UPDATE & ,NVARS_NESTBC & ,NVARS_NESTBC_H & ,NVARS_NESTBC_V ! INTEGER(kind=KINT) :: TWOWAY_SIGNAL_TAG !<-- Arbitrary tag used for 2way exchange ! INTEGER(kind=KINT) :: CSTEPMAX,VERBLEV INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: NBASE_VAR_H & ,NBASE_VAR_V ! REAL(kind=KDBL),SAVE :: HYPER_A ! REAL(kind=KFPT),SAVE :: EPS=1.E-4 & ,MIN_DIST_PARENT !<-- # of parent gridpoints a child can be from parent ! REAL(kind=KFPT),SAVE :: NORTH_LAT_MAX_MVG_NEST & !<-- Do not let nests move north of this latitude (rad) ,SOUTH_LAT_MAX_MVG_NEST !<-- Do not let nests move south of this latitude (rad) ! REAL(kind=KFPT),SAVE :: COUPLING_INTERVAL !<-- Seconds between updates from external model ! REAL(kind=KFPT) :: DT_C ! REAL(kind=KDBL) :: btim,btim0,btim1,btim2 ! CHARACTER(len=5),SAVE :: NEST_MODE !<--- Is the nesting 1-way or 2-way ! CHARACTER(len=99) :: CONFIG_FILE_NAME ! LOGICAL(kind=KLOG) :: FORCE_INTP_INIT,FREE_FORECAST,DIG_FILTER ! LOGICAL(kind=KLOG),SAVE :: GLOBAL_TOP_PARENT & !<-- Is the uppermost parent global? ,MPMD_COUPLING & !<-- Is there MPMD coupling with an external model? ,RESTART !<-- Is this a restarted run? ! TYPE(ESMF_Config),SAVE :: CF_1 !<-- Domain #1's configure object ! NAMELIST /CPL_SETTINGS/ RESTART,CSTEPMAX,DT_C,FORCE_INTP_INIT,VERBLEV ! integer(kind=kint),dimension(8) :: values ! !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_CPL_REGISTER(CPL_COMP,RC_NEST_REG) ! !----------------------------------------------------------------------- !*** Register the nesting coupler component's Initialize, Run, and !*** Finalize routines. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- Coupler component ! INTEGER(kind=KINT),INTENT(OUT) :: RC_NEST_REG !<-- Return code for register ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: RC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_NEST_REG=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** Register the various pieces of the Parent-Child coupler component. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 1 of the P-C Coupler Initialize" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_INITIALIZE & !<-- subroutineType ,PARENT_CHILD_CPL_INITIALIZE0 & !<-- User's subroutineName ,phase=1 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 2 of the P-C Coupler Initialize" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_INITIALIZE & !<-- subroutineType ,PARENT_CHILD_CPL_INITIALIZE1 & !<-- User's subroutineName ,phase=2 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 3 of the P-C Coupler Initialize" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_INITIALIZE & !<-- subroutineType ,PARENT_CHILD_CPL_INITIALIZE2 & !<-- User's subroutineName ,phase=3 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Register the Parent-Child coupler's Run subroutines. ! ! The Parent-Child Run step of the coupler has five distinct parts: ! (1) Check for signals related to 2-way exchange at the beginning ! of timesteps to determine if the execution should proceed ! into the timestep or drop out. This is only relevant for ! generational task assignment (i.e., for 2-way nesting). ! (2) At the start of parent timesteps a child receives BC data ! from its parent. ! (3) If using 2-way nesting then parents receive exchange data ! from their children at the start of every parent timestep. ! (4) At the end of every parent timestep a parent sends BC data ! to its children. For those children that moved, the parent ! must first generate new interpolation information and then ! compute the new internal shift data for those nests. ! (5) Finally any 2-way children send exchange data to their ! parents at the end of every parent timestep. ! !*** Thus register the coupler's Run step with those two phases. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 1 of P-C Coupler Run" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_RUN & !<-- subroutineType ,CHECK_2WAY_SIGNALS & !<-- User's subroutineName ,phase=1 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 2 of P-C Coupler Run" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_RUN & !<-- subroutineType ,CHILDREN_RECV_PARENT_DATA & !<-- User's subroutineName ,phase=2 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 3 of P-C Coupler Run" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_RUN & !<-- subroutineType ,PARENTS_RECV_CHILD_2WAY_DATA & !<-- User's subroutineName ,phase=3 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 4 of P-C Coupler Run" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_RUN & !<-- subroutineType ,PARENTS_SEND_CHILD_DATA & !<-- User's subroutineName ,phase=4 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Phase 5 of P-C Coupler Run" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_RUN & !<-- subroutineType ,CHILDREN_SEND_PARENTS_2WAY_DATA & !<-- User's subroutineName ,phase=5 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Register the coupler Finalize subroutine. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set Entry Point for Nesting Coupler Finalize" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component ,ESMF_METHOD_FINALIZE & !<-- subroutineType ,PARENT_CHILD_CPL_FINALIZE & !<-- User's subroutineName ,phase=1 & ,rc=RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Check the error signal variable. !----------------------------------------------------------------------- ! IF(RC_NEST_REG==ESMF_SUCCESS)THEN ! WRITE(0,*)" NESTING COUPLER REGISTER SUCCEEDED" ELSE WRITE(0,*)" NESTING COUPLER REGISTER FAILED" ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_CPL_REGISTER ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_CPL_INITIALIZE0(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** This preliminary routine is used only for runs containing nests. !*** It serves primarily to allow children to send their SW corner !*** location to their parents. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: CHILDTASK_0,CONFIG_ID,HANDLE_X,ID_CHILD & ,MAX_DOMAINS,MY_DOMAIN_ID,MYPE_X,N,NTAG ! INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT ! CHARACTER(len=2) :: INT_TO_CHAR CHARACTER(len=6) :: FMT='(I2.2)' ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_INIT=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** What is this domain's ID? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite ! !----------------------------------------------------------------------- ! !------------------------ !*** Number of Children !------------------------ ! NUM_CHILDREN=>cc%NUM_CHILDREN NUM_CHILDREN=0 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Number of Children on This Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NUM_CHILDREN' & !<-- Name of the attribute to extract ,value=NUM_CHILDREN & !<-- # of this domain's children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------- !*** Maximum number of domains !------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Maximum Number of Domains" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MAX_DOMAINS' & !<-- Name of the attribute to extract ,value=MAX_DOMAINS & !<-- Maximum # of domains ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------- !*** Child-to-Parent Communicator !---------------------------------- ! COMM_TO_MY_PARENT=>CC%COMM_TO_MY_PARENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Child-to-Parent Comm in P-C Coupler Init1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Child-to-Parent Comm' & !<-- Name of the attribute to extract ,value=COMM_TO_MY_PARENT & !<-- MPI communicator to my parent ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------- !*** The association of domains and their configure files. !----------------------------------------------------------- ! IF(.NOT.ASSOCIATED(DOMAIN_ID_TO_RANK))THEN ALLOCATE(DOMAIN_ID_TO_RANK(1:MAX_DOMAINS)) ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Association of Domains and Config Files" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='DOMAIN_ID_TO_RANK' & !<-- Name of the attribute to extract ,itemCount=MAX_DOMAINS & !<-- Name of elements in the Attribute ,valueList=DOMAIN_ID_TO_RANK & !<-- Array associating domains and config files ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------- !*** Intracommunicator for fcst tasks on each domain !----------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init0" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! I_AM_LEAD_FCST_TASK=>cc%I_AM_LEAD_FCST_TASK I_AM_LEAD_FCST_TASK=.FALSE. ! IF(I_AM_A_FCST_TASK)THEN ! CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_X,IERR) ! IF(MYPE_X==0)THEN I_AM_LEAD_FCST_TASK=.TRUE. ENDIF ! ENDIF ! !----------------------------------------------------------------------- !*** Tasks load their domain's configure file. !----------------------------------------------------------------------- ! CONFIG_ID=DOMAIN_ID_TO_RANK(MY_DOMAIN_ID) WRITE(INT_TO_CHAR,FMT)CONFIG_ID CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file name ! cc%CF_MINE=ESMF_ConfigCreate(rc=RC) CF_MINE=>cc%CF_MINE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Nest Loads Its Configure File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigLoadFile(config =CF_MINE & ,filename=CONFIG_FILE_NAME & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Parent tasks must know the communicators to their children !*** and their domain IDs. !----------------------------------------------------------------------- ! IF(I_AM_A_FCST_TASK.AND.NUM_CHILDREN>0)THEN !<-- Select parent fcst tasks for additional setup ! ALLOCATE(cc%COMM_TO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%COMM_TO_MY_CHILDREN stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init0: Extract Parent-to-Child Comm in Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='Parent-to-Child Comms' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute ,valueList=COMM_TO_MY_CHILDREN & !<-- MPI communicators to my children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------- !*** The IDs of the Children !----------------------------- ! ALLOCATE(CC%MY_CHILDREN_ID(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%MY_CHILDREN_ID stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ! MY_CHILDREN_ID=>cc%MY_CHILDREN_ID ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init0: Extract IDs of Children" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='CHILD_IDs' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute ,valueList=MY_CHILDREN_ID & !<-- The domain IDs of the current domain's children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** Is this a restarted run? !----------------------------------------------------------------------- ! I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK ! RESTART=.FALSE. ! IF(I_AM_A_FCST_TASK)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init0: Extract Restart Flag from P-C Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='RESTART' & !<-- Name of the attribute to extract ,value=RESTART & !<-- The restart flag (true or false) ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** The children get the location of their SW corner. !*** That information was exported from the Domain component. !----------------------------------------------------------------------- ! child_block_0: IF(MY_DOMAIN_ID>1)THEN !<-- Select the children ! I_SW_PARENT_CURRENT=>cc%I_SW_PARENT_CURRENT J_SW_PARENT_CURRENT=>cc%J_SW_PARENT_CURRENT LAST_STEP_MOVED=>cc%LAST_STEP_MOVED ! IF(I_AM_A_FCST_TASK)THEN ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Gets SW Corner from Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='I_PAR_STA' & !<-- Name of Attribute to extract ,value=I_SW_PARENT_CURRENT & !<-- Put the extracted Attribute here ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='J_PAR_STA' & !<-- Name of Attribute to extract ,value=J_SW_PARENT_CURRENT & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Get Last Move Timestep from Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='LAST_STEP_MOVED' & !<-- Name of Attribute to extract ,value=LAST_STEP_MOVED & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Fill the domain's next move timestep. The value is a dummy if !*** it is not relevant. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Get Next Move Timestep from Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of Attribute to extract ,value=cc%NEXT_MOVE_TIMESTEP & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** The lead child task ISends its parent's lead task the child !*** domain's SW corner location. There is no need for a Wait !*** since a task will only ever execute this send one time. !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ! NTAG=12121+100*MY_DOMAIN_ID !<-- Use a unique tag dependent on the domain ID ! CALL MPI_ISSEND(I_SW_PARENT_CURRENT & !<-- Parent I of SW corner of nest domain ,1 & !<-- There is 1 word ,MPI_INTEGER & !<-- The message is an integer ,0 & !<-- Send to lead parent task (always 0 in intracomm) ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator to the parent ,HANDLE_X & !<-- Request handle for this ISend ,IERR ) ! NTAG=12122+100*MY_DOMAIN_ID !<-- Use a unique tag dependent on the domain ID ! CALL MPI_ISSEND(J_SW_PARENT_CURRENT & !<-- Parent J of SW corner of nest domain ,1 & !<-- There is 1 word ,MPI_INTEGER & !<-- The message is an integer ,0 & !<-- Send to lead parent task (always 0 in intracomm) ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator to the parent ,HANDLE_X & !<-- Request handle for this ISend ,IERR ) ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF child_block_0 ! !----------------------------------------------------------------------- !*** Parents receive their children's SW corner locations. !----------------------------------------------------------------------- ! parent_block_0: IF(NUM_CHILDREN>0)THEN !<-- Select the parents ! !----------------------------------------------------------------------- ! ALLOCATE(cc%I_PARENT_SW(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%I_PARENT_SW stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ALLOCATE(cc%J_PARENT_SW(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%J_PARENT_SW stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ! I_PARENT_SW=>cc%I_PARENT_SW J_PARENT_SW=>cc%J_PARENT_SW ! !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ! DO N=1,NUM_CHILDREN ! CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child's lead task in P-C communicator ID_CHILD=MY_CHILDREN_ID(N) !<-- Domain ID of child N NTAG=12121+100*MY_CHILDREN_ID(N) ! CALL MPI_IRECV(I_PARENT_SW(N) & !<-- Parent I of SW corner of child N ,1 & !<-- There is 1 word ,MPI_INTEGER & !<-- The word is an integer ,CHILDTASK_0 & !<-- The Child task who sent ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N ,HANDLE_I_SW(ID_CHILD) & !<-- Request handle for IRecv from child N ,IERR ) ! NTAG=12122+100*MY_CHILDREN_ID(N) ! CALL MPI_IRECV(J_PARENT_SW(N) & !<-- Parent J of SW corner of child N ,1 & !<-- There is 1 word ,MPI_INTEGER & !<-- The word is an integer ,CHILDTASK_0 & !<-- The Child task who sent ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N ,HANDLE_J_SW(ID_CHILD) & !<-- Request handle for IRecv from child N ,IERR ) ! ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parent_block_0 ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE0 ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_CPL_INITIALIZE1(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** Perform initial work needed by the Parent-Child coupler. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT),SAVE :: N8=8 ! INTEGER(kind=KINT) :: I,J,L ! INTEGER(kind=KINT) :: CHILD_FILTER,CHILDTASK_0,CONFIG_ID & ,H_OR_V_INT,HANDLE_X,ID_CHILD,ID_DOM & ,IDIM,IEND,ISTART,IUNIT_FIS_NEST & ,JCORNER,JDIM,JEND,JSTART,JSTOP & ,KOUNT & ,LENGTH,LIM1_H,LIM1_V,LIM2_H,LIM2_V,LMP1,LOR & ,MAX_DOMAINS,MY_DOMAIN_ID,MY_PARENT_ID & ,MYPE_X & ,N,N1,N2,N3,NN & ,N_CHILD,N_FIELD,N_START,N_END & ,N_H_EAST_WEST,N_H_NORTH_SOUTH & ,N_V_EAST_WEST,N_V_NORTH_SOUTH & ,NKOUNT,NTAG,NTIMESTEP & ,NUM_BOUNDARY_WORDS & ,NUM_DOMAINS,NUM_TASKS_TOTAL & ,NUM_WORDS,NV ! INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER(kind=KINT),DIMENSION(1:3) :: INFO_EXT_DATA ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: CONST1,CONST2,CONST3,CONST4 & ,DIST_NESTV_SOUTH_TO_PARENTV_SOUTH & ,DT_PARENT & ,GRID_DIST_KM & ,REAL_I & ,REAL_J ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_R3D ! REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,PI ! CHARACTER(len=2) :: INT_TO_CHAR CHARACTER(len=6) :: FMT='(I2.2)' CHARACTER(len=5),DIMENSION(:),ALLOCATABLE :: NEST_MODE_CHILD CHARACTER(len=19) :: PRESCRIBED_FILENAME CHARACTER(len=99) :: FIELD_NAME ! LOGICAL(kind=KLOG) :: DOMAIN_MOVES,OPENED ! TYPE(COMPOSITE),POINTER :: CC ! TYPE(ESMF_Field) :: HOLD_FIELD ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_INIT=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** What is this domain's ID? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite ! !----------------------------------------------------------------------- !*** What is the total number of domains in this run? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Total Number of Domains in P-C Coupler Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NUM_DOMAINS' & !<-- Name of the attribute to extract ,value=NUM_DOMAINS & !<-- Total number of domains ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** What is the total # of tasks on each domain? !----------------------------------------------------------------------- ! ALLOCATE(cc%NTASKS_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NTASKS_DOMAIN stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! NTASKS_DOMAIN=>cc%NTASKS_DOMAIN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Total # of Tasks on Each Domain in P-C Coupler Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='NTASKS_DOMAIN' & !<-- Name of the attribute to extract ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute ,valueList=NTASKS_DOMAIN & !<-- # of fcst+quilt tasks on each domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** How many forecast tasks on each domain? !----------------------------------------------------------------------- ! ALLOCATE(cc%FTASKS_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%FTASKS_DOMAIN stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF FTASKS_DOMAIN=>cc%FTASKS_DOMAIN ! I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Number of Fcst Tasks on Each Domain in P-C Coupler Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='FTASKS_DOMAIN' & !<-- Name of the attribute to extract ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute ,valueList=FTASKS_DOMAIN & !<-- # of forecast tasks on each domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------- !*** Children sending 2-way data to parent !------------------------------------------- ! NUM_2WAY_CHILDREN=>cc%NUM_2WAY_CHILDREN NUM_2WAY_CHILDREN=0 ! !-------------------------------- !*** Motion and moving children !-------------------------------- ! NUM_MOVING_CHILDREN=>cc%NUM_MOVING_CHILDREN NUM_MOVING_CHILDREN=0 ! MY_DOMAIN_MOVES=>cc%MY_DOMAIN_MOVES MY_DOMAIN_MOVES=.FALSE. ! !--------------------------- !*** Domain IDs of Parents !--------------------------- ! ALLOCATE(cc%ID_PARENTS(1:NUM_DOMAINS),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%ID_PARENTS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ID_PARENTS=>cc%ID_PARENTS ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Domain IDs of Parents in Init Step Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='ID_PARENTS' & !<-- Name of the attribute to extract ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute ,valueList=ID_PARENTS & !<-- Domain IDs of parents ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------------------ !*** Number of forecast tasks on this domain's parent !------------------------------------------------------ ! MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent ! NUM_TASKS_PARENT =>cc%NUM_TASKS_PARENT NUM_FCST_TASKS_PARENT=>cc%NUM_FCST_TASKS_PARENT ! IF(MY_PARENT_ID>0)THEN NUM_TASKS_PARENT =NTASKS_DOMAIN(MY_PARENT_ID) !<-- Total # of fcst+quilt tasks on the parent's domain NUM_FCST_TASKS_PARENT=FTASKS_DOMAIN(MY_PARENT_ID) !<-- # of forecast tasks on the parent's domain ELSE NUM_TASKS_PARENT=0 !<-- Uppermost parent has no parent NUM_FCST_TASKS_PARENT=0 !<-- Uppermost parent has no parent ENDIF ! !------------------------------------------------------------- !*** Task's local rank in its Parent-Child Intracommunicator !------------------------------------------------------------- ! MYPE=>CC%MYPE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Task Rank in Domain Component" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MYPE_DOMAIN' & !<-- Name of the attribute to extract ,value=MYPE & !<-- Rank of task in Parent-Child intracomm ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------- !*** Intracommunicator for fcst tasks on each domain !----------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------- !*** Number of fcst tasks on this domain !----------------------------------------- ! NUM_PES_FCST=>CC%NUM_PES_FCST ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of Forecast Tasks in P-C Coupler Init1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NUM_PES_FCST' & !<-- Name of the attribute to extract ,value=NUM_PES_FCST & !<-- MPI communicator for this domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------- !*** Fundamental Timestep on Each Domain !----------------------------------------- ! ALLOCATE(cc%DT_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%DT_DOMAIN stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF DT_DOMAIN=>cc%DT_DOMAIN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Timestep of Domains in P-C Coupler Init1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='DOMAIN_DTs' & !<-- Name of the attribute to extract ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute ,valueList=DT_DOMAIN & !<-- Timestep on each domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Parent tasks must know the communicators to their children. !----------------------------------------------------------------------- ! IF(NUM_CHILDREN>0)THEN !<-- Select parents for additional setup ! ALLOCATE(cc%COMM_TO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%COMM_TO_MY_CHILDREN stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Extract Parent-to-Child Comm in Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='Parent-to-Child Comms' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute ,valueList=COMM_TO_MY_CHILDREN & !<-- MPI communicators to my children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** Write/quilt tasks are excluded from the grid-specific information. !----------------------------------------------------------------------- ! I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK ! IF(.NOT.I_AM_A_FCST_TASK)RETURN ! !--------------------------------------------- !*** The Tasks' Subdomain Integration Limits !--------------------------------------------- ! ITS=>cc%ITS ITE=>cc%ITE JTS=>cc%JTS JTE=>cc%JTE LM =>cc%LM ! NHALO=>cc%NHALO ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Integration Subdomain Limits in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='ITS' & !<-- Name of the attribute to extract ,value=ITS & !<-- This task's integration limit: Starting I ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='ITE' & !<-- Name of the attribute to extract ,value=ITE & !<-- This task's integration limit: Ending I ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='JTS' & !<-- Name of the attribute to extract ,value=JTS & !<-- This task's integration limit: Starting J ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='JTE' & !<-- Name of the attribute to extract ,value=JTE & !<-- This task's integration limit: Ending J ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='LM' & !<-- Name of the attribute to extract ,value=LM & !<-- This task's integration limit: # of layers in vertical ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NHALO' & !<-- Name of the attribute to extract ,value=NHALO & !<-- Width of the task subdomain haloes ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IMS=>cc%IMS IME=>cc%IME JMS=>cc%JMS JME=>cc%JME ! IMS=ITS-NHALO IME=ITE+NHALO JMS=JTS-NHALO JME=JTE+NHALO ! !----------------------------------------------------- !*** Index Limits of All Forecast Tasks on My Domain !----------------------------------------------------- ! ALLOCATE(cc%LOCAL_ISTART(1:FTASKS_DOMAIN(MY_DOMAIN_ID)),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate LOCAL_ISTART for MY_DOMAIN_ID=',MY_DOMAIN_ID,' stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ALLOCATE(cc%LOCAL_IEND (1:FTASKS_DOMAIN(MY_DOMAIN_ID))) ALLOCATE(cc%LOCAL_JSTART(1:FTASKS_DOMAIN(MY_DOMAIN_ID))) ALLOCATE(cc%LOCAL_JEND (1:FTASKS_DOMAIN(MY_DOMAIN_ID))) ! LOCAL_ISTART=>cc%LOCAL_ISTART LOCAL_IEND =>cc%LOCAL_IEND LOCAL_JSTART=>cc%LOCAL_JSTART LOCAL_JEND =>cc%LOCAL_JEND ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Index Limits of Fcst Tasks on My Domain in Init Step Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='LOCAL ISTART' & !<-- Name of the attribute to extract ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute ,valueList=LOCAL_ISTART & !<-- Starting I's of fcst tasks on my domain ,rc =RC) ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='LOCAL IEND' & !<-- Name of the attribute to extract ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute ,valueList=LOCAL_IEND & !<-- Ending I's of fcst tasks on my domain ,rc =RC) ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='LOCAL JSTART' & !<-- Name of the attribute to extract ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute ,valueList=LOCAL_JSTART & !<-- Starting J's of fcst tasks on my domain ,rc =RC) ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='LOCAL JEND' & !<-- Name of the attribute to extract ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute ,valueList=LOCAL_JEND & !<-- Ending J's of fcst tasks on my domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------------- !*** The Full Domain Dimensions !-------------------------------- ! IDS=>cc%IDS IDE=>cc%IDE JDS=>cc%JDS JDE=>cc%JDE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Full Domain Dimensions in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='IDS' & !<-- Name of the attribute to extract ,value=IDS & !<-- This task's integration limit: Starting I ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='IDE' & !<-- Name of the attribute to extract ,value=IDE & !<-- This task's integration limit: Ending I ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='JDS' & !<-- Name of the attribute to extract ,value=JDS & !<-- This task's integration limit: Starting J ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='JDE' & !<-- Name of the attribute to extract ,value=JDE & !<-- This task's integration limit: Ending J ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------------ !*** The Widths of the Boundary Blending Region !------------------------------------------------ ! N_BLEND_H=>cc%N_BLEND_H N_BLEND_V=>cc%N_BLEND_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Widths of Bndry Blending Region in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='N_BLEND_H' & !<-- Name of the attribute to extract ,value=N_BLEND_H & !<-- # of boundary blending rows for H points ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='N_BLEND_V' & !<-- Name of the attribute to extract ,value=N_BLEND_V & !<-- # of boundary blending rows for V points ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N_BLEND_V>N_BLEND_H)THEN WRITE(0,*)' N_BLEND_V CANNOT EXCEED N_BLEND_H DUE TO PD AVERAGING!!!' WRITE(0,*)' ABORTING' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! !-------------------------------------- !*** Each forecast task's 8 neighbors !-------------------------------------- ! MY_NEB=>cc%MY_NEB ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_NEB' & !<-- Name of the attribute to extract ,itemCount=N8 & !<-- # of items in the Attribute ,valueList=MY_NEB & !<-- This task's eight neighbors ,rc =RC) ! !------------------------------------ !*** The frequency of physics calls !------------------------------------ ! NPHS=>cc%NPHS ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract NPHS in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NPHS' & !<-- Name of the attribute to extract ,value=NPHS & !<-- The frequency of physics calls ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Unload some key prognostic data from the import state that are !*** needed inside the Parent-Child coupler and point at those data !*** (located in the Solver internal state) appropriate for the !*** current domain. !----------------------------------------------------------------------- ! !-------- !*** PD !-------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PD Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='PD' & !<-- Extract PD ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PD from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=PD & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%PD=>PD ! !------------------------------- !*** Layer Interface Pressures !------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PINT from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='PINT' & !<-- Extract layer interface pressures ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PINT from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=PINT & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%PINT=>PINT ! !----------------- !*** Temperature !----------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract T Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='T' & !<-- Extract temperature ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract T from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=T & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%T=>T ! !------------ !*** U Wind !------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract U Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='U' & !<-- Extract U wind ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract U from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=U & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%U=>U ! !------------ !*** V Wind !------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract V Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='V' & !<-- Extract V wind ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract V from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=V & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%V=>V ! !---------------- !*** Modlayer Z !---------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Midlayer Z Field from P-C Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='Z' & !<-- Extract midlayer Z ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Midlayer Z from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=Z & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%Z=>Z ! !---------------------------------- !*** 10-m U component of the wind !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 10-m U Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='U10' & !<-- Extract 10-m U wind component ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 10-m U from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=U10 & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%U10=>U10 ! !---------------------------------- !*** 10-m V component of the wind !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 10-m V Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='V10' & !<-- Extract 10-m V wind component ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 10-m V from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=V10 & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%V10=>V10 ! !------------- !*** Tracers !------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Tracers Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='TRACERS' & !<-- Extract tracers ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Tracers from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=TRACERS & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%TRACERS=>TRACERS ! !---------------------- !*** Sfc Geopotential !---------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract FIS Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='FIS' & !<-- Extract sfc geopotential ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract FIS from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=FIS & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%FIS=>FIS ! !-------------- !*** Sea Mask !-------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Sea Mask from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='SM' & !<-- Extract sea mask ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SM from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=SM & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%SM=>SM ! !------------------------- !*** Geographic latitude !------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLAT Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='GLAT' & !<-- Extract geographic latitude ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLAT from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=cc%GLAT & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------- !*** Geographic longitude !-------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLON Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='GLON' & !<-- Extract geographic longitude ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLON from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=cc%GLON & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------------------- !*** PT,PDTOP,PSGML1,SG1,SG2,SGML2,DSG2,PDSG1 !---------------------------------------------- ! PT=>cc%PT PDTOP=>cc%PDTOP ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PT from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='PT' & !<-- Extract PT ,value=PT & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PDTOP from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='PDTOP' & !<-- Extract PDTOP ,value=PDTOP & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%PSGML1(1:LM),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PSGML1 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! PSGML1=>cc%PSGML1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PSGML1 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='PSGML1' & !<-- Name of Attribute to extract ,itemCount=LM & !<-- # of words in data list ,valueList=PSGML1 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! LMP1=LM+1 ALLOCATE(cc%SG1(1:LMP1),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SG1 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! SG1=>cc%SG1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SG1 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='SG1' & !<-- Name of Attribute to extract ,itemCount=LMP1 & !<-- # of words in data list ,valueList=SG1 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%SG2(1:LMP1),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SG2 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! SG2=>cc%SG2 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SG2 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='SG2' & !<-- Name of Attribute to extract ,itemCount=LMP1 & !<-- # of words in data list ,valueList=SG2 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%SGML2(1:LM),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SGML2 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! SGML2=>cc%SGML2 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SGML2 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='SGML2' & !<-- Name of Attribute to extract ,itemCount=LM & !<-- # of words in data list ,valueList=SGML2 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%DSG2(1:LM),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%DSG2 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! DSG2=>cc%DSG2 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DSG2 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='DSG2' & !<-- Extract DSG2 ,itemCount=LM & !<-- # of words in data list ,valueList=DSG2 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%PDSG1(1:LM),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PDSG1 stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! PDSG1=>cc%PDSG1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PDSG1 from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='PDSG1' & !<-- Extract PDSG1 ,itemCount=LM & !<-- # of words in data list ,valueList=PDSG1 & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------- !*** DYH,DXH !------------- ! DYH=>cc%DYH ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DYH from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='DYH' & !<-- Extract DYH ,value=DYH & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(CC%DXH(JDS:JDE),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%DXH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! DXH=>cc%DXH ! NKOUNT=JDE-JDS+1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DXH from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='DXH' & !<-- Name of Attribute to extract ,itemCount=NKOUNT & !<-- # of words in data list ,valueList=DXH & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------ !*** DPHD,DLMD,JM !------------------ ! DLM=>cc%DLM DPH=>cc%DPH JM=>cc%JM ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~~~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DPHD,DLMD from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~~~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='DLMD' & !<-- Extract grid's longitude increment (deg) ,value=DLM & !<-- Put the extracted Attribute here ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='DPHD' & !<-- Extract grid's latitude increment (deg) ,value=DPH & !<-- Put the extracted Attribute here ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='JM' & !<-- Extract J extent of domain ,value=JM & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! D_ONE=1. D_180=180. PI=DACOS(-D_ONE) D2R=PI/D_180 ! DLM=DLM*D2R !<-- Convert from degrees to radians DPH=DPH*D2R !<-- Convert from degrees to radians ! !------------ !*** INDX_Q !------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract INDX_Q from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='INDX_Q' & !<-- Name of Attribute to extract ,value=INDX_Q & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------- !*** INDX_CW !------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract INDX_CW from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='INDX_CW' & !<-- Name of Attribute to extract ,value=INDX_CW & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%Q=>TRACERS(IMS:IME,JMS:JME,1:LM,INDX_Q) cc%CW=>TRACERS(IMS:IME,JMS:JME,1:LM,INDX_CW) ! !----------------------------------------------------------------------- !*** Extract the Bundles holding pointers to nest boundary variables !*** updated by the parents (used in all nesting) and to 2-way !*** variables updated by the child on the parent (if indeed 2-way !*** nesting is invoked). Since the Fields in these Bundles will be !*** accessed via looping through the Bundles then we need to know !*** how many total Fields are present as well as specifically how !*** many are on H points and on V points. !----------------------------------------------------------------------- ! IF(I_AM_A_FCST_TASK)THEN ! !----------------------------------------------------------------------- !*** Begin with the Bundle of pointers to the variables specified !*** by the user that are to be updated on the nest boundaries. !*** In addition to the total number of such variables, we need !*** to know how many of them are on H points and how many are !*** on V points. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Nest BC Bundle in P-C Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state ,itemname ='Bundle_nestbc' & !<-- Name of Bundle of nest BC internal state arrays to use ,fieldbundle=BUNDLE_NESTBC & !<-- The ESMF nest BC Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How many Fields in the Nest BC Bundle?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- The ESMF Bundle of 2-way exchange variables ,fieldcount =NVARS_NESTBC & !<-- # of Fields in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NLEV_H=>cc%NLEV_H NLEV_V=>cc%NLEV_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of Model Lyrs for all Nest BC Variables" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NLEV_H' & !<-- Name of Attribute to extract ,value=NLEV_H & !<-- # of model lyrs for all BC H-pt variables ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NLEV_V' & !<-- Name of Attribute to extract ,value=NLEV_V & !<-- # of model lyrs for all BC H-pt variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NVARS_BC_2D_H=>cc%NVARS_BC_2D_H NVARS_BC_3D_H=>cc%NVARS_BC_3D_H NVARS_BC_4D_H=>cc%NVARS_BC_4D_H ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of H-pt Nest BC Variables from P-C Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NVARS_BC_2D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NVARS_BC_3D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NVARS_BC_4D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NVARS_BC_2D_V=>cc%NVARS_BC_2D_V NVARS_BC_3D_V=>cc%NVARS_BC_3D_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of V-pt Nest BC Variables from P-C Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NVARS_BC_2D_V' & !<-- Name of Attribute to extract ,value=NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='NVARS_BC_3D_V' & !<-- Name of Attribute to extract ,value=NVARS_BC_3D_V & !<-- # of 3-D V-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NVARS_NESTBC_H=NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H NVARS_NESTBC_V=NVARS_BC_2D_V+NVARS_BC_3D_V ! IF(.NOT.ALLOCATED(NBASE_VAR_H))THEN ALLOCATE(NBASE_VAR_H(1:NVARS_NESTBC_H-1)) ENDIF ! IF(.NOT.ALLOCATED(NBASE_VAR_V))THEN ALLOCATE(NBASE_VAR_V(1:NVARS_NESTBC_V)) ENDIF ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Allocate the objects that hold the boundary values for arrays !*** of various dimensions. While it is certain there will be 2-D !*** H-pt variables (PD) and 3-D H-pt and V-pt variables (T,Q,U,V) !*** there may not be 4-D H-pt or 2-D V-pt variables so account for !*** the possible lack of those. !----------------------------------------------------------------------- ! ALLOCATE(cc%MY_BC_VARS_H_S%VAR_2D(1:NVARS_BC_2D_H)) ALLOCATE(cc%MY_BC_VARS_H_N%VAR_2D(1:NVARS_BC_2D_H)) ALLOCATE(cc%MY_BC_VARS_H_W%VAR_2D(1:NVARS_BC_2D_H)) ALLOCATE(cc%MY_BC_VARS_H_E%VAR_2D(1:NVARS_BC_2D_H)) ! ALLOCATE(cc%MY_BC_VARS_H_S%VAR_3D(1:NVARS_BC_3D_H)) ALLOCATE(cc%MY_BC_VARS_H_N%VAR_3D(1:NVARS_BC_3D_H)) ALLOCATE(cc%MY_BC_VARS_H_W%VAR_3D(1:NVARS_BC_3D_H)) ALLOCATE(cc%MY_BC_VARS_H_E%VAR_3D(1:NVARS_BC_3D_H)) ! IF(NVARS_BC_4D_H==0)THEN ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(-1:-1)) ELSEIF(NVARS_BC_4D_H>0)THEN ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(1:NVARS_BC_4D_H)) ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(1:NVARS_BC_4D_H)) ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(1:NVARS_BC_4D_H)) ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(1:NVARS_BC_4D_H)) ENDIF ! IF(NVARS_BC_2D_V==0)THEN ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(-1:-1)) ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(-1:-1)) ELSEIF(NVARS_BC_2D_V>0)THEN ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(1:NVARS_BC_2D_V)) ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(1:NVARS_BC_2D_V)) ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(1:NVARS_BC_2D_V)) ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(1:NVARS_BC_2D_V)) ENDIF ! ALLOCATE(cc%MY_BC_VARS_V_S%VAR_3D(1:NVARS_BC_3D_V)) ALLOCATE(cc%MY_BC_VARS_V_N%VAR_3D(1:NVARS_BC_3D_V)) ALLOCATE(cc%MY_BC_VARS_V_W%VAR_3D(1:NVARS_BC_3D_V)) ALLOCATE(cc%MY_BC_VARS_V_E%VAR_3D(1:NVARS_BC_3D_V)) ! !----------------------------------------------------------------------- !*** Extract the lower and upper bounds of each of the 4-D H-pt !*** boundary variables. !----------------------------------------------------------------------- ! IF(NVARS_BC_4D_H==0)THEN ! ALLOCATE(cc%LBND_4D(1:1)) ALLOCATE(cc%UBND_4D(1:1)) ! cc%LBND_4D(1)=-1 cc%UBND_4D(1)=-1 ! ELSEIF(NVARS_BC_4D_H>0)THEN ! ALLOCATE(cc%LBND_4D(1:NVARS_BC_4D_H)) ALLOCATE(cc%UBND_4D(1:NVARS_BC_4D_H)) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Get Lower Bounds of 4-D Bndry Vbls" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='LBND_4D' & !<-- Extract Attribute with this name ,itemCount=NVARS_BC_4D_H & !<-- How many items? ,valueList=cc%LBND_4D & !<-- Lower bounds of 4-D H-pt bndry vbls ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Get Upper Bounds of 4-D Bndry Vbls" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='UBND_4D' & !<-- Extract Attribute with this name ,itemCount=NVARS_BC_4D_H & !<-- How many items? ,valueList=cc%UBND_4D & !<-- Upper bounds of 4-D H-pt bndry vbls ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- ! IF(NVARS_NESTBC/=NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H & +NVARS_BC_2D_V+NVARS_BC_3D_V)THEN WRITE(0,22001)NVARS_NESTBC 22001 FORMAT(' Total # of variables in nest BC Bundle is ',I4) WRITE(0,22002)NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H 22002 FORMAT(' # of H-pt nest BC variables is ',I4) WRITE(0,22002)NVARS_BC_2D_V+NVARS_BC_3D_V 22003 FORMAT(' # of V-pt nest BC variables is ',I4) WRITE(0,22004) 22004 FORMAT(' They do not add up so ABORT!!') CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & ,rc =RC) ENDIF ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- !*** Extract the mode of nesting, i.e., 1-way or 2-way. Use the !*** configure file of domain #1 where the variable is required. !----------------------------------------------------------------------- ! CF_1=ESMF_ConfigCreate(rc=RC) ! CONFIG_FILE_NAME='configure_file_01' !<-- Config file name of uppermost parent ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Configure Object of Upper Domain in P-C Cpl Init1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigLoadFile(config =CF_1 & ,filename=CONFIG_FILE_NAME & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Extract Nesting Mode from Config File 1" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object for the uppermost domain ,value =NEST_MODE & !<-- The mode of nesting ('1-way' or '2-way') ,label ='nest_mode:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Tasks load their domain's configure file. !----------------------------------------------------------------------- ! CONFIG_ID=DOMAIN_ID_TO_RANK(MY_DOMAIN_ID) WRITE(INT_TO_CHAR,FMT)CONFIG_ID CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file name ! CF_MINE=>cc%CF_MINE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Domain Loads Its Configure File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigLoadFile(config =CF_MINE & ,filename=CONFIG_FILE_NAME & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Is there MPMD coupling?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object for the uppermost domain ,value =MPMD_COUPLING & !<-- Is there MPMD coupling? ,label ='mpmd_coupling:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Children need to save the ratio of their parent's timestep and !*** grid increment to their own. The timestep ratio MUST be an !*** integer and for now so must the space ratio. !*** Then obtain the parent I,J of the nest's SW corner. !----------------------------------------------------------------------- ! child_block: IF(MY_DOMAIN_ID>1)THEN !<-- Select the children ! !----------------------------------------------------------------------- ! DT_PARENT=DT_DOMAIN(ID_PARENTS(MY_DOMAIN_ID)) ! TIME_RATIO_MY_PARENT=>cc%TIME_RATIO_MY_PARENT TIME_RATIO_MY_PARENT=NINT(DT_PARENT/DT_DOMAIN(MY_DOMAIN_ID)) !<-- Ratio of my parent's timestep to mine ! !----------------------------------------------------------------------- !*** In order to allow moving nests to be updated their tasks need !*** to know their domain's forecast task layout as well as that of !*** their parents. Likewise the parents of moving nests need to !*** know the forecast task layout of their moving children. For !*** simplicity we will provide that information to all domain tasks !*** now. !*** The SW corner location of the nests is read from the configure !*** files for regular forecasts but must come from the restart !*** file data for restarted runs. !----------------------------------------------------------------------- ! SPACE_RATIO_MY_PARENT=>cc%SPACE_RATIO_MY_PARENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Child Gets Space Ratio" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =SPACE_RATIO_MY_PARENT & !<-- The variable filled (Parent-to-child space ratio) ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%RECIP_PARENT_SPACE_RATIO=1./REAL(SPACE_RATIO_MY_PARENT) ! !----------------------------------------------------------------------- ! INPES=>cc%INPES JNPES=>cc%JNPES ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Child Gets INPES,JNPES" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =INPES & !<-- The variable filled (fcst tasks in I direction) ,label ='inpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =JNPES & !<-- The variable filled (fcst tasks in J direction) ,label ='jnpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Task 0 on each child receives the domain index limits of their !*** parents then braodcasts them to the other child tasks. !*** Task 0 on each child then receives the integration limits of !*** their parents' forecast tasks and broadcasts that information to !*** the remaining child tasks. !*** Also each child task needs to allocate the derived type that will !*** hold: (i) Which parent task(s) will send boundary data to it; !*** (ii) The grid index limits on the child boundary covered by !*** the parent task's data the child will receive. Then it receives !*** those pieces of information from the parent. !----------------------------------------------------------------------- ! MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent ! !----------------------------------------------------------------------- ! NUM_FCST_TASKS_PARENT=FTASKS_DOMAIN(MY_PARENT_ID) !<-- # of forecast tasks on the parent's domain ! ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%ITS(0:NUM_FCST_TASKS_PARENT-1)) !<-- Task subdomain limits for current domain's parent ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%ITE(0:NUM_FCST_TASKS_PARENT-1)) ! ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%JTS(0:NUM_FCST_TASKS_PARENT-1)) ! ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%JTE(0:NUM_FCST_TASKS_PARENT-1)) !<-- ! DO N=0,NUM_FCST_TASKS_PARENT-1 PTASK_LIMITS(MY_DOMAIN_ID)%ITS(N)=-9999 PTASK_LIMITS(MY_DOMAIN_ID)%ITE(N)=-9999 PTASK_LIMITS(MY_DOMAIN_ID)%JTS(N)=-9999 PTASK_LIMITS(MY_DOMAIN_ID)%JTE(N)=-9999 ENDDO ! CALL MPI_BARRIER(COMM_FCST_TASKS,IERR) !<-- Syncs all child fcst tasks on this domain ! !----------------------------------------------------------------------- !*** Child task 0 recvs its parent's domain limits and task subdomain !*** limits from parent task 0. !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ! NTAG=MY_DOMAIN_ID*111+1 CALL MPI_RECV(cc%PARENT_DOMAIN_LIMITS & !<-- This domain's parent's domain index limits ,4 & !<-- Total words received ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Receive from this parent task ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%ITS & !<-- Starting I on each parent forecast task's subdomain ,NUM_FCST_TASKS_PARENT & !<-- Total words received ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Receive from this parent task ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! NTAG=NTAG+1 CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%JTS & !<-- Starting J on each parent forecast task's subdomain ,NUM_FCST_TASKS_PARENT & !<-- Total words received ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Receive from this parent task ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! NTAG=NTAG+1 CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%ITE & !<-- Ending I on each parent forecast task's subdomain ,NUM_FCST_TASKS_PARENT & !<-- Total words received ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Receive from this parent task ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! NTAG=NTAG+1 CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%JTE & !<-- Ending J on each parent forecast task's subdomain ,NUM_FCST_TASKS_PARENT & !<-- Total words received ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Receive from this parent task ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! ENDIF ! !----------------------------------------------------------------------- !*** The lead child task sends the parent's domain limits and !*** task subdomain limits to all the other child forecast tasks. !----------------------------------------------------------------------- ! CALL MPI_BCAST(cc%PARENT_DOMAIN_LIMITS & !<-- This domain's parent's domain index limits ,4 & !<-- There are 4 index limits ,MPI_INTEGER & !<-- Data are integers ,0 & !<-- Data sent from child task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%ITS & !<-- Starting I indices for parent subdomains ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data ,MPI_INTEGER & !<-- Data are integers ,0 & !<-- Data sent from child task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%ITE & !<-- Ending I indices for parent subdomains ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data ,MPI_INTEGER & !<-- Data are integers ,0 & !<-- Data sent from child task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%JTS & !<-- Starting J indices for parent subdomains ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data ,MPI_INTEGER & !<-- Data are integers ,0 & !<-- Data sent from child task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%JTE & !<-- Ending J indices for parent subdomains ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data ,MPI_INTEGER & !<-- Data are integers ,0 & !<-- Data sent from child task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! !----------------------------------------------------------------------- !*** Children receive from their parents basic bookkeeping information !*** needed for the exchange of boundary data during the integration. !----------------------------------------------------------------------- ! MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent ALLOCATE(CC%PARENT_TASK(1:FTASKS_DOMAIN(MY_PARENT_ID))) !<-- Dimensioned as # of fcst tasks on domain of parent. ! CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Recv specs of new parent/child task associations ! !----------------------------------------------------------------------- !*** All the children send to their parents their boundary !*** topography so that the parents can properly balance the data !*** generated for the children's boundaries. For moving nests !*** these are only initial values that will change when the nests !*** move. !----------------------------------------------------------------------- ! CALL CHILD_SENDS_TOPO_TO_PARENT(MY_DOMAIN_ID,IMP_STATE) ! !----------------------------------------------------------------------- !*** Children are going to need some information from their !*** parents' configure files so load those objects into memory. !----------------------------------------------------------------------- ! MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) CONFIG_ID=DOMAIN_ID_TO_RANK(MY_PARENT_ID) WRITE(INT_TO_CHAR,FMT)CONFIG_ID CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the parent's config file name ! cc%CF_PARENT=ESMF_ConfigCreate(rc=RC) CF_PARENT=>cc%CF_PARENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init1: Nest Loads Parent Config File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigLoadFile(config =CF_PARENT & ,filename=CONFIG_FILE_NAME & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** What is the parent's layout of forecast tasks? !----------------------------------------------------------------------- ! INPES_PARENT=>cc%INPES_PARENT JNPES_PARENT=>cc%JNPES_PARENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init1: Child Gets Parent INPES,JNPES" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object ,value =INPES_PARENT & !<-- The variable filled (fcst tasks in I direction) ,label ='inpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object ,value =JNPES_PARENT & !<-- The variable filled (fcst tasks in J direction) ,label ='jnpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** If this child moves then some additional information is gathered. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Move Flag from Nest's Configure File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =MY_DOMAIN_MOVES & !<-- The variable filled (Move flag) ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Moving nests must know if their parents move. !----------------------------------------------------------------------- ! MY_PARENT_MOVES=>cc%MY_PARENT_MOVES MY_PARENT_MOVES=.FALSE. ! IF(MY_DOMAIN_MOVES)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Nest Checks If Parent Moves" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object ,value =MY_PARENT_MOVES & !<-- The variable filled (does the parent move?) ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(MY_PARENT_MOVES)THEN cc%FORCED_PARENT_SHIFT=.FALSE. ENDIF ! DO N=1,3 cc%PARENT_SHIFT(N)=-999 ENDDO ! !----------------------------------------------------------------------- !*** Since the nests can only move on parent timesteps and !*** are allowed to move only on physics timesteps then !*** warn the user if the Parent timestep ratio does not !*** divide evenly into the nest's physics frequency. !----------------------------------------------------------------------- ! NPHS=>cc%NPHS ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Child Gets NPHS" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =NPHS & !<-- The variable filled (frequency of physics calls) ,label ='nphs:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(MOD(NPHS,TIME_RATIO_MY_PARENT)/=0)THEN WRITE(0,*)' WARNING: Moving nest parent time ratio does' & ,' not divide into its NPHS!!!' ENDIF ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- !*** Moving nests must know the move type !----------------------------------------------------------------------- ! IF(MY_DOMAIN_MOVES)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Move Type Flag from Nest's Configure File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! MOVE_TYPE=>cc%MOVE_TYPE ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =MOVE_TYPE & !<-- The variable filled (type of this child's move) ,label ='move_type:' & !<-- Give this label's value to the previous variabl ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF (TRIM(MOVE_TYPE) == 'prescribed') THEN WRITE(PRESCRIBED_FILENAME,"(A,I2.2)") 'prescribed_moves_',MY_DOMAIN_ID OPEN(99,FILE=PRESCRIBED_FILENAME,STATUS='OLD',ACTION='READ',IOSTAT=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to open ',PRESCRIBED_FILENAME,' stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF READ(99,*)MOVE_INTERVAL_MINUTES N_MOVES=0 DO WHILE(.TRUE.) N_MOVES=N_MOVES+1 READ(99,*,END=101) ENDDO 101 CONTINUE N_MOVES=N_MOVES-1 REWIND(99) ALLOCATE(MOVE_MINUTE(N_MOVES)) ALLOCATE(MOVE_I_SW(N_MOVES)) ALLOCATE(MOVE_J_SW(N_MOVES)) READ(99,*) DO N=1,N_MOVES READ(99,*)MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N) END DO CLOSE(99) ! write(0,*)'MOVE_INTERVAL_MINUTES=',MOVE_INTERVAL_MINUTES ! write(0,*)'N_MOVES=',N_MOVES ! DO N=1,N_MOVES ! write(0,*)'MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N)',N,MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N) ! END DO ! END IF ! !----------------------------------------------------------------------- !*** The user can specify if a nest's motion must be limited to !*** only a certain number of its parent's grid increments per !*** shift. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Shift Limit from Nest's Configure File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! MAX_SHIFT=>cc%MAX_SHIFT ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object ,value =MAX_SHIFT & !<-- Max shift in parent I,J this nest can execute ,label ='max_shift:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Collisions must be avoided between a moving nest and its !*** independently moving child. When the inner nest gets too !*** close to the outer nest's boundary then the inner nest will !*** inform the outer nest that it (outer) must move away. !*** Use a totally empirical relation to determine the distance !*** measured in parent gridpoints that the parent is pushed !*** by the child. Likewise compute the minimum distance in parent !*** grid increments that the child can be to its parent's !*** boundary. These values are used by moving children and are !*** are only relevant if the parent also moves. !----------------------------------------------------------------------- ! MAX_FORCED_SHIFT=-999 MIN_DIST_PARENT=-999. ! IF(MY_PARENT_ID>1)THEN GRID_DIST_KM=DPH*A*1.E-3 !<-- Approximate grid increment in km CONST1=-8./15. CONST2=15.33333 MAX_FORCED_SHIFT=NINT(GRID_DIST_KM*SPACE_RATIO_MY_PARENT*CONST1+CONST2) MAX_FORCED_SHIFT=MIN(MAX_FORCED_SHIFT,10) MAX_FORCED_SHIFT=MAX(MAX_FORCED_SHIFT, 2) ! CONST3=-1./3. CONST4=11.33333 MIN_DIST_PARENT=GRID_DIST_KM*SPACE_RATIO_MY_PARENT*CONST3+CONST4 MIN_DIST_PARENT=MIN(MIN_DIST_PARENT,8.) MIN_DIST_PARENT=MAX(MIN_DIST_PARENT,3.) ENDIF ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- !*** If the run will use 2-way nesting then allocate the objects !*** the children will use to hold the indices of the points to !*** be updated on each parent task. The use of the upper dimension !*** of 4 in the following allocations is a reflection of the fact !*** that a nest task can update no more than 4 parent task subdomains !*** under the assumption that parent task subdomains must always !*** cover a larger physical area than child task subdomains. !----------------------------------------------------------------------- ! IF(NEST_MODE=='2-way')THEN ! !----------------------------------------------------------------------- ! CALLED_CHILD_2WAY_BOOKKEEPING=>cc%CALLED_CHILD_2WAY_BOOKKEEPING CALLED_CHILD_2WAY_BOOKKEEPING=.FALSE. ! ALLOCATE(cc%UPDATE_PARENT_2WAY(1:4)) ! ALLOCATE(cc%ID_PARENT_UPDATE_TASKS(1:4)) ALLOCATE(cc%NPTS_UPDATE_ON_PARENT_TASKS(1:4)) ! ALLOCATE(cc%I_2WAY_UPDATE(1:4)) ALLOCATE(cc%J_2WAY_UPDATE(1:4)) ! ALLOCATE(cc%I_2WAY_H(1:4)) ALLOCATE(cc%J_2WAY_H(1:4)) ALLOCATE(cc%I_2WAY_V(1:4)) ALLOCATE(cc%J_2WAY_V(1:4)) ! ALLOCATE(cc%CHILD_SFC_ON_PARENT(1:4)) ! ALLOCATE(cc%HANDLE_SEND_2WAY_DATA(1:4)) ALLOCATE(cc%HANDLE_SEND_2WAY_SFC(1:4)) ! DO N=1,4 ! cc%UPDATE_PARENT_2WAY(N)%DATA=>NULL() ! cc%ID_PARENT_UPDATE_TASKS(N)=0 cc%NPTS_UPDATE_ON_PARENT_TASKS(N)=0 ! cc%I_2WAY_UPDATE(N)%DATA=>NULL() cc%J_2WAY_UPDATE(N)%DATA=>NULL() ! cc%I_2WAY_H(N)%DATA=>NULL() cc%J_2WAY_H(N)%DATA=>NULL() cc%I_2WAY_V(N)%DATA=>NULL() cc%J_2WAY_V(N)%DATA=>NULL() ! cc%CHILD_SFC_ON_PARENT(N)%DATA=>NULL() ! cc%HANDLE_SEND_2WAY_DATA(N)=MPI_REQUEST_NULL cc%HANDLE_SEND_2WAY_SFC(N) =MPI_REQUEST_NULL ! ENDDO ! cc%NTASKS_UPDATE_PARENT=0 ! cc%NTIMESTEP_WAIT_PARENT=0 cc%NTIMESTEP_WAIT_FORCED_PARENT=0 ! cc%PARENT_WANTS_TO_MOVE=.FALSE. ! !----------------------------------------------------------------------- !*** The averaging stencil used by the child to interpolate its !*** gridpoint values to the parent's points must have permissible !*** values. The range of theoretical values are: ! Parent-Child Space Ratio ! Odd Even ! ! N_STENCIL_H (h-->H): 1,3,5,.. N_STENCIL_H (h-->H): 1,3,5,.. ! N_STENCIL_V (v-->V): 1,3,5,.. N_STENCIL_V (v-->V): 2,4,6,.. ! N_STENCIL_SFC_H (fis,pd-->H): 1,3,5,.. N_STENCIL_SFC_H (fis,pd-->H): 1,3,5,.. ! N_STENCIL_SFC_V (fis,pd-->V): 2,4,6,.. N_STENCIL_SFC_V (fis,pd-->V): 1,3,5,.. ! !*** where small letters refer to the child and capitals to the parent. !*** The stencils are oriented along I and J (they are not rotated !*** diamonds). A stencil of 1 means the child point lies on top !*** of a parent point and can thus be lifted directly to the parent !*** point with no interpolation. A stencil of 2 means a 2x2 square !*** of child points surrounding the parent point are used to average !*** onto the parent point. Likewise for 3x3, etc. Note that for !*** odd parent-to-child space ratios with odd stencil values the !*** type of child point (h or v) lying on the the target parent !*** point is the same as that target point whereas if the stencil !*** value is even then the child and parent point types are !*** different. That is not the case with an even parent-to-child !*** space ratio as seen in the above table. ! !*** HOWEVER, due to the MPI subdomain haloes we must select values !*** that are less than or equal to 3 (halo width is set in module !*** VARS_STATE with IHALO,JHALO). If the halo width increases then !*** so can the stencil values. !----------------------------------------------------------------------- ! N_STENCIL_H =>cc%N_STENCIL_H N_STENCIL_V =>cc%N_STENCIL_V N_STENCIL_SFC_H=>cc%N_STENCIL_SFC_H N_STENCIL_SFC_V=>cc%N_STENCIL_SFC_V ! IF(MOD(SPACE_RATIO_MY_PARENT,2)==1)THEN N_STENCIL_H=STENCIL_H_ODD !<-- N_STENCIL_V=STENCIL_V_ODD ! Parent-Child space ratio N_STENCIL_SFC_H=STENCIL_SFC_H_ODD ! is odd N_STENCIL_SFC_V=STENCIL_SFC_V_ODD !<-- ELSE N_STENCIL_H=STENCIL_H_EVEN !<-- N_STENCIL_V=STENCIL_V_EVEN ! Parent-Child space ratio N_STENCIL_SFC_H=STENCIL_SFC_H_EVEN ! is even N_STENCIL_SFC_V=STENCIL_SFC_V_EVEN !<-- ENDIF ! IF(MOD(N_STENCIL_H,2)/=1)THEN WRITE(0,*)' N_STENCIL_H must be odd for any Parent-Child space ratio!!!' WRITE(0,15551)SPACE_RATIO_MY_PARENT,N_STENCIL_H 15551 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_H=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(MOD(N_STENCIL_SFC_H,2)/=1)THEN WRITE(0,*)' N_STENCIL_SFC_H must be odd for any Parent-Child space ratio!!!' WRITE(0,15552)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_H 15552 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_SFC_H=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(MOD(SPACE_RATIO_MY_PARENT,2)==1)THEN !<-- For odd parent-child space ratios ! IF(MOD(N_STENCIL_V,2)/=1)THEN WRITE(0,*)' N_STENCIL_V must be odd for odd Parent-Child space ratios!!!' WRITE(0,15553)SPACE_RATIO_MY_PARENT,N_STENCIL_V 15553 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_V=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(MOD(N_STENCIL_SFC_V,2)/=0)THEN WRITE(0,*)' N_STENCIL_SFC_V must be even for odd Parent-Child space ratios!!!' WRITE(0,15554)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_V 15554 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_SFC_V=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ENDIF ! IF(MOD(SPACE_RATIO_MY_PARENT,2)==0)THEN !<-- For even parent-child space ratios ! IF(MOD(N_STENCIL_V,2)/=0)THEN WRITE(0,*)' N_STENCIL_V must be even for even Parent-Child space ratios!!!' WRITE(0,15555)SPACE_RATIO_MY_PARENT,N_STENCIL_V 15555 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_V=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(MOD(N_STENCIL_SFC_V,2)/=1)THEN WRITE(0,*)' N_STENCIL_SFC_V must be odd for even Parent-Child space ratios!!!' WRITE(0,15556)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_V 15556 FORMAT(' Parent-Child space ratio=',I2 & ,' but N_STENCIL_SFC_V=',I2) WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ENDIF ! !----------------------------------------------------------------------- !*** Initialize the flag that indicates whether or not the 2-way !*** forecast is in its first step. !----------------------------------------------------------------------- ! cc%FIRST_STEP_2WAY=.TRUE. ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF child_block ! !----------------------------------------------------------------------- !*** Parent tasks prepare various quantities for the integration. !----------------------------------------------------------------------- ! parent_block_1: IF(NUM_CHILDREN>0)THEN !<-- Select parents for additional setup ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Extract integer ratios of parent-to-child timesteps. !----------------------------------------------------------------------- ! ALLOCATE(CC%TIME_RATIO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%TIME_RATIO_MY_CHILDREN stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ! TIME_RATIO_MY_CHILDREN=>cc%TIME_RATIO_MY_CHILDREN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Parent-to-Child DT Ratio from Imp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='Parent-Child Time Ratio' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute ,valueList=TIME_RATIO_MY_CHILDREN & !<-- Ratio of parent to child DTs ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Extract the timestep from the Clock to set the initial value for !*** the child's timestep at which it will next receive parent data. !----------------------------------------------------------------------- ! CALL ESMF_ClockGet(clock =CLOCK & ,advanceCount=NTIMESTEP_ESMF & ,rc =RC) ! NTIMESTEP=NTIMESTEP_ESMF ! ALLOCATE(cc%NSTEP_CHILD_RECV(1:NUM_CHILDREN),stat=ISTAT) !<-- Children's timesteps at which they recv data IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NSTEP_CHILD_RECV stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ! NSTEP_CHILD_RECV=>cc%NSTEP_CHILD_RECV ! DO N=1,NUM_CHILDREN NSTEP_CHILD_RECV(N)=(NTIMESTEP-1)*TIME_RATIO_MY_CHILDREN(N) ENDDO ! !----------------------------------------------------------------------- !*** Allocate more arrays needed by the parent to hold child !*** information derived from the children's configure files. !----------------------------------------------------------------------- ! ALLOCATE(cc%IM_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- I extent of children's domains IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%IM_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF IM_CHILD=>cc%IM_CHILD ! ALLOCATE(cc%JM_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- J extent of children's domains IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%JM_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF JM_CHILD=>cc%JM_CHILD ! ALLOCATE(cc%PARENT_CHILD_SPACE_RATIO(1:NUM_CHILDREN),stat=ISTAT) !<-- Integer ratio of parent grid increment to children's IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PARENT_CHILD_SPACE_RATIO stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF PARENT_CHILD_SPACE_RATIO=>cc%PARENT_CHILD_SPACE_RATIO ! ALLOCATE(cc%CHILD_PARENT_SPACE_RATIO(1:NUM_CHILDREN),stat=ISTAT) !<-- Inverse of PARENT_CHILD_SPACE_RATIO IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_PARENT_SPACE_RATIO stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF CHILD_PARENT_SPACE_RATIO=>cc%CHILD_PARENT_SPACE_RATIO ! ALLOCATE(cc%N_BLEND_H_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Boundary blending width for child H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%N_BLEND_H_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF N_BLEND_H_CHILD=>cc%N_BLEND_H_CHILD ! ALLOCATE(cc%N_BLEND_V_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Boundary blending width for child V points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%N_BLEND_V_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF N_BLEND_V_CHILD=>cc%N_BLEND_V_CHILD ! ALLOCATE(cc%CHILD_ACTIVE(1:NUM_CHILDREN),stat=ISTAT) !<-- Will child participate in the digital filtering? IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_ACTIVE stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF CHILD_ACTIVE=>cc%CHILD_ACTIVE ! ALLOCATE(cc%INC_FIX(1:NUM_CHILDREN),stat=ISTAT) !<-- See below where INC_FIX is filled IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%INC_FIX stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF INC_FIX=>cc%INC_FIX ! ALLOCATE(cc%RANK_2WAY_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Location of moving nests in list of all children IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%RANK_2WAY_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF RANK_2WAY_CHILD=>cc%RANK_2WAY_CHILD ! ALLOCATE(cc%RANK_MOVING_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Location of moving nests in list of all children IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%RANK_MOVING_CHILD stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF RANK_MOVING_CHILD=>cc%RANK_MOVING_CHILD ! ALLOCATE(cc%STATIC_OR_MOVING(1:NUM_CHILDREN),stat=ISTAT) !<-- Are the individual children static or moving? IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%STATIC_OR_MOVING stat=',ISTAT CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF STATIC_OR_MOVING=>cc%STATIC_OR_MOVING ! ALLOCATE(NEST_MODE_CHILD(1:NUM_CHILDREN)) ! !----------------------------------------------------------------------- ! ALLOCATE(cc%CF(1:NUM_CHILDREN)) !<-- Configure objects of this parent's children CF=>cc%CF ! !----------------------------------------------------------------------- ! child_info_loop: DO N=1,NUM_CHILDREN ! !----------------------------------------------------------------------- !*** Initialize to nonsense the newly allocated arrays. !----------------------------------------------------------------------- ! IM_CHILD(N) =-999 JM_CHILD(N) =-999 PARENT_CHILD_SPACE_RATIO(N)=-999 CHILD_PARENT_SPACE_RATIO(N)=-999. INC_FIX(N) =-999 RANK_2WAY_CHILD(N) =-999 RANK_MOVING_CHILD(N) =-999 ! STATIC_OR_MOVING(N) ='Static' ! !----------------------------------------------------------------------- !*** The parent loads each of its children's configure files. !----------------------------------------------------------------------- ! CF(N)=ESMF_ConfigCreate(rc=RC) ! MY_CHILDREN_ID=>cc%MY_CHILDREN_ID CHILD_ID=MY_CHILDREN_ID(N) CONFIG_ID=DOMAIN_ID_TO_RANK(CHILD_ID) WRITE(INT_TO_CHAR,FMT)CONFIG_ID CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file names ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init1: Load Configure Files" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigLoadFile(config =CF(N) & ,filename=CONFIG_FILE_NAME & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(RC/=0)THEN WRITE(0,*)' Parent unable to load child configure file ' & ,TRIM(CONFIG_FILE_NAME) & ,' in PARENT_CHILD_CPL_INITIALIZE1' WRITE(0,*)' ABORTING!' CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & ,rc =RC) ENDIF ! !----------------------------------------------------------------------- !*** Extract the children's domain sizes from the configure files. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Extract Global IM,JM of Child" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =IM_CHILD(N) & !<-- The variable filled (IM of child domain) ,label ='im:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =JM_CHILD(N) & !<-- The variable filled (JM of child domain) ,label ='jm:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Extract the children's boundary blending widths. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init: Extract Child Bndry Blending Width" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =N_BLEND_H_CHILD(N) & !<-- The variable filled (N_BLEND_H of child domain N) ,label ='lnsh:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =N_BLEND_V_CHILD(N) & !<-- The variable filled (N_BLEND_V of child domain N) ,label ='lnsv:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N_BLEND_V_CHILD(N)>N_BLEND_H_CHILD(N))THEN WRITE(0,*)' N_BLEND_V CANNOT EXCEED N_BLEND_H DUE TO PD AVERAGING!!!' WRITE(0,*)' ABORTING in child N=',N CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! !----------------------------------------------------------------------- !*** Extract the integer ratio of parent-to-child grid increments. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Parent-to-Child Space Ratio" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =PARENT_CHILD_SPACE_RATIO(N) & !<-- The variable filled (# of child grid inc's to parent's) ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Use this ratio to compute an increment that is needed for !*** selecting the appropriate nest tasks as mass values on the !*** nest boundaries are averaged to the V points. Its values !*** are based on the nest grid increment distance from the !*** southernmost V point on a nest's southernmost tasks to !*** the nearest parent V point to the north. Fractional values !*** are increased to the next integer. !----------------------------------------------------------------------- ! DIST_NESTV_SOUTH_TO_PARENTV_SOUTH= & (PARENT_CHILD_SPACE_RATIO(N)-1)*0.5 INC_FIX(N)=INT(DIST_NESTV_SOUTH_TO_PARENTV_SOUTH+0.9) ! !----------------------------------------------------------------------- !*** Which of the children will be sending 2-way update data? Save !*** their ranks in the list of all child ranks. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Child's Flag Indicating Nest Mode" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =NEST_MODE_CHILD(N) & !<-- The variable filled (does the child send 2-way data?) ,label ='nest_mode:' & !<-- Give this label's value to the previous variable ,rc =RC) ! IF(NEST_MODE_CHILD(N)=='2-way')THEN NEST_MODE='2-way' ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(NEST_MODE_CHILD(N)=='2-way')THEN !<-- If true then this child sends 2-way update data. ! NUM_2WAY_CHILDREN=NUM_2WAY_CHILDREN+1 !<-- Add up the # of 2-way children. RANK_2WAY_CHILD(NUM_2WAY_CHILDREN)=N !<-- Rank of 2-way children among all children. ! ENDIF ! !----------------------------------------------------------------------- !*** Which of the children will be moving? Save their ranks in !*** the list of all children. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Child's Flag Indicating Movability" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =DOMAIN_MOVES & !<-- The variable filled (will the child move?) ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(DOMAIN_MOVES)THEN !<-- If true then child N moves. ! NUM_MOVING_CHILDREN=NUM_MOVING_CHILDREN+1 !<-- Add up the # of moving children. RANK_MOVING_CHILD(NUM_MOVING_CHILDREN)=N !<-- Location in list of children of those who move. STATIC_OR_MOVING(N)='Moving' !<-- Child N moves ! ENDIF ! !----------------------------------------------------------------------- !*** We do not allow moving parents to have static children for now. !----------------------------------------------------------------------- ! IF(MY_DOMAIN_MOVES)THEN IF(NUM_MOVING_CHILDREN/=NUM_CHILDREN)THEN WRITE(0,*)' You have specified a moving parent with' & ,' static children. This is not allowed. ' WRITE(0,*)' Moving parents can have only moving children.' WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO child_info_loop ! !----------------------------------------------------------------------- !*** The number of 2-way children is a required argument in the !*** call to NMM_INTEGRATE therefore it must be known by the NMM !*** component. Insert it into the P-C coupler export state. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Set # of 2-Way Children in P-C Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state ,name ='NUM_2WAY_CHILDREN' & ,value=NUM_2WAY_CHILDREN & !<-- Current domain has this many 2-way children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Allocate arrays/pointers needed by the parents to compute !*** update data for their children. The routine is called only !*** by parents. !----------------------------------------------------------------------- ! CALL PARENT_CHILD_INTERP_SETUP(MY_DOMAIN_ID & ,NUM_CHILDREN & ,MY_CHILDREN_ID & ,IM_CHILD & ,JM_CHILD & ,FTASKS_DOMAIN & ,N_BLEND_H_CHILD & ,N_BLEND_V_CHILD & ,CF & ,ITS,ITE,JTS,JTE & ,IDS,IDE,JDS,JDE ) ! !----------------------------------------------------------------------- !*** The lead parent task now broadcasts the locations of the !*** children's SW corner. The lead tasks recvd this information !*** from the children in phase 0 of the P-C coupler initialize !*** step (subroutine _INITIALIZE0). !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN ! IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task clears IRecv in P-C Initialize0 ID_CHILD=MY_CHILDREN_ID(N) !<-- Child N's domain ID CALL MPI_WAIT(HANDLE_I_SW(ID_CHILD) & !<-- Be sure the lead parent task has recvd child N's data. ,JSTAT & ,IERR ) ENDIF ! CALL MPI_BCAST(I_PARENT_SW(N) & !<-- Parent I of chkid N's SW corner ,1 & !<-- It is one word ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Lead parent task in parent-child intracomm is root ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task clears IRecv in P-C Initialize0 ID_CHILD=MY_CHILDREN_ID(N) !<-- Child N's domain ID CALL MPI_WAIT(HANDLE_J_SW(ID_CHILD) & !<-- Be sure the lead parent task has recvd child N's data. ,JSTAT & ,IERR ) ENDIF ! CALL MPI_BCAST(J_PARENT_SW(N) & !<-- Parent J of chkid N's SW corner ,1 & !<-- It is one word ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Lead parent task in parent-child intracomm is root ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) ! ENDDO ! !----------------------------------------------------------------------- !*** We now compute various indices and weights needed by the parents !*** to compute boundary data for their children. It is here that !*** location-dependent interpolation information is determined !*** regarding the parent and nests. Again only parents call this !*** routine. !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN CALL PREPARE_NEST_INTERP_FACTORS(N,MY_DOMAIN_ID) ENDDO ! !----------------------------------------------------------------------- !*** The parents need to send their children some key information !*** regarding the association of child boundary tasks with parent !*** tasks so the children know how to receive boundary data from !*** their parents. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** MPI request handles for nonblocking sends in the following call !*** to subroutine PARENT_SENDS_CHILD_DATA_LIMITS. !----------------------------------------------------------------------- ! ALLOCATE(HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,20001)MY_DOMAIN_ID,NUM_CHILDREN 20001 FORMAT(' Failed to allocate HANDLE_PACKET_S_H(',I2,')%CHILDREN(1:',I2,')') WRITE(0,*)' ISTAT=',ISTAT WRITE(0,*)' Aborting!' CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ALLOCATE(HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ! DO N=1,NUM_CHILDREN ! ID_CHILD=MY_CHILDREN_ID(N) N1=0 N2=FTASKS_DOMAIN(ID_CHILD)-1 ALLOCATE(HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ALLOCATE(HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) ! DO NN=N1,N2 HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL ENDDO ! ENDDO ! !----------------------------------------------------------------------- !*** Allocate unique memory locations for all of the data packets !*** that parents will send to their children's tasks to inform !*** them precisely which BC update data will be provided. !----------------------------------------------------------------------- ! ALLOCATE(INFO_SEND(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate INFO_SEND%CHILDREN stat=',ISTAT WRITE(0,*)' Aborting!' CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ! DO N=1,NUM_CHILDREN ! CHILD_ID=MY_CHILDREN_ID(N) ALLOCATE(INFO_SEND(MY_DOMAIN_ID)%CHILDREN(N)%INFO(1:6,0:FTASKS_DOMAIN(CHILD_ID)-1,1:8) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate INFO for n=',n,' child ID=',CHILD_ID,' stat=',ISTAT WRITE(0,*)' Aborting!' CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ! DO N3=1,8 DO N2=0,FTASKS_DOMAIN(CHILD_ID)-1 DO N1=1,6 INFO_SEND(MY_DOMAIN_ID)%CHILDREN(N)%INFO(N1,N2,N3)=-1 !<-- Initialize to invalid values ENDDO ENDDO ENDDO ! CALL PARENT_SENDS_CHILD_DATA_LIMITS(N,MY_DOMAIN_ID,'Future') ! ENDDO ! !----------------------------------------------------------------------- !*** Allocate the pointers that will hold the surface geopotential !*** of child tasks on each side of the child boundaries. The child !*** tasks of static nests will send that data to the appropriate !*** parent tasks. !----------------------------------------------------------------------- ! ALLOCATE(cc%FIS_CHILD_SOUTH(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%FIS_CHILD_SOUTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ALLOCATE(cc%FIS_CHILD_NORTH(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%FIS_CHILD_WEST(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%FIS_CHILD_EAST(1:NUM_CHILDREN),stat=ISTAT) ! !----------------------------------------------------------------------- !*** The parent receives the child's boundary topography. This !*** is needed to maintain hydrostatic balance when parent data is !*** interpolated to child boundaries where the terrain is different. !----------------------------------------------------------------------- ! ALLOCATE(HANDLE_CHILD_TOPO_S(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_CHILD_TOPO_N(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_CHILD_TOPO_W(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ALLOCATE(HANDLE_CHILD_TOPO_E(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) ! DO N=1,NUM_CHILDREN ! HANDLE_CHILD_TOPO_S(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() HANDLE_CHILD_TOPO_N(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() HANDLE_CHILD_TOPO_W(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() HANDLE_CHILD_TOPO_E(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() ! CALL PARENT_RECVS_CHILD_TOPO(N,MY_DOMAIN_ID) ! ENDDO ! !----------------------------------------------------------------------- !*** When the child's terrain is much lower than the parent's at !*** locations where the parent generates BC data for the child then !*** those values can be unrealistic due to the very large distance !*** the parent must extrapolate under its own ground surface. To !*** control this effect use the hyperbola Y=A/(X+A) to reduce the !*** magnitude of the parent's underground extrapolation as the !*** target depth increases. The following call returns the value !*** of the constant in the formula. One point on the curve must be !*** set by the user in subroutine HYPERBOLA in module_NESTING. !----------------------------------------------------------------------- ! CALL HYPERBOLA(HYPER_A) ! !----------------------------------------------------------------------- ! CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS N_BLEND_H_CHILD=>cc%N_BLEND_H_CHILD COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN MY_CHILDREN_ID=>cc%MY_CHILDREN_ID MYPE=>cc%MYPE ! CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(1),MYPE,IERR) !<-- Obtain local rank of parent task in p-c intracomm ! !----------------------------------------------------------------------- !*** Parents send their children the parent domain limits and the !*** integration limits of all forecast tasks on the parent domain. !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ! ALLOCATE(HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) cc%MY_DOMAIN_LIMITS(1)=IDS cc%MY_DOMAIN_LIMITS(2)=IDE cc%MY_DOMAIN_LIMITS(3)=JDS cc%MY_DOMAIN_LIMITS(4)=JDE ! ALLOCATE(HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate HANDLE_PARENT_ITS(',MY_DOMAIN_ID,')%DATA' WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ALLOCATE(HANDLE_PARENT_ITE(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PARENT_JTS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) ALLOCATE(HANDLE_PARENT_JTE(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) ! DO N=1,NUM_CHILDREN ! CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child N's lead task in parent-child intracomm NTAG=MY_CHILDREN_ID(N)*111+1 ! HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(N)=MPI_REQUEST_NULL ! CALL MPI_ISSEND(cc%MY_DOMAIN_LIMITS & !<-- Index limits of parent domain ,4 & !<-- There are 4 index limits ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK_0 & !<-- Send to each child's task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N ,HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend ,IERR ) ! HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(N)=MPI_REQUEST_NULL ! CALL MPI_ISSEND(LOCAL_ISTART & !<-- Starting I's of fcst tasks on parent domain ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK_0 & !<-- Send to each child's task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N ,HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend ,IERR ) ! NTAG=NTAG+1 CALL MPI_ISSEND(LOCAL_JSTART & !<-- Starting J's of fcst tasks on parent domain ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK_0 & !<-- Send to each child's task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N ,HANDLE_PARENT_JTS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend ,IERR ) ! NTAG=NTAG+1 CALL MPI_ISSEND(LOCAL_IEND & !<-- Ending I's of fcst tasks on parent domain ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK_0 & !<-- Send to each child's task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N ,HANDLE_PARENT_ITE(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend ,IERR ) ! NTAG=NTAG+1 CALL MPI_ISSEND(LOCAL_JEND & !<-- Ending J's of fcst tasks on parent domain ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK_0 & !<-- Send to each child's task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N ,HANDLE_PARENT_JTE(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend ,IERR ) ! ENDDO ENDIF ! !----------------------------------------------------------------------- !*** If there are any 2-way children then allocate the top of the !*** linked list that will hold specifications of each relevant !*** child task's updating of a parent task's point. !----------------------------------------------------------------------- ! IF(NUM_2WAY_CHILDREN>0)THEN ! ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(1:NUM_2WAY_CHILDREN)) DO N=1,NUM_2WAY_CHILDREN ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%TASK_ID) ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%NUM_PTS_UPDATE_HZ) ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%IL(1:2)) ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%JL(1:2)) cc%CHILD_TASKS_2WAY_UPDATE(N)%NEXT_LINK=>NULL() ENDDO ! !----------------------------------------------------------------------- !*** Initialize parent flag for its computing 2-way bookkeeping. !----------------------------------------------------------------------- ! ALLOCATE(cc%CALLED_PARENT_2WAY_BOOKKEEPING(1:NUM_2WAY_CHILDREN)) DO N=1,NUM_2WAY_CHILDREN cc%CALLED_PARENT_2WAY_BOOKKEEPING(N)=.FALSE. ENDDO ! !----------------------------------------------------------------------- !*** Allocate the object that will keep track of the number of !*** tasks on each child that will provide 2-way exchange data !*** to this parent task. !----------------------------------------------------------------------- ! ALLOCATE(cc%NTASKS_UPDATE_CHILD(1:NUM_2WAY_CHILDREN)) DO N=1,NUM_2WAY_CHILDREN cc%NTASKS_UPDATE_CHILD(N)=0 ENDDO ! !----------------------------------------------------------------------- !*** Each 2-way nest can have its own weight used in blending the !*** child's update values with the parents' pre-update values. !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILD_2WAY_WGT(1:NUM_2WAY_CHILDREN)) DO N=1,NUM_2WAY_CHILDREN cc%CHILD_2WAY_WGT(N)=-99999. ENDDO ! !----------------------------------------------------------------------- !*** Allocate the stencils used for averaging a child's data to !*** its parent's grid. !----------------------------------------------------------------------- ! ALLOCATE(cc%N_STENCIL_H_CHILD(1:NUM_2WAY_CHILDREN)) ALLOCATE(cc%N_STENCIL_v_CHILD(1:NUM_2WAY_CHILDREN)) ALLOCATE(cc%N_STENCIL_SFC_H_CHILD(1:NUM_2WAY_CHILDREN)) ALLOCATE(cc%N_STENCIL_SFC_V_CHILD(1:NUM_2WAY_CHILDREN)) ! N_STENCIL_H_CHILD=>cc%N_STENCIL_H_CHILD N_STENCIL_V_CHILD=>cc%N_STENCIL_V_CHILD N_STENCIL_SFC_H_CHILD=>cc%N_STENCIL_SFC_H_CHILD N_STENCIL_SFC_V_CHILD=>cc%N_STENCIL_SFC_V_CHILD ! DO N=1,NUM_2WAY_CHILDREN cc%N_STENCIL_H_CHILD(N)=-99999. cc%N_STENCIL_V_CHILD(N)=-99999. cc%N_STENCIL_SFC_H_CHILD(N)=-99999. cc%N_STENCIL_SFC_V_CHILD(N)=-99999. ENDDO ! !----------------------------------------------------------------------- !*** Set the 2-way children's averaging weights. When a child !*** updates its parent's points the final value is a blend of the !*** child's interpolated value and the parent's own incoming value. !----------------------------------------------------------------------- ! NN=0 ! !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN ! !----------------------------------------------------------------------- ! IF(NEST_MODE_CHILD(N)=='2-way')THEN NN=NN+1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Child's 2-Way Weight" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =cc%CHILD_2WAY_WGT(NN) & !<-- Child domain's weight in 2-way updates. ,label ='2way_wgt:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Set the children's 2-way averaging widths for H and V points. !----------------------------------------------------------------------- ! IF(MOD(PARENT_CHILD_SPACE_RATIO(N),2)==1)THEN N_STENCIL_H_CHILD(N)=STENCIL_H_ODD N_STENCIL_V_CHILD(N)=STENCIL_V_ODD N_STENCIL_SFC_H_CHILD(N)=STENCIL_SFC_H_ODD N_STENCIL_SFC_V_CHILD(N)=STENCIL_SFC_V_ODD ELSE N_STENCIL_H_CHILD(N)=STENCIL_H_EVEN N_STENCIL_V_CHILD(N)=STENCIL_V_EVEN N_STENCIL_SFC_H_CHILD(N)=STENCIL_SFC_H_EVEN N_STENCIL_SFC_V_CHILD(N)=STENCIL_SFC_V_EVEN ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO ! !----------------------------------------------------------------------- ! ENDIF ! DEALLOCATE(NEST_MODE_CHILD) ! !----------------------------------------------------------------------- !*** Allocate the Handle for use by moving parents in ISends of their !*** shift information to their children. !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ALLOCATE(cc%HANDLE_PARENT_SHIFT(1:NUM_CHILDREN)) DO N=1,NUM_CHILDREN cc%HANDLE_PARENT_SHIFT(N)=MPI_REQUEST_NULL ENDDO ENDIF ! !----------------------------------------------------------------------- !*** If a moving child comes too close to its parent's boundary !*** then the parent must move to avoid the collision. Initialize !*** the flag and shift array. !----------------------------------------------------------------------- ! cc%CHILD_FORCES_MY_SHIFT=.FALSE. cc%MY_FORCED_SHIFT(1)=-99999 cc%MY_FORCED_SHIFT(2)=-99999 ! DO N=1,3 cc%PARENT_SHIFT(N)=-999 ENDDO ! !----------------------------------------------------------------------- ! ENDIF parent_block_1 ! !----------------------------------------------------------------------- !*** All domains want to know what their very last timestep is !*** in the forecast. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child Init1: Get Forecast Length" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- This domain's configure object ,value =NHOURS_FCST & !<-- The # of hours in the forecast ,label ='nhours_fcst:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%NTIMESTEP_FINAL=NHOURS_FCST*3600./DT_DOMAIN(MY_DOMAIN_ID)-1 !<-- This domain's final timestep in the forecast ! !----------------------------------------------------------------------- !*** If there is digital filtering does this domain participate? !*** Currently a nest must be static and 1-way for this to be !*** considered. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Extract domain DFI flag from P-C cpl imp state" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='I Am Active' & !<-- Name of Attribute to extract ,value=I_AM_ACTIVE & !<-- Does domain participate in digital filtering? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Insert the flag indicating digital filter activity into the !*** P-C coupler export state. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init1: Insert DFI activity flag into P-C Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state ,name ='I Am Active' & ,value=I_AM_ACTIVE & !<-- Does this domain execute the digital filter? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(NUM_CHILDREN>0)THEN ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract child DFI flags from P-C cpl import state" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state ,name ='Child Active' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute ,valueList=CHILD_ACTIVE & !<-- Which children participate in digital filtering? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert child DFI flags into P-C cpl export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXP_STATE & !<-- This Parent_child Coupler export state ,name ='Child Active' & !<-- Name of the attribute to extract ,itemCount=NUM_CHILDREN & !<-- # of words in the data ,valueList=CHILD_ACTIVE & !<-- Which children participate in digital filtering? ,rc =RC) ! ENDIF ! !----------------------------------------------------------------------- ! IF(RC_CPL_INIT==ESMF_SUCCESS)THEN ! WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP SUCCEEDED" ELSE WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP FAILED" ENDIF ! RC_FINAL=RC_CPL_INIT ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE1 ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_CPL_INITIALIZE2(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** Perform final work needed by the Parent-Child coupler. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: CONFIG_ID & ,ID_CHILD,KR & ,MINUTES_RESTART,MY_DOMAIN_ID & ,N,N_FIELD,N_MOVING,N1,N2,NN & ,NROWS_P_UPD_X,NTAG,NTIMESTEP & ,NUM_CHILD_TASKS,NUM_DIMS,NV & ,SFC_FILE_RATIO,UPDATE_TYPE_INT ! INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_LO,LIMITS_HI ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: DPH_1,DLM_1 & ,SBD_1,WBD_1 & ,TPH0D_1,TLM0D_1 ! REAL(kind=KFPT) :: LATITUDE_LIMIT ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: DUMMY_3D=>NULL() ! REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,FACTOR1,FACTOR2,PI ! LOGICAL(kind=KLOG) :: FOUND ! LOGICAL(kind=KLOG) :: I_AM_A_NEST & ,INTEGRATE_TIMESTEP ! CHARACTER(len=1) :: UPDATE_TYPE_CHAR CHARACTER(len=2) :: INT_TO_CHAR CHARACTER(len=6) :: FMT='(I2.2)' CHARACTER(len=99) :: FIELD_NAME ! TYPE(COMPOSITE),POINTER :: CC ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! TYPE(ESMF_Field) :: HOLD_FIELD ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_INIT=ESMF_SUCCESS ! !---------------------- !*** This domain's ID !---------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Point to this domain's values in the composite object. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite ! !----------------------------------------------------------------------- ! NUM_CHILDREN=>cc%NUM_CHILDREN !<-- How many children does this domain have? ! D_ONE=1. D_180=180. PI=DACOS(-D_ONE) D2R=PI/D_180 ! !----------------------------------------------------------------------- !*** Begin the work of the parents. !----------------------------------------------------------------------- ! parent_block_2: IF(NUM_CHILDREN>0)THEN ! !----------------------------------------------------------------------- !*** Allocate arrays for the parents' tracking of when children have !*** data ready to send in 2-way nesting. Also initialize the flag !*** that allows DOMAIN_RUN to always be called during the first !*** pass through NMM_INTEGRATE. For 1-way nesting the flag will !*** remain TRUE and never be reset. !----------------------------------------------------------------------- ! IF(NUM_2WAY_CHILDREN>0)THEN ALLOCATE(cc%SIGNAL_2WAY_SEND_READY(1:NUM_2WAY_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SIGNAL_2WAY_SEND_READY stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF SIGNAL_2WAY_SEND_READY=>cc%SIGNAL_2WAY_SEND_READY ! DO N=1,NUM_2WAY_CHILDREN SIGNAL_2WAY_SEND_READY(N)=.FALSE. ENDDO ! ALLOCATE(cc%SKIP_2WAY_UPDATE(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SKIP_2WAY_UPDATE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF SKIP_2WAY_UPDATE=>cc%SKIP_2WAY_UPDATE ! DO N=1,NUM_CHILDREN SKIP_2WAY_UPDATE(N)=.FALSE. ENDDO ! ENDIF ! ALLOCATE(cc%HANDLE_SEND_ALLCLEAR(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_SEND_ALLCLEAR stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF HANDLE_SEND_ALLCLEAR=>cc%HANDLE_SEND_ALLCLEAR ! DO N=1,NUM_CHILDREN HANDLE_SEND_ALLCLEAR(N)=MPI_REQUEST_NULL ENDDO ! cc%KOUNT_2WAY_CHILDREN=0 ! cc%FIRST_CALL_RECV_2WAY=.TRUE. INTEGRATE_TIMESTEP=.TRUE. cc%RECV_ALL_CHILD_DATA=.TRUE. ! RECV_ALL_CHILD_DATA=>cc%RECV_ALL_CHILD_DATA ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Set Integrate Flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state ,name ='Integrate Flag' & ,value=INTEGRATE_TIMESTEP & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Set Recv Flag for Child Data" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state ,name ='Recv All Child Data' & ,value=RECV_ALL_CHILD_DATA & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Write/quilt tasks return now since the rest of the routine !*** is directly or indirectly related to the grid. !----------------------------------------------------------------------- ! IF(.NOT.I_AM_A_FCST_TASK)RETURN ! !----------------------------------------------------------------------- !*** Allocate the pointers that will hold all of the interpolated !*** boundary data for the child tasks if the parent task contains !*** child boundary points on the four sides. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** The data pointer within the CHILD_BOUND_* arrays will !*** hold the boundary data of each child tasks' boundary data in a !*** 1-D string that will be used to send the data from the parent !*** to the child tasks. The *_B_* arrays are what will be sent !*** into subroutine PARENT_TO_CHILD_BNDRY_COMPUTE where the !*** actual computations of the boundary data are carried out. !*** The unallocated subcomponents of the *_B_* arrays are filled !*** by the routine and thus the 1-D string will automatically !*** be filled and ready for sending to each child task that contains !*** boundary points. ! !*** NOTE the heirarchy of the derived data variables' pointers !*** that hold the boundary data: ! !*** (1) Primary variable dimensioned 1-D over the children. !*** (2) For each child, TASKS is dimensioned 1-D over the given !*** child's tasks that contain segments of boundary on the !*** parent task. !*** (3) For each child task, DATA is dimensioned 1-D since !*** 1-D strings are required for MPI Send/Recv. !*** (a) The 1-D CHILD_BOUND_* DATA pointers are allocated !*** and are filled with the child boundary data destined !*** for each individual child task that contains any !*** segment of a child's boundary on a given parent !*** task. !*** (b) The specific boundary variables (T_B_*, Q_B_*, etc.) !*** DATA subcomponent pointers are declared but never !*** allocated and instead are simply pointed into the !*** allocated 1-D CHILD_BOUND_* DATA subcomponent pointer. !*** These specific boundary variables are sent into the !*** subroutine where the child boundary data is computed !*** which then leads to the allocated CHILD_BOUND_* 1-D !*** DATA pointer being filled automatically. Thus the !*** allocated 1-D pointer is immediately ready for subsequent !*** sending to child tasks. !*** The subcomponent pointer for PD_B_* though must be !*** allocated. That is because it contains values one row !*** beyond those actually needed to be sent to the child !*** tasks to update their boundary values of PD. That !*** extra row is used to do 4-pt averaging to obtain PD !*** on V points within the nests' boundary regions which !*** is needed to do the hydrostatic updating of the winds !*** there. So the PD_B sections of the full 1-D DATA !*** pointer CHILD_BOUND_* that is actually sent from !*** parents to children must be filled explicitly inside !*** subroutine PARENT_UPDATE_CHILD_PSFC. !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILD_BOUND_H_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Sbndry H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_SOUTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILD_BOUND_H_SOUTH=>cc%CHILD_BOUND_H_SOUTH ! ALLOCATE(cc%CHILD_BOUND_V_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Sbndry V points CHILD_BOUND_V_SOUTH=>cc%CHILD_BOUND_V_SOUTH ! !----------------------------------------------------------------------- ! ALLOCATE(cc%WORDS_BOUND_H_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Sbndry H point 1-D data string WORDS_BOUND_H_SOUTH=>cc%WORDS_BOUND_H_SOUTH ! ALLOCATE(cc%WORDS_BOUND_V_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Sbndry V point 1-D data string WORDS_BOUND_V_SOUTH=>cc%WORDS_BOUND_V_SOUTH ! !----------------------------------------------------------------------- ! ALLOCATE(cc%PD_B_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- South boundary PD on H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PD_B_SOUTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PD_B_SOUTH=>cc%PD_B_SOUTH ! ALLOCATE(cc%PD_B_SOUTH_V(1:NUM_CHILDREN),stat=ISTAT) !<-- South boundary PD on V points PD_B_SOUTH_V=>cc%PD_B_SOUTH_V ! !----------------------------------------------------------------------- !*** Allocate the working objects used by the parents for H-pt !*** update variables on the nest boundaries. Exclude PD since !*** it must be handled separately (thus the '-1' in the allocates). !----------------------------------------------------------------------- ! ALLOCATE(cc%BND_VAR_H_SOUTH(1:NVARS_NESTBC_H-1),stat=ISTAT) IF(ISTAT>0)THEN WRITE(0,11001)NVARS_NESTBC_H-1,ISTAT 11001 FORMAT(' P-C Init2 failed to allocate BND_VAR_H_SOUTH(1:',I2,') istat=',i3) ENDIF ALLOCATE(cc%BND_VAR_H_NORTH(1:NVARS_NESTBC_H-1),stat=ISTAT) ALLOCATE(cc%BND_VAR_H_WEST (1:NVARS_NESTBC_H-1),stat=ISTAT) ALLOCATE(cc%BND_VAR_H_EAST (1:NVARS_NESTBC_H-1),stat=ISTAT) ! DO NV=1,NVARS_NESTBC_H-1 ALLOCATE(cc%BND_VAR_H_SOUTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT>0)THEN WRITE(0,11011)NV,NUM_CHILDREN,ISTAT 11011 FORMAT(' P-C Init2 failed to allocate BND_VAR_H_SOUTH(',I2,')%CHILD(1:',I2,') istat=',i3) ENDIF ALLOCATE(cc%BND_VAR_H_NORTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%BND_VAR_H_WEST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%BND_VAR_H_EAST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ENDDO ! BND_VAR_H_SOUTH=>cc%BND_VAR_H_SOUTH BND_VAR_H_NORTH=>cc%BND_VAR_H_NORTH BND_VAR_H_WEST =>cc%BND_VAR_H_WEST BND_VAR_H_EAST =>cc%BND_VAR_H_EAST ! !----------------------------------------------------------------------- !*** Allocate the working objects used by the parents for V-pt !*** update variables on the nest boundaries. !----------------------------------------------------------------------- ! ALLOCATE(cc%BND_VAR_V_SOUTH(1:NVARS_NESTBC_V),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_NORTH(1:NVARS_NESTBC_V),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_WEST (1:NVARS_NESTBC_V),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_EAST (1:NVARS_NESTBC_V),stat=ISTAT) ! DO NV=1,NVARS_NESTBC_V ALLOCATE(cc%BND_VAR_V_SOUTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_NORTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_WEST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ALLOCATE(cc%BND_VAR_V_EAST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) ENDDO ! BND_VAR_V_SOUTH=>cc%BND_VAR_V_SOUTH BND_VAR_V_NORTH=>cc%BND_VAR_V_NORTH BND_VAR_V_WEST =>cc%BND_VAR_V_WEST BND_VAR_V_EAST =>cc%BND_VAR_V_EAST ! !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILD_BOUND_H_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Nbndry H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_NORTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILD_BOUND_H_NORTH=>cc%CHILD_BOUND_H_NORTH ! ALLOCATE(cc%CHILD_BOUND_V_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Nbndry V points CHILD_BOUND_V_NORTH=>cc%CHILD_BOUND_V_NORTH ! !----------------------------------------------------------------------- ! ALLOCATE(cc%WORDS_BOUND_H_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Nbndry H point 1-D data string WORDS_BOUND_H_NORTH=>cc%WORDS_BOUND_H_NORTH ! ALLOCATE(cc%WORDS_BOUND_V_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Nbndry V point 1-D data string WORDS_BOUND_V_NORTH=>cc%WORDS_BOUND_V_NORTH ! !----------------------------------------------------------------------- ! ALLOCATE(cc%PD_B_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- North boundary PD on H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PD_B_NORTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PD_B_NORTH=>cc%PD_B_NORTH ! ALLOCATE(cc%PD_B_NORTH_V(1:NUM_CHILDREN),stat=ISTAT) !<-- North boundary PD on V points PD_B_NORTH_V=>cc%PD_B_NORTH_V ! !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILD_BOUND_H_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Wbndry H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_WEST stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILD_BOUND_H_WEST=>cc%CHILD_BOUND_H_WEST ! ALLOCATE(cc%CHILD_BOUND_V_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Wbndry V points CHILD_BOUND_V_WEST=>cc%CHILD_BOUND_V_WEST ! !----------------------------------------------------------------------- ! ALLOCATE(cc%WORDS_BOUND_H_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Wbndry H point 1-D data string WORDS_BOUND_H_WEST=>cc%WORDS_BOUND_H_WEST ! ALLOCATE(cc%WORDS_BOUND_V_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Wbndry V point 1-D data string WORDS_BOUND_V_WEST=>cc%WORDS_BOUND_V_WEST ! !----------------------------------------------------------------------- ! ALLOCATE(cc%PD_B_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- West boundary PD on H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PD_B_WEST stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PD_B_WEST=>cc%PD_B_WEST ! ALLOCATE(cc%PD_B_WEST_V(1:NUM_CHILDREN),stat=ISTAT) !<-- West boundary PD on V points PD_B_WEST_V=>cc%PD_B_WEST_V ! !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILD_BOUND_H_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Ebndry H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_EAST stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILD_BOUND_H_EAST=>cc%CHILD_BOUND_H_EAST ! ALLOCATE(cc%CHILD_BOUND_V_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Ebndry V points CHILD_BOUND_V_EAST=>cc%CHILD_BOUND_V_EAST ! ALLOCATE(cc%WORDS_BOUND_H_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Ebndry H point 1-D data string WORDS_BOUND_H_EAST=>cc%WORDS_BOUND_H_EAST ! ALLOCATE(cc%WORDS_BOUND_V_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Ebndry V point 1-D data string WORDS_BOUND_V_EAST=>cc%WORDS_BOUND_V_EAST ! !----------------------------------------------------------------------- ! ALLOCATE(cc%PD_B_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- East boundary PD on H points IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PD_B_EAST stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PD_B_EAST=>cc%PD_B_EAST ! ALLOCATE(cc%PD_B_EAST_V(1:NUM_CHILDREN),stat=ISTAT) !<-- East boundary PD on V points PD_B_EAST_V=>cc%PD_B_EAST_V ! DO NN=1,2 DO N=1,NUM_CHILDREN CHILD_BOUND_H_SOUTH(N,NN)%TASKS=>NULL() CHILD_BOUND_H_NORTH(N,NN)%TASKS=>NULL() CHILD_BOUND_H_WEST(N,NN)%TASKS=>NULL() CHILD_BOUND_H_EAST(N,NN)%TASKS=>NULL() ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Allocate dummy subcomponents for the working pointers for (N,2) !*** which correspond to values used when parents must send BC data !*** to a nest immediately after it has moved, i.e., for that nest's !*** current time and not for its future time. Pointers for (N,1) !*** will always be allocated ahead of deallocation since they are !*** continually needed for the parent's sending BC data to all the !*** nests from their future. !*** In the normal sequence these working pointers are deallocated !*** each time a nest moves so that they can be reallocated properly !*** for the given association of parent and nest tasks. Therefore !*** they must be allocated already for the deallocations that take !*** place with each nest's first move. !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN ! ALLOCATE(CHILD_BOUND_H_SOUTH(N,2)%TASKS(1)) ALLOCATE(CHILD_BOUND_V_SOUTH(N,2)%TASKS(1)) CHILD_BOUND_H_SOUTH(N,2)%TASKS(1)%DATA=>NULL() CHILD_BOUND_V_SOUTH(N,2)%TASKS(1)%DATA=>NULL() ! ALLOCATE(CHILD_BOUND_H_NORTH(N,2)%TASKS(1)) ALLOCATE(CHILD_BOUND_V_NORTH(N,2)%TASKS(1)) CHILD_BOUND_H_NORTH(N,2)%TASKS(1)%DATA=>NULL() CHILD_BOUND_V_NORTH(N,2)%TASKS(1)%DATA=>NULL() ! ALLOCATE(CHILD_BOUND_H_WEST(N,2)%TASKS(1)) ALLOCATE(CHILD_BOUND_V_WEST(N,2)%TASKS(1)) CHILD_BOUND_H_WEST(N,2)%TASKS(1)%DATA=>NULL() CHILD_BOUND_V_WEST(N,2)%TASKS(1)%DATA=>NULL() ! ALLOCATE(CHILD_BOUND_H_EAST(N,2)%TASKS(1)) ALLOCATE(CHILD_BOUND_V_EAST(N,2)%TASKS(1)) CHILD_BOUND_H_EAST(N,2)%TASKS(1)%DATA=>NULL() CHILD_BOUND_V_EAST(N,2)%TASKS(1)%DATA=>NULL() ! ENDDO ! !----------------------------------------------------------------------- !*** Allocate logical flags indicating if parent task holds any !*** child boundary points for the purpose of sending that data !*** to pertinent child tasks. !----------------------------------------------------------------------- ! ALLOCATE(cc%SEND_CHILD_DATA(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SEND_CHILD_DATA stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF SEND_CHILD_DATA=>cc%SEND_CHILD_DATA ! !----------------------------------------------------------------------- !*** Allocate the handles to be used by parent tasks when they ISend !*** data directly to the appropiate child boundary tasks. The 2nd !*** dimension is 2 because these handles are used in two different !*** and essentially independent situations. The first is when the !*** parents send their children the usual boundary updates from the !*** children's future so that the children can compute time tendencies !*** for their integration through the next parent timestep. The !*** second is when parents send their moving children the same set !*** of boundary values that they will receive at one of their !*** current timesteps immediately after they move to a new location. !*** Those values will serve as the time N values in the subsequent !*** tendency computations for variable X: [X(N+1)-X(N)]/DT(parent) !*** Note that while the 2nd dimension of all children is 2, the !*** Handles' subcomponents associated with that index's value of 2 !*** will be allocated and used only for moving nests. !----------------------------------------------------------------------- ! ALLOCATE(cc%HANDLE_H_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_H_SOUTH stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF HANDLE_H_SOUTH=>cc%HANDLE_H_SOUTH ! ALLOCATE(cc%HANDLE_H_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_H_NORTH=>cc%HANDLE_H_NORTH ! ALLOCATE(cc%HANDLE_H_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_H_WEST=>cc%HANDLE_H_WEST ! ALLOCATE(cc%HANDLE_H_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_H_EAST=>cc%HANDLE_H_EAST ! ALLOCATE(cc%HANDLE_V_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_V_SOUTH=>cc%HANDLE_V_SOUTH ! ALLOCATE(cc%HANDLE_V_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_V_NORTH=>cc%HANDLE_V_NORTH ! ALLOCATE(cc%HANDLE_V_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_V_WEST=>cc%HANDLE_V_WEST ! ALLOCATE(cc%HANDLE_V_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) HANDLE_V_EAST=>cc%HANDLE_V_EAST ! DO N=1,NUM_CHILDREN ! ALLOCATE(HANDLE_H_SOUTH(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_V_SOUTH(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_H_NORTH(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_V_NORTH(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_H_WEST(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_V_WEST(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_H_EAST(N,2)%NTASKS_TO_RECV(1)) ALLOCATE(HANDLE_V_EAST(N,2)%NTASKS_TO_RECV(1)) ! HANDLE_H_SOUTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_V_SOUTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_H_NORTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_V_NORTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_H_WEST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_V_WEST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_H_EAST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL HANDLE_V_EAST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ! ENDDO ! !----------------------------------------------------------------------- !*** Point unallocated working pointers of parent's interpolated data !*** into the allocated composite pointer holding all boundary data !*** to be sent to each child from their future. !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN CALL POINT_INTERP_DATA_TO_MEMORY(N,MY_DOMAIN_ID,'Future') ENDDO ! !----------------------------------------------------------------------- !*** Allocate an array of logical flags the parent will use for its !*** moving children to know when they want to move. !*** Also allocate the composite data object that will hold all of !*** the update data the parent sends to its moving children and !*** the associated Handles for the ISends. !----------------------------------------------------------------------- ! IF(NUM_MOVING_CHILDREN>0)THEN ALLOCATE(cc%MOVE_FLAG(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%MOVE_FLAG stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF MOVE_FLAG=>cc%MOVE_FLAG MY_CHILDREN_ID=>cc%MY_CHILDREN_ID ! ALLOCATE(cc%HANDLE_BC_UPDATE(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_BC_UPDATE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF HANDLE_BC_UPDATE=>cc%HANDLE_BC_UPDATE ! ALLOCATE(cc%HANDLE_TIMESTEP(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_TIMESTEP stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF HANDLE_TIMESTEP=>cc%HANDLE_TIMESTEP ! ALLOCATE(cc%HANDLE_MOVE_DATA(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_MOVE_DATA stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF HANDLE_MOVE_DATA=>cc%HANDLE_MOVE_DATA ! DO N=1,NUM_MOVING_CHILDREN MOVE_FLAG(N) =.FALSE. HANDLE_BC_UPDATE(N)=MPI_REQUEST_NULL HANDLE_TIMESTEP(N) =MPI_REQUEST_NULL ! N_MOVING=RANK_MOVING_CHILD(N) NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N_MOVING)) ALLOCATE(HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV(1:NUM_CHILD_TASKS)) ! DO NN=1,NUM_CHILD_TASKS HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ENDDO ! ALLOCATE(cc%TASK_UPDATE_SPECS(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%TASK_UPDATE_SPECS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF TASK_UPDATE_SPECS=>cc%TASK_UPDATE_SPECS ! ALLOCATE(cc%MOVING_CHILD_UPDATE(1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%MOVING_CHILD_UPDATE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF MOVING_CHILD_UPDATE=>cc%MOVING_CHILD_UPDATE ! DO N=1,NUM_MOVING_CHILDREN TASK_UPDATE_SPECS(N)%TASK_ID=>NULL() TASK_UPDATE_SPECS(N)%NUM_PTS_UPDATE_HZ=>NULL() TASK_UPDATE_SPECS(N)%NEXT_LINK=>NULL() MOVING_CHILD_UPDATE(N)%TASKS=>NULL() ENDDO ! ALLOCATE(cc%SHIFT_INFO_CHILDREN(1:4,1:NUM_MOVING_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SHIFT_INFO_CHILDREN stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF SHIFT_INFO_CHILDREN=>cc%SHIFT_INFO_CHILDREN ! DO N2=1,NUM_MOVING_CHILDREN DO N1=1,4 SHIFT_INFO_CHILDREN(N1,N2)=0 ENDDO ENDDO ! !----------------------------------------------------------------------- !*** If this is a restarted run then take the value of the children's !*** next move timestep from the import state (the values having !*** originated from the Solver's read of the restart file). !----------------------------------------------------------------------- ! IF(RESTART)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Get Next Move Timestep of Children for Restart" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Parent-Child coupler import state ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name in import state ,valueList=cc%NTIMESTEP_CHILD_MOVES & !<-- The next timestep the moving children move ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! cc%NCYCLE_PARENT=0 ! !----------------------------------------------------------------------- ! ENDIF parent_block_2 ! !----------------------------------------------------------------------- !*** Both parent and child need to know the child's shift information. !----------------------------------------------------------------------- ! ALLOCATE(cc%SHIFT_INFO_MINE(1:4),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%SHIFT_INFO_MINE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF SHIFT_INFO_MINE=>cc%SHIFT_INFO_MINE ! DO N=1,4 SHIFT_INFO_MINE(N)=-99999 ENDDO ! !----------------------------------------------------------------------- ! I_AM_A_NEST=.TRUE. ! IF(COMM_TO_MY_PARENT==-999)THEN !<-- The uppermost parent I_AM_A_NEST=.FALSE. ENDIF ! !----------------------------------------------------------------------- !*** Everyone loads the coupler export state with the flag indicating !*** whether or not they are a nest. Nests load the flag indicating !*** if they move or not. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Nest Flag into the Coupler Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state ,name ='I-Am-A-Nest Flag' & !<-- The name of the flag ,value=I_AM_A_NEST & !<-- The nest flag ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! IF(I_AM_A_NEST)THEN ! !----------------------------------------------------------------------- !*** If this child moves then a variety of motion-related issues !*** are now taken care of. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Moving Nest Flag into the Coupler Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state ,name ='MY_DOMAIN_MOVES' & !<-- The name of the flag ,value=MY_DOMAIN_MOVES & !<-- The moving nest flag ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** If this is not a restarted run then initialize the value of !*** the nest's next move timestep to nonsense. If this is a !*** restarted run then the value originated in the restart file !*** and was obtained through the P-C coupler import state in !*** PARENT_CHILD_COUPLER_SETUP. !----------------------------------------------------------------------- ! NEXT_MOVE_TIMESTEP=>cc%NEXT_MOVE_TIMESTEP ! IF(.NOT.RESTART)THEN NEXT_MOVE_TIMESTEP=-999999 ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Insert NEST_MOVE_TIMESTEP into P-C Cpl Exp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute ,value=NEXT_MOVE_TIMESTEP & !<-- Initialized value for nest's next move timestep ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! I_SHIFT_CHILD=>cc%I_SHIFT_CHILD J_SHIFT_CHILD=>cc%J_SHIFT_CHILD I_SHIFT_CHILD=-999999 J_SHIFT_CHILD=-999999 ! I_SW_PARENT_NEW=>cc%I_SW_PARENT_NEW J_SW_PARENT_NEW=>cc%J_SW_PARENT_NEW ! LAST_STEP_MOVED=>cc%LAST_STEP_MOVED ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nests get their SW corners." ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =I_SW_PARENT_NEW & !<-- The nest's SW corner I on its parent's grid. ,label ='i_parent_start:' & !<-- The configure label ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =J_SW_PARENT_NEW & !<-- The nest's SW corner J on its parent's grid. ,label ='j_parent_start:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Insert I_SHIFT/J_SHIFT into P-C Cpl Exp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='I_SHIFT' & !<-- Insert Attribute with this name ,value=I_SHIFT_CHILD & !<-- Motion of nest in I on its grid ,rc =RC ) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='J_SHIFT' & !<-- Insert Attribute with this name ,value=J_SHIFT_CHILD & !<-- Motion of nest in J on its grid ,rc =RC ) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='I_SW_PARENT_NEW' & !<-- Insert Attribute with this name ,value=I_SW_PARENT_NEW & !<-- Motion of nest in I on its grid ,rc =RC ) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='J_SW_PARENT_NEW' & !<-- Insert Attribute with this name ,value=J_SW_PARENT_NEW & !<-- Motion of nest in J on its grid ,rc =RC ) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='LAST_STEP_MOVED' & !<-- Insert Attribute with this name ,value=LAST_STEP_MOVED & !<-- Motion of nest in J on its grid ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! I_WANT_TO_MOVE=>cc%I_WANT_TO_MOVE MOVE_FLAG_SENT=>cc%MOVE_FLAG_SENT ! I_WANT_TO_MOVE=.FALSE. !<-- Initialize the nest 'move' flag MOVE_FLAG_SENT=.FALSE. !<-- Initialize the flag for ISending the nest move flag ! HANDLE_MOVE_FLAG=>cc%HANDLE_MOVE_FLAG HANDLE_MOVE_FLAG=MPI_REQUEST_NULL ! !----------------------------------------------------------------------- !*** Allocate variables for children's handling their data exchange !*** with parents in 2-way nesting. !----------------------------------------------------------------------- ! IF(NEST_MODE=='2-way')THEN ! !----------------------------------------------------------------------- ! HANDLE_SEND_2WAY_SIGNAL=>cc%HANDLE_SEND_2WAY_SIGNAL ! HANDLE_SEND_2WAY_SIGNAL=MPI_REQUEST_NULL ! cc%FIRST_CALL_RECV_BC=.TRUE. ! cc%NTIMESTEP_CHECK=-99999 ! cc%NCYCLE_CHILD=0 ! ENDIF ! ENDIF ! ! ALLCLEAR=.TRUE. ALLCLEAR_SIGNAL_PRESENT=.FALSE. STOP_MY_MOTION=.FALSE. ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Insert Initial ALLCLEAR Flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state ,name ='ALLCLEAR' & !<-- The name of the flag ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- The moving nest flag ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Now take care of several issues related to moving nests. !*** All moving nests and their parents must participate. !----------------------------------------------------------------------- ! parents_and_moving: IF(NUM_MOVING_CHILDREN>0 & !<-- This is a parent of moving nests. .OR. & ! MY_DOMAIN_MOVES)THEN !<-- This is a moving nest. ! !----------------------------------------------------------------------- !*** Extract the Bundle with the 2-D and 3-D arrays of Solver !*** internal state variables needed for updating any nests that !*** are moving. Since the eventual update of moving nest data !*** will be done via looping through the Fields in the Bundles !*** we need to know how many Fields there are. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Bundles for Updates of Moving Nests in P-C Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state ,itemname ='Move_Bundle H' & !<-- Name of Bundle of internal state arrays to update ,fieldbundle=MOVE_BUNDLE_H & !<-- The H-point ESMF Bundle ,rc =RC) ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state ,itemname ='Move_Bundle V' & !<-- Name of Bundle of internal state arrays to update ,fieldbundle=MOVE_BUNDLE_V & !<-- The V-point ESMF Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How many Fields in the H Bundle?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- The ESMF Bundle of H update arrays for moving nests ,fieldcount =NUM_FIELDS_MOVE & !<-- # of Fields in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Count the number of 2-D and 3-D Fields. Those numbers will be !*** needed to know how many points are updated on moving nest tasks. !*** Also initialize the flag telling parent domains they must !*** update halos of motion-related variables after they shift. !----------------------------------------------------------------------- ! NUM_FIELDS_MOVE_2D_H_I=0 NUM_FIELDS_MOVE_2D_X_I=0 NUM_FIELDS_MOVE_2D_H_R=0 NUM_FIELDS_MOVE_2D_X_R=0 NUM_FIELDS_MOVE_3D_H=0 NUM_LEVELS_MOVE_3D_H=0 ! !----------------------------------------------------------------------- ! DO N_FIELD=1,NUM_FIELDS_MOVE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fields from H Move Bundle for Counting" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How Many Dims in H Move Bundle Field?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract UPDATE_TYPE from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field ,name ='UPDATE_TYPE' & !<-- Name of the attribute to extract ,value=UPDATE_TYPE_INT & !<-- Value of the Attribute ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(UPDATE_TYPE_INT==1)THEN UPDATE_TYPE_CHAR='H' !<-- Ordinary H-pt variable ELSEIF(UPDATE_TYPE_INT==2)THEN UPDATE_TYPE_CHAR='L' !<-- H-pt land sfc variable ELSEIF(UPDATE_TYPE_INT==3)THEN UPDATE_TYPE_CHAR='S' !<-- H-pt sea sfc variable ELSEIF(UPDATE_TYPE_INT==4)THEN UPDATE_TYPE_CHAR='F' !<-- H-pt variable updated from external file ELSEIF(UPDATE_TYPE_INT==5)THEN UPDATE_TYPE_CHAR='V' !<-- Ordinary V-pt variable ENDIF ! !----------------------------------------------------------------------- ! IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Does the Field Contain Integer or Real Data?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,typekind=DATATYPE & !<-- Is the data Integer or Real? ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(DATATYPE==ESMF_TYPEKIND_I4)THEN NUM_FIELDS_MOVE_2D_H_I=NUM_FIELDS_MOVE_2D_H_I+1 !<-- Count ALL 2-D Integer Fields IF(UPDATE_TYPE_CHAR=='F')THEN NUM_FIELDS_MOVE_2D_X_I=NUM_FIELDS_MOVE_2D_X_I+1 !<-- Count the 2-D Integer variables updated from external files ENDIF ! ELSE NUM_FIELDS_MOVE_2D_H_R=NUM_FIELDS_MOVE_2D_H_R+1 !<-- Count ALL 2-D Real Fields IF(UPDATE_TYPE_CHAR=='F')THEN NUM_FIELDS_MOVE_2D_X_R=NUM_FIELDS_MOVE_2D_X_R+1 !<-- Count the 2-D Real variables updated from external files ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 3rd Dimension Limits in 3-D H Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle ,localDe =0 & ,farrayPtr =DUMMY_3D & !<-- Dummy 3-D array with Field's data ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NUM_FIELDS_MOVE_3D_H=NUM_FIELDS_MOVE_3D_H+1 !<-- Count the 3-D Real H Fields ! NUM_LEVELS_MOVE_3D_H=LIMITS_HI(3)-LIMITS_LO(3)+1 & !<-- Count the # of 2-D levels in the 3-D H Fields +NUM_LEVELS_MOVE_3D_H ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How many Fields in the V Bundle?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- The ESMF Bundle of V update arrays for moving nests ,fieldcount =NUM_FIELDS_MOVE & !<-- # of Fields in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Count the number of 2-D and 3-D Fields. Those numbers will be !*** needed to know how many points are updated on moving nest tasks. !----------------------------------------------------------------------- ! NUM_FIELDS_MOVE_2D_V=0 NUM_FIELDS_MOVE_3D_V=0 NUM_LEVELS_MOVE_3D_V=0 ! DO N_FIELD=1,NUM_FIELDS_MOVE ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fields from V Move Bundle for Counting" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the H arrays for move updates ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How Many Dims in V Move Bundle Field?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(NUM_DIMS==2)THEN NUM_FIELDS_MOVE_2D_V=NUM_FIELDS_MOVE_2D_V+1 ! ELSEIF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 3rd Dimension Limits in 3-D V Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle ,localDe =0 & ,farrayPtr =DUMMY_3D & !<-- Dummy 3-D array with Field's data ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NUM_FIELDS_MOVE_3D_V=NUM_FIELDS_MOVE_3D_V+1 !<-- Count the 3-D V Fields ! NUM_LEVELS_MOVE_3D_V=LIMITS_HI(3)-LIMITS_LO(3)+1 & !<-- Count the # of 2-D levels in the 3-D V Fields +NUM_LEVELS_MOVE_3D_V ENDIF ! ENDDO ! !----------------------------------------------------------------------- !*** The moving nests and their parents read in the four configure !*** variables specifying the number of boundary rows on the nests' !*** pre-move footprints whose locations will receive update data !*** from the parent after the nests move. All moving nests use !*** the same values and the parent checks to be sure this is true. !----------------------------------------------------------------------- ! parents_with_movers: IF(NUM_MOVING_CHILDREN>0)THEN !<-- Parents read moving nests' configure files ! !----------------------------------------------------------------------- ! DO N=1,NUM_MOVING_CHILDREN NN=RANK_MOVING_CHILD(N) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_W" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =NROWS_P_UPD_X & !<-- # of footprint W bndry rows updated by parent ,label ='nrows_p_upd_w:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N==1)THEN NROWS_P_UPD_W=NROWS_P_UPD_X ELSE IF(NROWS_P_UPD_X/=NROWS_P_UPD_W)THEN WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_W!' WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_E" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =NROWS_P_UPD_X & !<-- # of footprint E bndry rows updated by parent ,label ='nrows_p_upd_e:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N==1)THEN NROWS_P_UPD_E=NROWS_P_UPD_X ELSE IF(NROWS_P_UPD_X/=NROWS_P_UPD_E)THEN WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_E!' WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_S" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =NROWS_P_UPD_X & !<-- # of footprint S bndry rows updated by parent ,label ='nrows_p_upd_s:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N==1)THEN NROWS_P_UPD_S=NROWS_P_UPD_X ELSE IF(NROWS_P_UPD_X/=NROWS_P_UPD_S)THEN WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_S!' WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_N" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object ,value =NROWS_P_UPD_X & !<-- # of footprint N bndry rows updated by parent ,label ='nrows_p_upd_n:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(N==1)THEN NROWS_P_UPD_N=NROWS_P_UPD_X ELSE IF(NROWS_P_UPD_X/=NROWS_P_UPD_N)THEN WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_N!' WRITE(0,*)' Aborting!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! !----------------------------------------------------------------------- ! ENDDO ! !----------------------------------------------------------------------- !*** All parents of moving nests will be reading those children's !*** full resolution topography files that span the entire uppermost !*** parent. This will require these parents to know the dimensions !*** as well as other key aspects of the uppermost parent's grid. !*** Read the pertinent data from the uppermost parent's configure !*** file and save what will be needed later. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Is the Upper Parent Global?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =GLOBAL_TOP_PARENT & !<-- The variable filled ,label ='global:' & !<-- True--> upper parent is global ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Base Dimensions of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =IM_1 & !<-- The variable filled ,label ='im:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =JM_1 & !<-- The variable filled ,label ='jm:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Central Lat/Lon of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =TPH0D_1 & !<-- The variable filled ,label ='tph0d:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =TLM0D_1 & !<-- The variable filled ,label ='tlm0d:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Southern/Western Boundary of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =SBD_1 & !<-- The variable filled ,label ='sbd:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 ,value =WBD_1 & !<-- The variable filled ,label ='wbd:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! TPH0_1=TPH0D_1*D2R !<-- Central geo lat of domain (radians, positive north) TLM0_1=TLM0D_1*D2R !<-- Central geo lon of domain (radians, positive east) WB_1=WBD_1*D2R !<-- Rotated lon of west boundary (radians, positive east) SB_1=SBD_1*D2R !<-- Rotated lat of south boundary (radians, positive north) ! DPH_1=-2.*SB_1/(JM_1-1) !<-- Uppermost parent's grid increment in J (radians) DLM_1=-2.*WB_1/(IM_1-1) !<-- Uppermost parent's grid increment in I (radians) ! RECIP_DPH_1=1./DPH_1 RECIP_DLM_1=1./DLM_1 ! !----------------------------------------------------------------------- ! ENDIF parents_with_movers ! !----------------------------------------------------------------------- ! IF(MY_DOMAIN_MOVES)THEN !<-- Moving nests read their configure files ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Extract NTRACK flag from P-C Cpl import state." ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Parent-Child coupler import state. ,name ='NTRACK' & !<-- Name of the attribute to extract ,value=NTRACK & !<-- Total # of levels in all Real 2-way exch variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_W" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =NROWS_P_UPD_W & !<-- # of footprint W bndry rows updated by parent ,label ='nrows_p_upd_w:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_E" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =NROWS_P_UPD_E & !<-- # of footprint E bndry rows updated by parent ,label ='nrows_p_upd_e:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_S" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =NROWS_P_UPD_S & !<-- # of footprint S bndry rows updated by parent ,label ='nrows_p_upd_s:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_N" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =NROWS_P_UPD_N & !<-- # of footprint N bndry rows updated by parent ,label ='nrows_p_upd_n:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** What is the distance between this moving nest's center !*** and its moving child's before this nest will consider !*** shifting in order to follow its child? The value is only !*** relevant for a moving nest with a child. Units are grid !*** increments on this moving nest's grid. !----------------------------------------------------------------------- ! CENTERS_DISTANCE=R4_IN !<-- Initialize to nonsense ! IF(NUM_CHILDREN>0.AND.MY_DOMAIN_MOVES)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Outer nest reads centers separation" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =CENTERS_DISTANCE & !<-- Distance between outer/inner nest centers before outer shift ,label ='centers_distance:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** What is the latitude (degrees) past which no nests will be !*** allowed to move? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads Latitude Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =LATITUDE_LIMIT & !<-- Max distance nest bndry can move from equator (deg) ,label ='latitude_limit:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NORTH_LAT_MAX_MVG_NEST=LATITUDE_LIMIT*D2R !<-- Mvg nest Nbndry must not pass this latitude (rad) SOUTH_LAT_MAX_MVG_NEST=-NORTH_LAT_MAX_MVG_NEST !<-- Mvg nest Sbndry must not pass this latitude (rad) ! !----------------------------------------------------------------------- !*** Moving nests set up some variables for computing motion. !----------------------------------------------------------------------- ! FIRST_PASS_M=.TRUE. ! ALLOCATE(cc%I_PG(1:4)) ALLOCATE(cc%J_PG(1:4)) ! ALLOCATE(cc%I_HOLD_PG_POINT(1:4)) ! I_CENTER_CURRENT=IDS+INT(0.5*(IDE-IDS)+EPS) J_CENTER_CURRENT=JDS+INT(0.5*(JDE-JDS)+EPS) ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parents_and_moving ! !----------------------------------------------------------------------- !*** Additional setup for parents of moving nests and/or for moving !*** parents with any children at all. !----------------------------------------------------------------------- ! nests_move: IF(NUM_MOVING_CHILDREN>0)THEN ! !----------------------------------------------------------------------- !*** By 'moving nest' we mean any domain that moves across the earth !*** and not those domains that move within their parent's domain. !*** This would therefore include static children inside moving parents !*** however that arrangement is not allowed at present. That setup !*** would require full updates of the child domain following the !*** parent's shift since the child moved with resepct to the earth !*** and atmosphere. However a moving child in a moving parent will !*** stay in place when its parent shifts and thus that child domain !*** needs no updating at all following the parent shift. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Parents with moving nests need to know those nests' topography !*** at the nests' own resolutions for the hydrostatic adjustment !*** that must take place when the parents interpolate their data !*** to moving nest grid points. For the sake of generality all !*** of those nest-resolution datasets must span the domain of the !*** uppermost parent which is the true maximum range of any nest's !*** motion. ! !*** So each parent with moving nests must: !*** (1) Know how many different space resolutions its moving !*** children use; !*** (2) Associate each resolution with the appropriate moving !*** child using the nest-to-uppermost parent space ratio !*** that the user specified in each moving nest's configure !*** file; !*** (3) Have each of its forecast tasks read in its own piece of !*** each different resolution of topography data needed by !*** all of its moving children. ! !*** If a parent domain moves then it must refill its task subdomains !*** with the topography of its moving children each time it (the !*** parent) shifts its position. That is handled in subroutine !*** CHILDREN_RECV_PARENT_DATA. !----------------------------------------------------------------------- ! ALLOCATE(cc%M_NEST_RATIO(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Associate moving nests with list of different space ratios IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%M_NEST_RATIO stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF M_NEST_RATIO=>cc%M_NEST_RATIO ! ALLOCATE(cc%LIST_OF_RATIOS(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Keep a list of the different space ratios IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%LIST_OF_RATIOS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF LIST_OF_RATIOS=>cc%LIST_OF_RATIOS ! ALLOCATE(cc%LINK_MRANK_RATIO(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Which different space ratio for each moving child IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%LINK_MRANK_RATIO stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF LINK_MRANK_RATIO=>cc%LINK_MRANK_RATIO ! NN=0 NUM_SPACE_RATIOS_MVG=0 !<-- Count the different resolutions of moving children ! !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN ! IF(STATIC_OR_MOVING(N)=='Static')CYCLE NN=NN+1 ! !----------------------------------------------------------------------- ! LIST_OF_RATIOS(NN)=0 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Moving Child's Sfc File Ratio" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- Child N's config object ,value =SFC_FILE_RATIO & !<-- Save the configure value with the following label. ,label ='ratio_sfc_files:' & !<-- Ratio of upper parent's grid increment to this nest's ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! M_NEST_RATIO(NN)=SFC_FILE_RATIO !<-- Moving child NN uses topography file with this ratio/ID ! IF(NN==1)THEN NUM_SPACE_RATIOS_MVG=1 !<-- Begin counting the space ratios of moving children LIST_OF_RATIOS(1)=SFC_FILE_RATIO !<-- The 1st sfc file ratio is that of the 1st moving nest LINK_MRANK_RATIO(1)=1 !<-- 1st moving nest uses 1st sfc file ratio ! ELSE FOUND=.FALSE. DO KR=1,NUM_SPACE_RATIOS_MVG IF(SFC_FILE_RATIO==LIST_OF_RATIOS(KR))THEN FOUND=.TRUE. LINK_MRANK_RATIO(NN)=KR !<-- Moving nest NN uses existing KR'th sfc file ratio EXIT ENDIF ENDDO ! IF(.NOT.FOUND)THEN NUM_SPACE_RATIOS_MVG=NUM_SPACE_RATIOS_MVG+1 !<-- Increment the counter of children's different space ratios LIST_OF_RATIOS(NUM_SPACE_RATIOS_MVG)=SFC_FILE_RATIO !<-- Save the new ratio in the list of different ratios LINK_MRANK_RATIO(NN)=NUM_SPACE_RATIOS_MVG !<-- Moving child NN uses this rank in list of all different ratios ENDIF ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! ALLOCATE(cc%NEST_FIS_ON_PARENT(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_ON_PARENT stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NEST_FIS_ON_PARENT=>cc%NEST_FIS_ON_PARENT ! ALLOCATE(cc%NEST_FIS_V_ON_PARENT(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_V_ON_PARENT stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NEST_FIS_V_ON_PARENT=>cc%NEST_FIS_V_ON_PARENT ! DO N=1,NUM_SPACE_RATIOS_MVG NEST_FIS_ON_PARENT(N)%DATA=>NULL() NEST_FIS_V_ON_PARENT(N)%DATA=>NULL() ENDDO ! ALLOCATE(cc%NEST_FIS_ON_PARENT_BNDS(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_ON_PARENT_BNDS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NEST_FIS_ON_PARENT_BNDS=>cc%NEST_FIS_ON_PARENT_BNDS ! !----------------------------------------------------------------------- !*** Now fill the parent's data objects that hold the nest-resolution !*** topography at child H points and child V points. !----------------------------------------------------------------------- ! CALL PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & ,NUM_MOVING_CHILDREN & ,LINK_MRANK_RATIO & ,LIST_OF_RATIOS & ,M_NEST_RATIO & ,NUM_SPACE_RATIOS_MVG & ,GLOBAL_TOP_PARENT & ,IM_1,JM_1 & ,TPH0_1,TLM0_1 & ,SB_1,WB_1 & ,RECIP_DPH_1,RECIP_DLM_1 & ,GLAT,GLON & ,NEST_FIS_ON_PARENT_BNDS & ,NEST_FIS_ON_PARENT & ,NEST_FIS_V_ON_PARENT & ,IDS,IDE,IMS,IME,ITS,ITE & ,JDS,JDE,JMS,JME,JTS,JTE) ! !----------------------------------------------------------------------- ! ENDIF nests_move ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Extract the 2-way Bundle holding pointers to Solver internal !*** state variables needed for 2-way exchange of data between !*** children and parents. Since the generation and incorporation !*** of 2-way exchange data will be done via looping through Fields !*** we need to know how many Fields there are. !----------------------------------------------------------------------- ! IF(I_AM_A_FCST_TASK.AND.NEST_MODE=='2-way')THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 2-way Bundle in P-C Init" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state ,itemname ='Bundle_2way' & !<-- Name of 2-way Bundle of internal state arrays to use ,fieldbundle=BUNDLE_2WAY & !<-- The ESMF 2-way Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="How many Fields in the 2-way Bundle?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- The ESMF Bundle of 2-way exchange variables ,fieldcount =NVARS_2WAY_UPDATE & !<-- # of Fields in the Bundle ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of levels in all fields in 2-way Bundle" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- The ESMF Bundle of 2-way exchange variables ,name ='NLEV 2-way' & !<-- Name of the attribute to extract ,value=NLEV_2WAY & !<-- Total # of levels in all Real 2-way exch variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !----------------------------------------------------------------------- !*** Compute the number of timesteps between restart outputs. !*** This will be used if the domain is a moving nest. The nest !*** will not be allowed to decide to move LAG_STEPS parent !*** timesteps before a restart output time. This will postpone !*** such decisions until after the restart output time and thus !*** ensure that the same decision will be made in the forecast !*** when it is restarted. !*** This variable is also used in a similar way in 2-way nesting. !*** Children send 2-way exchange data to their parents at the end !*** of parent timestep N and the parents receive it early in !*** parent timestep N+1. For bit-reproducible restarts we must !*** therefore not let parents incorporate 2-way data in parent !*** timesteps that immediately follow the writing of a restart file. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_N" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object ,value =MINUTES_RESTART & !<-- Minutes between restart output ,label ='minutes_restart:' & !<-- The configure label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! cc%NTIMESTEPS_RESTART=NINT((60.*MINUTES_RESTART)/DT_DOMAIN(MY_DOMAIN_ID)) ! !----------------------------------------------------------------------- ! IF(ASSOCIATED(DOMAIN_ID_TO_RANK))DEALLOCATE(DOMAIN_ID_TO_RANK) ! !----------------------------------------------------------------------- !*** Get the coupling interval (sec) from the CPL_NML namelist. !*** Save the coupling interval (sec) in case it is to be used !*** for constraining the shifts of nests that are directly !*** coupled to an external model. !----------------------------------------------------------------------- ! OPEN(7,file='cpl_nml',delim='APOSTROPHE') READ(unit=7,nml=CPL_SETTINGS) CLOSE(7) ! COUPLING_INTERVAL=DT_C !<-- Coupling interval (sec) ! !------------ !*** Timers !------------ ! cpl1_prelim_tim=>cc%cpl1_prelim_tim cpl1_south_h_tim=>cc%cpl1_south_h_tim cpl1_south_v_tim=>cc%cpl1_south_v_tim cpl1_north_h_tim=>cc%cpl1_north_h_tim cpl1_north_v_tim=>cc%cpl1_north_v_tim cpl1_west_h_tim=>cc%cpl1_west_h_tim cpl1_west_v_tim=>cc%cpl1_west_v_tim cpl1_east_h_tim=>cc%cpl1_east_h_tim cpl1_east_v_tim=>cc%cpl1_east_v_tim cpl1_recv_tim=>cc%cpl1_recv_tim ! cpl1_recv_tim=>cc%cpl1_recv_tim ! cpl1_south_h_recv_tim=>cc%cpl1_south_h_recv_tim cpl1_south_h_undo_tim=>cc%cpl1_south_h_undo_tim cpl1_south_h_exp_tim=>cc%cpl1_south_h_exp_tim cpl1_south_v_recv_tim=>cc%cpl1_south_v_recv_tim cpl1_south_v_undo_tim=>cc%cpl1_south_v_undo_tim cpl1_south_v_exp_tim=>cc%cpl1_south_v_exp_tim ! cpl2_comp_tim=>cc%cpl2_comp_tim cpl2_wait_tim=>cc%cpl2_wait_tim cpl2_send_tim=>cc%cpl2_send_tim ! moving_nest_bookkeep_tim=>cc%moving_nest_bookkeep_tim moving_nest_update_tim=>cc%moving_nest_update_tim parent_bookkeep_moving_tim=>cc%parent_bookkeep_moving_tim parent_update_moving_tim=>cc%parent_update_moving_tim t0_recv_move_tim=>cc%t0_recv_move_tim read_moving_child_topo_tim=>cc%read_moving_child_topo_tim barrier_move_tim=>cc%barrier_move_tim pscd_tim=>cc%pscd_tim pscd1_tim=>cc%pscd1_tim pscd2_tim=>cc%pscd2_tim pscd3_tim=>cc%pscd3_tim pscd4_tim=>cc%pscd4_tim ja1_tim=>cc%ja1_tim ja2_tim=>cc%ja2_tim ja3_tim=>cc%ja3_tim ja4_tim=>cc%ja4_tim jat_tim=>cc%jat_tim ! cpl1_prelim_tim=0. cpl1_south_h_tim=0. cpl1_south_v_tim=0. cpl1_north_h_tim=0. cpl1_north_v_tim=0. cpl1_west_h_tim=0. cpl1_west_v_tim=0. cpl1_east_h_tim=0. cpl1_east_v_tim=0. cpl1_recv_tim=0. ! cpl1_south_h_recv_tim=0. cpl1_south_h_undo_tim=0. cpl1_south_h_exp_tim=0. cpl1_south_v_recv_tim=0. cpl1_south_v_undo_tim=0. cpl1_south_v_exp_tim=0. ! cpl2_comp_tim=0. cpl2_wait_tim=0. cpl2_send_tim=0. ! moving_nest_bookkeep_tim =0. moving_nest_update_tim =0. parent_bookkeep_moving_tim=0. parent_update_moving_tim =0. t0_recv_move_tim =0. read_moving_child_topo_tim=0.0 barrier_move_tim=0.0 pscd_tim=0. pscd1_tim=0. pscd2_tim=0. pscd3_tim=0. pscd4_tim=0. ja1_tim=0. ja2_tim=0. ja3_tim=0. ja4_tim=0. jat_tim=0. ! !----------------------------------------------------------------------- ! IF(RC_CPL_INIT==ESMF_SUCCESS)THEN ! WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP SUCCEEDED" ELSE WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP FAILED" ENDIF ! RC_FINAL=RC_CPL_INIT ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE2 ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHECK_2WAY_SIGNALS(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL ) ! !----------------------------------------------------------------------- !*** When 2-way nesting is used do not proceed into a timestep until !*** the update data from all of the current domain's children have !*** been received and the current domain's parent has signaled that !*** the parent has received 2-way update data from all of its !*** children. This routine checks for those conditions. !*** This is phase 1 of the Parent-Child coupler's Run step. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG,CHILDTASK_0 & ,COMM_FCST_TASKS,MY_DOMAIN_ID,N,NTIMESTEP ! INTEGER(kind=KINT) :: IERR,RC,RC_CPL_RUN ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_IS_PRESENT & ,ALLCLEAR_SIGNAL & ,READY_TO_RECV & ,TWOWAY_SIGNAL_IS_PRESENT ! LOGICAL(kind=KLOG) :: RECV_ALL_CHILD_DATA ! integer(kind=kint) :: mype_local !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_RUN=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** What is the current timestep on this nest's Clock? !----------------------------------------------------------------------- ! CALL ESMF_ClockGet(clock =CLOCK & ,advanceCount=NTIMESTEP_ESMF & !<-- The current timestep of this domain (ESMF) ,rc =RC) ! NTIMESTEP=NTIMESTEP_ESMF !<-- The current timestep of this domain (integer) ! !----------------------- !*** Current Domain ID !----------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------------------- !*** Intracommunicator between forecast tasks !---------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init0" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Point to the correct part of the composite object. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Do not repeatedly extract the parent's ALLCLEAR signal if it !*** was already done in the current timestep. !----------------------------------------------------------------------- ! IF(NTIMESTEP>NTIMESTEP_CHECK)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract ALLCLEAR Signal from P-C Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE & !<-- The parent-child coupler import state ,name ='ALLCLEAR' & !<-- Name of the attribute to extract ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- ALLCLEAR signal reset to fals ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NTIMESTEP_CHECK=NTIMESTEP ! ENDIF ! !----------------------------------------------------------------------- !*** When 2-way nests are being used then this child checks to see !*** if its parent has sent a signal indicating it has received all !*** exchange data from this child and its siblings. That signal !*** means this child is now free to proceed in its integration. !*** If the signal is not present then the child immediately !*** returns and exits the current iteration of the time loop !*** without incrementing the timestep. !----------------------------------------------------------------------- ! children: IF(MY_DOMAIN_ID>1 & !<-- Select the domains with parents .AND. & MOD(NTIMESTEP,TIME_RATIO_MY_PARENT)==0 & !<-- Is this a timestep boundary of my parent? .AND. & .NOT.ALLCLEAR_SIGNAL_PRESENT)THEN !<-- Already recvd signal from parent this timestep? !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN ALLCLEAR_SIGNAL_TAG=20000+1000*MY_DOMAIN_ID+10*NTIMESTEP !<-- Use the domain ID,timestep to get a unique tag ! CALL MPI_IPROBE(0 & !<-- Parent task 0 sends the signal ,ALLCLEAR_SIGNAL_TAG & !<-- The message's tag ,COMM_TO_MY_PARENT & !<-- Communicator to the parent ,ALLCLEAR_SIGNAL_IS_PRESENT & !<-- Has the parent's signal arrived? ,JSTAT & !<-- MPI status object ,IERR ) ! IF(ALLCLEAR_SIGNAL_IS_PRESENT)THEN CALL MPI_RECV(ALLCLEAR_SIGNAL & !<-- Clear the buffer if signal is present ,1 & !<-- Signal has 1 word ,MPI_LOGICAL & !<-- Signal is logical ,0 & !<-- Signal sent by parent task 0 ,ALLCLEAR_SIGNAL_TAG & !<-- Tag associated with the signal ,COMM_TO_MY_PARENT & !<-- Communicator between child and parent ,JSTAT & !<-- MPI status object ,IERR ) ! ENDIF ! ENDIF ! btim=timef() CALL MPI_BCAST(ALLCLEAR_SIGNAL_IS_PRESENT & !<-- Can the child tasks proceed or not? ,1 & !<-- The signal is one word ,MPI_LOGICAL & !<-- The signal is logical ,0 & !<-- Broadcast from lead nest forecast task ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks ,IERR) cbcst_tim(my_domain_id)=cbcst_tim(my_domain_id)+(timef()-btim) ! ALLCLEAR_SIGNAL_PRESENT=ALLCLEAR_SIGNAL_IS_PRESENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="NMM_INTEGRATE: Child Inserts ALLCLEAR into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='ALLCLEAR' & !<-- Name of the attribute to insert ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- Parent does/not have exch data; child can/not proceed ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ENDIF children ! !----------------------------------------------------------------------- !*** Also with 2-way nesting this parent checks to see if all its !*** children have indicated they are ready to send their 2-way !*** update data. If not then the parent immediately returns and !*** exits the current iteration of the time loop without incrementing !*** the timestep. ! !*** When any of this parent's children catch up to the parent at !*** the end of a parent timestep then that child's lead fcst task !*** sends a signal to the parent's lead fcst task that the child !*** is ready to send the 2-way exchange data. Here the parent lead !*** fcst task probes for that signal from each of the children. The !*** probe needs to be done until all children have been heard from. !----------------------------------------------------------------------- ! parents: IF(NUM_CHILDREN>0)THEN !<-- Select the domains with children ! !----------------------------------------------------------------------- ! ! call mpi_comm_rank(comm_fcst_tasks,mype_local,ierr) READY_TO_RECV=.FALSE. ! task0_a: IF(I_AM_LEAD_FCST_TASK)THEN ! IF(KOUNT_2WAY_CHILDREN3)then ! write(0,24331)ncycle_parent,my_domain_id,ntimestep 24331 format(' parent cycled ',i5,' times my_domain_id=',i2,' ntimestep=',i6) ! endif ! ncycle_parent=0 ! endif ! ELSE ! RECV_ALL_CHILD_DATA=.FALSE. ! ncycle_parent=ncycle_parent+1 ! ENDIF ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA: Set Integrate Flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state ,name ='Recv All Child Data' & ,value=RECV_ALL_CHILD_DATA & ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ENDIF parents ! !----------------------------------------------------------------------- ! END SUBROUTINE CHECK_2WAY_SIGNALS ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE CHILDREN_RECV_PARENT_DATA(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** Run the coupler step where children receive data from parents. !*** This is phase 2 of the coupler Run step and it occurs at the !*** beginning of the timesteps. The parents send the data in !*** phase 4 at the end of the timesteps. Only child tasks enter !*** this routine. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: NEXT_MOVE_TIMESTEP_PARENT ! INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG & ,BC_UPDATE_FLAG,CHILDTASK_0 & ,COMM_FCST_TASKS & ,ID_GRANDPARENT & ,I_DIFF,J_DIFF & ,MAX_SHIFT_CHILD & ,MY_DOMAIN_ID,MY_PARENT_ID,MYPE_LOCAL & ,N,NN,NTIMESTEP,NTAG0 ! INTEGER(kind=KINT) :: I_SHIFT,I_SHIFT_MY_GRID,I_SHIFT_PARENT_GRID & ,J_SHIFT,J_SHIFT_MY_GRID,J_SHIFT_PARENT_GRID ! INTEGER(kind=KINT) :: IERR,IRTN,RC,RC_CPL_RUN ! !xxx INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! REAL(kind=KFPT) :: CHILD_DOMAIN_EW,CHILD_DOMAIN_NS & ,DIFF_I,DIFF_J,DIFF_TIMESTEPS & ,DT_GRANDPARENT,DT_MINE & ,INTERVAL_ADD,INTERVAL_MIN & ,NEXT_COUPLING_TIMESTEP & ,PARENT_DIFF,SHIFT_LAT ! REAL(kind=KFPT) :: CENTER_I_INNER,CENTER_I_OUTER & ,CENTER_J_INNER,CENTER_J_OUTER ! REAL(kind=KFPT) :: DIST_EAST,DIST_WEST & ,DIST_NORTH,DIST_SOUTH & ,DIST_TO_PARENT_BNDRY & ,DISTANCE ! REAL(kind=KFPT) :: DISTN_TO_PARENT_BNDRY & ,DISTN_EAST,DISTN_WEST & ,DISTN_NORTH,DISTN_SOUTH ! REAL(kind=KFPT) :: DOMAIN_NBND,DOMAIN_SBND & ,PARENT_NBND,PARENT_SBND ! LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_IS_PRESENT & ,ALLCLEAR_SIGNAL ! TYPE(COMPOSITE),POINTER :: CC ! TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4) :: SEND_TASK !<-- Specifics about interior data from sending parent tasks ! LOGICAL(kind=KLOG) :: PARENT_SHIFT_IS_PRESENT ! LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_PRESENT & ,MOVE_NOW ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! btim =timef() btim0=timef() ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_RUN=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** What is the current timestep on this nest's Clock? !----------------------------------------------------------------------- ! CALL ESMF_ClockGet(clock =CLOCK & ,advanceCount=NTIMESTEP_ESMF & !<-- The current timestep of this child (ESMF) ,rc =RC) ! NTIMESTEP=NTIMESTEP_ESMF !<-- The current timestep of this child (integer) ! !----------------------- !*** Current Domain ID !----------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Point to the correct part of the composite object. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !---------------------------------- !*** Are we in the free forecast? !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Free Forecast flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Free Forecast' & !<-- Name of the attribute to extract ,value=FREE_FORECAST & !<-- Is this the free forecast? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DIG_FILTER=.FALSE. IF(.NOT.FREE_FORECAST)THEN DIG_FILTER=.TRUE. ELSEIF(FREE_FORECAST)THEN I_AM_ACTIVE=.TRUE. !<-- All domains are always active in the free forecast. ENDIF ! !----------------------------------------------------------- !*** Intracommunicator for current domain's forecast tasks !----------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fcst Task Intracommunicator" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_LOCAL,IERR) !<-- Local task rank in this domain's fcst tasks ! !----------------------------------------------------------------------- !*** The child is now at the beginning of a timestep that coincides !*** with the beginning of a parent timestep which is where moving !*** children execute their shifts. To eliminate potential randomness !*** a child will always shift a fixed number of timesteps after it !*** has made the decision to move. It is then at that point in !*** time that the parent will generate new internal data for the !*** child as well as new starting boundary data for the child's new !*** location. So it is at that point in time that the child will !*** have the data needed to execute its shift. !----------------------------------------------------------------------- ! moving_children_a: IF(MY_DOMAIN_MOVES)THEN !<-- Select the moving nests ! !----------------------------------------------------------------------- ! MOVE_NOW=.FALSE. ! !----------------------------------------------------------------------- !*** If this is now the point in time at which the parent prepared !*** internal and boundary data for the child's new position, then !*** the child initiates its shift now by receiving the data prepared !*** for it by its parent for the child's new position. Note that !*** the actual updating of the prognostic variables due to the !*** shift takes place in DOMAIN_RUN which is called in NMM_INTEGRATE !*** following phases 2 and 3 of the Parent-Child coupler (where the !*** children receive update data from their parents and the parents !*** receive update data from their children, respectively). !----------------------------------------------------------------------- ! the_child_moves: IF(NTIMESTEP==NEXT_MOVE_TIMESTEP)THEN ! !----------------------------------------------------------------------- !*** Later in this subroutine moving nests begin their decision of !*** whether they want to shift with the call to COMPUTE_STORM_MOTION. !*** If they do want to shift then they check to see if the shift !*** would lead to a collision with their parent's boundary. If the !*** nest is also a parent it checks to see if its desired shift !*** would lead to a collision with its children. However after !*** the decision to shift is made then the nest must wait LAG_STEPS !*** timesteps of its parent before executing that shift. This is !*** because in 1-way nesting the parent can run several timesteps !*** ahead of its children and thus the parent will lie out in the !*** child's future when the parent learns what the new location of !*** the child will be. Only then can the parent generate new data !*** to update the child's boundaries at that location. The existence !*** of this time lag can permit a fatal situation. A child/parent !*** may determine it is safe to shift given the current location !*** of the domains involved but then before it executes the shift !*** the related parent/child may decide it also wants to shift and !*** determines it is safe to shift given the present location of the !*** of the domains. After the first of the domains shifts that may !*** then make the shift of the second domain fatal by leading to !*** a collision IF either or both shifts are relatively large. ! !*** Here are the three basic scenarios that must be avoided. ! !----------------------------------------------------------------------- ! Scenario 1 !----------------------------------------------------------------------- ! ! <------ Child decides it wants to shift ! ! <------- Parent decides it wants to shift ! TIME ! | <------ Child executes its shift ! | ! | ! v ! ! ! ! ! <------- Parent executes its shift ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! Scenario 2 !----------------------------------------------------------------------- ! ! <------- Parent decides it wants to shift ! ! ! TIME ! | <------ Child decides it wants to shift ! | ! | ! v ! <------ Child executes its shift ! ! ! ! ! <------- Parent executes its shift ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! Scenario 3 (~equivalent to Scenario 2) !----------------------------------------------------------------------- ! ! <------- Parent decides it wants to shift ! ! ! TIME ! | ! | ! | ! v ! <------ Child decides it wants to shift ! ! <------- Parent executes its shift ! ! <------ Child executes its shift ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! MOVE_NOW=.TRUE. !<-- Yes, the child moves at beginning of this timestep ! ! IF(NTRACK>0)THEN ! I_CENTER_CURRENT=STORM_CENTER(1) & ! -(I_SW_PARENT_NEW-I_SW_PARENT_CURRENT) & ! *SPACE_RATIO_MY_PARENT ! J_CENTER_CURRENT=STORM_CENTER(2) & ! -(J_SW_PARENT_NEW-J_SW_PARENT_CURRENT) & ! *SPACE_RATIO_MY_PARENT ! ENDIF ! I_WANT_TO_MOVE=.FALSE. !<-- Reset the 'move' flag MOVE_FLAG_SENT=.FALSE. !<-- Reset the flag for ISending the move flag ! !----------------------------------------------------------------------- !*** Deallocate this moving nest's working arrays/pointers whose !*** dimensions are functions of moving nests' positions. They will !*** be reallocated with dimensions appropriate for the new positions. !*** For static nests the same nest arrays/pointers never become !*** invalid and thus are not deallocated/reallocated. !----------------------------------------------------------------------- ! CALL DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) !<-- Reset this child's working pointers for new location ! !----------------------------------------------------------------------- !*** Each child boundary task receives small information packets !*** from the parent tasks that cover them. That information !*** can change with each move and includes the identities of !*** those parent tasks that will be sending boundary data !*** updates along with the index limits on the child task of !*** that boundary data from each parent task. !----------------------------------------------------------------------- ! CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Recv specs of new parent/child task associations ! ! for BC data. !----------------------------------------------------------------------- !*** Receive standard boundary data update from the parent valid for !*** the current timestep but now at the child's new location. This !*** data will be for time N in the boundary tendency computation: !*** dX/dt = [ X(N+1) - X(N) ] / DT_parent !----------------------------------------------------------------------- ! CALL NEST_RECVS_BC_DATA('Current') !<-- Recv parent data for new nest boundary after move ! !----------------------------------------------------------------------- !*** Receive update data for all interior points on the nest domain !*** that have moved outside of the nest's pre-move footprint. Those !*** points can only be updated by the parent. The index limits of !*** the parent update regions on the nest tasks are identical for !*** H and V points therefore the nest needs to call its bookkeeping !*** only once. !----------------------------------------------------------------------- ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,12341)MY_DOMAIN_ID,NTIMESTEP WRITE(0,12342)I_SHIFT_CHILD,J_SHIFT_CHILD & ,I_SW_PARENT_NEW,J_SW_PARENT_NEW 12341 FORMAT(' Nest shifts now my_domain_id=',I2,' ntimestep=',I6) 12342 FORMAT(' i_shift_child=',I4,' j_shift_child=',I4 & ,' i_sw_parent_new=',I4,' j_sw_parent_new=',I4) ENDIF ! btim=timef() CALL MOVING_NEST_BOOKKEEPING(I_SHIFT_CHILD & ,J_SHIFT_CHILD & ,I_SW_PARENT_NEW & ,J_SW_PARENT_NEW & ,NUM_FCST_TASKS_PARENT & ,INPES_PARENT & ,PTASK_LIMITS(MY_DOMAIN_ID)%ITS & ,PTASK_LIMITS(MY_DOMAIN_ID)%ITE & ,PTASK_LIMITS(MY_DOMAIN_ID)%JTS & ,PTASK_LIMITS(MY_DOMAIN_ID)%JTE & ,SPACE_RATIO_MY_PARENT & ,NROWS_P_UPD_W & ,NROWS_P_UPD_E & ,NROWS_P_UPD_S & ,NROWS_P_UPD_N & ,SEND_TASK & ,ITS,ITE,JTS,JTE & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE & ) ! btim=timef() CALL MOVING_NEST_RECV_DATA(COMM_TO_MY_PARENT & ,NTIMESTEP & ,NUM_FIELDS_MOVE_2D_H_I & ,NUM_FIELDS_MOVE_2D_X_I & ,NUM_FIELDS_MOVE_2D_H_R & ,NUM_FIELDS_MOVE_2D_X_R & ,NUM_LEVELS_MOVE_3D_H & ,NUM_FIELDS_MOVE_2D_V & ,NUM_LEVELS_MOVE_3D_V & ,SEND_TASK & ,EXP_STATE & ) moving_nest_update_tim=moving_nest_update_tim+(timef()-btim) ! I_SW_PARENT_CURRENT=I_SW_PARENT_NEW !<-- Reset the location of the nest's SW corner J_SW_PARENT_CURRENT=J_SW_PARENT_NEW ! in its parent's grid space. ! ENDIF the_child_moves ! !----------------------------------------------------------------------- !*** Load the Attribute into the coupler export state indicating that !*** the child is or is not moving at this timestep. This information !*** will be used in the transfer of the new data from the Parent-Child !*** coupler export state to the Domain import state to the Solver !*** import state. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child Inserts Move Flag into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='MOVE_NOW' & !<-- Name of the attribute to insert ,value=MOVE_NOW & !<-- Is the child moving right now? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------------------------------------------- ! ENDIF moving_children_a ! !----------------------------------------------------------------------- !*** If this is a (moving) child of a moving parent then it needs !*** to watch for the appearance of a signal from the parent !*** indicating that it (the parent) intends to move. The child !*** will use that shift information in two different ways. !*** If two-way interaction is being used then the child must know !*** the direction of the parent's move and prepare/send the 2-way !*** data at the end of the parent timestep in which the parent !*** shift took place. Then for all nesting the child uses the !*** new parent location at the beginning of the parent timestep !*** in which the shift occurs to properly prepare working objects, !*** to receive, and to incorporate standard BC update data that !*** was sent from the parent at the end of the timestep of the !*** parent's shift. !*** So in order to be ready for both those situations the child !*** now receives the parent's shift and the new specifics of the !*** parent task and nest task associations if this is the start !*** of the parent timestep preceding the parent's shift. !----------------------------------------------------------------------- ! moving_parent: IF(MY_PARENT_MOVES)THEN ! !----------------------------------------------------------------------- ! PARENT_SHIFT_IS_PRESENT=.FALSE. ! IF(I_AM_LEAD_FCST_TASK)THEN NTAG0=PARENT_SHIFT_TAG+NTIMESTEP/TIME_RATIO_MY_PARENT !<-- Unique timestep-dependent MPI tag. It is valid one ! parent timestep after the parent decides to move. CALL MPI_IPROBE(0 & !<-- The message is sent by moving parent's fcst task 0. ,NTAG0 & !<-- Tag associated with parent's shift ,COMM_TO_MY_PARENT & !<-- Communicator between this nest and its parent ,PARENT_SHIFT_IS_PRESENT & !<-- Is the parent's shift now available? ,JSTAT & ,IERR) ! IF(PARENT_SHIFT_IS_PRESENT)THEN CALL MPI_RECV(PARENT_SHIFT & !<-- Recv the parent's shift ,3 & !<-- # of words in the message ,MPI_INTEGER & !<-- The shifts in I and J are integers ,0 & !<-- Local rank of the parent task sending the word ,NTAG0 & !<-- Tag used for this data exchange ,COMM_TO_MY_PARENT & !<-- Communicator between this nest and its parent ,JSTAT & ,IERR ) ENDIF ! ENDIF ! CALL MPI_BCAST(PARENT_SHIFT_IS_PRESENT & !<-- Has the new move timestep been received? ,1 & !<-- The signal is one word ,MPI_LOGICAL & !<-- The signal is type Logical ,0 & !<-- Broadcast from nest forecast task 0 ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks ,IRTN) ! IF(PARENT_SHIFT_IS_PRESENT)THEN ! CALL MPI_BCAST(PARENT_SHIFT & !<-- Broadcast the parent shift ,3 & !<-- # of words in the message ,MPI_INTEGER & !<-- The shifts in I and J are integers ,0 & !<-- Broadcast from nest forecast task 0 ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks ,IRTN) ! PARENT_WANTS_TO_MOVE=.TRUE. NTIMESTEP_WAIT_PARENT=PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT !<-- This child domain's timestep in which ! ! its parent will shift. ! ENDIF ! IF(NTIMESTEP==PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT & !<-- Did the parent shift at the start of this parent timestep? .AND. & PARENT_SHIFT(1)>0)THEN ! I_SW_PARENT_CURRENT=I_SW_PARENT_CURRENT-PARENT_SHIFT(2) !<-- Current parent I,J of SW corner of this child's domain J_SW_PARENT_CURRENT=J_SW_PARENT_CURRENT-PARENT_SHIFT(3) ! after its parent shifts. ! I_SW_PARENT_NEW=I_SW_PARENT_NEW-PARENT_SHIFT(2) !<-- New parent I,J of SW corner of this child's domain J_SW_PARENT_NEW=J_SW_PARENT_NEW-PARENT_SHIFT(3) ! after the child and parent have shifted. ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='I_SW_PARENT_NEW' & !<-- Insert Attribute with this name ,value=I_SW_PARENT_NEW & !<-- Motion of nest in I on its grid ,rc =RC ) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state ,name ='J_SW_PARENT_NEW' & !<-- Insert Attribute with this name ,value=J_SW_PARENT_NEW & !<-- Motion of nest in J on its grid ,rc =RC ) ! CALL DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) !<-- Reset this child's working pointers for 'new' location ! CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Parent/child bndry task associations ! IF(FORCED_PARENT_SHIFT)THEN I_WANT_TO_MOVE=.FALSE. !<-- Now the child is free to compute its storm motion after FORCED_PARENT_SHIFT=.FALSE. ! forcing its parent to shift due to close boundaries. ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF moving_parent ! !----------------------------------------------------------------------- !*** Children receive boundary data from their parents from one !*** parent timestep in the future which will be put into the Parent- !*** Child coupler export state on its way to the dynamics where it !*** will be used to compute boundary tendencies through the next !*** NN timesteps. NN is the number of child timesteps per parent !*** timestep. This data will be for time N+1 in the boundary !*** tendency computation: !*** dX/dt = [ X(N+1) - X(N) ] / DT_parent ! !*** Note that if this is a timestep at which a child has just moved, !*** the child's location-dependent working pointers for the boundary !*** data were already reset for the new location in the IF block for !*** NTIMESTEP==NEXT_MOVE_TIMESTEP above. ! !*** If the digital filter is running and this child is not active !*** in it then it does not receive. !----------------------------------------------------------------------- ! IF(FREE_FORECAST.OR.(DIG_FILTER.AND.I_AM_ACTIVE))THEN ! CALL NEST_RECVS_BC_DATA('Future') ! ENDIF ! !----------------------------------------------------------------------- !*** In telescoping moving nests only the innermost utilizes the !*** storm center location from the storm tracker. This prevents !*** different generations of moving nests over the same storm !*** from deciding to move in different ways. ! !*** If the nest is forcing its parent to shift to avoid a !*** collision then it will not call the routine until it knows !*** the parent has completed its evasive shift. ! !*** If a nest's or its parent's poleward boundary has moved !*** beyond the user-specified latitude limit then the nest !*** is permanently immobilized. ! !*** After taking the storm center location if the nest decides it !*** wants to move then the shift will be executed LAG_STEPS parent !*** timesteps later in this routine immediately above. By that !*** time its parent will have learned that the nest wants to move !*** and will have prepared BC and internal shift data valid at the !*** proper timestep. !----------------------------------------------------------------------- ! moving_children_b: IF(MY_DOMAIN_MOVES)THEN !<-- Select the moving nests ! !----------------------------------------------------------------------- ! motion: IF(.NOT.I_WANT_TO_MOVE & !<-- Nest not waiting to shift from earlier call to routine .AND. & .NOT.FORCED_PARENT_SHIFT & !<-- Nest not immobilized after forcing its parent to shift .AND. & .NOT.STOP_MY_MOTION)THEN !<-- Nest not immobilized at the specified latitude limit. ! !----------------------------------------------------------------------- ! innermost: IF(NUM_CHILDREN==0)THEN !<-- Only innermost moving nests explicitly follow storms ! ! whereas outer nests follow their inner nests. !----------------------------------------------------------------------- ! IF (TRIM(MOVE_TYPE) == 'storm') THEN ! !----------------------------------------------------------------------- !*** The storm tracker determines the storm center on this domain's !*** grid every NPHS*NTRACK timesteps. If this is an appropriate !*** timestep then extract the latest center location. !----------------------------------------------------------------------- ! new_center: & ! IF(NTRACK>0 & .AND. & NTIMESTEP>0 & .AND. & MOD(NTIMESTEP,NTRACK*NPHS)==0)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract storm center from P-C Cpl import state." ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =IMP_STATE & ,name ='Storm Center' & !<-- Name of the attribute to extract ,valueList=STORM_CENTER & !<-- I,J of the storm center on this grid. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! I_DIFF=STORM_CENTER(1)-I_CENTER_CURRENT !<-- Distance in I,J from current to J_DIFF=STORM_CENTER(2)-J_CENTER_CURRENT ! new storm center. ! !----------------------------------------------------------------------- !*** If the child moves then its SW corner must shift from one parent !*** H point to another which means the I and J shifts must be in !*** integer multiples of SPACE_RATIO_MY_PARENT. Adjust I_DIFF and !*** J_DIFF given this constraint. !----------------------------------------------------------------------- ! IF(MOD(I_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN PARENT_DIFF=REAL(I_DIFF)/REAL(SPACE_RATIO_MY_PARENT) IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN I_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ELSE I_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ENDIF ENDIF ! IF(MOD(J_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN PARENT_DIFF=REAL(J_DIFF)/REAL(SPACE_RATIO_MY_PARENT) IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN J_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ELSE J_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ENDIF ENDIF ! IF(MAX_SHIFT<999)THEN !<-- If true the nest's shift distance is restricted. MAX_SHIFT_CHILD=MAX_SHIFT*SPACE_RATIO_MY_PARENT !<-- Max shift in I and/or J on the nest's grid I_DIFF=MIN(MAX(I_DIFF,-MAX_SHIFT_CHILD),MAX_SHIFT_CHILD) J_DIFF=MIN(MAX(J_DIFF,-MAX_SHIFT_CHILD),MAX_SHIFT_CHILD) ENDIF ! I_SW_PARENT_NEW=I_SW_PARENT_CURRENT+I_DIFF/SPACE_RATIO_MY_PARENT J_SW_PARENT_NEW=J_SW_PARENT_CURRENT+J_DIFF/SPACE_RATIO_MY_PARENT ! I_WANT_TO_MOVE=.TRUE. ! IF(ABS(I_DIFF)==0.AND.ABS(J_DIFF)==0)THEN I_WANT_TO_MOVE=.FALSE. IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,*)' NO MOTION: Less than one parent grid increment.' ENDIF ENDIF ! ENDIF new_center ! ! CALL COMPUTE_STORM_MOTION(NTIMESTEP & ! ,LAST_STEP_MOVED & ! ,DT_DOMAIN(MY_DOMAIN_ID) & ! ,NUM_PES_FCST & ! ,COMM_FCST_TASKS & ! ,FIS & ! ,PD & ! ,PINT & ! ,T & ! ,Q & ! ,CW & ! ,U & ! ,V & ! ,DSG2 & ! ,PDSG1 & ! ,DXH & ! ,DYH & ! ,SM & ! ,I_SW_PARENT_CURRENT & ! ,J_SW_PARENT_CURRENT & ! ,I_WANT_TO_MOVE & ! ,I_SW_PARENT_NEW & ! ,J_SW_PARENT_NEW & ! ,MY_DOMAIN_ID ) ! ELSE IF (TRIM(MOVE_TYPE) == 'prescribed') THEN CALL PRESCRIBED_MOVE(NTIMESTEP,DT_DOMAIN(MY_DOMAIN_ID) & ,I_WANT_TO_MOVE & ,I_SW_PARENT_CURRENT & ,J_SW_PARENT_CURRENT & ,I_SW_PARENT_NEW & ,J_SW_PARENT_NEW ) ! ELSE IF (TRIM(MOVE_TYPE) == 'artificial5') THEN ! ! CALL ARTIFICIAL_MOVE5(NTIMESTEP & ! ,KOUNT_MOVES & ! ,I_WANT_TO_MOVE & ! ,I_SW_PARENT_CURRENT & ! ,J_SW_PARENT_CURRENT & ! ,I_SW_PARENT_NEW & ! ,J_SW_PARENT_NEW ) ELSE WRITE(0,*)' Unknown move type :', TRIM(MOVE_TYPE) WRITE(0,*)' ABORTING!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ENDIF innermost ! !----------------------------------------------------------------------- !*** The motion of a moving parent is essentially determined by the !*** motion of its child. The parent watches the location of its !*** child and when the distance between the centers of the two !*** domains exceeds the specified value then the parent shifts in !*** order to bring its center as close as possible to the child's. !*** However that desired shift must also be great enough to span !*** at least one of its own parent's grid increments since all !*** nests move so that their SW corner coincides with an H point !*** on their parent's grid. !----------------------------------------------------------------------- ! outer: IF(NUM_CHILDREN>0 & !<-- This moving child has a moving child. .AND. & NTIMESTEP>NEXT_MOVE_TIMESTEP)THEN !<-- Wait 1 timestep after shifting before considering another. ! !----------------------------------------------------------------------- ! N=1 !<-- Moving nests can have only one child for now. ! CENTER_I_OUTER=0.5*(IDS+IDE) CENTER_J_OUTER=0.5*(JDS+JDE) ! CENTER_I_INNER=I_PARENT_SW(N) & +0.5*(IM_CHILD(N)-1.)*CHILD_PARENT_SPACE_RATIO(N) CENTER_J_INNER=J_PARENT_SW(N) & +0.5*(JM_CHILD(N)-1.)*CHILD_PARENT_SPACE_RATIO(N) DIFF_I=CENTER_I_INNER-CENTER_I_OUTER DIFF_J=CENTER_J_INNER-CENTER_J_OUTER ! DISTANCE=SQRT(DIFF_I**2+DIFF_J**2) !<-- Distance in outer nest grid increments ! between the outer and inner nest centers. ! I_SHIFT_PARENT_GRID=NINT(DIFF_I/REAL(SPACE_RATIO_MY_PARENT)) !<-- Prospective I shift on this nest's parent's grid. J_SHIFT_PARENT_GRID=NINT(DIFF_J/REAL(SPACE_RATIO_MY_PARENT)) !<-- Prospective J shift on this nest's parent's grid. I_SHIFT_MY_GRID=I_SHIFT_PARENT_GRID*SPACE_RATIO_MY_PARENT !<-- Prospective I shift on this nest's grid. J_SHIFT_MY_GRID=J_SHIFT_PARENT_GRID*SPACE_RATIO_MY_PARENT !<-- Prospective J shift on this nest's grid. ! !----------------------------------------------------------------------- !*** The outer moving nest now checks to see if the distance between !*** its center and its moving child's exceeds the pre-specified !*** value. If it does then it will set a prospective shift as !*** long as that shift will span at least one of its parent's grid !*** increments since all nest motion involves moving the SW corner !*** of the nest domain from one parent H point to another. !----------------------------------------------------------------------- ! IF(DISTANCE>CENTERS_DISTANCE & !<-- Inner nest center exceeds distance for outer nest shift. .AND. & (ABS(I_SHIFT_PARENT_GRID)>=1 & !<-- Outer nest shift must be at least .OR. & ! one grid increment in I or J ABS(J_SHIFT_PARENT_GRID)>=1))THEN ! on its parent's grid. ! I_WANT_TO_MOVE=.TRUE. ! I_SW_PARENT_NEW=I_SW_PARENT_CURRENT+I_SHIFT_PARENT_GRID !<-- This nest's SW corner will lie on this I and J J_SW_PARENT_NEW=J_SW_PARENT_CURRENT+J_SHIFT_PARENT_GRID ! of its parent's domain after this shift. ! !----------------------------------------------------------------------- !*** This moving parent wants to shift since its and its childs !*** centers are now too far apart. However make sure the child !*** is not already prepared to shift again. If it is then the !*** parent will not shift. !----------------------------------------------------------------------- ! DO NN=1,NUM_CHILDREN IF(NTIMESTEP<=SHIFT_INFO_CHILDREN(1,NN) & .AND. & SHIFT_INFO_CHILDREN(1,NN) & <=NTIMESTEP+TIME_RATIO_MY_PARENT*LAG_STEPS)THEN ! I_WANT_TO_MOVE=.FALSE. I_SW_PARENT_NEW=I_SW_PARENT_CURRENT J_SW_PARENT_NEW=J_SW_PARENT_CURRENT ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,51511)MY_DOMAIN_ID,NTIMESTEP & ,N,SHIFT_INFO_CHILDREN(1,NN) 51511 FORMAT(' CHILDREN_RECV MY_DOMAIN_ID=',I2,' NTIMESTEP=',I6 & ,' I wanted to move but child #',I2,' will shift at ',i6) WRITE(0,51512) 51512 FORMAT(' So I will not shift.') ENDIF ENDIF ENDDO ! !----------------------------------------------------------------------- ! ENDIF ! ENDIF outer ! !----------------------------------------------------------------------- ! ENDIF motion ! !----------------------------------------------------------------------- !*** If necessary account for the very special situation in which !*** a child of this domain wants to move too close to this domain's !*** boundary. When that happens then this domain is forced to !*** move to avoid the collision. !----------------------------------------------------------------------- ! IF(CHILD_FORCES_MY_SHIFT)THEN I_WANT_TO_MOVE=.TRUE. MOVE_FLAG_SENT=.FALSE. I_SW_PARENT_NEW=I_SW_PARENT_CURRENT & +NINT(MY_FORCED_SHIFT(1)*RECIP_PARENT_SPACE_RATIO) J_SW_PARENT_NEW=J_SW_PARENT_CURRENT & +NINT(MY_FORCED_SHIFT(2)*RECIP_PARENT_SPACE_RATIO) ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,52053)I_WANT_TO_MOVE,MOVE_FLAG_SENT,MY_DOMAIN_ID,NTIMESTEP WRITE(0,52054)MY_FORCED_SHIFT(1),MY_FORCED_SHIFT(2) 52053 FORMAT(' CHILDREN_RECV child_forces_my_shift i_want_to_move=',L1,' move_flag_sent=',L1,' my_domain_id=',I2,' ntimestep=',I5) 52054 FORMAT(' my forced I shift=',i4,' my forced J shift=',I4) ENDIF ENDIF ! !----------------------------------------------------------------------- !*** If this child wants to shift and it knows that its parent !*** had already initiated its own shift but has not yet moved !*** then this child simply ignores its own desire to shift and !*** waits NTIMESTEP_WAIT_PARENT after which its parent will !*** have executed its shift. The child will then be free to !*** initiate a shift. !----------------------------------------------------------------------- ! IF(I_WANT_TO_MOVE.AND.PARENT_WANTS_TO_MOVE)THEN ! I_WANT_TO_MOVE=.FALSE. I_SW_PARENT_NEW=I_SW_PARENT_CURRENT J_SW_PARENT_NEW=J_SW_PARENT_CURRENT NEXT_MOVE_TIMESTEP=-999 MOVE_FLAG_SENT=.FALSE. ! ENDIF ! IF(NTIMESTEP_WAIT_PARENT>0 & !<-- Parent has wanted to shift at least once .AND. & NTIMESTEP>NTIMESTEP_WAIT_PARENT-TIME_RATIO_MY_PARENT)THEN !<-- Reset this brake 1 parent timestep before parent shifts. PARENT_WANTS_TO_MOVE=.FALSE. ENDIF ! !----------------------------------------------------------------------- !*** If the nest has decided it wants to shift then finalize the !*** key values and inform the parent. !----------------------------------------------------------------------- ! IF(I_WANT_TO_MOVE.AND..NOT.MOVE_FLAG_SENT)THEN !<-- Nest wants to move; shift info not already sent ! !----------------------------------------------------------------------- !*** If this child domain is also a parent then it must check to see !*** if its shift would bring its children's domains too close to the !*** parent boundary. If it does then this domain must not shift. !----------------------------------------------------------------------- ! DISTN_TO_PARENT_BNDRY=1.E6 ! IF(NUM_CHILDREN>0)THEN DO N=1,NUM_CHILDREN I_SHIFT=(I_SW_PARENT_NEW-I_SW_PARENT_CURRENT)*SPACE_RATIO_MY_PARENT J_SHIFT=(J_SW_PARENT_NEW-J_SW_PARENT_CURRENT)*SPACE_RATIO_MY_PARENT CHILD_DOMAIN_EW=REAL(IM_CHILD(N)-1)/REAL(PARENT_CHILD_SPACE_RATIO(N)) CHILD_DOMAIN_NS=REAL(JM_CHILD(N)-1)/REAL(PARENT_CHILD_SPACE_RATIO(N)) DISTN_SOUTH=J_PARENT_SW(N)-J_SHIFT-JDS DISTN_NORTH=JDE-(J_PARENT_SW(N)+CHILD_DOMAIN_NS)+J_SHIFT DISTN_WEST =I_PARENT_SW(N)-I_SHIFT-IDS DISTN_EAST =IDE-(I_PARENT_SW(N)+CHILD_DOMAIN_EW)+I_SHIFT DISTN_TO_PARENT_BNDRY=MIN(DISTN_SOUTH,DISTN_NORTH & ,DISTN_WEST,DISTN_EAST & ,DISTN_TO_PARENT_BNDRY) ENDDO ENDIF ! !----------------------------------------------------------------------- ! check_shift: IF(DISTN_TO_PARENT_BNDRY<=MIN_DIST_PARENT)THEN ! I_WANT_TO_MOVE=.FALSE. !<-- Do not allow this domain (as a parent) to move. ! IF(NTIMESTEP>NTIMESTEP_WAIT_FORCED_PARENT)THEN !<-- If true, previous forced move of parent is done. I_SW_PARENT_NEW=I_SW_PARENT_CURRENT J_SW_PARENT_NEW=J_SW_PARENT_CURRENT ENDIF ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,77771)MY_DOMAIN_ID,NTIMESTEP,DISTN_TO_PARENT_BNDRY WRITE(0,77772)I_SHIFT,J_SHIFT WRITE(0,77773)DISTN_SOUTH,DISTN_NORTH,DISTN_WEST,DISTN_EAST 77771 FORMAT(' DO NOT allow this parent to move my_domain_id=',i2 & ,' ntimestep=',i5,' distn_to_parent_bndry=',e12.5) 77772 FORMAT(' Parent wanted to shift ',I3,3X,I3,' on its grid') 77773 FORMAT(' distn_south=',e12.5,' distn_north=',e12.5 & ,' distn_west=',e12.5,' distn_east=',e12.5) ENDIF ! ELSE ! !----------------------------------------------------------------------- !*** First the child checks to see if the shift it wants to make !*** will take it too near to the domain boundary of its parent. !*** If it does then the child does not move and instead informs !*** the parent that it must move far enough in the direction the !*** child wants to move so that when the child does move then !*** the child will not be too close to the parent boundary. !*** The array PARENT_DOMAIN_LIMITS used below holds the west, !*** east, south, and north index limits, respectively, of the !*** parent domain. !----------------------------------------------------------------------- ! CHILD_DOMAIN_EW=REAL(IDE-IDS)*RECIP_PARENT_SPACE_RATIO !<-- E-W extent of child domain in terms of parent grid CHILD_DOMAIN_NS=REAL(JDE-JDS)*RECIP_PARENT_SPACE_RATIO !<-- N-S extent of child domain in terms of parent grid ! DIST_SOUTH=J_SW_PARENT_NEW-PARENT_DOMAIN_LIMITS(3) !<-- Distance of child sbdry from parent sbdry DIST_NORTH=PARENT_DOMAIN_LIMITS(4)-(J_SW_PARENT_NEW+CHILD_DOMAIN_NS) !<-- Distance of child nbdry from parent nbdry DIST_WEST =I_SW_PARENT_NEW-PARENT_DOMAIN_LIMITS(1) !<-- Distance of child wbdry from parent wbdry DIST_EAST =PARENT_DOMAIN_LIMITS(2)-(I_SW_PARENT_NEW+CHILD_DOMAIN_EW) !<-- Distance of child ebdry from parent ebdry ! DIST_TO_PARENT_BNDRY=MIN(DIST_SOUTH,DIST_NORTH,DIST_WEST,DIST_EAST) !<-- Min distance between child and parent boundaries ! in terms of the parent grid. ! !----------------------------------------------------------------------- ! parent_bdy: IF(DIST_TO_PARENT_BNDRY>MIN_DIST_PARENT)THEN !<-- If true, the child is not too close to the parent boundary. ! !----------------------------------------------------------------------- !*** If this child's shift will take its poleward boundary beyond !*** the latitude limit then let it execute that shift after which !*** it will not move again. Likewise if this child's parent is a !*** moving nest and has reached the latitude limit then the child !*** must stop its own motion as the parent has already done. !----------------------------------------------------------------------- ! J_SHIFT=J_SW_PARENT_NEW-J_SW_PARENT_CURRENT !<-- This nest's shift in terms of its parent's grid SHIFT_LAT=J_SHIFT*SPACE_RATIO_MY_PARENT*DPH !<-- This nest's shift in geographic latitude (rad) DOMAIN_NBND=GLAT(ITS,JTS)+DPH*(JDE-JTS)+SHIFT_LAT !<-- Post-shift geog latitude (rad) of child's north bndry DOMAIN_SBND=GLAT(ITS,JTS)-DPH*(JTS-JDS)+SHIFT_LAT !<-- Post-shift geog latitude (rad) of child's south bndry ! PARENT_NBND=((PARENT_DOMAIN_LIMITS(4)-J_SW_PARENT_NEW) & !<-- *SPACE_RATIO_MY_PARENT & ! Geographic latitude (rad) -(JTS-JDS))*DPH & ! of parent's north boundary. +GLAT(ITS,JTS) !<-- ! PARENT_SBND=((PARENT_DOMAIN_LIMITS(3)-J_SW_PARENT_NEW) & !<-- *SPACE_RATIO_MY_PARENT & ! Geographic latitude (rad) -(JTS-JDS))*DPH & ! of parent's south boundary. +GLAT(ITS,JTS) !<-- ! IF(DOMAIN_NBND>NORTH_LAT_MAX_MVG_NEST-EPS & !<-- Has the nest's north boundary reached too far north? .OR. & DOMAIN_SBNDNORTH_LAT_MAX_MVG_NEST-EPS & !<-- Has the parent's north boundary reached too far north? .OR. & PARENT_SBNDTIME_RATIO_MY_PARENT*LAG_STEPS & .AND. & NTIMESTEPNTIMESTEP_WAIT_FORCED_PARENT)THEN !<-- If true, previous forced move of parent is done. ! FORCED_PARENT_SHIFT=.TRUE. !<-- Flag remains true until the parent shifts as told. ! IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead forecast task on this moving nest ! CALL MPI_WAIT(HANDLE_MOVE_FLAG & !<-- Handle for ISend of child's move flag to parent ,JSTAT & !<-- MPI status ,IERR) ! SHIFT_INFO_MINE(1)=-11111 !<-- This tells the parent it is being forced to shift. ! IF(DIST_WEST<=MIN_DIST_PARENT)THEN SHIFT_INFO_MINE(2)=-MAX_FORCED_SHIFT !<-- Child pushes parent to the west (parent grid increments) ELSEIF(DIST_EAST<=MIN_DIST_PARENT)THEN SHIFT_INFO_MINE(2)=MAX_FORCED_SHIFT !<-- Child pushes parent to the east (parent grid increments) ENDIF ! IF(DIST_SOUTH<=MIN_DIST_PARENT)THEN SHIFT_INFO_MINE(3)=-MAX_FORCED_SHIFT !<-- Child pushes parent to the south (parent grid increments) ELSEIF(DIST_NORTH<=MIN_DIST_PARENT)THEN SHIFT_INFO_MINE(3)=MAX_FORCED_SHIFT !<-- Child pushes parent to the north (parent grid increments) ENDIF ! MOVE_TAG=1111+10*MY_DOMAIN_ID+25*ID_PARENTS(MY_DOMAIN_ID) !<-- Unique MPI tag uses child and parent domain IDs ! CALL MPI_ISSEND(SHIFT_INFO_MINE & !<-- Key shift information ,4 & !<-- There are 3 words in the flag ,MPI_INTEGER & !<-- Signal is type Integer ,0 & !<-- Signal sent to parent task 0 ,MOVE_TAG & !<-- Arbitrary tag used for this data exchange ,COMM_TO_MY_PARENT & !<-- MPI communicator between this child and its parent ,HANDLE_MOVE_FLAG & !<-- Communication request handle for ISend to parent ,IERR ) ! WRITE(0,55551)MY_DOMAIN_ID,NTIMESTEP WRITE(0,55552)SHIFT_INFO_MINE,MOVE_TAG 55551 FORMAT(' CHILDREN_RECV forcing parent to shift' & ,' my_domain_id=',I2,' ntimestep=',I6) 55552 FORMAT(' SHIFT_INFO=',4(1X,I6),' move_tag=',I6) ! ENDIF ! !----------------------------------------------------------------------- !*** This child has just sent its parent a message saying that the !*** parent must shift because the child's desired shift would !*** otherwise cause a collision between the two domains' boundaries. !*** The parent will not be able to act on this until the start of !*** the following parent timestep and then must wait for LAG_STEPS !*** timesteps of its own parent before executing its shift. This !*** child must not initiate another forced shift of its parent !*** until after that amount of time which is LAG_STEPS+1 of this !*** child's grandparent's timesteps from now. !----------------------------------------------------------------------- ! ID_GRANDPARENT=ID_PARENTS(ID_PARENTS(MY_DOMAIN_ID)) !<-- My parent's parent's domain ID DT_GRANDPARENT=DT_DOMAIN(ID_GRANDPARENT) !<-- My parent's parent's timestep interval (sec) ! NTIMESTEP_WAIT_FORCED_PARENT=NTIMESTEP & !<-- The next timestep this domain +NINT(DT_GRANDPARENT*(LAG_STEPS+1) & ! will be allowed to initiate a /DT_DOMAIN(MY_DOMAIN_ID)) ! forced move of its parent. ! ENDIF ! !----------------------------------------------------------------------- ! ELSE !<-- This child's parent is static. ! I_WANT_TO_MOVE=.FALSE. !<-- The parent cannot be pushed so do nothing. ! WRITE(0,55553)MY_DOMAIN_ID,NTIMESTEP WRITE(0,55554) WRITE(0,55555) 55553 FORMAT(' CHILDREN_RECV my_domain_id=',I2 & ,' ntimestep=',I5) 55554 FORMAT(' Child wants to move too close to parent bndry!') 55555 FORMAT(' Parent cannot be pushed away so do not shift.') ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parent_bdy ! !----------------------------------------------------------------------- ! ENDIF check_shift ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF moving_children_b ! !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- ! SUBROUTINE NEST_RECVS_BC_DATA(TIME_FLAG) ! !----------------------------------------------------------------------- !*** A nest receives boundary data from its parent so that !*** it can compute boundary tendencies for its integration. !*** This is an internal subroutine to CHILDREN_RECV_PARENT_DATA. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- BC data valid for current or future timestep? ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ID_ADD,IERR,N,NP_H,NP_V,NTAG ! integer(kind=kint) :: mype_intra !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Point at the memory valid for this particular domain !*** since individual tasks might lie on more than one domain. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Each child task that holds part of the domain boundary receives !*** data from the parent tasks that cover its boundary points. !*** This occurs for two different situations: !*** (1) All nests receive boundary data from their parents that was !*** sent from one parent timestep in the future. That allows !*** each nest to compute boundary value tendencies that are !*** applied through the next NN child timesteps of integration !*** where NN is the number of child timesteps within each parent !*** timestep. !*** (2) Immediately after a moving nest moves, it needs new boundary !*** values for that current time at the new location. The !*** structure of that boundary data is the same as in (1) so !*** it is received from the parents in the same way. However !*** that data then needs to be stored as the values for current !*** parent timestep N where the boundary tendency for variable X !*** is [X(N+1)-X(N)]/DT(parent). The values from the future !*** timestep N+1 will subsequently be received as usual. ! !*** Thus we simply need to know whether the incoming data is for the !*** future time (#1 above) or for the current time (#2 above). That !*** information is given by this subroutine's input argument. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! !*** Now for each side of the nests' boundaries: ! !*** (a) Each child task receives all boundary data from the !*** relevant parent task(s). Note that more than one !*** parent task might send to each child task and there may !*** be overlap due to haloes. !*** (b) The child tasks separate the data received from each of !*** the parent tasks and combines them into unified segments !*** on the boundary for each variable. !*** (c) All boundary data is loaded into the Parent-Child Coupler's !*** export state. ! !----------------------------------------------------------------------- ! cpl1_prelim_tim=cpl1_prelim_tim+(timef()-btim0) ! ID_ADD=1000*MY_DOMAIN_ID ! !-------------------- !*** South H Points !-------------------- ! btim0=timef() ! NP_H=NUM_PARENT_TASKS_SENDING_H%SOUTH !<-- # of parent tasks sending south boundary H data ! IF(NP_H>0)THEN ! NTAG=NTIMESTEP+101+ID_ADD !<-- Add 101 and domain ID to obtain a unique south H tag ! DO N=1,NP_H !<-- Loop over each parent task sending Sboundary H data call date_and_time(values=values) ! write(0,123)n,parent_task(n)%south_h%id_source,values(5),values(6),values(7),values(8) 123 format(' Ready to recv South_H from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! ! if(my_domain_id==4.and.ntimestep>=15516)then ! write(0,39571)trim(time_flag) ! write(0,39572)n,PARENT_TASK(N)%SOUTH_H%ID_SOURCE,PARENT_TASK(N)%SOUTH_H%LENGTH,ntag,np_h 39571 format(' NEST_RECVS_BC_DATA(',a7,') for South_H') 39572 format(' from parent task #',i3,' id=',i3,' # words=',i5,' ntag=',i6,' # parent tasks sending=',i2) ! endif btim=timef() CALL MPI_RECV(PARENT_TASK(N)%SOUTH_H%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%SOUTH_H%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%SOUTH_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_south_h_recv_tim=cpl1_south_h_recv_tim+(timef()-btim) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) call date_and_time(values=values) ! write(0,124)n,parent_task(n)%south_h%id_source,values(5),values(6),values(7),values(8) 124 format(' Recvd South_H from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! !----------------------------------------------------------------------- ! btim=timef() CALL CHILD_DATA_FROM_STRING(length_data=PARENT_TASK(N)%SOUTH_H%LENGTH & !<-- Length of parent datastring ,datastring =PARENT_TASK(N)%SOUTH_H%STRING & !<-- Parent datastring of child task bndry segment ,ilim_lo =INDX_MIN_H%SOUTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_H%SOUTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary ,i_start =PARENT_TASK(N)%SOUTH_H%INDX_START & !<-- Child's segment Istart on each parent task ,i_end =PARENT_TASK(N)%SOUTH_H%INDX_END & !<-- Child's segment Iend on each parent task ,j_start =1 & !<-- Child's segment Jstart on each parent task ,j_end =N_BLEND_H & !<-- Child's segment Jend on each parent task ,nvars_bc_2d_h =NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h =NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h =NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v =NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v =NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_S & !<-- Child's 1-D segment of PD on Sbndry ,bc_vars_h =MY_BC_VARS_H_S ) !<-- Child's 1-D segment of other H-pt vbls on Sbndry ! cpl1_south_h_undo_tim=cpl1_south_h_undo_tim+(timef()-btim) ! ENDDO ! !----------------------------------------------------------------------- ! btim=timef() CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_S & !<-- Child's 1-D segment of PD on Sbndry ,bc_vars_h =MY_BC_VARS_H_S & !<-- Child's 1-D segment of other H-pt vbls on Sbndry ,ilim_lo =INDX_MIN_H%SOUTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_H%SOUTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary ,data_name ='SOUTH_H_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_SOUTH_H & !<-- Combined boundary segment H data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! cpl1_south_h_exp_tim=cpl1_south_h_exp_tim+(timef()-btim) ENDIF ! cpl1_south_h_tim=cpl1_south_h_tim+(timef()-btim0) ! !-------------------- !*** South V Points !-------------------- ! btim0=timef() ! NP_V=NUM_PARENT_TASKS_SENDING_V%SOUTH !<-- # of parent tasks sending south boundary V data ! IF(NP_V>0)THEN NTAG=NTIMESTEP+102+ID_ADD !<-- Add 102 and domain ID to obtain a unique south V tag ! DO N=1,NP_V !<-- Loop over each parent task sending Sboundary V data ! btim=timef() CALL MPI_RECV(PARENT_TASK(N)%SOUTH_V%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%SOUTH_V%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%SOUTH_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_south_v_recv_tim=cpl1_south_v_recv_tim+(timef()-btim) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) call date_and_time(values=values) ! write(0,125)n,parent_task(n)%south_v%id_source,values(5),values(6),values(7),values(8) 125 format(' Recvd South_V from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! !----------------------------------------------------------------------- ! btim=timef() CALL CHILD_DATA_FROM_STRING(length_data=PARENT_TASK(N)%SOUTH_V%LENGTH & !<-- Length of parent datastring ,datastring =PARENT_TASK(N)%SOUTH_V%STRING & !<-- Parent datastring of child task bndry segment ,ilim_lo =INDX_MIN_V%SOUTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_V%SOUTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary ,i_start =PARENT_TASK(N)%SOUTH_V%INDX_START & !<-- Child's segment Istart on each parent task ,i_end =PARENT_TASK(N)%SOUTH_V%INDX_END & !<-- Child's segment Iend on each parent task ,j_start =1 & !<-- Child's segment Jstart on each parent task ,j_end =N_BLEND_V & !<-- Child's segment Jend on each parent task ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_S ) !<-- Child's 1-D segment of V-pt vbls on Sbndry cpl1_south_v_undo_tim=cpl1_south_v_undo_tim+(timef()-btim) ! ENDDO ! !----------------------------------------------------------------------- ! btim=timef() CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_S & !<-- Child's 1-D segment of V-pt vbls on Sbndry ,ilim_lo =INDX_MIN_V%SOUTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_V%SOUTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary ,data_name ='SOUTH_V_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_SOUTH_V & !<-- Combined boundary segment V data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! cpl1_south_v_exp_tim=cpl1_south_v_exp_tim+(timef()-btim) ! ENDIF ! cpl1_south_v_tim=cpl1_south_v_tim+(timef()-btim0) ! !-------------------- !*** North H Points !-------------------- ! btim0=timef() ! NP_H=NUM_PARENT_TASKS_SENDING_H%NORTH !<-- # of parent tasks sending north boundary H data ! IF(NP_H>0)THEN NTAG=NTIMESTEP+103+ID_ADD !<-- Add 103 and domain ID to obtain a unique north H tag ! DO N=1,NP_H !<-- Loop over each parent task sending Nboundary H data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%NORTH_H%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%NORTH_H%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%NORTH_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%NORTH_H%LENGTH & ,datastring =PARENT_TASK(N)%NORTH_H%STRING & ,ilim_lo =INDX_MIN_H%NORTH & ,ilim_hi =INDX_MAX_H%NORTH & ,jlim_lo =1 & ,jlim_hi =N_BLEND_H & ,i_start =PARENT_TASK(N)%NORTH_H%INDX_START & ,i_end =PARENT_TASK(N)%NORTH_H%INDX_END & ,j_start =1 & ,j_end =N_BLEND_H & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_N & !<-- Child's 1-D segment of PD on Nbndry ,bc_vars_h =MY_BC_VARS_H_N ) !<-- Child's 1-D segment of other H-pt vbls on Nbndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_N & !<-- Child's 1-D segment of PD on Nbndry ,bc_vars_h =MY_BC_VARS_H_N & !<-- Child's 1-D segment of other H-pt vbls on Nbndry ,ilim_lo =INDX_MIN_H%NORTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_H%NORTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary ,data_name ='NORTH_H_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_NORTH_H & !<-- Combined boundary segment H data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_north_h_tim=cpl1_north_h_tim+(timef()-btim0) ! !-------------------- !*** North V Points !-------------------- ! btim0=timef() ! NP_V=NUM_PARENT_TASKS_SENDING_V%NORTH !<-- # of parent tasks sending north boundary V data ! IF(NP_V>0)THEN NTAG=NTIMESTEP+104+ID_ADD !<-- Add 104 and domain ID to obtain a unique north V tag ! DO N=1,NP_V !<-- Loop over each parent task sending Nboundary V data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%NORTH_V%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%NORTH_V%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%NORTH_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%NORTH_V%LENGTH & ,datastring =PARENT_TASK(N)%NORTH_V%STRING & ,ilim_lo =INDX_MIN_V%NORTH & ,ilim_hi =INDX_MAX_V%NORTH & ,jlim_lo =1 & ,jlim_hi =N_BLEND_V & ,i_start =PARENT_TASK(N)%NORTH_V%INDX_START & ,i_end =PARENT_TASK(N)%NORTH_V%INDX_END & ,j_start =1 & ,j_end =N_BLEND_V & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_N ) !<-- Child's 1-D segment of V-pt vbls on Nbndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_N & !<-- Child's 1-D segment of V-pt vbls on Nbndry ,ilim_lo =INDX_MIN_V%NORTH & !<-- Lower I limit of child's segment of boundary ,ilim_hi =INDX_MAX_V%NORTH & !<-- Upper I limit of child's segment of boundary ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary ,data_name ='NORTH_V_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_NORTH_V & !<-- Combined boundary segment V data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_north_v_tim=cpl1_north_v_tim+(timef()-btim0) ! !------------------- !*** West H Points !------------------- ! btim0=timef() ! NP_H=NUM_PARENT_TASKS_SENDING_H%WEST !<-- # of parent tasks sending west boundary H data ! IF(NP_H>0)THEN NTAG=NTIMESTEP+105+ID_ADD !<-- Add 105 and domain ID to obtain a unique west H tag ! DO N=1,NP_H !<-- Loop over each parent task sending Wboundary H data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%WEST_H%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%WEST_H%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%WEST_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%WEST_H%LENGTH & ,datastring =PARENT_TASK(N)%WEST_H%STRING & ,ilim_lo =1 & ,ilim_hi =N_BLEND_H & ,jlim_lo =INDX_MIN_H%WEST & ,jlim_hi =INDX_MAX_H%WEST & ,i_start =1 & ,i_end =N_BLEND_H & ,j_start =PARENT_TASK(N)%WEST_H%INDX_START & ,j_end =PARENT_TASK(N)%WEST_H%INDX_END & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_W & !<-- Child's 1-D segment of PD on Wbndry ,bc_vars_h =MY_BC_VARS_H_W ) !<-- Child's 1-D segment of other H-pt vbls on Wbndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_W & !<-- Child's 1-D segment of PD on Wbndry ,bc_vars_h =MY_BC_VARS_H_W & !<-- Child's 1-D segment of other H-pt vbls on Wbndry ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary ,ilim_hi =N_BLEND_H & !<-- Upper I limit of child's segment of boundary ,jlim_lo =INDX_MIN_H%WEST & !<-- Lower J limit of child's segment of boundary ,jlim_hi =INDX_MAX_H%WEST & !<-- Upper J limit of child's segment of boundary ,data_name ='WEST_H_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_WEST_H & !<-- Combined boundary segment H data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_west_h_tim=cpl1_west_h_tim+(timef()-btim0) ! !------------------- !*** West V Points !------------------- ! btim0=timef() ! NP_V=NUM_PARENT_TASKS_SENDING_V%WEST !<-- # of parent tasks sending west boundary V data ! IF(NP_V>0)THEN NTAG=NTIMESTEP+106+ID_ADD !<-- Add 106 and domain ID to obtain a unique west V tag ! DO N=1,NP_V !<-- Loop over each parent task sending Sboundary V data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%WEST_V%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%WEST_V%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%WEST_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%WEST_V%LENGTH & ,datastring =PARENT_TASK(N)%WEST_V%STRING & ,ilim_lo =1 & ,ilim_hi =N_BLEND_V & ,jlim_lo =INDX_MIN_V%WEST & ,jlim_hi =INDX_MAX_V%WEST & ,i_start =1 & ,i_end =N_BLEND_V & ,j_start =PARENT_TASK(N)%WEST_V%INDX_START & ,j_end =PARENT_TASK(N)%WEST_V%INDX_END & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_W ) !<-- Child's 1-D segment of V-pt vbls on Wbndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_W & !<-- Child's 1-D segment of V-pt vbls on Wbndry ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary ,ilim_hi =N_BLEND_V & !<-- Upper I limit of child's segment of boundary ,jlim_lo =INDX_MIN_V%WEST & !<-- Lower J limit of child's segment of boundary ,jlim_hi =INDX_MAX_V%WEST & !<-- Upper J limit of child's segment of boundary ,data_name ='WEST_V_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_WEST_V & !<-- Combined boundary segment V data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_west_v_tim=cpl1_west_v_tim+(timef()-btim0) ! !------------------- !*** East H Points !------------------- ! btim0=timef() ! NP_H=NUM_PARENT_TASKS_SENDING_H%EAST !<-- # of parent tasks sending east boundary H data ! IF(NP_H>0)THEN NTAG=NTIMESTEP+107+ID_ADD !<-- Add 107 and domain ID to obtain a unique east H tag ! DO N=1,NP_H !<-- Loop over each parent task sending Eboundary H data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%EAST_H%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%EAST_H%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%EAST_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%EAST_H%LENGTH & ,datastring =PARENT_TASK(N)%EAST_H%STRING & ,ilim_lo =1 & ,ilim_hi =N_BLEND_H & ,jlim_lo =INDX_MIN_H%EAST & ,jlim_hi =INDX_MAX_H%EAST & ,i_start =1 & ,i_end =N_BLEND_H & ,j_start =PARENT_TASK(N)%EAST_H%INDX_START & ,j_end =PARENT_TASK(N)%EAST_H%INDX_END & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_E & !<-- Child's 1-D segment of PD on Ebndry ,bc_vars_h =MY_BC_VARS_H_E ) !<-- Child's 1-D segment of other H-pt vbls on Ebndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,pdb =PDB_E & !<-- Child's 1-D segment of PD on Ebndry ,bc_vars_h =MY_BC_VARS_H_E & !<-- Child's 1-D segment of other H-pt vbls on Ebndry ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary ,ilim_hi =N_BLEND_H & !<-- Upper I limit of child's segment of boundary ,jlim_lo =INDX_MIN_H%EAST & !<-- Lower J limit of child's segment of boundary ,jlim_hi =INDX_MAX_H%EAST & !<-- Upper J limit of child's segment of boundary ,data_name ='EAST_H_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_EAST_H & !<-- Combined boundary segment H data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_east_h_tim=cpl1_east_h_tim+(timef()-btim0) ! !------------------- !*** East V Points !------------------- ! btim0=timef() ! NP_V=NUM_PARENT_TASKS_SENDING_V%EAST !<-- # of parent tasks sending east boundary V data ! IF(NP_V>0)THEN NTAG=NTIMESTEP+108+ID_ADD !<-- Add 108 and domain ID to obtain a unique east V tag ! DO N=1,NP_V !<-- Loop over each parent task sending Eboundary V data btim=timef() CALL MPI_RECV(PARENT_TASK(N)%EAST_V%STRING & !<-- 1-D boundary datastring from parent task ,PARENT_TASK(N)%EAST_V%LENGTH & !<-- # of words in the datastring ,MPI_REAL & !<-- Datatype ,PARENT_TASK(N)%EAST_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator ,JSTAT & !<-- MPI status object ,IERR) cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) ! !----------------------------------------------------------------------- ! CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%EAST_V%LENGTH & ,datastring =PARENT_TASK(N)%EAST_V%STRING & ,ilim_lo =1 & ,ilim_hi =N_BLEND_V & ,jlim_lo =INDX_MIN_V%EAST & ,jlim_hi =INDX_MAX_V%EAST & ,i_start =1 & ,i_end =N_BLEND_V & ,j_start =PARENT_TASK(N)%EAST_V%INDX_START & ,j_end =PARENT_TASK(N)%EAST_V%INDX_END & ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_E ) !<-- Child's 1-D segment of V-pt vbls on Ebndry ! ENDDO ! !----------------------------------------------------------------------- ! CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary ,bc_vars_v =MY_BC_VARS_V_E & !<-- Child's 1-D segment of V-pt vbls on Ebndry ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary ,ilim_hi =N_BLEND_V & !<-- Upper I limit of child's segment of boundary ,jlim_lo =INDX_MIN_V%EAST & !<-- Lower J limit of child's segment of boundary ,jlim_hi =INDX_MAX_V%EAST & !<-- Upper J limit of child's segment of boundary ,data_name ='EAST_V_'//TIME_FLAG & !<-- Name attached to the combined exported data ,data_exp =BOUND_1D_EAST_V & !<-- Combined boundary segment V data for child task ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state ! ENDIF ! cpl1_east_v_tim=cpl1_east_v_tim+(timef()-btim0) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Clocktime for Recv in Phase1 into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='Cpl1_Recv_Time' & !<-- Name of the attribute to insert ,value=cpl1_recv_tim & !<-- Phase 1 Recv time ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! END SUBROUTINE NEST_RECVS_BC_DATA ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILDREN_RECV_PARENT_DATA ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE PARENTS_SEND_CHILD_DATA(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** Parents send new boundary data to each of their children. !*** Only parents execute this routine that is called as phase 4 !*** of the Run step of the Parent-Child coupler in subroutine !*** NMM_INTEGRATE. !----------------------------------------------------------------------- ! IMPLICIT NONE ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The NMM Clock for this parent domain ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: CHILDTASK_0 & ,COMM_FCST_TASKS & ,I_PARENT_SW_OLD & ,J_PARENT_SW_OLD & ,KOUNT_MOVING,MY_DOMAIN_ID,N,N_MOVING & ,N_UPDATE_CHILD_TASKS & ,NR,NRES,NTAG0 & ,NTIMESTEP & ,NTIMESTEP_CHILD & ,NTIMESTEP_MOVE & ,NUM_CHILD_TASKS,SPACE_RATIO ! INTEGER(kind=KINT) :: IERR,IRTN,RC,RC_CPL_RUN ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: & PROCEED_AFTER_BC_RECV ! INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: CHILD_TASK_LIMITS ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! LOGICAL(kind=KLOG) :: EXCH_DONE & ,INTEGRATE_TIMESTEP,PARENT_MOVED & ,SHIFT_INFO_IS_PRESENT ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! btim0=timef() btim2=timef() ! !----------------------------------------------------------------------- !*** Initialize the error signal variables. !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_RUN=ESMF_SUCCESS ! !----------------------------------------------------------------------- ! !----------------------- !*** Current Domain ID !----------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------- !*** Are we in the free forecast? !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Free Forecast flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Free Forecast' & !<-- Name of the attribute to extract ,value=FREE_FORECAST & !<-- Is this the free forecast? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DIG_FILTER=.FALSE. IF(.NOT.FREE_FORECAST)THEN DIG_FILTER=.TRUE. ENDIF ! !----------------------------------------------------------------------- !*** Point to the correct part of the composite object which will !*** align working variables with values associated with this domain. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Intracommunicator for current domain's forecast tasks !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Fcst Task Intracommunicator" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_CLOCKGET(CLOCK =CLOCK & !<-- The ESMF Clock ,advanceCount=ntimestep_esmf & !<-- The parent's current timestep (ESMF) ,rc =rc) ! NTIMESTEP=NTIMESTEP_ESMF !<-- The parent just finished the current timestep ! !----------------------------------------------------------------------- ! CHILDTASK_0=FTASKS_DOMAIN(MY_DOMAIN_ID) !<-- Rank of each child's task 0 in intracommunicator KOUNT_MOVING=0 !<-- Keep track of nests who want to move. ! !----------------------------------------------------------------------- !*** The following block is for the setup in which this parent domain !*** is a moving nest and it contains children (which must be moving !*** and cannot be static). !*** If this domain is going to move in one of its parent's timesteps !*** from now (TIME_RATIO_MY_PARENT timesteps of this domain) then !*** it now notifies its children of the coming shift. This is !*** required so that the children will be able to recompute the !*** parent-child task layout relationships which will change when the !*** parent moves. This will force the children to wait to recv the !*** task update specifications for BCs from the parent before they !*** execute their normal recvs of BC data updates from the future !*** at the end of this routine. !*** If the parent just moved at the beginning of the current timestep !*** it must adjust its location of its children. !*** Note that I_SHIFT_CHILD and J_SHIFT_CHILD here are the shift !*** values of this parent domain on its own grid inherited from !*** subroutine CHILDREN_RECV_PARENT_DATA in which it was a child. !----------------------------------------------------------------------- ! PARENT_MOVED=.FALSE. ! parent_moves: IF(MY_DOMAIN_MOVES)THEN !<-- Does this parent domain move? ! !----------------------------------------------------------------------- !*** The lead task on this parent domain notifies the lead tasks on !*** each of its children's domains that it is going to shift. !*** Even though PARENT_SHIFT is the same for all children it must !*** be filled after the call to MPI_WAIT. !----------------------------------------------------------------------- ! btim2=timef() ! ! write(0,88851)my_domain_id,ntimestep,next_move_timestep,next_move_timestep-time_ratio_my_parent*lag_steps 88851 format(' Parents Send should I send my shift info to child? my_domain_id=',i2,' ntimestep=',i5 & ,' next_move_timestep=',i5,' shiftstep-12=',i5) IF(NTIMESTEP==NEXT_MOVE_TIMESTEP-TIME_RATIO_MY_PARENT*LAG_STEPS)THEN !<-- Parent sends its shift information at the end of the ! ! timestep in which the decision to shift was made. IF(NUM_CHILDREN>0.AND.I_AM_LEAD_FCST_TASK)THEN ! DO N=1,NUM_CHILDREN ! CALL MPI_WAIT(HANDLE_PARENT_SHIFT(N) & !<-- Handle for ISend of parent's shift ,JSTAT & !<-- MPI status ,IERR) ! PARENT_SHIFT(1)=NEXT_MOVE_TIMESTEP !<-- Parent will shift in this parent timestep. PARENT_SHIFT(2)=I_SHIFT_CHILD !<-- Parent's I shift in its space PARENT_SHIFT(3)=J_SHIFT_CHILD !<-- Parent's J shift in its space ! NTAG0=PARENT_SHIFT_TAG+NTIMESTEP+1 !<-- Unique MPI tag valid 1 parent timestep after decision to shift CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child N's lead task in parent-child intracomm ! CALL MPI_ISSEND(PARENT_SHIFT & !<-- Send parent's shift to all its children ,3 & !<-- There are 2 words in the message ,MPI_INTEGER & !<-- The shift increments are integers ,CHILDTASK_0 & !<-- Signal sent to all lead child tasks ,NTAG0 & !<-- Tag valid for parent timestep preceding its actual shift ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between this parent and its children ,HANDLE_PARENT_SHIFT(N) & !<-- Communication request handle for this ISend to children ,IERR ) ! write(0,28261)my_domain_id,ntimestep,next_move_timestep 28261 format(' Parents Send sending parent shift info to child my_domain_id=',i2 & ,' ntimestep=',i5,' my next_move_timestep=',i5) ! ENDDO ! pscd1_tim=pscd1_tim+(timef()-btim2) ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! this_timestep: IF(NTIMESTEP==NEXT_MOVE_TIMESTEP)THEN ! btim2=timef() ! PARENT_MOVED=.TRUE. !<-- Parent moved at beginning of current timestep ! DO N=1,NUM_CHILDREN I_PARENT_SW(N)=I_PARENT_SW(N)-I_SHIFT_CHILD !<-- Child N's new SW corner I after parent moved J_PARENT_SW(N)=J_PARENT_SW(N)-J_SHIFT_CHILD !<-- Child N's new SW corner J after parent moved ENDDO ! !----------------------------------------------------------------------- !*** Now fill the parent's data objects that hold the nest-resolution !*** topography at child H points and child V points. Since the !*** parent just moved then its MPI task subdomains need that data !*** for their new locations. Note that in this situation the total !*** number of children must equal the number of moving children. !----------------------------------------------------------------------- ! CALL PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & ,NUM_CHILDREN & ,LINK_MRANK_RATIO & ,LIST_OF_RATIOS & ,M_NEST_RATIO & ,NUM_SPACE_RATIOS_MVG & ,GLOBAL_TOP_PARENT & ,IM_1,JM_1 & ,TPH0_1,TLM0_1 & ,SB_1,WB_1 & ,RECIP_DPH_1,RECIP_DLM_1 & ,GLAT,GLON & ,NEST_FIS_ON_PARENT_BNDS & ,NEST_FIS_ON_PARENT & ,NEST_FIS_V_ON_PARENT & ,IDS,IDE,IMS,IME,ITS,ITE & ,JDS,JDE,JMS,JME,JTS,JTE) ! read_moving_child_topo_tim=read_moving_child_topo_tim+(timef()-btim2) ! ENDIF this_timestep ! ENDIF parent_moves ! !----------------------------------------------------------------------- !*** The parent generates new boundary data for all of its children !*** given their domains' positions at the beginning of this parent !*** timestep and sends it to the children so they can form time !*** tendencies for their boundary variables as they integrate through !*** this parent timestep. This is relevant for all children, both !*** static and moving. If this is now a timestep in which the !*** child shifts then the parent must now reset those working !*** pointers/arrays that are used for the preparation of the !*** standard child boundary updates that are sent back in time !*** to all children every parent timestep so the child can generate !*** its boundary tendencies. The reset is needed because the child's !*** boundary has different associations with the parent tasks after !*** the move. The same work is needed if the parent domain moved !*** at the beginning of this timestep since that also changes the !*** association of parent tasks and child boundary tasks. Also if !*** the child just moved then the parent should update its haloes !*** for those variables used to update the child's boundaries !*** because a parent task's halo points will need to be used if !*** some of the child's boundary rows lie within the parent task's !*** integration points while others lie within that parent task's !*** halo points. !----------------------------------------------------------------------- ! btim2=timef() ! DO N=1,NUM_CHILDREN ! IF(STATIC_OR_MOVING(N)=='Moving')THEN !<-- Select the children who can move. KOUNT_MOVING=KOUNT_MOVING+1 ! IF(NTIMESTEP==NTIMESTEP_CHILD_MOVES(N) & !<-- If either of these statements is true .OR. & ! then child N just moved relative PARENT_MOVED)THEN ! to this parent. ! NRES=LINK_MRANK_RATIO(KOUNT_MOVING) !<-- Rank of space ratio value among the moving children ! CALL RESET_WORK_PARENT(N,NRES,'Future',PARENT_MOVED) !<-- Reset working arrays for this moving nest. ! ENDIF ! ENDIF ! IF(FREE_FORECAST.OR.(DIG_FILTER.AND.CHILD_ACTIVE(N)))THEN !<-- For DFI, check that the child is participating. ! CALL COMPUTE_SEND_NEST_BC_DATA(N,'Future') !<-- Parent sends BC data to children from their future. ! ENDIF ! ENDDO ! IF(PARENT_MOVED)PARENT_MOVED=.FALSE. ! pscd2_tim=pscd2_tim + (timef()-btim2) ! !----------------------------------------------------------------------- !*** We are at the end of a parent timestep. If the parent has !*** children who move then: !*** !*** (1) The parent receives a message from each child who can move !*** only when the child wants to move. The message contains !*** the parent timestep in which the child will shift as well !*** as the shift in I and J on the parent grid. The message !*** is received by the parent at the end of a parent timestep !*** while the child will have sent it from the beginning of !*** an earlier parent timestep depending on the relative !*** integration speeds of parent and child. !*** (2) The parent computes and sends new information to the moving !*** children regarding the association of parent and child tasks !*** for the children's new locations after they move. Then the !*** parent computes and sends the new internal child data for !*** those child gridpoints that have moved over a new region of !*** the parent grid as well as the new starting boundary data !*** for their grids' new locations. !----------------------------------------------------------------------- ! moving_children: IF(NUM_MOVING_CHILDREN>0)THEN !<-- Select all of this parent's moving children ! !----------------------------------------------------------------------- ! btim2=timef() ! CALL MPI_BARRIER(COMM_FCST_TASKS,IRTN) !<-- Syncs Probe below with BC ISends above; required ! barrier_move_tim=barrier_move_tim+(timef()-btim2) ! EXCH_DONE=.FALSE. !<-- Initialize flag for parent halo exchanges ! !----------------------------------------------------------------------- ! btim2=timef() ! parent_task_0: IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task will probe for children's shift signals. ! !----------------------------------------------------------------------- ! child_loop_1: DO N=1,NUM_MOVING_CHILDREN !<-- Loop through this parent's moving children. ! !----------------------------------------------------------------------- ! N_MOVING=RANK_MOVING_CHILD(N) !<-- In the list of this parent's children, these can move. ! !----------------------------------------------------------------------- ! check_block1: IF(NTIMESTEP>NTIMESTEP_CHILD_MOVES(N))THEN !<-- Probe only after child's previous shift is complete. ! !----------------------------------------------------------------------- ! MOVE_FLAG(N)=.FALSE. !<-- True only when parent first learns child N wants to move. ! CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA(0) !<-- Local rank of child's lead task in p-c intracommunicator MOVE_TAG=1111+10*MY_CHILDREN_ID(N_MOVING) & !<-- Unique MPI tag uses child and parent domain IDs +25*MY_DOMAIN_ID ! CALL MPI_IPROBE(CHILDTASK_0 & !<-- Is shift info present from moving child N's fcst task 0? ,MOVE_TAG & !<-- Tag associated with nest N's move flag ,COMM_TO_MY_CHILDREN(N_MOVING) & !<-- MPI communicator between parent and moving child N ,SHIFT_INFO_IS_PRESENT & !<-- Is the nest's shift information now available? ,JSTAT & ,IERR) ! !----------------------------------------------------------------------- ! IF(SHIFT_INFO_IS_PRESENT)THEN ! MOVE_FLAG(N)=.TRUE. !<-- Moving child N is saying it wants to move ! CALL MPI_RECV(SHIFT_INFO_CHILDREN(1,N) & !<-- Recv the message and clear the nest's ISEND ,4 & !<-- # of words in message ,MPI_INTEGER & !<-- The message is type Integer. ,CHILDTASK_0 & !<-- The message was sent by moving child N's fcst task 0. ,MOVE_TAG & !<-- Arbitrary tag used for this data exchange ,COMM_TO_MY_CHILDREN(N_MOVING) & !<-- MPI communicator between parent and moving child N ,JSTAT & ,IERR) ! IF(I_WANT_TO_MOVE.AND.MOVE_FLAG(N))THEN MOVE_FLAG(N)=.FALSE. !<-- Turn off the child's shift if parent also wants to move. ENDIF ! IF(NTIMESTEP>=NTIMESTEP_FINAL-2)THEN MOVE_FLAG(N)=.FALSE. !<-- Children must not move just before the fcst ends ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF check_block1 ! !----------------------------------------------------------------------- ! ENDDO child_loop_1 ! !----------------------------------------------------------------------- ! ENDIF parent_task_0 ! t0_recv_move_tim=t0_recv_move_tim+(timef()-btim2) ! !----------------------------------------------------------------------- ! child_loop_2: DO N=1,NUM_MOVING_CHILDREN !<-- Loop through this parent's moving children ! N_MOVING=RANK_MOVING_CHILD(N) !<-- In the list of this parent's children, these can move. ! !----------------------------------------------------------------------- !*** Parent task 0 informs the other parent tasks if moving child N !*** has signaled that it wants to move and if so then it shares !*** the child's shift information. The 3 words in the shift info are: ! (1) The parent's timestep in which child N will move. ! (2) The child's shift in I on the parent grid. ! (3) The child's shift in J on the parent grid. !----------------------------------------------------------------------- ! check_block2: IF(NTIMESTEP>NTIMESTEP_CHILD_MOVES(N))THEN ! !----------------------------------------------------------------------- ! btim2=timef() ! CALL MPI_BCAST(MOVE_FLAG(N) & !<-- Moving child N's signal: Does it want to move? ,1 & !<-- The timestep is one word ,MPI_LOGICAL & !<-- The signal is type Logical ,0 & !<-- Broadcast from parent forecast task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for this parent's forecast tasks ,IRTN ) ! IF(MOVE_FLAG(N))THEN !<-- If true then moving child N sent shift information. ! CALL MPI_BCAST(SHIFT_INFO_CHILDREN(1,N) & !<-- Moving child N's shift information ,4 & !<-- # of words in message ,MPI_INTEGER & !<-- The message is type Integer ,0 & !<-- Broadcast from parent forecast task 0 ,COMM_FCST_TASKS & !<-- Intracommunicator for this parent's forecast tasks ,IRTN ) ! IF(SHIFT_INFO_CHILDREN(1,N)>0)THEN NTIMESTEP_CHILD_MOVES(N)=SHIFT_INFO_CHILDREN(1,N) !<-- The parent timestep in which the child will move ! ELSEIF(SHIFT_INFO_CHILDREN(1,N)==-11111)THEN !<-- Child is forcing the parent to move. IF(.NOT.I_WANT_TO_MOVE)THEN !<-- Parent already wants to shift so do not force it again. CHILD_FORCES_MY_SHIFT=.TRUE. !<-- Child N too close to parent boundary MY_FORCED_SHIFT(1)=SHIFT_INFO_CHILDREN(2,N) !<-- Parent must shift this many gridspaces in I MY_FORCED_SHIFT(2)=SHIFT_INFO_CHILDREN(3,N) !<-- Parent must shift this many gridspaces in J ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,74741)MY_FORCED_SHIFT,MY_DOMAIN_ID,NTIMESTEP 74741 FORMAT(' PARENTS_SEND my_forced_shift=',2(1X,I6),' my_domain_id=',I2,' ntimestep=',I5) ENDIF ! ENDIF ! ENDIF ! ENDIF ! pscd3_tim=pscd3_tim+(timef()-btim2) ! !----------------------------------------------------------------------- ! ENDIF check_block2 ! !----------------------------------------------------------------------- !*** If the parent is at the end of a timestep immediately preceding !*** a child's shift at the start of the next parent timestep then !*** it prepares appropriate internal and BC update data for the !*** child's new position. !----------------------------------------------------------------------- ! child_moves: IF(NTIMESTEP==NTIMESTEP_CHILD_MOVES(N)-1)THEN !<-- If true, moving child N will shift at the ! ! beginning of the next parent timestep. !----------------------------------------------------------------------- ! btim2=timef() ! I_PARENT_SW_OLD=I_PARENT_SW(N_MOVING) !<-- Save the previous location of the nest. J_PARENT_SW_OLD=J_PARENT_SW(N_MOVING) !<-- ! CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA(0) !<-- Local rank of child's lead task in p-c intracomm ! I_PARENT_SW(N_MOVING)=I_PARENT_SW_OLD+SHIFT_INFO_CHILDREN(2,N) !<-- Child N to move its SW corner to this parent I J_PARENT_SW(N_MOVING)=J_PARENT_SW_OLD+SHIFT_INFO_CHILDREN(3,N) !<-- Child N to move its SW corner to this parent J ! !----------------------------------------------------------------------- !*** If this child will shift at the start of the next parent timestep !*** then reset the working arrays/pointers used to generate values !*** interpolated from the parent to child's boundary immediately !*** after a move. This set of working objects is separate from the !*** standard ones used to interpolate boundary data for all nests !*** since when a nest moves we need to have the objects in place !*** for both the old location and the new until we know for certain !*** those for the old location have been received by the moving child. ! !*** Note that N_MOVING is the rank of the moving child among ALL of !*** children and NRES is the rank of the moving child's space ratio !*** in the list of unique space ratios for all moving children. !----------------------------------------------------------------------- ! NRES=LINK_MRANK_RATIO(N) !<-- Rank of space ratio value among the moving children ! CALL RESET_WORK_PARENT(N_MOVING,NRES,'Current',PARENT_MOVED) ! !----------------------------------------------------------------------- !*** The parent generates and sends new boundary data for the child's !*** new position that it will move to when it reaches this point in !*** time that the parent is at now. !----------------------------------------------------------------------- ! CALL COMPUTE_SEND_NEST_BC_DATA(N_MOVING,'Current') ! !----------------------------------------------------------------------- !*** Parent tasks determine the index limits of the regions on !*** moving nest N's task subdomains that they are responsible !*** for updating after the nest moves. Those index limits are !*** identical for H and V points. !----------------------------------------------------------------------- ! CHILD_TASK_LIMITS=>CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N_MOVING)) SPACE_RATIO=PARENT_CHILD_SPACE_RATIO(N_MOVING) ! N_UPDATE_CHILD_TASKS=0 pscd4_tim=pscd4_tim+(timef()-btim2) ! btim2=timef() CALL PARENT_BOOKKEEPING_MOVING(I_PARENT_SW(N_MOVING) & !<-- SW corner of nest is on this parent I after move ,J_PARENT_SW(N_MOVING) & !<-- SW corner of nest is on this parent J after move ,I_PARENT_SW_OLD & !<-- SW corner of nest is on this parent I before move ,J_PARENT_SW_OLD & !<-- SW corner of nest is on this parent J before move ,ITS,ITE,JTS,JTE & !<-- ITS,ITE,JTS,JTE for this parent task ,NUM_CHILD_TASKS & !<-- # of child forecast tasks ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task ,SPACE_RATIO & !<-- # of child grid increments in one of parent's ,NHALO & !<-- # of halo points ,NROWS_P_UPD_W & !<-- Moving nest footprint W bndry rows updated by parent ,NROWS_P_UPD_E & !<-- Moving nest footprint E bndry rows updated by parent ,NROWS_P_UPD_S & !<-- Moving nest footprint S bndry rows updated by parent ,NROWS_P_UPD_N & !<-- Moving nest footprint N bndry rows updated by parent ,N_UPDATE_CHILD_TASKS & !<-- # of moving nest tasks updated by this parent task ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & !<-- MPI handles for update data ISent to nest N's tasks ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for tasks on moving child N ) ! !----------------------------------------------------------------------- !*** When a parent needs to update data on some of its moving nests !*** and any of those nest points lie between ITE/JTE on one parent !*** task and ITS/JTS on an adjacent parent task then values from !*** the parent tasks' halo regions must be used. However some of !*** the variables that need updating are not computed in the halo !*** regions. That means that prior to proceeding with moving nest !*** updates the parent needs to do special halo exchanges for all !*** those variables required for moving nest updates but for which !*** halo exchanges were not performed during the normal integration. !*** Of course these parent tasks' halo exchanges need to be done !*** only once in a timestep in which any number of its nests move. !----------------------------------------------------------------------- ! IF(.NOT.EXCH_DONE)THEN ! CALL PARENT_UPDATES_HALOS('H' & ,MOVE_BUNDLE_H & ,NUM_FIELDS_MOVE_3D_H & ,NUM_FIELDS_MOVE_2D_H_R & ,nflds_2di=NUM_FIELDS_MOVE_2D_H_I) ! CALL PARENT_UPDATES_HALOS('V' & ,MOVE_BUNDLE_V & ,NUM_FIELDS_MOVE_3D_V & ,NUM_FIELDS_MOVE_2D_V ) ! EXCH_DONE=.TRUE. ! ENDIF ! parent_bookkeep_moving_tim=parent_bookkeep_moving_tim+(timef()-btim2) ! !----------------------------------------------------------------------- !*** While the index limits of each parent update region of each !*** moving nest are identical for H and V points the routine that !*** performs the updating will be called separately for H and V !*** points. That is because of the different physical locations !*** of H versus V points which must be accounted for when finding !*** the parent's four surrounding points for bilinear interpolations. !----------------------------------------------------------------------- ! btim2=timef() ! IF(N_UPDATE_CHILD_TASKS>0)THEN ! !----------------------------------------------------------------------- !*** First do the H point updates for moving nest N. !----------------------------------------------------------------------- ! NR=M_NEST_RATIO(N) !<-- Child's space ratio with uppermost parent. NTIMESTEP_CHILD=(NTIMESTEP+1) & !<-- The nest's timestep in which it will recv *TIME_RATIO_MY_CHILDREN(N_MOVING) ! parent shift data. ! CALL PARENT_UPDATES_MOVING('H' & ,N_UPDATE_CHILD_TASKS & ,SPACE_RATIO & ,TIME_RATIO_MY_CHILDREN(N_MOVING) & ,NTIMESTEP_CHILD & ,I_PARENT_SW(N_MOVING) & ,J_PARENT_SW(N_MOVING) & ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & ,DSG2,PDSG1 & ,FIS,PD & ,T & ,TRACERS(:,:,:,INDX_Q) & ,TRACERS(:,:,:,INDX_CW) & ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of forecast tasks on parent ,NUM_CHILD_TASKS & !<-- # of child forecast tasks ,child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Child task local ranks in p-c intracomm ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task ,HYPER_A & !<-- Underground extrapolation quantity ,IMS,IME,JMS,JME & !<-- Subdomain memory limits for parent tasks ,IDS,IDE,JDS,JDE & !<-- Full parent domain limits ,LM & ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND1 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND1 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND2 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND2 & ,NEST_FIS_ON_PARENT(NRES)%DATA & ,COMM_TO_MY_CHILDREN(N) & ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & ,MOVE_BUNDLE_H & ,NUM_FIELDS_MOVE_2D_H_I & ,NUM_FIELDS_MOVE_2D_X_I & ,NUM_FIELDS_MOVE_2D_H_R & ,NUM_FIELDS_MOVE_2D_X_R & ,NUM_FIELDS_MOVE_3D_H & ,NUM_LEVELS_MOVE_3D_H & ,NUM_FIELDS_MOVE_2D_V & ,NUM_FIELDS_MOVE_3D_V & ,NUM_LEVELS_MOVE_3D_V & ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for nest task N ) ! !----------------------------------------------------------------------- !*** Now the parent does the V point updates for moving nest N !*** and then sends all H and V update data to that nest. !----------------------------------------------------------------------- ! NR=M_NEST_RATIO(N) ! CALL PARENT_UPDATES_MOVING('V' & ,N_UPDATE_CHILD_TASKS & ,SPACE_RATIO & ,TIME_RATIO_MY_CHILDREN(N_MOVING) & ,NTIMESTEP_CHILD & ,I_PARENT_SW(N_MOVING) & ,J_PARENT_SW(N_MOVING) & ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & ,DSG2,PDSG1 & ,FIS,PD & ,T & ,TRACERS(:,:,:,INDX_Q) & ,TRACERS(:,:,:,INDX_CW) & ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of forecast tasks on parent ,NUM_CHILD_TASKS & !<-- # of child forecast tasks ,child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Child task local ranks in p-c intracomm ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task ,HYPER_A & !<-- Underground extrapolation quantity ,IMS,IME,JMS,JME & !<-- Subdomain memory limits for parent tasks ,IDS,IDE,JDS,JDE & !<-- Full parent domain limits ,LM & ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND1 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND1 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND2 & ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND2 & ,NEST_FIS_V_ON_PARENT(NRES)%DATA & ,COMM_TO_MY_CHILDREN(N) & ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & ,MOVE_BUNDLE_V & ,NUM_FIELDS_MOVE_2D_H_I & ,NUM_FIELDS_MOVE_2D_X_I & ,NUM_FIELDS_MOVE_2D_H_R & ,NUM_FIELDS_MOVE_2D_X_R & ,NUM_FIELDS_MOVE_3D_H & ,NUM_LEVELS_MOVE_3D_H & ,NUM_FIELDS_MOVE_2D_V & ,NUM_FIELDS_MOVE_3D_V & ,NUM_LEVELS_MOVE_3D_V & ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for nest task N ) ENDIF ! parent_update_moving_tim=parent_update_moving_tim & +(timef()-btim2) ! !----------------------------------------------------------------------- !*** If the child has executed its final shift before stopping due to !*** its having reached the specified latitude limit then the parent !*** sets its own flag to stop incorporating 2-way data from this !*** child. !----------------------------------------------------------------------- ! IF(SHIFT_INFO_CHILDREN(4,N)==-22222)THEN !<-- Child motion has stopped so skip 2-way updates. IF(NUM_2WAY_CHILDREN>0)THEN SKIP_2WAY_UPDATE(N_MOVING)=.TRUE. ENDIF ! IF(I_AM_LEAD_FCST_TASK)THEN WRITE(0,70110)N 70110 FORMAT(' Parent knows its moving child #',I2,' is now frozen.') ENDIF ENDIF ! !----------------------------------------------------------------------- ! ENDIF child_moves ! !----------------------------------------------------------------------- ! ENDDO child_loop_2 ! !----------------------------------------------------------------------- ! ENDIF moving_children ! btim2=timef() ! !----------------------------------------------------------------------- !*** The values of the moving children's next move timesteps need !*** to be updated in the Solver's internal state so they can be !*** written to the restart file. Dummy values are set for static !*** children. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert the Children's Next Move Timesteps into Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The parent-child coupler export state ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name of the attribute to insert ,itemCount=NUM_DOMAINS_MAX & !<-- # of words in array ,valueList=NTIMESTEP_CHILD_MOVES & !<-- The next timestep the moving children move ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Insert clocktimes into the coupler's export state that are related !*** to this phase. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Clocktime for Comp in Phase2 into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='Cpl2_Comp_Time' & !<-- Name of the attribute to insert ,value=cpl2_comp_tim & !<-- Phase 2 Compute time ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Clocktime for Wait in Phase2 into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='Cpl2_Wait_Time' & !<-- Name of the attribute to insert ,value=cpl2_wait_tim & !<-- Phase 2 Wait time ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Clocktime for Send in Phase2 into Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='Cpl2_Send_Time' & !<-- Name of the attribute to insert ,value=cpl2_send_tim & !<-- Phase 2 Send time ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='parent_bookkeep_moving_tim' & !<-- Name of the attribute to insert ,value=parent_bookkeep_moving_tim & !<-- moving nest bookeeping time ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='parent_update_moving_tim' & !<-- Name of the attribute to insert ,value=parent_update_moving_tim & !<-- moving nest update time ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='t0_recv_move_tim' & !<-- Name of the attribute to insert ,value=t0_recv_move_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='read_moving_child_topo_tim' & !<-- Name of the attribute to insert ,value=read_moving_child_topo_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='barrier_move_tim' & !<-- Name of the attribute to insert ,value=barrier_move_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='pscd_tim' & !<-- Name of the attribute to insert ,value=pscd_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='pscd1_tim' & !<-- Name of the attribute to insert ,value=pscd1_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='pscd2_tim' & !<-- Name of the attribute to insert ,value=pscd2_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='pscd3_tim' & !<-- Name of the attribute to insert ,value=pscd3_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='pscd4_tim' & !<-- Name of the attribute to insert ,value=pscd4_tim & !<-- task 0 time to process receive of move flag ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! pscd_tim=pscd_tim+(timef()-btim0) ! !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- ! SUBROUTINE RESET_WORK_PARENT(N_CHILD,N_RATIO & ,TIME_FLAG,PARENT_MOVED) ! !----------------------------------------------------------------------- !*** A parent resets its working pointers/arrays that depend on a !*** moving child's location to get ready to generate values on !*** that child's boundary. This routine is not called for static !*** nests since there is nothing to reset for them. !*** This is an internal subroutine to PARENTS_SEND_CHILD_DATA. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- Rank of nest in list of ALL children ,N_RATIO !<-- Rank of space ratio value among the moving children ! CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- Child to recv data from its present or future ! LOGICAL(kind=KLOG),INTENT(IN) :: PARENT_MOVED !<-- Did this parent just shift its own domain? ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: IERR,INDX,N,NR,NT,NTAG,NUM_CHILD_TASKS ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** If this child wants to move then deallocate parent working !*** arrays/pointers whose dimensions are functions of moving nests' !*** positions. They will be reallocated with dimensions appropriate !*** for the new positions. (For static nests these parent arrays !*** are used over and over and are not deallocated/reallocated.) !*** If this is the first time we have reached this point though !*** then nothing has been allocated yet so skip the deallocation. !*** Note however that if this parent can move then it must call !*** this routine when it shifts since that will also mean that !*** its children's positions have changed with respect to the !*** parent's grid. !----------------------------------------------------------------------- ! INDX=1 IF(TIME_FLAG=='Current')INDX=2 ! CALL DEALLOC_WORK_PARENTS(N_CHILD,TIME_FLAG) ! !----------------------------------------------------------------------- !*** We now compute various indices and weights needed by the parents !*** to compute boundary data for their children. It is here that !*** location-dependent interpolation information is determined !*** regarding the parent and nests. Parents need to call these !*** routines only for children who have moved because this work was !*** done once and for all for static nests in the coupler's Init !*** step. !----------------------------------------------------------------------- ! CALL PREPARE_NEST_INTERP_FACTORS(N_CHILD,MY_DOMAIN_ID) ! CALL POINT_INTERP_DATA_TO_MEMORY(N_CHILD,MY_DOMAIN_ID,TIME_FLAG) ! !----------------------------------------------------------------------- !*** The parent determines the new association between its tasks !*** and those of its moving child's then sends the information !*** to that child so the child will know exactly how to receive !*** the new internal and boundary data from its parent when the !*** child arrives at this point in time and executes its move. !*** This only needs to be done when the nest has just moved, i.e., !*** when the time flag has switched to 'Current'. When it goes !*** back to 'Future' we do not need to send the information again !*** since the nest has not moved again and thus the associations !*** remain the same. !----------------------------------------------------------------------- ! IF(TIME_FLAG=='Current'.OR.PARENT_MOVED)THEN ! CALL PARENT_SENDS_CHILD_DATA_LIMITS(N_CHILD,MY_DOMAIN_ID,TIME_FLAG) ! ENDIF ! !----------------------------------------------------------------------- !*** The parent determines the child's boundary topography at the !*** new location after the child moves. This is needed to maintain !*** hydrostatic balance when parent data is interpolated to child !*** boundaries where the terrain is different. !----------------------------------------------------------------------- ! NR=N_RATIO ! CALL PARENT_COMPUTES_CHILD_TOPO(N_CHILD & ,I_PARENT_SW(N_CHILD) & ,J_PARENT_SW(N_CHILD) & ,IM_CHILD(N_CHILD) & ,JM_CHILD(N_CHILD) & ,N_BLEND_H_CHILD(N_CHILD) & ,NEST_FIS_ON_PARENT_BNDS(NR)%LBND1 & ,NEST_FIS_ON_PARENT_BNDS(NR)%UBND1 & ,NEST_FIS_ON_PARENT_BNDS(NR)%LBND2 & ,NEST_FIS_ON_PARENT_BNDS(NR)%UBND2 & ,NEST_FIS_ON_PARENT(NR)%DATA & ) ! !----------------------------------------------------------------------- ! END SUBROUTINE RESET_WORK_PARENT ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE COMPUTE_SEND_NEST_BC_DATA(N_CHILD,TIME_FLAG) ! !----------------------------------------------------------------------- !*** A parent generates and sends boundary data to a child. !*** This is an internal subroutine to PARENTS_SEND_CHILD_DATA. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD !<-- Compute/send this child's boundary conditions ! CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- Child to recv data from its present or future ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: CHILDTASK,H_OR_V_INT,I,ID_ADD,IERR,INDX2,J & ,KOUNT_H,KOUNT_V & ,LB1,LB2,LB_4D & ,N,N4,NRANK,NT,NTAG & ,NUM_CHILD_TASKS,NUM_DIMS,NUM_LEVS,NV & ,UB1,UB2,UB_4D ! INTEGER(kind=KINT) :: ISTAT ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) :: PD_V ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_R2D ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_R3D & ,VBL_ARRAY ! REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: ARRAY_R4D ! CHARACTER(len=99) :: FIELD_NAME ! TYPE(ESMF_Field) :: HOLD_FIELD ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N=N_CHILD !<-- The Nth child of this parent. ! !----------------------------------------------------------------------- !*** Select the appropriate part of the working array depending on !*** whether we are now concerned with children's boundaries for !*** their current time or from their future. !----------------------------------------------------------------------- ! IF(TIME_FLAG=='Future')THEN INDX2=1 ELSEIF(TIME_FLAG=='Current')THEN INDX2=2 ENDIF ! KOUNT_H=0 KOUNT_V=0 ! !----------------------------------------------------------------------- !*** Before parents can generate new boundary data for their children !*** we must check to be sure the previous set of ISend's from the !*** parent tasks to the children's boundary tasks have completed. !----------------------------------------------------------------------- ! btim=timef() ! !------------- !*** South H !------------- ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has Sbndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_S(N) CALL MPI_WAIT(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------- !*** South V !------------- ! IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has Sbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_S(N) CALL MPI_WAIT(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------- !*** North H !------------- ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has Nbndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_N(N) CALL MPI_WAIT(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------- !*** North V !------------- ! IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has Nbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_N(N) CALL MPI_WAIT(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------ !*** West H !------------ ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has Wbndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_W(N) CALL MPI_WAIT(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------ !*** West V !------------ ! IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has Wbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_W(N) CALL MPI_WAIT(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------ !*** East H !------------ ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has Ebndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_E(N) CALL MPI_WAIT(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! !------------ !*** East V !------------ ! IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has Ebndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_E(N) CALL MPI_WAIT(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! cpl2_wait_tim=cpl2_wait_tim+(timef()-btim) ! !----------------------------------------------------------------------- !*** The parents can now compute the new surface pressure on the !*** nests' boundary points (overwriting the previous values). !*** This must be done for both H points and V points. Only the !*** H point pressure is actually sent to the nest boundaries. !*** The V point pressures are only used for proper vertical !*** interpolation of V point boundary variables. !----------------------------------------------------------------------- ! NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) ! !-------------------- !*** PD on H points !-------------------- ! btim=timef() CALL PARENT_UPDATE_CHILD_PSFC(FIS,PD,T,Q & !<-- Native parent values ,PT,PDTOP & !<-- Domain PT and PDTOP ,SG1,SG2 & !<-- General vertical structure (shared by all domains) ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions ,LM & !<-- # of model layers ! ,NUM_CHILD_TASKS & !<-- # of fcst tasks on child N ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Integration limits on each task of child N ! ,FIS_CHILD_SOUTH(N)%TASKS & !<-- Sfc geopotential on Sbndry points on child tasks ,FIS_CHILD_NORTH(N)%TASKS & !<-- Sfc geopotential on Nbndry points on child tasks ,FIS_CHILD_WEST(N)%TASKS & !<-- Sfc geopotential on Wbndry points on child tasks ,FIS_CHILD_EAST(N)%TASKS & !<-- Sfc geopotential on Ebndry points on child tasks ! ,NUM_TASKS_SEND_H_S(N) & !<-- # of child tasks with south boundary segments ,NUM_TASKS_SEND_H_N(N) & !<-- # of child tasks with north boundary segments ,NUM_TASKS_SEND_H_W(N) & !<-- # of child tasks with west boundary segments ,NUM_TASKS_SEND_H_E(N) & !<-- # of child tasks with east boundary segments ! ,PARENT_4_INDICES_H(N)%I_INDX_SBND & !<-- Parent I's west and east of each child Sbndry point ,PARENT_4_INDICES_H(N)%I_INDX_NBND & !<-- Parent I's west and east of each child Nbndry point ,PARENT_4_INDICES_H(N)%I_INDX_WBND & !<-- Parent I's west and east of each child Wbndry point ,PARENT_4_INDICES_H(N)%I_INDX_EBND & !<-- Parent I's west and east of each child Ebndry point ,PARENT_4_INDICES_H(N)%J_INDX_SBND & !<-- Parent J's south and north of each child Sbndry point ,PARENT_4_INDICES_H(N)%J_INDX_NBND & !<-- Parent J's south and north of each child Nbndry point ,PARENT_4_INDICES_H(N)%J_INDX_WBND & !<-- Parent J's south and north of each child Wbndry point ,PARENT_4_INDICES_H(N)%J_INDX_EBND & !<-- Parent J's south and north of each child Ebndry point ! ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Ending I on each south boundary child task ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Ending I on each north boundary child task ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Ending J on each west boundary child task ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Ending J on each east boundary child task ! ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & ! points surrounding each child bndry point ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & ! on each side of the child boundary. ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND & ! ! ,N_BLEND_H_CHILD(N) & !<-- Width of boundary blending region for mass points ,IM_CHILD(N) & !<-- East-west points on child domain ,JM_CHILD(N) & !<-- North-south points on child domain ! ^ ! | ! Input ! -------------- ! Output ! | ! v ,CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS & !<-- 1-D H-pt Sbndry datastring to be sent by parent to child ,CHILD_BOUND_H_NORTH(N,INDX2)%TASKS & !<-- 1-D H-pt Nbndry datastring to be sent by parent to child ,CHILD_BOUND_H_WEST(N,INDX2)%TASKS & !<-- 1-D H-pt Wbndry datastring to be sent by parent to child ,CHILD_BOUND_H_EAST(N,INDX2)%TASKS & !<-- 1-D H-pt Ebndry datastring to be sent by parent to child ! ,PD_B_SOUTH(N)%TASKS & !<-- Updated sigma domain pressure (Pa) on nest bndry points ,PD_B_NORTH(N)%TASKS & ! for all four sides of nest N's boundary. ,PD_B_WEST(N)%TASKS & ! ,PD_B_EAST(N)%TASKS ) !<-- ! !----------------------------------------------------------------------- ! !-------------------- !*** PD on V points !-------------------- ! CALL PRESSURE_ON_NEST_BNDRY_V(PD & !<-- Sigma domain pressure (Pa) on parent mass points ,IMS,IME,JMS,JME & !<-- Memory dimensions of PD ! ,PD_B_SOUTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry mass points ,PD_B_NORTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry mass points ,PD_B_WEST (N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry mass points ,PD_B_EAST (N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry mass points ! ,NUM_TASKS_SEND_V_S(N) & !<-- # of child tasks with south boundary segments on V ,NUM_TASKS_SEND_V_N(N) & !<-- # of child tasks with north boundary segments on V ,NUM_TASKS_SEND_V_W(N) & !<-- # of child tasks with west boundary segments on V ,NUM_TASKS_SEND_V_E(N) & !<-- # of child tasks with east boundary segments on V ! ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south V boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south V boundary child task ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north V boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north V boundary child task ,CHILDTASK_V_SAVE(N)%J_LO_WEST & !<-- Starting J on each west V boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_WEST & !<-- Ending J on each west V boundary child task ,CHILDTASK_V_SAVE(N)%J_LO_EAST & !<-- Starting J on each east V boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_EAST & !<-- Ending J on each east V boundary child task ! ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south H boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south H boundary child task ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north H boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north H boundary child task ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west H boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west H boundary child task ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east H boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east H boundary child task ! ,N_BLEND_H_CHILD(N) & !<-- H rows in nests' boundary regions ,N_BLEND_V_CHILD(N) & !<-- V rows in nests' boundary regions ,IM_CHILD(N) & !<-- East-west points on child domain ,JM_CHILD(N) & !<-- North-south points on child domain ! ,INC_FIX(N) & !<-- Increment used to select nest tasks for averaging H to V ! ^ ! | ! Input ! -------------- ! Output ! | ! v ,PD_V & !<-- Sigma domain pressure (Pa) on parent V points ,PD_B_SOUTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry V points ,PD_B_NORTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry V points ,PD_B_WEST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry V points ,PD_B_EAST_V(N)%TASKS ) !<-- Sigma domain pressure (Pa) on nest Ebndry V points ! !----------------------------------------------------------------------- !*** Now loop through the Solver internal state variables that the !*** user has specified for the nest boundary conditions. The 2-D !*** PD array was already taken care of. For the remaining variables !*** find the number of dimensions and see whether they are on H or !*** V points. !----------------------------------------------------------------------- ! vars_bc: DO NV=1,NVARS_NESTBC !<-- Loop over all nest BC variables updated by the parent. ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Field from the Bundle of Nest BC Vars" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- Bundle holding the arrays of nest BC update variables ,fieldIndex =NV & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field NV in the Bundle ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Name of this Nest BC Variable" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field NV in the Bundle ,name =FIELD_NAME & !<-- This Field's name ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Is this an H-pt or a V-pt Variable?" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field ,name ='H_OR_V_INT' & !<-- Name of the attribute to extract ,value=H_OR_V_INT & !<-- Value of the Attribute ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(TRIM(FIELD_NAME)=='PD-nestbc')THEN ! CYCLE vars_bc !<-- PD was already taken care of. ! ENDIF ! !----------------------------------------------------------------------- !*** Get the desired boundary variable array from the Field and !*** see whether it is on H or V points. !----------------------------------------------------------------------- ! !--------- !*** 2-D !--------- ! IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Nest BC Real 2-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=ARRAY_R2D & !<-- Use this 2-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NUM_LEVS=1 !<-- # of vertical levels for this variable. LB_4D=1 UB_4D=1 ! LB1=LBOUND(ARRAY_R2D,1) UB1=UBOUND(ARRAY_R2D,1) LB2=LBOUND(ARRAY_R2D,2) UB2=UBOUND(ARRAY_R2D,2) ALLOCATE(VBL_ARRAY(LB1:UB1,LB2:UB2,1),stat=ISTAT) !<-- Use only 3-D arrays in PARENT_UPDATE_CHILD_BNDRY below. IF(ISTAT/=0)THEN WRITE(0,20001)ISTAT 20001 FORMAT(' Failed to allocate VBL_ARRAY for 2-D variable stat=',i4) WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! DO J=LB2,UB2 DO I=LB1,UB1 VBL_ARRAY(I,J,1)=ARRAY_R2D(I,J) !<-- Fill the 3-D array with the 2-D boundary variable. ENDDO ENDDO ! !--------- !*** 3-D !--------- ! ELSEIF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Nest BC Real 3-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=VBL_ARRAY & !<-- Use this 3-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NUM_LEVS=SIZE(VBL_ARRAY,3) !<-- # of vertical levels for this 3-D boundary variable. LB_4D=1 UB_4D=1 ! !--------- !*** 4-D !--------- ! ELSEIF(NUM_DIMS==4)THEN !<-- Possible only for H-pt boundary variables ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Nest BC Real 4-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=ARRAY_R4D & !<-- Use this 4-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! LB_4D=LBOUND(ARRAY_R4D,4) UB_4D=UBOUND(ARRAY_R4D,4) ! ENDIF ! !----------------------------------------------------------------------- !*** The parent computes the new values of the specified H-pt !*** variables in the columns above the nest boundary points. !----------------------------------------------------------------------- ! IF(H_OR_V_INT==1)THEN !<-- Value of 1 implies an H-point variable ! KOUNT_H=KOUNT_H+1 !<-- Count the H-pt boundary variables (excluding PD) ! loop_4d: DO N4=LB_4D,UB_4D !<-- Loop through 3-D sub-variables of 4-D variables, if any. ! IF(NUM_DIMS==4)THEN VBL_ARRAY=>ARRAY_R4D(:,:,:,N4) !<-- Point at the current 3-D array in the 4-D variable. NUM_LEVS=SIZE(VBL_ARRAY,3) !<-- # of vertical levels for this 3-D sub-variable. ENDIF ! CALL PARENT_UPDATE_CHILD_BNDRY(VBL_ARRAY & !<-- Parent variable to interpolate to nest boundary ,TRIM(FIELD_NAME) & !<-- Name of the variable ! ,PD,PT,PDTOP & !<-- Parent PD; domain PT and PDTOP ,PSGML1,SGML2,SG1,SG2 & !<-- General vertical structure (shared by all domains) ! ,PD_B_SOUTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry points ,PD_B_NORTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry points ,PD_B_WEST(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry points ,PD_B_EAST(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry points ! ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions ,NUM_LEVS & !<-- # of model layers in the given H-pt boundary variable ,0 & !<-- # of rows to ignore on north/east nest boundaries ! ,NUM_TASKS_SEND_H_S(N) & !<-- # of child tasks with south boundary segments ,NUM_TASKS_SEND_H_N(N) & !<-- # of child tasks with north boundary segments ,NUM_TASKS_SEND_H_W(N) & !<-- # of child tasks with west boundary segments ,NUM_TASKS_SEND_H_E(N) & !<-- # of child tasks with east boundary segments ! ,PARENT_4_INDICES_H(N)%I_INDX_SBND & !<-- Parent I's west and east of each child S bndry point ,PARENT_4_INDICES_H(N)%I_INDX_NBND & !<-- Parent I's west and east of each child N bndry point ,PARENT_4_INDICES_H(N)%I_INDX_WBND & !<-- Parent I's west and east of each child W bndry point ,PARENT_4_INDICES_H(N)%I_INDX_EBND & !<-- Parent I's west and east of each child E bndry point ,PARENT_4_INDICES_H(N)%J_INDX_SBND & !<-- Parent J's south and north of each child S bndry point ,PARENT_4_INDICES_H(N)%J_INDX_NBND & !<-- Parent J's south and north of each child N bndry point ,PARENT_4_INDICES_H(N)%J_INDX_WBND & !<-- Parent J's south and north of each child W bndry point ,PARENT_4_INDICES_H(N)%J_INDX_EBND & !<-- Parent J's south and north of each child E bndry point ! ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Ending I for transfer to child on each Sbndry child task ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task ,CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Ending I for transfer to child on each Nbndry child task ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Ending J for transfer to child on each Wbndry child task ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task ,CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Ending J for transfer to child on each Ebndry child task ! ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & ! points surrounding each child bndry point. ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & ! ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND & !<-- ! ,N_BLEND_H_CHILD(N) & !<-- Width of boundary blending region ,IM_CHILD(N) & !<-- East-west points on child domain ,JM_CHILD(N) & !<-- North-south points on child domain ! ^ ! | ! Input ! -------------- ! Output ! | ! v ,BND_VAR_H_SOUTH(KOUNT_H)%CHILD(N)%TASKS & !<-- ,BND_VAR_H_NORTH(KOUNT_H)%CHILD(N)%TASKS & ! Updated H-point variable on the four sides ,BND_VAR_H_WEST(KOUNT_H)%CHILD(N)%TASKS & ! of the nest domain boundary. ,BND_VAR_H_EAST(KOUNT_H)%CHILD(N)%TASKS & !<-- ) ! ENDDO loop_4d ! !----------------------------------------------------------------------- !*** The parent computes the new values of the specified velocity !*** variables in the columns above the nest boundary points. !----------------------------------------------------------------------- ! ! ELSEIF(H_OR_V_INT==2)THEN !<-- Value of 2 implies a V-point variable ! KOUNT_V=KOUNT_V+1 !<-- Count the V-pt boundary variables. ! CALL PARENT_UPDATE_CHILD_BNDRY(VBL_ARRAY & !<-- Parent variable to interpolate to nest boundary ,TRIM(FIELD_NAME) & !<-- Name of the variable ! ,PD_V,PT,PDTOP & !<-- Parent PD on V; domain PT and PDTOP ,PSGML1,SGML2,SG1,SG2 & !<-- General vertical structure (shared by all domains) ! ,PD_B_SOUTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry points ,PD_B_NORTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry points ,PD_B_WEST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry points ,PD_B_EAST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry points ! ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions ,NUM_LEVS & !<-- # of model layers ,1 & !<-- # of rows to ignore on north/east nest boundaries ! ,NUM_TASKS_SEND_V_S(N) & !<-- # of child tasks with south boundary segments ,NUM_TASKS_SEND_V_N(N) & !<-- # of child tasks with north boundary segments ,NUM_TASKS_SEND_V_W(N) & !<-- # of child tasks with west boundary segments ,NUM_TASKS_SEND_V_E(N) & !<-- # of child tasks with east boundary segments ! ,PARENT_4_INDICES_V(N)%I_INDX_SBND & !<-- Parent I's west and east of each child S bndry point ,PARENT_4_INDICES_V(N)%I_INDX_NBND & !<-- Parent I's west and east of each child N bndry point ,PARENT_4_INDICES_V(N)%I_INDX_WBND & !<-- Parent I's west and east of each child W bndry point ,PARENT_4_INDICES_V(N)%I_INDX_EBND & !<-- Parent I's west and east of each child E bndry point ,PARENT_4_INDICES_V(N)%J_INDX_SBND & !<-- Parent J's south and north of each child S bndry point ,PARENT_4_INDICES_V(N)%J_INDX_NBND & !<-- Parent J's south and north of each child N bndry point ,PARENT_4_INDICES_V(N)%J_INDX_WBND & !<-- Parent J's south and north of each child W bndry point ,PARENT_4_INDICES_V(N)%J_INDX_EBND & !<-- Parent J's south and north of each child E bndry point ! ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Not relevant for V points ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task ,CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Not relevant for V points ,CHILDTASK_V_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Not relevant for V points ,CHILDTASK_V_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task ,CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Not relevant for V points ! ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND & ! points surrounding each child bndry point. ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND & ! ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND & !<-- ! ,N_BLEND_V_CHILD(N) & !<-- Width of boundary blending region ,IM_CHILD(N) & !<-- East-west points on child domain ,JM_CHILD(N) & !<-- North-south points on child domain ! ^ ! | ! Input ! -------------- ! Output ! | ! v ,BND_VAR_V_SOUTH(KOUNT_V)%CHILD(N)%TASKS & !<-- ,BND_VAR_V_NORTH(KOUNT_V)%CHILD(N)%TASKS & ! Updated V-point variable on the four sides ,BND_VAR_V_WEST(KOUNT_V)%CHILD(N)%TASKS & ! of the nest domain boundary. ,BND_VAR_V_EAST(KOUNT_V)%CHILD(N)%TASKS & !<-- ) ! ENDIF ! IF(NUM_DIMS==2.AND.ASSOCIATED(VBL_ARRAY))THEN DEALLOCATE(VBL_ARRAY,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,20002)ISTAT 20002 FORMAT(' Failed to deallocate VBL_ARRAY stat=',i4) WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! !----------------------------------------------------------------------- ! ENDDO vars_bc ! cpl2_comp_tim=cpl2_comp_tim+(timef()-btim) ! !----------------------------------------------------------------------- !*** Parent tasks send data directly to those child tasks whose !*** boundary points the parent tasks contain. !----------------------------------------------------------------------- ! IF(TIME_FLAG=='Current')THEN NSTEP_CHILD_RECV(N)=(NTIMESTEP+1)*TIME_RATIO_MY_CHILDREN(N) !<-- Child "N" is waiting at this timestep to recv its data ELSEIF(TIME_FLAG=='Future')THEN NSTEP_CHILD_RECV(N)=NTIMESTEP*TIME_RATIO_MY_CHILDREN(N) !<-- Child "N" is waiting at this timestep to recv its data ENDIF ! ID_ADD=1000*MY_CHILDREN_ID(N) ! !------------- !*** South H !------------- ! NTAG=NSTEP_CHILD_RECV(N)+101+ID_ADD !<-- Add 101 and child's domain ID to obtain a unique South H tag ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has Sbndry H data to send to child tasks? ! DO NT=1,NUM_TASKS_SEND_H_S(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! ! call date_and_time(values=values) ! write(0,221)n,nt,childtask,values(5),values(6),values(7),values(8) 221 format(' Ready to send South_H to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! ! write(0,22011)n,nt,childtask_bndry_h_ranks(n)%south(nt,1),childtask,ntag ! write(0,22012)nstep_child_recv(n),id_add,my_children_id(n) 22011 format(' ready to send South_H to child #',i2,' task #',i3,' count=',i3,' rank=',i3,' tag=',i5) 22012 format(' nstep_child_recv(n)=',i5,' id_add=',i5,' my_children_id(n)=',i2) btim=timef() CALL MPI_ISSEND(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child south boundary H data on child task NT ,WORDS_BOUND_H_SOUTH(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator ,HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! write(0,22013)n,nt,childtask_bndry_h_ranks(n)%south(nt,1),nrank,childtask ! write(0,22014)words_bound_h_south(n)%tasks(nt),ntag,comm_to_my_children(n) ! write(0,22015)indx2,handle_h_south(n,indx2)%ntasks_to_recv(nt) 22013 format(' isent South_H to child #',i2,' task #',i3,' count=',i3,' nrank=',i3,' rank=',i3) 22014 format(' # of words=',i5,' ntag=',i5,' comm=',i12) 22015 format(' indx2=',i3,' handle_h_south(n,indx2)%ntasks_to_recv(nt)=',i12) ! ! call date_and_time(values=values) ! write(0,124)n,nt,childtask,values(5),values(6),values(7),values(8) 124 format(' Sent South_H to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! ENDDO ! ENDIF ! !------------- !*** South V !------------- ! NTAG=NSTEP_CHILD_RECV(N)+102+ID_ADD !<-- Add 102 and child's domain ID to obtain a unique South V tag ! IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has Sbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_S(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! ! call date_and_time(values=values) ! write(0,125)n,nt,childtask,values(5),values(6),values(7),values(8) ! 125 format(' Ready to send South_V to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child south boundary V data on child task NT ,WORDS_BOUND_V_SOUTH(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ! call date_and_time(values=values) ! write(0,126)n,nt,childtask,values(5),values(6),values(7),values(8) 126 format(' Sent South_V to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) ! ENDDO ENDIF ! !------------- !*** North H !------------- ! NTAG=NSTEP_CHILD_RECV(N)+103+ID_ADD !<-- Add 103 and child's domain ID to obtain a unique North H tag ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has Nbndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_N(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child north boundary H data on child task NT ,WORDS_BOUND_H_NORTH(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !------------- !*** North V !------------- ! NTAG=NSTEP_CHILD_RECV(N)+104+ID_ADD !<-- Add 104 and child's domain ID to obtain a unique North V tag ! IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has Nbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_N(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_V_RANKS(N)%NORTH(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child north boundary V data on child task NT ,WORDS_BOUND_V_NORTH(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !------------ !*** West H !------------ ! NTAG=NSTEP_CHILD_RECV(N)+105+ID_ADD !<-- Add 105 and child's domain ID to obtain a unique West H tag ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has Wbndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_W(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA & !<-- Child west boundary H data on child task NT ,WORDS_BOUND_H_WEST(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !------------ !*** West V !------------ ! NTAG=NSTEP_CHILD_RECV(N)+106+ID_ADD !<-- Add 106 and child's domain ID to obtain a unique West V tag ! IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has Wbndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_W(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_V_RANKS(N)%WEST(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA & !<-- Child west boundary V data on child task NT ,WORDS_BOUND_V_WEST(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !------------ !*** East H !------------ ! NTAG=NSTEP_CHILD_RECV(N)+107+ID_ADD !<-- Add 107 and child's domain ID to obtain a unique East H tag ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has Ebndry H data to send to child tasks? DO NT=1,NUM_TASKS_SEND_H_E(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA & !<-- Child east boundary H data on child task NT ,WORDS_BOUND_H_EAST(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !------------ !*** East V !------------ ! NTAG=NSTEP_CHILD_RECV(N)+108+ID_ADD !<-- Add 108 and child's domain ID to obtain a unique East V tag ! IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has Ebndry V data to send to child tasks? DO NT=1,NUM_TASKS_SEND_V_E(N) !<-- Send to all appropriate child tasks NRANK=CHILDTASK_BNDRY_V_RANKS(N)%EAST(NT,1) !<-- Child task count in its list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm ! btim=timef() CALL MPI_ISSEND(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA & !<-- Child east boundary V data on child task NT ,WORDS_BOUND_V_EAST(N)%TASKS(NT) & !<-- # of words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local rank of child to recv data ,NTAG & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator ,HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT ,IERR ) cpl2_send_tim=cpl2_send_tim+(timef()-btim) ! ENDDO ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE COMPUTE_SEND_NEST_BC_DATA ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! END SUBROUTINE PARENTS_SEND_CHILD_DATA ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE PARENTS_RECV_CHILD_2WAY_DATA(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** When 2-way nesting is being used the parents will receive !*** internal update data from each of their children at the !*** start of every parent timestep. !*** Only parents execute this routine that is called as phase 3 !*** of the Run step of the Parent-Child coupler in subroutine !*** NMM_INTEGRATE. ! !*** IMPORTANT: The indices of the parent H points and V points !*** that are updated by the children are identical. !*** A signficant generalization will be needed if !*** that ever changes. !----------------------------------------------------------------------- ! IMPLICIT NONE ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The NMM Clock for this parent domain ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG & ,CHILDTASK,CHILDTASK_0,COMM_FCST_TASKS & ,ID_CHILD,L1,L2,MY_DOMAIN_ID,MYPE_LOCAL & ,N,N_ALL,NCHILD_TASKS,NL,NM,NMX,NPTS2 & ,NPTS_UPDATE_HORIZ,NPTS_UPDATE_TOTAL & ,NT,NTIMESTEP,NTIMESTEP_CHILD,NUM_DIMS,NV & ,PARENT_TAG,SFC_TAG,TASK_ID,UPDATE_TAG ! INTEGER(kind=KINT) :: I_2WAY_UPDATE_START,I_2WAY_UPDATE_END & ,J_2WAY_UPDATE_START,J_2WAY_UPDATE_END ! INTEGER(kind=KINT) :: I_PARENT_SW_X,J_PARENT_SW_X ! INTEGER(kind=KINT) :: IERR,RC ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! INTEGER,DIMENSION(:,:),POINTER :: CHILD_TASK_LIMITS ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: VAR_2WAY ! REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: CHILD_SFC_ON_PARENT_GRID ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VAR_PARENT_2D REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VAR_PARENT_3D,VAR_3D REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: VAR_PARENT_4D ! LOGICAL(kind=KLOG),SAVE :: ALLCLEAR_SIGNAL=.TRUE. ! ! LOGICAL(kind=KLOG) :: INTEGRATE_TIMESTEP & ! ,READY_TO_RECV & LOGICAL(kind=KLOG) :: READY_TO_RECV & ,TWOWAY_SIGNAL_IS_PRESENT ! LOGICAL(kind=KLOG) :: ALLCLEAR_FROM_MY_PARENT ! CHARACTER(len=99) :: FIELD_NAME ! TYPE(CHILD_UPDATE_LINK),POINTER :: PTR ! TYPE(COMPOSITE),POINTER :: CC ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! integer(kind=kint),dimension(8) :: values integer(kind=kint) :: mype_intra ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA:Extract Fcst Task Intracom" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_LOCAL,IERR) !<-- Local task rank in this domain's fcst tasks ! !----------------------- !*** Current Domain ID !----------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Point to the correct part of the composite object which will !*** align working variables with values associated with this domain. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite ! !----------------------------------------------------------------------- !*** Get the current timestep. !----------------------------------------------------------------------- ! CALL ESMF_CLOCKGET(CLOCK =CLOCK & !<-- The ESMF Clock ,advanceCount=NTIMESTEP_ESMF & !<-- The parent's current timestep (ESMF) ,rc =rc) ! NTIMESTEP=NTIMESTEP_ESMF !<-- The current parent timestep ! !----------------------------------------------------------------------- !*** At this point all the children's 2-way data is ready to be !*** received. There is one more issue that must be considered. !*** If any of the 2-way children has just shifted then the points !*** updated by such children have just changed so bookkeeping must !*** first be done so the parent knows the correct points to have !*** updated. If this parent has just moved in this timestep then !*** it must do the bookkeeping for all its children (currently a !*** domain that moves can have only moving children and not static !*** ones) to know which of its points will be updated. !*** Below is a diagram illustrating the relationship between a child's !*** move and the parent's need to execute 2-way bookkeeping after that !*** child's move. In this instance the parent was informed by the !*** child that the child would move at the start of the child's !*** timestep 24 (parent timestep 8) therefore the parent must prepare !*** and deposit move data at the end of its timestep 7. (The parent- !*** child timestep ratio is 3.) The parent first recvs 2-way update !*** data from the child's new position at the beginning of parent !*** timestep 9. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ! ---------------------------------- ! Parent-child timestep ratio is 3 ! ---------------------------------- ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ! Child shifts at start of its timestep 24 ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ! parent parent ! 7 <-- timestep --> 8 8 <-- timestep --> 9 ! boundary boundary ! ! | | ! parent sends | child recvs | ! post-shift | post-shift | ! internal data | internal data | ! to child | from parent | ! | | | | ! | | | | ! v | v | ! | ^ | ! | | | ! | | child child | ! | CHILD timestep timestep | ! | SHIFTS boundary boundary | ! | HERE | | | ! | | | | | ! 23<--|-->24 | 24<--|-->25 25<--|-->26 26<--|-->27 ! | v | | | ! | | | | ! | | ! | | ! | | ! ^ | ^ ^ | ^ ! | | | | | | ! | | | | | | ! child sends | parent recvs child sends | parent recvs ! pre-shift | pre-shift post-shift | post-shift ! 2-way data | 2-way data 2-way data | 2-way data ! to parent | from child to parent | from child ! | | ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- !*** Below is an example of the parent domain shifting at the start !*** of its timestep 8. However the parent receives and incorporates !*** the 2-way data from its child in that timestep BEFORE the shift !*** in position occurs therefore the child generates that data for !*** the parent's pre-shift position. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ! Parent shifts at start of its timestep 8 ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ! parent parent ! 7 <-- timestep --> 8 8 <-- timestep --> 9 ! boundary boundary ! ! | | ! | | ! | PARENT | ! | SHIFTS | ! | HERE | ! | | | ! | | | ! | | | ! | v | ! | child child | ! | timestep timestep | ! | boundary boundary | ! | | | | ! | | | | ! 23<--|-->24 24<--|-->25 25<--|-->26 26<--|-->27 ! | | | | ! | | | | ! | | ! | | ! | | ! ^ | ^ | ! | | | | ! | | | | ! child sends | parent recvs/ | ! pre-shift | incorporates | ! 2-way data | pre-shift | ! to parent | 2-way data | ! | from child | ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! two_way_children: DO N=1,NUM_2WAY_CHILDREN !<-- Loop through all of this domain's 2-way children ! !----------------------------------------------------------------------- ! N_ALL=RANK_2WAY_CHILD(N) !<-- Rank of 2-way child N among ALL children NM=1 call mpi_comm_rank(comm_to_my_children(n_all),mype_intra,ierr) ! IF(STATIC_OR_MOVING(N_ALL)=='Moving')THEN !<-- If so, 2-way child N's domain is movable. ! DO NMX=1,NUM_MOVING_CHILDREN IF(N_ALL==RANK_MOVING_CHILD(NMX))THEN !<-- Which moving child is 2-way child N? NM=NMX !<-- 2-way child N is moving child NM EXIT ENDIF ENDDO ! ENDIF ! IF(.NOT.CALLED_PARENT_2WAY_BOOKKEEPING(N) & !<-- Initial parent bookkeeping for all 2-way nests .OR. & NTIMESTEP==NTIMESTEP_CHILD_MOVES(NM)+1 & !<-- 2-way child N moved one parent timestep ago .OR. & NTIMESTEP==NEXT_MOVE_TIMESTEP+1)THEN !<-- This parent moved in its preceding timestep ! !----------------------------------------------------------------------- !*** If this parent moved in its preceding timestep then it !*** needs to modify the locations of its children accordingly. !*** This will be done as a local computation because 2-way nesting !*** is only optional. The children's locations as changed by !*** the parent's shift will be permanently modified in !*** PARENTS_SEND_CHILD_DATA where it is always required for !*** generation of BC update data to send to the children. !----------------------------------------------------------------------- ! I_PARENT_SW_X=I_PARENT_SW(N_ALL) J_PARENT_SW_X=J_PARENT_SW(N_ALL) ! !----------------------------------------------------------------------- !*** Parent tasks determine which if any of their points are updated !*** by 2-way child N in that child's or the parent's new location. !----------------------------------------------------------------------- ! NTASKS_UPDATE_CHILD(N)=0 !<-- Initialize # of child tasks that will update CHILD_TASK_LIMITS=>CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N_ALL)%DATA !<-- All subdomain limits on 2-way child N's domain ID_CHILD=MY_CHILDREN_ID(N_ALL) !<-- Domain ID of 2-way child N ! CALL PARENT_2WAY_BOOKKEEPING(PARENT_CHILD_SPACE_RATIO(N_ALL) & !<-- Ratio of parent grid increment to 2-way child N's ,FTASKS_DOMAIN(ID_CHILD) & !<-- # of forecast tasks on 2-way child N's domain ,CHILD_TASK_LIMITS & !<-- 2-way child N's subdomains' integration limits ,IM_CHILD(N_ALL) & !<-- I extent of 2-way child N's domain ,JM_CHILD(N_ALL) & !<-- J extent of 2-way child N's domain ,I_PARENT_SW_X & !<-- Parent I of SW corner of child domain N_ALL ,J_PARENT_SW_X & !<-- Parent J of SW corner of child domain N_ALL ,N_BLEND_H_CHILD(N_ALL) & !<-- H-pt blending region width for 2-way child N ,N_BLEND_V_CHILD(N_ALL) & !<-- V-pt blending region width for 2-way child N ,N_STENCIL_H_CHILD(N) & !<-- Stencil width for averaging child h to parent H ,N_STENCIL_V_CHILD(N) & !<-- Stencil width for averaging child v to parent V ,N_STENCIL_SFC_H_CHILD(N) & !<-- Stencil width for averaging child fis,pd to parent H ,N_STENCIL_SFC_V_CHILD(N) & !<-- Stencil width for averaging child fis,pd to parent V ,ITS,ITE,JTS,JTE & !<-- Integration limits of this parent task subdomain ! ,NTASKS_UPDATE_CHILD(N) & !<-- # of tasks on 2-way child N that update this parent task ,CHILD_TASKS_2WAY_UPDATE(N) & !<-- Info for 2-way child N's update on this parent task ) ! CALLED_PARENT_2WAY_BOOKKEEPING(N)=.TRUE. ! ENDIF ! !----------------------------------------------------------------------- !*** The parent receives update data from child N. !----------------------------------------------------------------------- ! IF(NTASKS_UPDATE_CHILD(N)<1)THEN CYCLE !<-- Skip this child if none of its tasks are sending data. ENDIF ! NCHILD_TASKS=NTASKS_UPDATE_CHILD(N) !<-- # of child N's tasks that update the parent task. NTIMESTEP_CHILD=NTIMESTEP*TIME_RATIO_MY_CHILDREN(N_ALL)-1 !<-- Child's timestep when it sent the data. ! PTR=>CHILD_TASKS_2WAY_UPDATE(N) !<-- Point at child N's 2-way exchange specifications ! !----------------------------------------------------------------------- ! child_tasks: DO NT=1,NCHILD_TASKS !<-- Loop though child N's tasks that send 2-way data ! !----------------------------------------------------------------------- ! IF(NT>1)PTR=>PTR%NEXT_LINK !<-- Advance through this child's tasks that are sending data ! NPTS_UPDATE_TOTAL=NLEV_2WAY*PTR%NUM_PTS_UPDATE_HZ !<-- Total # of values (Real) updated by child N's task NT. ALLOCATE(VAR_2WAY(1:NPTS_UPDATE_TOTAL)) !<-- The recv buffer ! TASK_ID=PTR%TASK_ID !<-- Local rank of task NT among child N's fcst tasks. CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_ALL)%DATA(TASK_ID) !<-- Local rank of child task NT in P-C intracommunicator. UPDATE_TAG=100*MY_CHILDREN_ID(N_ALL)+CHILDTASK ! CALL MPI_RECV(VAR_2WAY & !<-- All update values from child N's task NT ,NPTS_UPDATE_TOTAL & !<-- Receiving this many words ,MPI_REAL & !<-- The data is real ,CHILDTASK & !<-- Data was sent by this nest task ,UPDATE_TAG & !<-- The MPI tag ,COMM_TO_MY_CHILDREN(N_ALL) & !<-- Intracommunicator between current domain and child N_ALL ,JSTAT & !<-- MPI status ,IERR ) ! NPTS_UPDATE_HORIZ=2*PTR%NUM_PTS_UPDATE_HZ !<-- # of sfc H,V points updated on parent by child N's task NT. ALLOCATE(CHILD_SFC_ON_PARENT_GRID(1:NPTS_UPDATE_HORIZ,1:2)) !<-- The recv buffer NPTS2=2*NPTS_UPDATE_HORIZ !<-- Total # of points in CHILD_SFC_ON_PARENT_GRID ! (child N's FIS,PD interpolated to parent H and V) SFC_TAG=100*MY_CHILDREN_ID(N_ALL)+CHILDTASK ! CALL MPI_RECV(CHILD_SFC_ON_PARENT_GRID & !<-- Child PD,FIS interpolated to parent points ,NPTS2 & !<-- Receiving this many words ,MPI_REAL & !<-- The data is real ,CHILDTASK & !<-- Data was sent by this nest task ,SFC_TAG & !<-- The MPI tag ,COMM_TO_MY_CHILDREN(N_ALL) & !<-- Intracommunicator between current domain and child N_ALL ,JSTAT & !<-- MPI status ,IERR ) ! !----------------------------------------------------------------------- !*** The parent does not incorporate data sent from the child if !*** this is a parent timestep that immediately follows the writing !*** of a restart file. This ensures bit-reproducible restarts. !*** A child sends 2-way data to its parent at the end of parent !*** timestep N and the parent receives that data early in timestep !*** N+1. Two-way data is not in the restart files so in a restart !*** the parent sees no 2-way data coming from its children in the !*** first timestep. Therefore the parent must not use 2-way data !*** from the children in any parent timestep that follows the !*** writing of a restart file. !----------------------------------------------------------------------- ! no_restart: IF(MOD(NTIMESTEP,NTIMESTEPS_RESTART)/=0)THEN ! !----------------------------------------------------------------------- !*** The parent incorporates the 2-way data sent from child N's !*** task NT. !----------------------------------------------------------------------- ! I_2WAY_UPDATE_START=PTR%IL(1) !<-- Starting parent I updated by child N's task NT I_2WAY_UPDATE_END =PTR%IL(2) !<-- Ending parent I updated by child N's task NT J_2WAY_UPDATE_START=PTR%JL(1) !<-- Starting parent J updated by child N's task NT J_2WAY_UPDATE_END =PTR%JL(2) !<-- Ending parent J updated by child N's task NT ! IF(.NOT.SKIP_2WAY_UPDATE(N_ALL))THEN !<-- IF test passes => nest N lies within latitude limits CALL PARENT_2WAY_UPDATE(I_2WAY_UPDATE_START & !<-- # of tasks on 2-way child N that update this parent task ,I_2WAY_UPDATE_END & !<-- Info for 2-way child N's update on this parent task ,J_2WAY_UPDATE_START & !<-- Info for 2-way child N's update on this parent task ,J_2WAY_UPDATE_END & !<-- Info for 2-way child N's update on this parent task ,LM & !<-- # of model layers (all domains) ,NPTS_UPDATE_HORIZ & !<-- # of update parent sfc H,V points ,NPTS_UPDATE_TOTAL & !<-- Total # of words in 2-way 3D update data from child ,NVARS_2WAY_UPDATE & !<-- # of variables updated in 2-way exchange ,VAR_2WAY & !<-- String of all 2-way update data from child ,CHILD_SFC_ON_PARENT_GRID & !<-- Child's FIS,PD interpolated to parent update points ,CHILD_2WAY_WGT(N) & !<-- Weight (0-1) given to child 2-way data in the update ,FIS & !<-- Parent's sfc geopotential ,PD,PDTOP,PT & !<-- Parent's PD ,SG1,SG2 & !<-- Interface 'sigma' values in pressure/hybrid regions ,IMS,IME,JMS,JME & !<-- Memory limits of parent subdomains ! ,BUNDLE_2WAY & !<-- Bundle holding pointers to the 2-way exchange variables ) ENDIF ! !----------------------------------------------------------------------- ! ENDIF no_restart ! !----------------------------------------------------------------------- ! DEALLOCATE(VAR_2WAY) DEALLOCATE(CHILD_SFC_ON_PARENT_GRID) ! !----------------------------------------------------------------------- ! ENDDO child_tasks ! !----------------------------------------------------------------------- ! ENDDO two_way_children ! !----------------------------------------------------------------------- ! KOUNT_2WAY_CHILDREN=0 ! !----------------------------------------------------------------------- !*** The parent tasks have received all the 2-way exchange data from !*** their children. The lead parent task now informs the lead !*** child tasks that the children are now free to proceed to the !*** beginning of the next parent timestep since the parent will now !*** be able to integrate its next step and send back BC data to the !*** children. Until the children are informed of this by their !*** parents at the end of each parent timestep the children will !*** simply continue to fall out of the integration loop in !*** NMM_INTEGRATE. !----------------------------------------------------------------------- ! task0_b: IF(I_AM_LEAD_FCST_TASK)THEN ! !----------------------------------------------------------------------- ! DO N=1,NUM_CHILDREN ! ALLCLEAR_SIGNAL_TAG=20000+1000*MY_CHILDREN_ID(N) & !<-- Use child's domain ID, timestep to create a unique tag +10*NTIMESTEP*TIME_RATIO_MY_CHILDREN(N) CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child's lead task in p-c communicator ! CALL MPI_WAIT(HANDLE_SEND_ALLCLEAR(N) & !<-- Handle for this ISend ,JSTAT & !<-- MPI status object ,IERR) ! CALL MPI_ISSEND(ALLCLEAR_SIGNAL & !<-- Send signal to children they may now integrate ,1 & !<-- # of words in signal ,MPI_LOGICAL & !<-- The signal is type Logical (it is TRUE) ,CHILDTASK_0 & !<-- The signal was sent by child N's fcst task 0. ,ALLCLEAR_SIGNAL_TAG & !<-- Tag to free the children to integrate ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator between parent and moving child N ,HANDLE_SEND_ALLCLEAR(N) & ,IERR) ! ENDDO ! !----------------------------------------------------------------------- ! ENDIF task0_b ! !----------------------------------------------------------------------- ! CALL SET_DOMAIN_SPECS(ITS,ITE,JTS,JTE & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE & ,NHALO,NHALO & ,MY_DOMAIN_ID & ,MYPE_LOCAL & ,MY_NEB & ,COMM_FCST_TASKS & ,NUM_PES_FCST & ) ! !----------------------------------------------------------------------- !*** Now that parent variables have been modified by each of the !*** children who have contributions the parent's halos need to !*** be updated. Therefore extract each of the 2-way exchange !*** variables from the Bundle and call the halo exchange. !----------------------------------------------------------------------- ! vars: DO NV=1,NVARS_2WAY_UPDATE !<-- Loop over all parent exchange variables updated by the child. ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vars" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding pointers to the 2-way exchange variables ,fieldIndex =NV & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field NV in the Bundle ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Info about this 2-way Variable" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field NV in the Bundle ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? ,name =FIELD_NAME & !<-- This Field's name ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 2-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_2D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL HALO_EXCH(VAR_PARENT_2D,LM,2,2) ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS>=3)THEN ! !----------------------------------------------------------------------- ! IF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 3-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_3D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=1 L2=1 VAR_3D=>VAR_PARENT_3D ! ELSEIF(NUM_DIMS==4)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 4-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_4D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=LBOUND(VAR_PARENT_4D,4) L2=UBOUND(VAR_PARENT_4D,4) ! ENDIF ! DO NL=L1,L2 ! IF(NUM_DIMS==4)THEN VAR_3D=>VAR_PARENT_4D(:,:,:,NL) !<-- Point at NL'th 3-D array in the 4-D variable. ENDIF ! CALL HALO_EXCH(VAR_3D,LM,2,2) ! ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO vars ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENTS_RECV_CHILD_2WAY_DATA ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE CHILDREN_SEND_PARENTS_2WAY_DATA(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** Run the coupler step where children send their 2-way exchange !*** data to their parents. This is phase 5 of the Parent-Child !*** coupler Run step called in subroutine NMM_INTEGRATE and takes !*** place at the end of a parent timestep after the parents execute !*** their receiving and incorporation of 2-way exchanges from their !*** children which occurred in phase 2 at the beginning of the parent !*** timestep. Of course this routine is executed only if 2-way !*** nesting is being used. ! !*** IMPORTANT: The specific indices of the parent H points and V !*** points that are updated by the children are identical. !*** A signficant generalization will be needed if that !*** fact ever changes. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT),SAVE :: H_OR_V_INT,NTOT,NTOT_H_V ! INTEGER(kind=KINT) :: L1,L2,MY_DOMAIN_ID,MY_PARENT_ID & ,N,N_STENCIL,N_STENCIL_SFC & ,N1,N1P,N2,N2P,NL,NT,NTAG,NTIMESTEP & ,NUM_DIMS,NV,NVERT,NX,NY ! INTEGER(kind=KINT) :: I_SW_PARENT_CURRENT_X & ,J_SW_PARENT_CURRENT_X ! INTEGER(kind=KINT) :: LB1,LB2,UB1,UB2 ! INTEGER(kind=KINT) :: IERR,RC ! INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! INTEGER(kind=KINT),DIMENSION(1:2) :: LBND,UBND ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_2WAY,I_2WAY_X & ,J_2WAY,J_2WAY_X ! REAL(kind=KFPT),DIMENSION(:),POINTER :: VAR_PARENT ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2WAY_R2D ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CHILD_SFC_INTERP ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_2WAY_R3D & ,VAR_CHILD ! REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: ARRAY_2WAY_R4D ! LOGICAL(kind=KLOG) :: INTERPOLATE_SFC ! LOGICAL(kind=KLOG),SAVE :: BEGIN_H,BEGIN_V & ,MY_2WAY_SIGNAL=.TRUE. ! CHARACTER(len=1) :: H_OR_V ! CHARACTER(len=99) :: FIELD_NAME ! LOGICAL(kind=KLOG) :: MOVE_NOW ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! TYPE(COMPOSITE),POINTER :: CC ! integer(kind=kint),dimension(8) :: values !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !-------------------------- !*** The current timestep !-------------------------- ! CALL ESMF_CLOCKGET(clock =CLOCK & ,advanceCount=NTIMESTEP_ESMF & ,rc =RC) ! NTIMESTEP=NTIMESTEP_ESMF ! !----------------------- !*** Current Domain ID !----------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="CHILDREN_SEND_PARENTS_2WAY_DATA: Extract Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Point to the correct part of the composite object which will !*** align working variables in this task's memory with values !*** associated with this particular domain. !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Did this domain move at the beginning of this timestep? !----------------------------------------------------------------------- ! IF(MY_DOMAIN_MOVES.AND..NOT.FIRST_STEP_2WAY)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="CHILDREN_SEND_PARENTS_2WAY_DATA: Extract Move Flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE & !<-- The parent-child coupler export state ,name ='MOVE_NOW' & !<-- Name of the attribute to extract ,value=MOVE_NOW & !<-- Did this child just move? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! IF(FIRST_STEP_2WAY)THEN FIRST_STEP_2WAY=.FALSE. ENDIF ! !----------------------------------------------------------------------- ! CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain my local rank in parent-child intracomm ! !----------------------------------------------------------------------- !*** The lead child task now sends the lead parent task a signal !*** indicating that the child has caught up to the parent in time !*** and is ready to send its 2-way exchange data. !*** A child must never send its signal to its parent at the end !*** of the final timestep of the forecast since the parent would !*** need to go one timestep beyond the end of the forecast in !*** order to receive that signal. !----------------------------------------------------------------------- ! IF(NTIMESTEP0)THEN DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop through parent task subdomains updated last time. ! CALL MPI_WAIT(HANDLE_SEND_2WAY_DATA(NT) & !<-- Request handle for ISend of update to parent task NT ,JSTAT & !<-- MPI status ,IERR ) ! CALL MPI_WAIT(HANDLE_SEND_2WAY_SFC(NT) & !<-- Request handle for ISend of FIS,PD to parent task NT ,JSTAT & !<-- MPI status ,IERR ) ! ENDDO ENDIF ! !----------------------------------------------------------------------- !*** Each child task determines the parent tasks to which it must !*** provide update data and to which points on those parent tasks. !*** This needs to be done only once for static nests. For moving !*** nests it must be done initially and then again each time the !*** child or parent has moved at the beginning of this parent !*** timestep. Recall that at this point in time the child !*** is at the end of a parent timestep and that the parent will !*** receive 2-way update data from this child at the beginning !*** of the next parent timestep. In timesteps that the parent !*** shifts the parent will incorporate the 2-way data BEFORE the !*** the shift of data actually occurs in DOMAIN_RUN. Therefore !*** the child always generates 2-way data for the parent's !*** position valid for the same time at which the child is !*** doing the 2-way data generation. ! !*** Recall that the child's I,J of its southwest corner on its !*** parent's grid is part of the composite object and thus is !*** always retained. However the change of that corner location !*** due to the parent's upcoming shift is computed locally here !*** because 2-way exchange is only optional. The location of !*** the child's SW corner due the motion of its parent will be !*** permanently updated in CHILD_RECV_PARENT_DATA where the !*** computation is always needed for receiving BC updates. !----------------------------------------------------------------------- ! I_SW_PARENT_CURRENT_X=I_SW_PARENT_CURRENT J_SW_PARENT_CURRENT_X=J_SW_PARENT_CURRENT ! !----------------------------------------------------------------------- ! IF(.NOT.CALLED_CHILD_2WAY_BOOKKEEPING & !<-- All nests' first update of their parents. .OR. & MY_DOMAIN_MOVES.AND.MOVE_NOW & !<-- This child moved at the start of this parent timestep. .OR. & MY_DOMAIN_MOVES & .AND. & NTIMESTEP==PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT & !<-- Parent moved at the start of +TIME_RATIO_MY_PARENT-1)THEN !<-- the current parent timestep. ! MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent ! CALL CHILD_2WAY_BOOKKEEPING(I_SW_PARENT_CURRENT_X & ! ^ ,J_SW_PARENT_CURRENT_X & ! | ,SPACE_RATIO_MY_PARENT & ! | ,NUM_FCST_TASKS_PARENT & ! | ,PTASK_LIMITS(MY_DOMAIN_ID)%ITS & ! | ,PTASK_LIMITS(MY_DOMAIN_ID)%ITE & ! | ,PTASK_LIMITS(MY_DOMAIN_ID)%JTS & ! | ,PTASK_LIMITS(MY_DOMAIN_ID)%JTE & ! ,N_BLEND_H & ! input ,N_BLEND_V & ! ,N_STENCIL_H & ! | ,N_STENCIL_V & ! | ,N_STENCIL_SFC_H & ! | ,N_STENCIL_SFC_V & ! | ,ITS,ITE,JTS,JTE & ! | ,IDS,IDE,JDS,JDE & ! v ! ----- ,NTASKS_UPDATE_PARENT & ! ^ ,ID_PARENT_UPDATE_TASKS & ! | ,NPTS_UPDATE_ON_PARENT_TASKS & ! | ,I_2WAY_UPDATE & ! output ,J_2WAY_UPDATE & ! | ) ! v ! CALLED_CHILD_2WAY_BOOKKEEPING=.TRUE. ! !----------------------------------------------------------------------- !*** If this child task has determined that it is responsible for !*** updating any of its parent tasks initially or after either domain !*** shifts then reset arrays/variables associated with the !*** interpolation from the child to the parent. !----------------------------------------------------------------------- ! reset: IF(NTASKS_UPDATE_PARENT>0)THEN !<-- If true then the current child task must update ! ! at least one parent task subdomain. !----------------------------------------------------------------------- ! parent_subdomains_1: DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop through each parent task subdomain to be updated. ! !----------------------------------------------------------------------- ! IF(ASSOCIATED(I_2WAY_H(NT)%DATA))THEN DEALLOCATE(I_2WAY_H(NT)%DATA) DEALLOCATE(J_2WAY_H(NT)%DATA) DEALLOCATE(I_2WAY_V(NT)%DATA) DEALLOCATE(J_2WAY_V(NT)%DATA) ENDIF ! ALLOCATE(I_2WAY_H(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) ALLOCATE(J_2WAY_H(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) ALLOCATE(I_2WAY_V(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) ALLOCATE(J_2WAY_V(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) ! !----------------------------------------------------------------------- !*** Translate to this child's I's and J's the parent I's and J's to !*** be updated. If a child h point lies on a parent target V point !*** (the opposite cannot happen on the B-grid) then the child's I and !*** J are those of the child h point which corresponds to the child !*** v point to the NE of the parent V point. The H-V diagrams seen in !*** subroutines GENERATE_2WAY_DATA and PARENT_BOOKKEEPING_MOVING help !*** clarify the relationship between h,v and H,V. !----------------------------------------------------------------------- ! I_2WAY=>I_2WAY_UPDATE(NT)%DATA !<-- Parent I at each parent update point on parent task NT J_2WAY=>J_2WAY_UPDATE(NT)%DATA !<-- Parent J at each parent update point on parent task NT ! DO N=1,NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- Loop through each parent I,J to be updated on subdomain NT ! I_2WAY_H(NT)%DATA(N)=(I_2WAY(N)-I_SW_PARENT_CURRENT_X) & !<-- Child I at parent update H point *SPACE_RATIO_MY_PARENT+1 ! on parent task NT. J_2WAY_H(NT)%DATA(N)=(J_2WAY(N)-J_SW_PARENT_CURRENT_X) & !<-- Child J at parent update H point *SPACE_RATIO_MY_PARENT+1 ! on parent task NT. ! I_2WAY_V(NT)%DATA(N)=I_2WAY_H(NT)%DATA(N) & !<-- Child I at parent update V point +SPACE_RATIO_MY_PARENT/2 ! on parent task NT. ! J_2WAY_V(NT)%DATA(N)=J_2WAY_H(NT)%DATA(N) & !<-- Child J at parent update V point +SPACE_RATIO_MY_PARENT/2 !<-- on parent task NT. ! ENDDO ! !----------------------------------------------------------------------- ! NTOT=NPTS_UPDATE_ON_PARENT_TASKS(NT)*NLEV_2WAY !<-- # of points updated for all vbls on parent task NT ! IF(ASSOCIATED(cc%UPDATE_PARENT_2WAY(NT)%DATA))THEN DEALLOCATE(cc%UPDATE_PARENT_2WAY(NT)%DATA) ENDIF ALLOCATE(cc%UPDATE_PARENT_2WAY(NT)%DATA(1:NTOT),stat=RC) !<-- Updated values for all 2-way variables on parent task NT ! !----------------------------------------------------------------------- ! NTOT_H_V=NPTS_UPDATE_ON_PARENT_TASKS(NT)*2 !<-- # of updated H points then V points (thus *2) IF(ASSOCIATED(cc%CHILD_SFC_ON_PARENT(NT)%DATA))THEN DEALLOCATE(cc%CHILD_SFC_ON_PARENT(NT)%DATA) ENDIF ALLOCATE(cc%CHILD_SFC_ON_PARENT(NT)%DATA(1:NTOT_H_V,1:2)) !<-- Child FIS(:1),PD(:2) interp'd to H and V parent update pts ! NTOT_SFC=2*NTOT_H_V !<-- Both FIS and PD (thus *2) are interpolated from the child ! ! to parent H and V. !----------------------------------------------------------------------- ! ENDDO parent_subdomains_1 ! !----------------------------------------------------------------------- ! ENDIF reset ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- !*** If this child task is responsible for updating none of its !*** parent's task subdomains then it may leave. !----------------------------------------------------------------------- ! IF(NTASKS_UPDATE_PARENT==0)THEN RETURN !<-- Nothing more to do if no parent tasks are updated ENDIF ! !----------------------------------------------------------------------- !*** The child tasks generate 2-way update data for those points on !*** each parent task for which they are responsible. !----------------------------------------------------------------------- ! parent_subdomains_2: DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop over the parent task subdomains this child task updates. ! !----------------------------------------------------------------------- ! N2=0 BEGIN_H=.TRUE. BEGIN_V=.TRUE. ! !----------------------------------------------------------------------- !*** Loop through the variables in the 2-way exchange. !----------------------------------------------------------------------- ! vars: DO NV=1,NVARS_2WAY_UPDATE !<-- Loop over all parent exchange variables updated by the child. ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vars" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding the arrays for 2-way exchange ,fieldIndex =NV & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field NV in the Bundle ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Info about this 2-way Variable" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? ,name =FIELD_NAME & !<-- This Field's name ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Character variables cannot be used as ESMF Attributes so !*** integers are used below to indicate whether the 2-way variable !*** is on H or V points. After this integer Attribute is read in !*** translate it to a character. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract whether H or V Array from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field ,name ='H_OR_V_INT' & !<-- Name of the attribute to extract ,value=H_OR_V_INT & !<-- Value of the Attribute ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(H_OR_V_INT==1)THEN H_OR_V='H' ELSEIF(H_OR_V_INT==2)THEN H_OR_V='V' ENDIF ! !----------------------------------------------------------------------- !*** Point at the child I,J points used for interpolation to the !*** appropriate parent tasks' H and V points. !----------------------------------------------------------------------- ! IF(H_OR_V=='H')THEN I_2WAY_X=>I_2WAY_H(NT)%DATA !<-- Use child I's at parent H points J_2WAY_X=>J_2WAY_H(NT)%DATA !<-- Use child J's at parent H points N_STENCIL=N_STENCIL_H !<-- Width of stencil of child averaging for parent H pts ! ELSEIF(H_OR_V=='V')THEN I_2WAY_X=>I_2WAY_V(NT)%DATA !<-- Use child I's at parent V points J_2WAY_X=>J_2WAY_V(NT)%DATA !<-- Use child J's at parent V points N_STENCIL=N_STENCIL_V !<-- Width of stencil of child averaging for parent V pts ! ENDIF ! !----------------------------------------------------------------------- !*** The nest also interpolates its PD and sfc geopotential to parent !*** H and V points so the parent will be able to adjust the update !*** variables when the parent and nest surface elevations differ. !----------------------------------------------------------------------- ! INTERPOLATE_SFC=.FALSE. ! IF(H_OR_V=='H'.AND.BEGIN_H)THEN !<-- Child generates FIS,PD on H only once per vbl for parent task NT INTERPOLATE_SFC=.TRUE. N1P=1 !<-- Starting word location for FIS,PD on H for parent task NT N2P=NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- Ending word location for FIS,PD on H for parent task NT CHILD_SFC_INTERP=>cc%CHILD_SFC_ON_PARENT(NT)%DATA(N1P:N2P,1:2) !<-- Child's FIS,PD on parent task NT's update H points N_STENCIL_SFC=N_STENCIL_SFC_H !<-- Stencil width for interpolating child FIS,PD to parent H ! ELSEIF(H_OR_V=='V'.AND.BEGIN_V)THEN !<-- Child generates FIS,PD on V only once per vbl for parent task NT INTERPOLATE_SFC=.TRUE. N1P=NPTS_UPDATE_ON_PARENT_TASKS(NT)+1 !<-- Starting word location for FIS,PD on V for parent task NT N2P=N1P+NPTS_UPDATE_ON_PARENT_TASKS(NT)-1 !<-- Ending word location for FIS,PD on V for parent task NT CHILD_SFC_INTERP=>cc%CHILD_SFC_ON_PARENT(NT)%DATA(N1P:N2P,1:2) !<-- Child's FIS,PD on parent task NT's update V points N_STENCIL_SFC=N_STENCIL_SFC_V !<-- Stencil width for interpolating child FIS,PD to parent V ! ENDIF ! !----------------------------------------------------------------------- ! dtype: IF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Is this a Real 2-way variable? ! !----------------------------------------------------------------------- ! ndims: IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 2-way Real 2-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the 2-D data pointer ,localDe =0 & ,farrayPtr=ARRAY_2WAY_R2D & !<-- Use this 2-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=1 L2=1 NVERT=1 ! LBND=LBOUND(ARRAY_2WAY_R2D) LB1=LBND(1) LB2=LBND(2) UBND=UBOUND(ARRAY_2WAY_R2D) UB1=UBND(1) UB2=UBND(2) ! ALLOCATE(VAR_CHILD(LB1:UB1,LB2:UB2,1)) DO NY=LB2,UB2 DO NX=LB1,UB1 VAR_CHILD(NX,NY,1)=ARRAY_2WAY_R2D(NX,NY) !<-- For simplicity the generic exchange input is always 3-D ENDDO ENDDO ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 2-way Real 3-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=ARRAY_2WAY_R3D & !<-- Use this 3-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=1 L2=1 NVERT=LM !<-- Assume all 3-D exchange vbls have LM levels VAR_CHILD=>ARRAY_2WAY_R3D ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==4)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 2-way Real 4-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=ARRAY_2WAY_R4D & !<-- Use this 4-D pointer to the variable. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=LBOUND(ARRAY_2WAY_R4D,4) L2=UBOUND(ARRAY_2WAY_R4D,4) NVERT=LM !<-- Assume all 3-D exchange vbls have LM levels ! !----------------------------------------------------------------------- ! ENDIF ndims ! !----------------------------------------------------------------------- ! ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN ! WRITE(0,10001) 10001 FORMAT(' Not considering the use of Integer 2-way exchange variables') WRITE(0,*)' ABORT!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ! !----------------------------------------------------------------------- ! ENDIF dtype ! !----------------------------------------------------------------------- ! DO NL=L1,L2 !<-- Loop through this variable's 4th dimension if it exists. ! IF(NUM_DIMS==4)THEN VAR_CHILD=>ARRAY_2WAY_R4D(:,:,:,NL) !<-- Select the NL'th 3-D piece of the 4-D exchange variable ENDIF ! N1=N2+1 !<-- Starting word location of Real vbl #NV to parent task NT N2=N1+NPTS_UPDATE_ON_PARENT_TASKS(NT)*NVERT-1 !<-- Ending word location of Real vbl #NV to parent task NT VAR_PARENT=>cc%UPDATE_PARENT_2WAY(NT)%DATA(N1:N2) !<-- Updated values for Real variable #NV on parent task NT ! CALL GENERATE_2WAY_DATA(VAR_CHILD & !<-- Child variable to be interpolated ,PD & !<-- The child's PD array ,FIS & !<-- The child's sfc geopotential array ,IMS,IME,JMS,JME,NVERT & !<-- This child task subdomain's memory dimensions ,I_2WAY_X & !<-- Child I at each parent update point (H or V) ,J_2WAY_X & !<-- Child J at each parent update point (H or V) ,N_STENCIL & !<-- Stencil width of child averaging for parent variable ,N_STENCIL_SFC & !<-- Stencil width of child averaging its FIS,PD to parent grid ,NPTS_UPDATE_ON_PARENT_TASKS(NT) & !<-- # of update points (I,J) on parent task NT ,VAR_PARENT & !<-- Child values interpolated onto parent points for this vbl ,INTERPOLATE_SFC & !<-- Should PD and FIS be interpolated in this call? ,CHILD_SFC_INTERP & !<-- Child PD,FIS interpolated onto parent H then V points ) ENDDO ! IF(BEGIN_H)THEN BEGIN_H=.FALSE. ENDIF IF(BEGIN_V)THEN BEGIN_V=.FALSE. ENDIF ! IF(NUM_DIMS==2)THEN !<-- VAR_CHILD explicitly allocated only for 2-D variables DEALLOCATE(VAR_CHILD) ENDIF ! !----------------------------------------------------------------------- ! ENDDO vars ! !----------------------------------------------------------------------- !*** The child task ISSends parent fcst task NT its update data for !*** all the relevant variables at once followed by another ISSend !*** of the child's FIS and PD values interpolated to the parent's !*** H and V points to be updated. !----------------------------------------------------------------------- ! NTOT=NLEV_2WAY*NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- # of points (3-D) updated for all vbls on parent task NT NTAG=100*MY_DOMAIN_ID+MYPE ! CALL MPI_ISSEND(cc%UPDATE_PARENT_2WAY(NT)%DATA & !<-- All variables at parent task NT's 2-way update points ,NTOT & !<-- # of words sent to parent task to update 3-D variables ,MPI_REAL & !<-- The words are real ,ID_PARENT_UPDATE_TASKS(NT) & !<-- Local ID of target parent task in P-C intracomm ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,HANDLE_SEND_2WAY_DATA(NT) & !<-- Request handle for ISend ,IERR ) ! NTOT_H_V=NPTS_UPDATE_ON_PARENT_TASKS(NT)*2 !<-- # of updated H points then V points (thus *2) NTOT_SFC=2*NTOT_H_V !<-- # of updated FIS and PD values updated (thus *2) NTAG=100*MY_DOMAIN_ID+MYPE ! CALL MPI_ISSEND(cc%CHILD_SFC_ON_PARENT(NT)%DATA & !<-- Child FIS,PD on H,V update points of parent task NT ,NTOT_SFC & !<-- # of words sent to parent task to update FIS,PD ,MPI_REAL & !<-- The words are real ,ID_PARENT_UPDATE_TASKS(NT) & !<-- Local ID of parent task in P-C intracomm ,NTAG & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,HANDLE_SEND_2WAY_SFC(NT) & !<-- Request handle for ISend ,IERR ) ! !----------------------------------------------------------------------- ! ENDDO parent_subdomains_2 ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILDREN_SEND_PARENTS_2WAY_DATA ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_CPL_FINALIZE(CPL_COMP & ,IMP_STATE & ,EXP_STATE & ,CLOCK & ,RC_FINAL) ! !----------------------------------------------------------------------- !*** FINALIZE THE COUPLER. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component ! TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State ,EXP_STATE !<-- The Coupler's Export State ! TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock ! INTEGER,INTENT(OUT) :: RC_FINAL ! !--------------------- !*** Local variables !--------------------- ! INTEGER :: MY_DOMAIN_ID,RC,RC_CPL_FINAL ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_FINAL =ESMF_SUCCESS RC_CPL_FINAL=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** Extract the domain ID. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Finalize: Extract Current Domain ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract ,value=MY_DOMAIN_ID & !<-- Current domain's ID ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- ! WRITE(0,*)' Clocktime Parent-Child Coupler' WRITE(0,*)' Cpl1 Prelim=',cpl1_prelim_tim*1.e-3 WRITE(0,*)' Cpl1 South_H=',cpl1_south_h_tim*1.e-3 WRITE(0,*)' Cpl1 South_V=',cpl1_south_v_tim*1.e-3 WRITE(0,*)' Cpl1 North_H=',cpl1_north_h_tim*1.e-3 WRITE(0,*)' Cpl1 North_V=',cpl1_north_v_tim*1.e-3 WRITE(0,*)' Cpl1 West_H=',cpl1_west_h_tim*1.e-3 WRITE(0,*)' Cpl1 West_V=',cpl1_west_v_tim*1.e-3 WRITE(0,*)' Cpl1 East_H=',cpl1_east_h_tim*1.e-3 WRITE(0,*)' Cpl1 East_V=',cpl1_east_v_tim*1.e-3 WRITE(0,*)' ' WRITE(0,*)' Cpl1 South_H_Recv=',cpl1_south_h_recv_tim*1.e-3 WRITE(0,*)' Cpl1 South_H_Undo=',cpl1_south_h_undo_tim*1.e-3 WRITE(0,*)' Cpl1 South_H_Exp =',cpl1_south_h_exp_tim*1.e-3 WRITE(0,*)' Cpl1 South_V_Recv=',cpl1_south_v_recv_tim*1.e-3 WRITE(0,*)' Cpl1 South_V_Undo=',cpl1_south_v_undo_tim*1.e-3 WRITE(0,*)' Cpl1 South_V_Exp =',cpl1_south_v_exp_tim*1.e-3 WRITE(0,*)' ' ! !----------------------------------------------------------------------- ! IF(I_AM_A_PARENT)THEN WRITE(0,*)' Cpl2 Parent Bookkeeping for Moving Nest=' & ,parent_bookkeep_moving_tim*1.e-3 WRITE(0,*)' Cpl2 Parent Update for Moving Nest=' & ,parent_update_moving_tim*1.e-3 ENDIF WRITE(0,*)' ' IF(MY_DOMAIN_MOVES)THEN WRITE(0,*)' Cpl1 Moving Nest Bookkeeping=' & ,parent_bookkeep_moving_tim*1.e-3 WRITE(0,*)' Cpl1 Moving Nest Update=' & ,parent_update_moving_tim*1.e-3 ENDIF ! !----------------------------------------------------------------------- ! IF(RC_CPL_FINAL==ESMF_SUCCESS)THEN ! WRITE(0,*)"CPL FINALIZE STEP SUCCEEDED" ELSE WRITE(0,*)"CPL FINALIZE STEP FAILED" ENDIF ! RC_FINAL=RC_CPL_FINAL ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_CPL_FINALIZE ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_COUPLER_SETUP(NUM_DOMAINS & ! ,MY_DOMAIN_ID & ! ,NUM_CHILDREN & ! ,COMM_TO_MY_CHILDREN & ! ,COMM_TO_MY_PARENT & ! ,DT & ! ,CHILD_ID & ! ^ ,DOMAIN_GRID_COMP & ! | ,EXP_STATE_DOMAIN & ! | ,FTASKS_DOMAIN & ! | ,NTASKS_DOMAIN & ! | ,ID_PARENTS_IN & ! | ,DOMAIN_ID_TO_RANK & ! | ,MAX_DOMAINS & ! Input ! ----------- ,IMP_STATE_CPL_NEST & ! Output ,EXP_STATE_CPL_NEST & ! | ) ! v ! !----------------------------------------------------------------------- !*** Create the Parent-Child coupler through which they will !*** communicate. This coupler is called by the NMM component. !*** Move data from the DOMAIN export state into the Parent-Child !*** coupler import state that the coupler will need in order for !*** parents to generate data for their children and for moving !*** nests to determine when to move. !----------------------------------------------------------------------- ! USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & ,WRAP_DOMAIN_INTERNAL_STATE ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_PARENT & !<-- Current domain's MPI communicator to its parent ,MAX_DOMAINS & !<-- Maximum # of domains ,MY_DOMAIN_ID & !<-- ID of current domain ,NUM_CHILDREN & !<-- Current domain's number of children ,NUM_DOMAINS !<-- Total number of domains ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: CHILD_ID & !<-- Domain IDs of current domain's children ,COMM_TO_MY_CHILDREN & !<-- Current domain's MPI communicators to its children ,FTASKS_DOMAIN & !<-- # of forecast tasks on each domain ,ID_PARENTS_IN & !<-- IDs of parents of nested domains ,NTASKS_DOMAIN !<-- # of fcst+quilt tasks on each domain ! INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS),INTENT(IN) :: DOMAIN_ID_TO_RANK !<-- Configure file associated with each domain ID ! REAL(kind=KFPT),DIMENSION(1:NUM_DOMAINS),INTENT(IN) :: DT !<-- Timesteps for all domains (DOMAIN Components) ! TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The current DOMAIN component ! TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE_DOMAIN !<-- Export state of the current DOMAIN Component ! TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE_CPL_NEST & !<-- Parent-Child Coupler import state ,EXP_STATE_CPL_NEST !<-- Parent-Child Coupler export state ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT),SAVE :: N8=8 ! INTEGER(kind=KINT) :: CHILDTASK & ,COMM_FCST_TASKS & ,COMM_MY_DOMAIN & ,ITS,ITE,JTS,JTE & ,IDS,IDE,JDS,JDE & ,ID,ID_CHILD,IERR & ,IHANDLE_RECV,IHANDLE_SEND & ,INDX_CW,INDX_Q & ,I_PAR_STA,J_PAR_STA & ,JM & ,LAST_STEP_MOVED & ,KOUNT,LM,LMP1,MYPE,MYPE_DOMAIN & ,N,N_BLEND_H,N_BLEND_V,NHALO & ,NKOUNT,NN,NPHS,NTAG,NX ! INTEGER(kind=KINT) :: ISTAT,RC,RC_NESTSET ! INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER ! INTEGER(kind=KINT),DIMENSION(4) :: LIMITS ! INTEGER(kind=KINT),DIMENSION(8) :: MY_NEB ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: PARENT_CHILD_RATIO ! ! REAL(kind=KFPT) :: DLMD,DPHD,DYH,PDTOP,PT ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: ARRAY_1D ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_VM) :: VM_DOMAIN ! LOGICAL(kind=KLOG) :: I_AM_ACTIVE,RESTART ! LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: CHILD_ACTIVE ! TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN ! TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_NESTSET=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** Allocate the coupler's composite object to the total # of domains !*** for generality. Use the specific domain ID to access only that !*** part of the object that is pertinent to the given domain. This !*** is needed because any MPI task can be on more than one domain !*** and it must know which domain's variables to use. !----------------------------------------------------------------------- ! IF(.NOT.ASSOCIATED(CPL_COMPOSITE))THEN ALLOCATE(CPL_COMPOSITE(1:NUM_DOMAINS),stat=ISTAT) ! IF(ISTAT/=0)THEN WRITE(0,*)' Parent-Child composite object already allocated!' WRITE(0,*)' ABORTING!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** From the DOMAIN export state find out if this task is a forecast !*** task and if it is on a parent domain. Set them into the Parent- !*** Child coupler's export state s they are available. !----------------------------------------------------------------------- ! I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK I_AM_A_PARENT =>cc%I_AM_A_PARENT ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child CPL Setup: Extract Fcst-or-Write Flag from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='Fcst-or-Write Flag' & !<-- Name of the attribute to extract ,value=I_AM_A_FCST_TASK & !<-- Am I a forecast task? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Parent/Not-a-Parent Flag from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='I-Am-A-Parent Flag' & !<-- Name of the attribute to extract ,value=I_AM_A_PARENT & !<-- Am I on a nested domain? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent-Child CPL Setup: Insert Fcst-or-Write Flag into Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE_CPL_NEST & !<-- The P-C coupler export state ,name ='Fcst-or-Write Flag' & !<-- Name of the attribute to extract ,value=I_AM_A_FCST_TASK & !<-- Am I a forecast task? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Parent/Not-a-Parent Flag into Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE_CPL_NEST & !<-- The P-C coupler export state ,name ='I-Am-A-Parent Flag' & !<-- Name of the attribute to extract ,value=I_AM_A_PARENT & !<-- Am I on a nested domain? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------- !*** Current Domain's ID !------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Current Domain ID to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='MY_DOMAIN_ID' & !<-- Current domain's ID ,value=MY_DOMAIN_ID & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Retrieve this domain's VM !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Get the VM of this Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain Component ,vm =VM_DOMAIN & !<-- This domain's VM ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Now load key variables into the coupler's import state. !----------------------------------------------------------------------- ! !--------------------------------------------------- !*** The task's local rank in the Domain component !--------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Cpl Setup: Obtain the Local Task ID" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_VMGet(vm =VM_DOMAIN & !<-- The virtual machine for this Domain component ,localpet=MYPE_DOMAIN & !<-- Each MPI task rank in the Domain component ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Local Task Rank on Domain to P-C Cpl Imp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='MYPE_DOMAIN' & !<-- Local rank in Domain component ,value=MYPE_DOMAIN & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------- !*** Maximum number of domains !------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Max # of Domains to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='MAX_DOMAINS' & !<-- Maximum # of domains ,value=MAX_DOMAINS & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------- !*** Total Number of Domains !----------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Number of Domains to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NUM_DOMAINS' & !<-- Total number of domains ,value=NUM_DOMAINS & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------------------------------- !*** The association of domains and their configure files !---------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Domain/ConfigFile Association to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DOMAIN_ID_TO_RANK' & !<-- The association of domains and their config files ,itemCount=MAX_DOMAINS & !<-- Maximum # of domains ,valueList=DOMAIN_ID_TO_RANK & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------------------- !*** Total Number of Tasks on Domains !-------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Total Number of Tasks Per Domain to the P-C Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NTASKS_DOMAIN' & !<-- Number of fcst+quilt tasks on each domain ,itemCount=NUM_DOMAINS & !<-- Number of domains ,valueList=NTASKS_DOMAIN & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------- !*** Number of Fcst Tasks on Domains !------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Number of Fcst Tasks Per Domain to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='FTASKS_DOMAIN' & !<-- Number of forecast tasks on each domain ,itemCount=NUM_DOMAINS & !<-- Number of domains ,valueList=FTASKS_DOMAIN & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------- !*** Fundamental Timestep on Domains !------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Number of Fcst Tasks Per Domain to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DOMAIN_DTs' & !<-- Number of forecast tasks on each domain ,itemCount=NUM_DOMAINS & !<-- Number of domains ,valueList=DT & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------------- !*** Domain IDs of Parents !--------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Domain IDs of Parents to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='ID_PARENTS' & !<-- IDs of parent domain ,itemCount=NUM_DOMAINS & !<-- Number of domains ,valueList=ID_PARENTS_IN & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------ !*** Number of Children !------------------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Number of Children to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NUM_CHILDREN' & !<-- This DOMAIN component's # of children ,value=NUM_CHILDREN & !<-- Insert this into the import state ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------- !*** Communicators to Children !------------------------------- ! IF(NUM_CHILDREN>0)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Parent-to-Child Communicators to the Parent-Child CPL Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Parent-to-Child Comms' & !<-- Name of Attribute ,itemCount=NUM_CHILDREN & !<-- Length of inserted array ,valueList=COMM_TO_MY_CHILDREN & !<-- Communicators to my children ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! !---------------------------- !*** Communicator to Parent !---------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Child-to-Parent Communicator to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Child-to-Parent Comm' & !<-- Name of Attribute ,value=COMM_TO_MY_PARENT & !<-- The communicator to my parent ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------- !*** Communicator for each domain !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C CPL Setup: Get the Intracommunicator of this Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_VMGet(vm =VM_DOMAIN & !<-- This domain's VM ,mpiCommunicator=COMM_MY_DOMAIN & !<-- This domain's intracommunicator ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------------------------- !*** The intracommunicator for forecast tasks on this domain !------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C CPL Setup: Extract Fcst Task Intracomm from Domain Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract ,value=COMM_FCST_TASKS & !<-- Intracomm for fcst task on this domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add COMM_FCST_TASKS to Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Comm Fcst Tasks' & !<-- Name of Attribute ,value=COMM_FCST_TASKS & !<-- Intracomm for fcst task on this domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------- !*** Number of fcst tasks on this domain !----------------------------------------- ! NUM_PES_FCST=>cc%NUM_PES_FCST ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add NUM_PES_FCST to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NUM_PES_FCST' & !<-- The name of the Attribute ,value=NUM_PES_FCST & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NUM_PES_FCST' & !<-- Name of Attribute ,value=NUM_PES_FCST & !<-- The # of fcst tasks on this domain ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** The write/quilt tasks are no longer needed. !----------------------------------------------------------------------- ! IF(.NOT.I_AM_A_FCST_TASK)RETURN ! !----------------------------------------------------------------------- ! !-------------------------------------------------------- !*** Subdomain integration limits on the forecast tasks !-------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Integration Limits from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='ITS' & !<-- The name of the Attribute ,value=ITS & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='ITE' & !<-- The name of the Attribute ,value=ITE & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='JTS' & !<-- The name of the Attribute ,value=JTS & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='JTE' & !<-- The name of the Attribute ,value=JTE & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='LM' & !<-- The name of the Attribute ,value=LM & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NHALO' & !<-- The name of the Attribute ,value=NHALO & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Subdomain Integration Limits to the P-C Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='ITS' & !<-- The name of the Attribute ,value=ITS & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='ITE' & !<-- The name of the Attribute ,value=ITE & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='JTS' & !<-- The name of the Attribute ,value=JTS & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='JTE' & !<-- The name of the Attribute ,value=JTE & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LM' & !<-- The name of the Attribute ,value=LM & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NHALO' & !<-- The name of the Attribute ,value=NHALO & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------------------------------ !*** Subdomain integration limits for all fcst tasks on my domain !------------------------------------------------------------------ ! ! CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The DOMAIN component ,WRAP_DOMAIN & !<-- Extract the pointer to my DOMAIN internal state ,RC ) ! DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE !<-- Point at my DOMAIN internal state ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add All Fcst Task Integration Limits to the P-C Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LOCAL ISTART' & !<-- Name of Attribute ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) ,valueList=domain_int_state%LOCAL_ISTART & !<-- Starting I's on my domain's fcst tasks ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LOCAL IEND' & !<-- Name of Attribute ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) ,valueList=domain_int_state%LOCAL_IEND & !<-- Ending I's on my domain's fcst tasks ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LOCAL JSTART' & !<-- Name of Attribute ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) ,valueList=domain_int_state%LOCAL_JSTART & !<-- Starting J's on my domain's fcst tasks ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LOCAL JEND' & !<-- Name of Attribute ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) ,valueList=domain_int_state%LOCAL_JEND & !<-- Ending J's on my domain's fcst tasks ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------- !*** Full Domain Dimensions !---------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Full Domain Dimensions from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='IDS' & !<-- The name of the Attribute ,value=IDS & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='IDE' & !<-- The name of the Attribute ,value=IDE & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='JDS' & !<-- The name of the Attribute ,value=JDS & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='JDE' & !<-- The name of the Attribute ,value=JDE & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Full Domain Dimensions to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='IDS' & !<-- The name of the Attribute ,value=IDS & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='IDE' & !<-- The name of the Attribute ,value=IDE & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='JDS' & !<-- The name of the Attribute ,value=JDS & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='JDE' & !<-- The name of the Attribute ,value=JDE & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** My 8 neighboring tasks. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract MY_NEB from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='MY_NEB' & !<-- The name of the Attribute ,itemCount=N8 & !<-- # of words in data list ,valueList=MY_NEB & !<-- Put extracted values here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add MY_NEB to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='MY_NEB' & !<-- The name of the Attribute ,itemCount=N8 & !<-- # of words in data list ,valueList=MY_NEB & !<-- Put added values here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------------- !*** Frequency of physics calls !-------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract NPHS from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NPHS' & !<-- The name of the Attribute ,value=NPHS & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add NPHS to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NPHS' & !<-- The name of the Attribute ,value=NPHS & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------------------------- !*** Width of Boundary Blending Region !--------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Boundary Blending Region Widths from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='LNSH' & !<-- The name of the Attribute ,value=N_BLEND_H & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='LNSV' & !<-- The name of the Attribute ,value=N_BLEND_V & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Boundary Blending Region Widths to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='N_BLEND_H' & !<-- The name of the Attribute ,value=N_BLEND_H & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='N_BLEND_V' & !<-- The name of the Attribute ,value=N_BLEND_V & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------------- !*** Transfer SW Corner of Nest !-------------------------------- ! nests_only: IF(ID_PARENTS_IN(MY_DOMAIN_ID)>0)THEN !<-- If so, this domain is a nest. ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SW Corner of Nest from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='I_PAR_STA' & !<-- The name of the Attribute ,value=I_PAR_STA & !<-- The Attribute to be retrieved ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='J_PAR_STA' & !<-- The name of the Attribute ,value=J_PAR_STA & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add SW Corner of Nest to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='I_PAR_STA' & !<-- The name of the Attribute ,value=I_PAR_STA & !<-- The Attribute to be inserted ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='J_PAR_STA' & !<-- The name of the Attribute ,value=J_PAR_STA & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------- !*** Transfer the domain's storm center. !----------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Storm Center of Nest from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='Storm Center' & !<-- The name of the Attribute ,valueList=STORM_CENTER & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Storm Center of Nest to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Storm Center' & !<-- The name of the Attribute ,itemCount=2 & !<-- The # of words in the Attribute ,valueList=STORM_CENTER & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------- !*** Transfer the domain's last move timestep. !----------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Last Move Timestep from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='LAST_STEP_MOVED' & !<-- The name of the Attribute ,value=LAST_STEP_MOVED & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Next Move Timestep to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='LAST_STEP_MOVED' & !<-- The name of the Attribute ,value=LAST_STEP_MOVED & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------- !*** Transfer the domain's next move timestep. !----------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Next Move Timestep from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute ,value=cc%NEXT_MOVE_TIMESTEP & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Next Move Timestep to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute ,value=cc%NEXT_MOVE_TIMESTEP & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Cpl Setup: Extract NTRACK storm flag from Domain exp state." ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NTRACK' & !<-- The name of the Attribute ,value=cc%NTRACK & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="P-C Cpl Setup: Insert NTRACK storm flag into P-C Cpl imp state." ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NTRACK' & !<-- The name of the Attribute ,value=cc%NTRACK & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF nests_only ! !--------------------------- !*** Transfer restart flag !--------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Restart Flag from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='RESTART' & !<-- The name of the Attribute ,value=RESTART & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Restart Flag to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='RESTART' & !<-- The name of the Attribute ,value=RESTART & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------- !*** Transfer Sfc Geopotential !------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract FIS from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='FIS' & !<-- Extract FIS Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert FIS into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------- !*** Transfer geographic latitude !---------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLAT from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='GLAT' & !<-- Extract GLAT Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert GLAT into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------- !*** Transfer geographic longitude !----------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract GLON from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='GLON' & !<-- Extract GLON Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert GLON into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------------------------- !*** Transfer PT,PDTOP,PSGML1,SG1,SG2,SGML2,DSG2,PDSG1 !------------------------------------------------------- ! LMP1=LM+1 ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PT from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='PT' & !<-- Extract PT ,value=PT & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='PT' & !<-- Insert PT ,value=PT & !<-- Insert this value ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='PDTOP' & !<-- Extract PDTOP ,value=PDTOP & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='PDTOP' & !<-- Insert PDTOP ,value=PDTOP & !<-- Insert this value ,rc =RC) ! ALLOCATE(ARRAY_1D(1:LM)) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='PSGML1' & !<-- Extract PGMSL1 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='PSGML1' & !<-- Insert PGMSL1 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='SGML2' & !<-- Extract SGML2 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='SGML2' & !<-- Insert SGML2 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='DSG2' & !<-- Extract DSG2 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DSG2' & !<-- Insert DSG2 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='PDSG1' & !<-- Extract PDSG1 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='PDSG1' & !<-- Insert PDSG1 ,itemCount=LM & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! DEALLOCATE(ARRAY_1D) ! ALLOCATE(ARRAY_1D(1:LMP1)) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='SG1' & !<-- Extract SG1 ,itemCount=LMP1 & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='SG1' & !<-- Insert SG1 ,itemCount=LMP1 & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='SG2' & !<-- Extract SG2 ,itemCount=LMP1 & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='SG2' & !<-- Insert SG2 ,itemCount=LMP1 & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(ARRAY_1D) ! !------------------------ !*** Transfer DY and DX !------------------------ ! NKOUNT=JDE-JDS+1 ALLOCATE(ARRAY_1D(1:NKOUNT)) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DY,DX from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='DYH' & !<-- Extract DYH ,value=DYH & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DYH' & !<-- Insert DYH ,value=DYH & !<-- Insert this value ,rc =RC) ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='DXH' & !<-- Extract DXH ,itemCount=NKOUNT & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Put extracted values here ,rc =RC) ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DXH' & !<-- Insert DXH ,itemCount=NKOUNT & !<-- # of words in data list ,valueList=ARRAY_1D & !<-- Insert these values ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(ARRAY_1D) ! !------------------------ !*** Transfer DPHD,JM !------------------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DPHD,JM from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='DPHD' & !<-- Extract latitude grid increment (deg) ,value=DPHD & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DPHD' & !<-- Insert latitude grid increment (deg) ,value=DPHD & !<-- Insert this value ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='DLMD' & !<-- Extract longitude grid increment (deg) ,value=DLMD & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='DLMD' & !<-- Insert longitude grid increment (deg) ,value=DLMD & !<-- Insert this value ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='JM' & !<-- Extract DYH ,value=JM & !<-- Put the extracted value here ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='JM' & !<-- Insert DYH ,value=JM & !<-- Insert this value ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! parents_only: IF(I_AM_A_PARENT)THEN ! !----------------------------------------------------------------------- ! !---------------------------------------------- !*** Ratio of Domain's Timestep to Children's !---------------------------------------------- ! ALLOCATE(PARENT_CHILD_RATIO(1:NUM_CHILDREN)) ! DO N=1,NUM_CHILDREN PARENT_CHILD_RATIO(N)=NINT(DT(MY_DOMAIN_ID)/DT(CHILD_ID(N))) ENDDO ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Parent-Child DT Ratios to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Parent-Child Time Ratio' & !<-- Name of Attribute ,itemCount=NUM_CHILDREN & !<-- Length of inserted array ,valueList=PARENT_CHILD_RATIO & !<-- The communicator to my parent ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(PARENT_CHILD_RATIO) ! !------------------------------- !*** The Children's Domain IDs !------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Domain IDs of Children to Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='CHILD_IDs' & !<-- Name of Attribute ,itemCount=NUM_CHILDREN & !<-- Length of inserted array ,valueList=CHILD_ID & !<-- The children's IDs of this ATM Component ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF parents_only ! !----------------------------------------------------------------------- !*** Now transfer the parent's prognostic arrays from the DOMAIN export !*** state to the Parent-Child coupler import state that will be !*** required for the children's boundary data. !----------------------------------------------------------------------- ! !----------------- !*** Transfer PD !----------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PD Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='PD' & !<-- Extract PD Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert PD into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------------------- !*** Transfer Layer Interface Pressures !---------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PINT Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='PINT' & !<-- Extract PINT Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert PINT into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------- !*** Transfer Temperature !-------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract T Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='T' & !<-- Extract T Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert T into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------- !*** Transfer U Wind !--------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract U Wind Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='U' & !<-- Extract U Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert U into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------- !*** Transfer V Wind !--------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract V Wind Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='V' & !<-- Extract V Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert V into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------- !*** Transfer Midlayer Z !------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Midlyaer Z Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='Z' & !<-- Extract midlayer Z Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Midlayer Z into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------- !*** Transfer TRACERS Field !---------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Tracers Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='TRACERS' & !<-- Extract TRACERS Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Tracers into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------- !*** Transfer Sea Mask Field !----------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract SM Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='SM' & !<-- Extract Seas Mask Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert SM into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !--------------------- !*** Transfer INDX_Q !--------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract INDX_Q from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='INDX_Q' & !<-- Name of Attribute to extract ,value=INDX_Q & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert INDX_Q into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='INDX_Q' & !<-- The name of the Attribute to insert ,value=INDX_Q & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------- !*** Transfer INDX_CW !---------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract INDX_CW from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='INDX_CW' & !<-- Name of Attribute to extract ,value=INDX_CW & !<-- Put the extracted Attribute here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert INDX_CW into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='INDX_CW' & !<-- The name of the Attribute to insert ,value=INDX_CW & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------ !*** Transfer 10-m U wind component !------------------------------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract U10 Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='U10' & !<-- Extract U10 Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert U10 into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !------------------------------------ !*** Transfer 10-m V wind component !------------------------------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract V10 Field from Parent DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName='V10' & !<-- Extract V10 Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert V10 into Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/HOLD_FIELD/) & !<-- The Field to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** All parent tasks need to know the local subdomain limits of each !*** task on their children. !----------------------------------------------------------------------- ! LIMITS(1)=ITS LIMITS(2)=ITE LIMITS(3)=JTS LIMITS(4)=JTE ! !----------------------------------------------------------------------- !*** Child tasks send their subdomain limits to parent task 0. !----------------------------------------------------------------------- ! IF(COMM_TO_MY_PARENT/=-999)THEN !<-- Select child tasks CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain my local rank in parent-child intracomm NTAG=MYPE+9999 ! CALL MPI_SEND(LIMITS & !<-- Child task sends its subdomain limits ,4 & !<-- # of indices sent ,MPI_INTEGER & !<-- Indices are integers ,0 & !<-- Indices sent to parent fcst task 0 ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between parent and child ,IERR) ENDIF ! !----------------------------------------------------------------------- !*** Rank 0 parent tasks recv their children's tasks' subdomain limits !*** then send the children the integration limits of every fcst task !*** on the parent domain. !----------------------------------------------------------------------- ! ID=MY_DOMAIN_ID ! IF(I_AM_A_PARENT)THEN ! ALLOCATE(CTASK_LIMITS(ID)%CHILDREN(1:NUM_CHILDREN)) ! ALLOCATE(HANDLE_CHILD_LIMITS(ID)%CHILDREN(1:NUM_CHILDREN)) ! DO N=1,NUM_CHILDREN ID_CHILD=CHILD_ID(N) ! ALLOCATE(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1:4,1:FTASKS_DOMAIN(ID_CHILD)),stat=IERR) !<-- Pointer to hold each child task's ! subdomain limits IF(IERR/=0)WRITE(0,*)' Failed to allocate CTASK_LIMITS' ! CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(N),MYPE,IERR) !<-- Obtain the ranks of parent tasks ! HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA=>NULL() ! IF(MYPE==0)THEN ! ALLOCATE(HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA(1:FTASKS_DOMAIN(ID_CHILD))) ! DO NN=1,FTASKS_DOMAIN(ID_CHILD) CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN-1) !<-- Local rank of child task NN in p-c intracomm NTAG=CHILDTASK+9999 CALL MPI_IRECV(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1,NN) & !<-- Subdomain limits of fcst task NN on child N ,4 & !<-- # of index limits received ,MPI_INTEGER & !<-- Indices are integers ,CHILDTASK & !<-- Local rank of child task NN (the sender) in p-c intracomm ,NTAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N ,HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA(NN) & ,IERR) ENDDO ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- !*** Create then transfer the object holding the domain's children's !*** next move timesteps if this is a restarted run. !----------------------------------------------------------------------- ! ALLOCATE(cc%NTIMESTEP_CHILD_MOVES(1:NUM_DOMAINS_MAX),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NTIMESTEP_CHILD_MOVES stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NTIMESTEP_CHILD_MOVES=>cc%NTIMESTEP_CHILD_MOVES ! DO N=1,NUM_DOMAINS_MAX NTIMESTEP_CHILD_MOVES(N)=-999 ENDDO ! IF(RESTART)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Next Move Timestep of Children from DOMAIN Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- The name of the Attribute ,valueList=NTIMESTEP_CHILD_MOVES & !<-- The Attribute to be retrieved ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add Next Move Timestep of Children to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- The name of the Attribute ,itemCount=NUM_DOMAINS_MAX & !<-- The number of items ,valueList=cc%NTIMESTEP_CHILD_MOVES & !<-- The Attribute to be inserted ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- !*** The Parent-Child coupler needs the pointers to the Solver !*** internal state variables that are updated on the child !*** boundaries by the parents. The Bundle holding those pointers !*** is in the Domain component's export state. Transfer the !*** Bundle to the P-C coupler's import state. !----------------------------------------------------------------------- ! ! get_bc_bundle: IF(I_AM_A_FCST_TASK)THEN BUNDLE_NESTBC=>cc%BUNDLE_NESTBC ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Bundle of Nest BC Vbls from Domain Exp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName ='Bundle_nestbc' & !<-- Bundle of Solver internal state pointers for nest BC vbls ,fieldbundle=BUNDLE_NESTBC & !<-- Put the extracted Bundle here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Bundle of Nest BC Vbls into P-C Coupler Imp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/BUNDLE_NESTBC/) & !<-- The Bundle of Solver int state pointers for nest BC vbls ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** The Parent-Child coupler also needs to know the # of H-pt and !*** V-pt boundary variables. Transfer those values. !----------------------------------------------------------------------- ! NVARS_BC_2D_H=>cc%NVARS_BC_2D_H NVARS_BC_3D_H=>cc%NVARS_BC_3D_H NVARS_BC_4D_H=>cc%NVARS_BC_4D_H ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of H-pt Nest Bndry Vrbls from Domain Exp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NVARS_BC_2D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NVARS_BC_3D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NVARS_BC_4D_H' & !<-- Name of Attribute to extract ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NVARS_BC_2D_V=>cc%NVARS_BC_2D_V NVARS_BC_3D_V=>cc%NVARS_BC_3D_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of V-pt Nest Bndry Vrbls from Domain Exp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NVARS_BC_2D_V' & !<-- Name of Attribute to extract ,value=NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NVARS_BC_3D_V' & !<-- Name of Attribute to extract ,value=NVARS_BC_3D_V & !<-- # of 3-D V-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert # of H-pt Nest Bndry Vrbls into P-C Imp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NVARS_BC_2D_H' & !<-- The name of the Attribute to insert ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NVARS_BC_3D_H' & !<-- The name of the Attribute to insert ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NVARS_BC_4D_H' & !<-- The name of the Attribute to insert ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert # of V-pt Nest Bndry Vrbls into P-C Imp State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NVARS_BC_2D_V' & !<-- The name of the Attribute to insert ,value=NVARS_BC_2D_V & !<-- # of 2-D H-pt boundary variables ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='NVARS_BC_3D_V' & !<-- The name of the Attribute to insert ,value=NVARS_BC_3D_V & !<-- # of 3-D H-pt boundary variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** How many total model layers are involved with all H-pt and V-pt !*** boundary variables? Tansfer that information to the Parent- !*** Child coupler for use in allocating working objects. !----------------------------------------------------------------------- ! NLEV_H=>cc%NLEV_H NLEV_V=>cc%NLEV_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of Model Lyrs in all Nest Bndry Vrbls" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NLEV_H' & !<-- Name of Attribute to extract ,value=NLEV_H & !<-- # of model layers for all H-pt BC variables ,rc =RC) ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='NLEV_V' & !<-- Name of Attribute to extract ,value=NLEV_V & !<-- # of model layers for all V-pt BC variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Set # of Model Lyrs in all Nest Bndry Vrbls" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state ,name ='NLEV_H' & !<-- Name of Attribute to extract ,value=NLEV_H & !<-- # of model layers for all H-pt BC variables ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state ,name ='NLEV_V' & !<-- Name of Attribute to extract ,value=NLEV_V & !<-- # of model layers for all V-pt BC variables ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF get_bc_bundle ! !----------------------------------------------------------------------- !*** If there are moving nests then their parents need the Bundles !*** of 2-D and 3-D variables in the Solver internal state that !*** need to be updated after the nests move. The Bundles are !*** unloaded from the DOMAIN export state and loaded into the !*** Parent-Child coupler import state. If there are no moving !*** nests then the Bundles are empty. !----------------------------------------------------------------------- ! MOVE_BUNDLE_H=>cc%MOVE_BUNDLE_H MOVE_BUNDLE_V=>cc%MOVE_BUNDLE_V ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Bundles for Moving Nests from Domain Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName ='Move_Bundle H' & !<-- Name of Bundle of internal state H arrays ,fieldbundle=MOVE_BUNDLE_H & !<-- Put the extracted Bundle here ,rc =RC) ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName ='Move_Bundle V' & !<-- Name of Bundle of internal state V arrays ,fieldbundle=MOVE_BUNDLE_V & !<-- Put the extracted Bundle here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert Bundle for Moving Nests into P-C Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/MOVE_BUNDLE_H/) & !<-- The Bundle of internal state H arrays to update ,rc =RC) ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/MOVE_BUNDLE_V/) & !<-- The Bundle of internal state V arrays to update ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** If 2-way nesting is being used then an ESMF Bundle is used !*** to hold pointers to the Solver component's internal state !*** variables which are interpolated by the child to its parent's !*** grid then sent to the parent. Unload the 2-way Bundle from !*** the Domain component's export state and load it into the !*** parent-Child coupler's import state. If 2-way nesting has !*** not been selected by the user then the 2-way Bundle is !*** still present but is empty. !----------------------------------------------------------------------- ! BUNDLE_2WAY=>cc%BUNDLE_2WAY ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract 2-way Bundle from Domain Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,itemName ='Bundle_2way' & !<-- Bundle of Solver internal state pointers for 2-way exch ,fieldbundle=BUNDLE_2WAY & !<-- Put the extracted Bundle here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Insert 2-way Bundle into P-C Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,(/BUNDLE_2WAY/) & !<-- The Bundle of Solver internal state pointers for 2-way exch ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Transfer the flags indicating whether a domain and any of its !*** children are active in the digital filtering. !----------------------------------------------------------------------- ! IF(I_AM_A_FCST_TASK)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract DFI flag for this domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='I Am Active' & !<-- Name of Attribute to extract ,value=I_AM_ACTIVE & !<-- Does this domain participate in digital filtering? ,rc =RC) ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state ,name ='I Am Active' & !<-- Name of Attribute to set. ,value=I_AM_ACTIVE & !<-- Does this domain participate in digital filtering? ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(NUM_CHILDREN>0)THEN ALLOCATE(CHILD_ACTIVE(1:NUM_CHILDREN)) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract child DFI flags from Domain export state" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state ,name ='Child Active' & !<-- The name of the Attribute ! ,itemCount=NUM_CHILDREN & !<-- # of words in data list ,valueList=CHILD_ACTIVE & !<-- Put extracted values here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Add child DFI flags to the Parent-Child Cpl Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state ,name ='Child Active' & !<-- The name of the Attribute ,itemCount=NUM_CHILDREN & !<-- # of words in data list ,valueList=CHILD_ACTIVE & !<-- Put added values here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(CHILD_ACTIVE) ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_COUPLER_SETUP ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Tasks point into the Parent-Child coupler's composite object !*** in order to access coupler variables valid for the current !*** domain. This is an internal subroutine of !*** PARENT_CHILD_CPL_INITIALIZE. !----------------------------------------------------------------------- ! INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID ! !----------------------------------------------------------------------- ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- ! ! NCYCLE_CHILD =>cc%NCYCLE_CHILD NCYCLE_PARENT=>cc%NCYCLE_PARENT ! I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK ! COMM_TO_MY_PARENT =>cc%COMM_TO_MY_PARENT I_CENTER_CURRENT =>cc%I_CENTER_CURRENT I_SHIFT_CHILD =>cc%I_SHIFT_CHILD J_SHIFT_CHILD =>cc%J_SHIFT_CHILD I_SW_PARENT_CURRENT =>cc%I_SW_PARENT_CURRENT I_SW_PARENT_NEW =>cc%I_SW_PARENT_NEW J_CENTER_CURRENT =>cc%J_CENTER_CURRENT J_SW_PARENT_CURRENT =>cc%J_SW_PARENT_CURRENT J_SW_PARENT_NEW =>cc%J_SW_PARENT_NEW ITS =>cc%ITS ITE =>cc%ITE JTS =>cc%JTS JTE =>cc%JTE JM =>cc%JM LM =>cc%LM IMS =>cc%IMS IME =>cc%IME JMS =>cc%JMS JME =>cc%JME IDS =>cc%IDS IDE =>cc%IDE JDS =>cc%JDS JDE =>cc%JDE IM_1 =>cc%IM_1 JM_1 =>cc%JM_1 INPES =>cc%INPES JNPES =>cc%JNPES INPES_PARENT =>cc%INPES_PARENT JNPES_PARENT =>cc%JNPES_PARENT KOUNT_2WAY_CHILDREN =>cc%KOUNT_2WAY_CHILDREN LAST_STEP_MOVED =>cc%LAST_STEP_MOVED MAX_SHIFT =>cc%MAX_SHIFT MYPE =>cc%MYPE N_BLEND_H =>cc%N_BLEND_H N_BLEND_V =>cc%N_BLEND_V N_STENCIL_H =>cc%N_STENCIL_H N_STENCIL_V =>cc%N_STENCIL_V N_STENCIL_SFC_H =>cc%N_STENCIL_SFC_H N_STENCIL_SFC_V =>cc%N_STENCIL_SFC_V NLEV_H =>cc%NLEV_H NLEV_V =>cc%NLEV_V NHALO =>cc%NHALO NPHS =>cc%NPHS NTASKS_UPDATE_PARENT =>cc%NTASKS_UPDATE_PARENT NTIMESTEP_CHECK =>cc%NTIMESTEP_CHECK NTIMESTEP_FINAL =>cc%NTIMESTEP_FINAL NTOT_SFC =>cc%NTOT_SFC NTIMESTEPS_RESTART =>cc%NTIMESTEPS_RESTART NTRACK =>cc%NTRACK NUM_CHILDREN =>cc%NUM_CHILDREN NUM_2WAY_CHILDREN =>cc%NUM_2WAY_CHILDREN NUM_MOVING_CHILDREN =>cc%NUM_MOVING_CHILDREN NUM_PES_FCST =>cc%NUM_PES_FCST NUM_FCST_TASKS_PARENT=>cc%NUM_FCST_TASKS_PARENT NUM_TASKS_PARENT =>cc%NUM_TASKS_PARENT NEXT_MOVE_TIMESTEP =>cc%NEXT_MOVE_TIMESTEP NUM_LEVELS_MOVE_3D_H =>cc%NUM_LEVELS_MOVE_3D_H NUM_LEVELS_MOVE_3D_V =>cc%NUM_LEVELS_MOVE_3D_V NUM_SPACE_RATIOS_MVG =>cc%NUM_SPACE_RATIOS_MVG NVARS_BC_2D_H =>cc%NVARS_BC_2D_H NVARS_BC_3D_H =>cc%NVARS_BC_3D_H NVARS_BC_4D_H =>cc%NVARS_BC_4D_H NVARS_BC_2D_V =>cc%NVARS_BC_2D_V SPACE_RATIO_MY_PARENT=>cc%SPACE_RATIO_MY_PARENT TIME_RATIO_MY_PARENT =>cc%TIME_RATIO_MY_PARENT ! NTIMESTEP_WAIT_PARENT =>cc%NTIMESTEP_WAIT_PARENT NTIMESTEP_WAIT_FORCED_PARENT=>cc%NTIMESTEP_WAIT_FORCED_PARENT PARENT_WANTS_TO_MOVE =>cc%PARENT_WANTS_TO_MOVE ! LBND_4D=>cc%LBND_4D UBND_4D=>cc%UBND_4D ! LOCAL_ISTART=>cc%LOCAL_ISTART LOCAL_IEND =>cc%LOCAL_IEND LOCAL_JSTART=>cc%LOCAL_JSTART LOCAL_JEND =>cc%LOCAL_JEND ! MY_DOMAIN_LIMITS =>cc%MY_DOMAIN_LIMITS MY_FORCED_SHIFT =>cc%MY_FORCED_SHIFT MY_NEB =>cc%MY_NEB PARENT_DOMAIN_LIMITS=>cc%PARENT_DOMAIN_LIMITS PARENT_SHIFT =>cc%PARENT_SHIFT STORM_CENTER =>cc%STORM_CENTER ! PARENT_CHILD_SPACE_RATIO =>cc%PARENT_CHILD_SPACE_RATIO TIME_RATIO_MY_CHILDREN =>cc%TIME_RATIO_MY_CHILDREN IM_CHILD =>cc%IM_CHILD JM_CHILD =>cc%JM_CHILD I_PARENT_SW =>cc%I_PARENT_SW J_PARENT_SW =>cc%J_PARENT_SW ITE_PARENT =>cc%ITE_PARENT ITS_PARENT =>cc%ITS_PARENT JTE_PARENT =>cc%JTE_PARENT JTS_PARENT =>cc%JTS_PARENT LINK_MRANK_RATIO =>cc%LINK_MRANK_RATIO LIST_OF_RATIOS =>cc%LIST_OF_RATIOS M_NEST_RATIO =>cc%M_NEST_RATIO N_STENCIL_H_CHILD =>cc%N_STENCIL_H_CHILD N_STENCIL_V_CHILD =>cc%N_STENCIL_V_CHILD N_STENCIL_SFC_H_CHILD =>cc%N_STENCIL_SFC_H_CHILD N_STENCIL_SFC_V_CHILD =>cc%N_STENCIL_SFC_V_CHILD N_BLEND_H_CHILD =>cc%N_BLEND_H_CHILD N_BLEND_V_CHILD =>cc%N_BLEND_V_CHILD CHILD_2WAY_WGT =>cc%CHILD_2WAY_WGT NTASKS_UPDATE_CHILD =>cc%NTASKS_UPDATE_CHILD NSTEP_CHILD_RECV =>cc%NSTEP_CHILD_RECV INC_FIX =>cc%INC_FIX COMM_TO_MY_CHILDREN =>cc%COMM_TO_MY_CHILDREN ID_PARENTS =>cc%ID_PARENTS ID_PARENT_UPDATE_TASKS =>cc%ID_PARENT_UPDATE_TASKS MY_CHILDREN_ID =>cc%MY_CHILDREN_ID RANK_2WAY_CHILD =>cc%RANK_2WAY_CHILD RANK_MOVING_CHILD =>cc%RANK_MOVING_CHILD FTASKS_DOMAIN =>cc%FTASKS_DOMAIN NTASKS_DOMAIN =>cc%NTASKS_DOMAIN NPTS_UPDATE_ON_PARENT_TASKS=>cc%NPTS_UPDATE_ON_PARENT_TASKS HANDLE_BC_UPDATE =>cc%HANDLE_BC_UPDATE HANDLE_MOVE_FLAG =>cc%HANDLE_MOVE_FLAG HANDLE_PARENT_SHIFT =>cc%HANDLE_PARENT_SHIFT HANDLE_SEND_2WAY_DATA =>cc%HANDLE_SEND_2WAY_DATA HANDLE_SEND_2WAY_SFC =>cc%HANDLE_SEND_2WAY_SFC HANDLE_SEND_2WAY_SIGNAL =>cc%HANDLE_SEND_2WAY_SIGNAL HANDLE_SEND_ALLCLEAR =>cc%HANDLE_SEND_ALLCLEAR HANDLE_TIMESTEP =>cc%HANDLE_TIMESTEP NTIMESTEP_CHILD_MOVES =>cc%NTIMESTEP_CHILD_MOVES SHIFT_INFO_MINE =>cc%SHIFT_INFO_MINE ! SHIFT_INFO_CHILDREN=>cc%SHIFT_INFO_CHILDREN ! NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E NUM_TASKS_SEND_V_S=>cc%NUM_TASKS_SEND_V_S NUM_TASKS_SEND_V_N=>cc%NUM_TASKS_SEND_V_N NUM_TASKS_SEND_V_W=>cc%NUM_TASKS_SEND_V_W NUM_TASKS_SEND_V_E=>cc%NUM_TASKS_SEND_V_E ! CENTERS_DISTANCE=>cc%CENTERS_DISTANCE DLM =>cc%DLM DPH =>cc%DPH DYH =>cc%DYH PDTOP =>cc%PDTOP PT =>cc%PT SB_1 =>cc%SB_1 WB_1 =>cc%WB_1 TPH0_1 =>cc%TPH0_1 TLM0_1 =>cc%TLM0_1 RECIP_DPH_1 =>cc%RECIP_DPH_1 RECIP_DLM_1 =>cc%RECIP_DLM_1 RECIP_PARENT_SPACE_RATIO=>cc%RECIP_PARENT_SPACE_RATIO ! DT_DOMAIN=>cc%DT_DOMAIN DXH =>cc%DXH DSG2 =>cc%DSG2 PDSG1 =>cc%PDSG1 PSGML1 =>cc%PSGML1 SG1 =>cc%SG1 SG2 =>cc%SG2 SGML2 =>cc%SGML2 ! CHILD_PARENT_SPACE_RATIO=>cc%CHILD_PARENT_SPACE_RATIO ! BOUND_1D_SOUTH_H=>cc%BOUND_1D_SOUTH_H BOUND_1D_SOUTH_V=>cc%BOUND_1D_SOUTH_V BOUND_1D_NORTH_H=>cc%BOUND_1D_NORTH_H BOUND_1D_NORTH_V=>cc%BOUND_1D_NORTH_V BOUND_1D_WEST_H =>cc%BOUND_1D_WEST_H BOUND_1D_WEST_V =>cc%BOUND_1D_WEST_V BOUND_1D_EAST_H =>cc%BOUND_1D_EAST_H BOUND_1D_EAST_V =>cc%BOUND_1D_EAST_V ! FIS =>cc%FIS FIS_CHILD_ON_PARENT=>cc%FIS_CHILD_ON_PARENT GLAT =>cc%GLAT GLON =>cc%GLON PD =>cc%PD SM =>cc%PD U10 =>cc%U10 V10 =>cc%V10 ! PDB_S=>cc%PDB_S PDB_N=>cc%PDB_N PDB_W=>cc%PDB_W PDB_E=>cc%PDB_E ! CW =>cc%CW PINT=>cc%PINT Q =>cc%Q T =>cc%T U =>cc%U V =>cc%V Z =>cc%Z ! TRACERS=>cc%TRACERS ! STATIC_OR_MOVING=>cc%STATIC_OR_MOVING ! ALLCLEAR_SIGNAL_PRESENT =>cc%ALLCLEAR_SIGNAL_PRESENT CALLED_CHILD_2WAY_BOOKKEEPING=>cc%CALLED_CHILD_2WAY_BOOKKEEPING FIRST_CALL_RECV_2WAY =>cc%FIRST_CALL_RECV_2WAY FIRST_CALL_RECV_BC =>cc%FIRST_CALL_RECV_BC FORCED_PARENT_SHIFT =>cc%FORCED_PARENT_SHIFT I_AM_ACTIVE =>cc%I_AM_ACTIVE I_AM_LEAD_FCST_TASK =>cc%I_AM_LEAD_FCST_TASK I_WANT_TO_MOVE =>cc%I_WANT_TO_MOVE MOVE_FLAG_SENT =>cc%MOVE_FLAG_SENT MY_DOMAIN_MOVES =>cc%MY_DOMAIN_MOVES MY_PARENT_MOVES =>cc%MY_PARENT_MOVES ! CALLED_PARENT_2WAY_BOOKKEEPING=>cc%CALLED_PARENT_2WAY_BOOKKEEPING CHILD_ACTIVE =>cc%CHILD_ACTIVE CHILD_FORCES_MY_SHIFT =>cc%CHILD_FORCES_MY_SHIFT MOVE_FLAG =>cc%MOVE_FLAG SEND_CHILD_DATA =>cc%SEND_CHILD_DATA SIGNAL_2WAY_SEND_READY=>cc%SIGNAL_2WAY_SEND_READY SKIP_2WAY_UPDATE =>cc%SKIP_2WAY_UPDATE ! I_2WAY_UPDATE=>cc%I_2WAY_UPDATE J_2WAY_UPDATE=>cc%J_2WAY_UPDATE ! I_2WAY_H=>cc%I_2WAY_H J_2WAY_H=>cc%J_2WAY_H I_2WAY_V=>cc%I_2WAY_V J_2WAY_V=>cc%J_2WAY_V ! WORDS_BOUND_H_SOUTH =>cc%WORDS_BOUND_H_SOUTH WORDS_BOUND_H_NORTH =>cc%WORDS_BOUND_H_NORTH WORDS_BOUND_H_WEST =>cc%WORDS_BOUND_H_WEST WORDS_BOUND_H_EAST =>cc%WORDS_BOUND_H_EAST ! WORDS_BOUND_V_SOUTH=>cc%WORDS_BOUND_V_SOUTH WORDS_BOUND_V_NORTH=>cc%WORDS_BOUND_V_NORTH WORDS_BOUND_V_WEST =>cc%WORDS_BOUND_V_WEST WORDS_BOUND_V_EAST =>cc%WORDS_BOUND_V_EAST ! CHILD_SFC_ON_PARENT=>cc%CHILD_SFC_ON_PARENT UPDATE_PARENT_2WAY=>cc%UPDATE_PARENT_2WAY ! NEST_FIS_ON_PARENT =>cc%NEST_FIS_ON_PARENT NEST_FIS_V_ON_PARENT=>cc%NEST_FIS_V_ON_PARENT ! PD_B_SOUTH=>cc%PD_B_SOUTH PD_B_NORTH=>cc%PD_B_NORTH PD_B_WEST =>cc%PD_B_WEST PD_B_EAST =>cc%PD_B_EAST ! PD_B_SOUTH_V=>cc%PD_B_SOUTH_V PD_B_NORTH_V=>cc%PD_B_NORTH_V PD_B_WEST_V =>cc%PD_B_WEST_V PD_B_EAST_V =>cc%PD_B_EAST_V ! MY_BC_VARS_H_S=>cc%MY_BC_VARS_H_S MY_BC_VARS_H_N=>cc%MY_BC_VARS_H_N MY_BC_VARS_H_W=>cc%MY_BC_VARS_H_W MY_BC_VARS_H_E=>cc%MY_BC_VARS_H_E MY_BC_VARS_V_S=>cc%MY_BC_VARS_V_S MY_BC_VARS_V_N=>cc%MY_BC_VARS_V_N MY_BC_VARS_V_W=>cc%MY_BC_VARS_V_W MY_BC_VARS_V_E=>cc%MY_BC_VARS_V_E ! BND_VAR_H_SOUTH=>cc%BND_VAR_H_SOUTH BND_VAR_H_NORTH=>cc%BND_VAR_H_NORTH BND_VAR_H_WEST =>cc%BND_VAR_H_WEST BND_VAR_H_EAST =>cc%BND_VAR_H_EAST BND_VAR_V_SOUTH=>cc%BND_VAR_V_SOUTH BND_VAR_V_NORTH=>cc%BND_VAR_V_NORTH BND_VAR_V_WEST =>cc%BND_VAR_V_WEST BND_VAR_V_EAST =>cc%BND_VAR_V_EAST ! FIS_CHILD_SOUTH=>cc%FIS_CHILD_SOUTH FIS_CHILD_NORTH=>cc%FIS_CHILD_NORTH FIS_CHILD_WEST =>cc%FIS_CHILD_WEST FIS_CHILD_EAST =>cc%FIS_CHILD_EAST ! CHILD_BOUND_H_SOUTH=>cc%CHILD_BOUND_H_SOUTH CHILD_BOUND_H_NORTH=>cc%CHILD_BOUND_H_NORTH CHILD_BOUND_H_WEST =>cc%CHILD_BOUND_H_WEST CHILD_BOUND_H_EAST =>cc%CHILD_BOUND_H_EAST CHILD_BOUND_V_SOUTH=>cc%CHILD_BOUND_V_SOUTH CHILD_BOUND_V_NORTH=>cc%CHILD_BOUND_V_NORTH CHILD_BOUND_V_WEST =>cc%CHILD_BOUND_V_WEST CHILD_BOUND_V_EAST =>cc%CHILD_BOUND_V_EAST ! NEST_FIS_ON_PARENT_BNDS=>cc%NEST_FIS_ON_PARENT_BNDS ! INDX_MAX_H=>cc%INDX_MAX_H INDX_MAX_V=>cc%INDX_MAX_V INDX_MIN_H=>cc%INDX_MIN_H INDX_MIN_V=>cc%INDX_MIN_V ! NUM_PARENT_TASKS_SENDING_H=>cc%NUM_PARENT_TASKS_SENDING_H NUM_PARENT_TASKS_SENDING_V=>cc%NUM_PARENT_TASKS_SENDING_V ! CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS CHILDTASK_BNDRY_V_RANKS=>cc%CHILDTASK_BNDRY_V_RANKS ! CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE CHILDTASK_V_SAVE=>cc%CHILDTASK_V_SAVE ! PARENT_4_INDICES_H=>cc%PARENT_4_INDICES_H PARENT_4_INDICES_V=>cc%PARENT_4_INDICES_V ! PARENT_4_WEIGHTS_H=>cc%PARENT_4_WEIGHTS_H PARENT_4_WEIGHTS_V=>cc%PARENT_4_WEIGHTS_V ! PARENT_TASK=>cc%PARENT_TASK ! HANDLE_MOVE_DATA=>cc%HANDLE_MOVE_DATA ! HANDLE_H_SOUTH=>cc%HANDLE_H_SOUTH HANDLE_H_NORTH=>cc%HANDLE_H_NORTH HANDLE_H_WEST =>cc%HANDLE_H_WEST HANDLE_H_EAST =>cc%HANDLE_H_EAST HANDLE_V_SOUTH=>cc%HANDLE_V_SOUTH HANDLE_V_NORTH=>cc%HANDLE_V_NORTH HANDLE_V_WEST =>cc%HANDLE_V_WEST HANDLE_V_EAST =>cc%HANDLE_V_EAST ! CF_PARENT=>cc%CF_PARENT CF_MINE =>cc%CF_MINE CF =>cc%CF ! BUNDLE_2WAY =>cc%BUNDLE_2WAY BUNDLE_NESTBC=>cc%BUNDLE_NESTBC MOVE_BUNDLE_H=>cc%MOVE_BUNDLE_H MOVE_BUNDLE_V=>cc%MOVE_BUNDLE_V ! cpl1_prelim_tim =>cc%cpl1_prelim_tim cpl1_south_h_tim=>cc%cpl1_south_h_tim cpl1_south_v_tim=>cc%cpl1_south_v_tim cpl1_north_h_tim=>cc%cpl1_north_h_tim cpl1_north_v_tim=>cc%cpl1_north_v_tim cpl1_west_h_tim =>cc%cpl1_west_h_tim cpl1_west_v_tim =>cc%cpl1_west_v_tim cpl1_east_h_tim =>cc%cpl1_east_h_tim cpl1_east_v_tim =>cc%cpl1_east_v_tim cpl1_recv_tim =>cc%cpl1_recv_tim cpl1_south_h_recv_tim=>cc%cpl1_south_h_recv_tim cpl1_south_h_undo_tim=>cc%cpl1_south_h_undo_tim cpl1_south_h_exp_tim =>cc%cpl1_south_h_exp_tim cpl1_south_v_recv_tim=>cc%cpl1_south_v_recv_tim cpl1_south_v_undo_tim=>cc%cpl1_south_v_undo_tim cpl1_south_v_exp_tim =>cc%cpl1_south_v_exp_tim cpl2_comp_tim =>cc%cpl2_comp_tim cpl2_send_tim =>cc%cpl2_send_tim cpl2_wait_tim =>cc%cpl2_wait_tim moving_nest_bookkeep_tim=>cc%moving_nest_bookkeep_tim moving_nest_update_tim =>cc%moving_nest_update_tim parent_bookkeep_moving_tim=>cc%parent_bookkeep_moving_tim parent_update_moving_tim =>cc%parent_update_moving_tim t0_recv_move_tim =>cc%t0_recv_move_tim read_moving_child_topo_tim =>cc%read_moving_child_topo_tim barrier_move_tim =>cc%barrier_move_tim pscd_tim=>cc%pscd_tim pscd1_tim=>cc%pscd1_tim pscd2_tim=>cc%pscd2_tim pscd3_tim=>cc%pscd3_tim pscd4_tim=>cc%pscd4_tim ja1_tim=>cc%ja1_tim ja2_tim=>cc%ja2_tim ja3_tim=>cc%ja3_tim ja4_tim=>cc%ja4_tim jat_tim=>cc%jat_tim ! !---------------------------------------- !*** The following are for moving nests !---------------------------------------- ! I_EAST_M=>cc%I_EAST_M I_WEST_M=>cc%I_WEST_M J_NORTH_M=>cc%J_NORTH_M J_SOUTH_M=>cc%J_SOUTH_M ! I_MAX=>cc%I_MAX I_MIN=>cc%I_MIN J_MAX=>cc%J_MAX J_MIN=>cc%J_MIN ! NPTS_NS=>cc%NPTS_NS NPTS_WE=>cc%NPTS_WE ! I_PG=>cc%I_PG J_PG=>cc%J_PG ! COEF=>cc%COEF RNPTS_HZ=>cc%RNPTS_HZ ELAPSED_TIME_MIN=>cc%ELAPSED_TIME_MIN ! FIRST_PASS_M =>cc%FIRST_PASS_M FIRST_STEP_2WAY=>cc%FIRST_STEP_2WAY IN_WINDOW =>cc%IN_WINDOW STOP_MY_MOTION =>cc%STOP_MY_MOTION ! I_HOLD_CENTER_POINT=>cc%I_HOLD_CENTER_POINT I_HOLD_PG_POINT=>cc%I_HOLD_PG_POINT ! MOVING_CHILD_UPDATE=>cc%MOVING_CHILD_UPDATE TASK_UPDATE_SPECS=>cc%TASK_UPDATE_SPECS ! MOVE_TYPE=>CC%MOVE_TYPE ! MOVE_INTERVAL_MINUTES=>CC%MOVE_INTERVAL_MINUTES N_MOVES=>CC%N_MOVES MOVE_MINUTE=>CC%MOVE_MINUTE MOVE_I_SW=>CC%MOVE_I_SW MOVE_J_SW=>CC%MOVE_J_SW ! !---------------------------------------- !*** The following is for 2-way nesting !---------------------------------------- ! CHILD_TASKS_2WAY_UPDATE=>cc%CHILD_TASKS_2WAY_UPDATE ! !----------------------------------------------------------------------- ! END SUBROUTINE POINT_TO_COMPOSITE ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_INTERP_SETUP(MY_DOMAIN_ID & ,NUM_CHILDREN & ,MY_CHILDREN_ID & ,IM_CHILD & ,JM_CHILD & ,FTASKS_DOMAIN & ,N_BLEND_H_CHILD & ,N_BLEND_V_CHILD & ,CF & ,ITS,ITE,JTS,JTE & ,IDS,IDE,JDS,JDE ) ! !----------------------------------------------------------------------- ! !*** ALLOCATE THREE PRIMARY INTERPOLATION QUANTITIES NEEDED BY !*** A PARENT DOMAIN TO GENERATE BOUNDARY DATA FOR ITS CHILDREN: ! ! (1) Children's boundary index limits on each parent task; ! (2) Parent I's and J's surrounding each child boundary point; ! (3) Bilinear weights of each parent point surrounding each ! child boundary point. ! !----------------------------------------------------------------------- ! !*** ONLY PARENT TASKS EXECUTE THIS ROUTINE. ! !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & ,IDS,IDE,JDS,JDE & ,MY_DOMAIN_ID & ,NUM_CHILDREN ! INTEGER(kind=KINT),DIMENSION(1:NUM_CHILDREN),INTENT(IN) :: IM_CHILD & ,JM_CHILD & ,N_BLEND_H_CHILD & ,N_BLEND_V_CHILD ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: FTASKS_DOMAIN & ,MY_CHILDREN_ID ! TYPE(ESMF_Config),DIMENSION(1:NUM_CHILDREN),INTENT(INOUT) :: CF ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: N,N_CHILD_TASKS,NUM_CHILD_TASKS & ,THIS_CHILD_ID ! INTEGER(kind=KINT) :: EAST_LIMIT1 ,EAST_LIMIT2 & ,WEST_LIMIT1 ,WEST_LIMIT2 & ,NORTH_LIMIT1,NORTH_LIMIT2 & ,SOUTH_LIMIT1,SOUTH_LIMIT2 ! INTEGER(kind=KINT) :: ISTAT,RC,RC_SET ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_SET=ESMF_SUCCESS ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Allocate the pointers that hold the four H and V parent points !*** that surround each child point in the child's boundary region. !----------------------------------------------------------------------- ! ALLOCATE(CC%PARENT_4_INDICES_H(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_INDICES_H stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PARENT_4_INDICES_H=>cc%PARENT_4_INDICES_H ! ALLOCATE(CC%PARENT_4_INDICES_V(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_INDICES_V stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PARENT_4_INDICES_V=>cc%PARENT_4_INDICES_V ! !----------------------------------------------------------------------- !*** Allocate the pointers that hold the weights of the four H and V !*** parent points that surround each child point in the child's !*** boundary region. !----------------------------------------------------------------------- ! ALLOCATE(CC%PARENT_4_WEIGHTS_H(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_WEIGHTS_H stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PARENT_4_WEIGHTS_H=>CC%PARENT_4_WEIGHTS_H ! ALLOCATE(CC%PARENT_4_WEIGHTS_V(1:NUM_CHILDREN)) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_WEIGHTS_V stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF PARENT_4_WEIGHTS_V=>CC%PARENT_4_WEIGHTS_V ! !----------------------------------------------------------------------- !*** Allocate the arrays that hold the number of child tasks !*** on each side of the child boundaries that will be sent !*** data from the parent tasks. !----------------------------------------------------------------------- ! ALLOCATE(cc%NUM_TASKS_SEND_H_S(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%NUM_TASKS_SEND_H_S stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S ! ALLOCATE(cc%NUM_TASKS_SEND_H_N(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N ! ALLOCATE(cc%NUM_TASKS_SEND_H_W(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W ! ALLOCATE(cc%NUM_TASKS_SEND_H_E(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E ! ALLOCATE(cc%NUM_TASKS_SEND_V_S(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_V_S=>cc%NUM_TASKS_SEND_V_S ! ALLOCATE(cc%NUM_TASKS_SEND_V_N(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_V_N=>cc%NUM_TASKS_SEND_V_N ! ALLOCATE(cc%NUM_TASKS_SEND_V_W(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_V_W=>cc%NUM_TASKS_SEND_V_W ! ALLOCATE(cc%NUM_TASKS_SEND_V_E(1:NUM_CHILDREN),stat=ISTAT) NUM_TASKS_SEND_V_E=>cc%NUM_TASKS_SEND_V_E ! !----------------------------------------------------------------------- !*** Allocate the pointers that will hold the ranks of all child tasks !*** on each side of the child boundaries that will be sent data !*** from the parent tasks. !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILDTASK_BNDRY_H_RANKS(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_BNDRY_H_RANKS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS ! ALLOCATE(cc%CHILDTASK_BNDRY_V_RANKS(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_BNDRY_V_RANKS stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILDTASK_BNDRY_V_RANKS=>cc%CHILDTASK_BNDRY_V_RANKS ! !----------------------------------------------------------------------- !*** Allocate the pointers for starting/ending I's and J's on each !*** parent task for each side of the boundary. !----------------------------------------------------------------------- ! ALLOCATE(cc%CHILDTASK_H_SAVE(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_H_SAVE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE ! ALLOCATE(cc%CHILDTASK_V_SAVE(1:NUM_CHILDREN),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_V_SAVE stat=',ISTAT CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF CHILDTASK_V_SAVE=>cc%CHILDTASK_V_SAVE ! !----------------------------------------------------------------------- !*** Extract relevant information from the children's configure files. !----------------------------------------------------------------------- ! child_loop_0: DO N=1,NUM_CHILDREN ! THIS_CHILD_ID=MY_CHILDREN_ID(N) ! !----------------------------------------------------------------------- !*** Invert the Parent-to-Child space ratio for computation. !----------------------------------------------------------------------- ! CHILD_PARENT_SPACE_RATIO(N)=1./REAL(PARENT_CHILD_SPACE_RATIO(N)) ! !----------------------------------------------------------------------- !*** Allocate the individual pointers holding the four H points of !*** the parent that surround this child's boundary region H points !*** and the bilinear interpolation weights of the four parent points !*** surrounding those same child points. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! *************************** NOTE ***************************** !----------------------------------------------------------------------- ! Although the H points in the nests' boundary region cover only ! N_BLEND rows, we actually need to have the nests' PD values ! one row further. That is because we also need PD values at the ! V points in the nests' boundary region to perform the proper ! hydrostatic updating of the winds by the parents there. To ! do the 4-point average needed to obtain PD on V points, we ! necessarily must have them on mass points one row beyond where ! they are needed for the mass points alone. !----------------------------------------------------------------------- ! *************************** NOTE ***************************** !----------------------------------------------------------------------- ! SOUTH_LIMIT1=1 SOUTH_LIMIT2=N_BLEND_H_CHILD(N)+1 !<-- Extend the region by 1 row for 4-point averaging of PD ! NORTH_LIMIT1=JM_CHILD(N)-N_BLEND_H_CHILD(N) !<-- Extend the region by 1 row for 4-point averaging of PD NORTH_LIMIT2=JM_CHILD(N) ! WEST_LIMIT1=1 WEST_LIMIT2=N_BLEND_H_CHILD(N)+1 !<-- Extend the region by 1 row for 4-point averaging of PD ! EAST_LIMIT1=IM_CHILD(N)-N_BLEND_H_CHILD(N) !<-- Extend the region by 1 row for 4-point averaging of PD EAST_LIMIT2=IM_CHILD(N) ! !-------------------------- !*** Parent point indices !-------------------------- ! ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_SBND(1:IM_CHILD(N) & !<-- Parent I's west/east of child south bndry H points ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_NBND(1:IM_CHILD(N) & !<-- Parent I's west/east of child north bndry H points ,NORTH_LIMIT1:NORTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent I's west/east of child west bndry H points ,1:JM_CHILD(N) & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent I's west/east of child east bndry H points ,1:JM_CHILD(N) & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_SBND(1:IM_CHILD(N) & !<-- Parent J's south/north of child south bndry H points ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_NBND(1:IM_CHILD(N) & !<-- Parent J's south/north of child north bndry H points ,NORTH_LIMIT1:NORTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent J's south/north of child west bndry H points ,1:JM_CHILD(N) & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent J's south/north of child east bndry H points ,1:JM_CHILD(N) & ,1:2)) ! !-------------------------- !*** Parent point weights !-------------------------- ! ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND(1:IM_CHILD(N) & !<-- Bilinear interpolation weights of parent points ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ! surrounding child south bndry region H points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND(1:IM_CHILD(N) & !<-- Bilinear interpolation weights of parent points ,NORTH_LIMIT1:NORTH_LIMIT2 & ! surrounding child north bndry region H points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Bilinear interpolation weights of parent points ,1:JM_CHILD(N) & ! surrounding child west bndry region H points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Bilinear interpolation weights of parent points ,1:JM_CHILD(N) & ! surrounding child east bndry region H points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! !----------------------------------------------------------------------- !*** Allocate the individual pointers holding the four V points of !*** the parent that surround this child's boundary region V points. !----------------------------------------------------------------------- ! SOUTH_LIMIT1=1 SOUTH_LIMIT2=N_BLEND_V_CHILD(N) ! NORTH_LIMIT1=JM_CHILD(N)-1-N_BLEND_V_CHILD(N)+1 NORTH_LIMIT2=JM_CHILD(N)-1 ! WEST_LIMIT1=1 WEST_LIMIT2=N_BLEND_V_CHILD(N) ! EAST_LIMIT1=IM_CHILD(N)-1-N_BLEND_V_CHILD(N)+1 EAST_LIMIT2=IM_CHILD(N)-1 ! !-------------------------- !*** Parent point indices !-------------------------- ! ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_SBND(1:IM_CHILD(N)-1 & !<-- Parent I's west/east of child south bndry V points. ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_NBND(1:IM_CHILD(N)-1 & !<-- Parent I's west/east of child north bndry V points. ,NORTH_LIMIT1:NORTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent I's west/east of child west bndry V points. ,1:JM_CHILD(N)-1 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent I's west/east of child east bndry V points. ,1:JM_CHILD(N)-1 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_SBND(1:IM_CHILD(N)-1 & !<-- Parent J's south/north of child south bndry V points. ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_NBND(1:IM_CHILD(N)-1 & !<-- Parent J's south/north of child north bndry V points. ,NORTH_LIMIT1:NORTH_LIMIT2 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent J's south/north of child west bndry V points. ,1:JM_CHILD(N)-1 & ,1:2)) ! ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent J's south/north of child east bndry V points. ,1:JM_CHILD(N)-1 & ,1:2)) ! !-------------------------- !*** Parent point weights !-------------------------- ! ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND(1:IM_CHILD(N)-1 & !<-- Bilinear interpolation weights of parent points ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ! surrounding child south bndry region V points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND(1:IM_CHILD(N)-1 & !<-- Bilinear interpolation weights of parent points ,NORTH_LIMIT1:NORTH_LIMIT2 & ! surrounding child north bndry region V points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Bilinear interpolation weights of parent points ,1:JM_CHILD(N)-1 & ! surrounding child west bndry region V points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Bilinear interpolation weights of parent points ,1:JM_CHILD(N)-1 & ! surrounding child east bndry region V points. ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. ! !----------------------------------------------------------------------- !*** What is the number of forecast tasks on the child domain? !----------------------------------------------------------------------- ! NUM_CHILD_TASKS=FTASKS_DOMAIN(THIS_CHILD_ID) ! !----------------------------------------------------------------------- !*** Allocate the pointers for starting/ending I's and J's on each !*** parent task for each side of the boundary. !----------------------------------------------------------------------- ! ALLOCATE(CHILDTASK_H_SAVE(N)%I_LO_SOUTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_SOUTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%I_LO_NORTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_NORTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_LO_WEST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_WEST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_LO_EAST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_EAST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER (1:NUM_CHILD_TASKS)) ! ALLOCATE(CHILDTASK_V_SAVE(N)%I_LO_SOUTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_SOUTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER(1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%I_LO_NORTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_NORTH (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER(1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_LO_WEST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_WEST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER(1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_LO_EAST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_EAST (1:NUM_CHILD_TASKS)) ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER(1:NUM_CHILD_TASKS)) ! !----------------------------------------------------------------------- !*** Allocate the pointers for the child task ID's that contain !*** segments of the child boundary within a parent task for !*** each side of the boundary. !----------------------------------------------------------------------- ! ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%NORTH(1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%WEST (1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%EAST (1:NUM_CHILD_TASKS,2)) ! ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%NORTH(1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%WEST (1:NUM_CHILD_TASKS,2)) ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%EAST (1:NUM_CHILD_TASKS,2)) ! !----------------------------------------------------------------------- ! ENDDO child_loop_0 ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_CHILD_INTERP_SETUP ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PREPARE_NEST_INTERP_FACTORS(N_CHILD,MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Call the routine that computes the interpolation factors !*** each parent needs in order to interpolate its data to !*** its nests' boundaries. ! !*** Only parent tasks execute this routine. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The parent's N-CHILD'th child ,MY_DOMAIN_ID !<-- The parent's domain ID ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: ITE_CHILD_X,JTE_CHILD_X & ,N,N_CHILD_TASKS,NCX,NT,NUM_CHILD_TASKS ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** The parent sets up quantities to be used for general !*** bilinear interpolation from the parent to its children's !*** boundary regions. These quantities are: ! ! (1a) The westernmost/eastermost I's of children's south/north ! boundary region points on this parent task's subdomain. ! (1b) The southernmost/northernmost J's of children's west/east ! boundary region points on this parent task's subdomain. ! (2) The I,J of the four parent points surrounding each ! child's boundary region point. ! (3) The bilinear interpolation weights for each of the four ! parent points surrounding each child's boundary region ! point. !----------------------------------------------------------------------- ! N=N_CHILD ! NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) !<-- # of fcst tasks on this parent's Nth child ! !------------------------------------------------------------ !*** Compute interpolation indices and weights for H points !------------------------------------------------------------ ! CALL PARENT_TO_CHILD_INTERP_FACTORS('H_POINTS' & ,N_CHILD & ,I_PARENT_SW(N) & ,J_PARENT_SW(N) & ,N_BLEND_H_CHILD(N) & ! ,IM_CHILD(N) & ,JM_CHILD(N) & ! ,NUM_CHILD_TASKS & ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & ,CHILD_RANKS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & ! ^ ,CHILD_PARENT_SPACE_RATIO(N) & ! | ! ! | ,ITS,ITE,JTS,JTE & ! | ,IDS,IDE,JDS,JDE & ! Input ! ----------------- ,NUM_TASKS_SEND_H_S(N) & ! Output ,NUM_TASKS_SEND_H_N(N) & ! | ,NUM_TASKS_SEND_H_W(N) & ! | ,NUM_TASKS_SEND_H_E(N) & ! v ! ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & ,CHILDTASK_H_SAVE(N)%J_LO_WEST & ,CHILDTASK_H_SAVE(N)%J_HI_WEST & ,CHILDTASK_H_SAVE(N)%J_LO_EAST & ,CHILDTASK_H_SAVE(N)%J_HI_EAST & ! ,CHILDTASK_BNDRY_H_RANKS(N)%SOUTH & ,CHILDTASK_BNDRY_H_RANKS(N)%NORTH & ,CHILDTASK_BNDRY_H_RANKS(N)%WEST & ,CHILDTASK_BNDRY_H_RANKS(N)%EAST & ! ,PARENT_4_INDICES_H(N)%I_INDX_SBND & ,PARENT_4_INDICES_H(N)%I_INDX_NBND & ,PARENT_4_INDICES_H(N)%I_INDX_WBND & ,PARENT_4_INDICES_H(N)%I_INDX_EBND & ,PARENT_4_INDICES_H(N)%J_INDX_SBND & ,PARENT_4_INDICES_H(N)%J_INDX_NBND & ,PARENT_4_INDICES_H(N)%J_INDX_WBND & ,PARENT_4_INDICES_H(N)%J_INDX_EBND & ! ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND) ! !------------------------------------------------------------------------ !*** The child J extent of words to be transferred from this parent task !*** to child task NT is one less than the limit used for saving values !*** of PDB on the child boundary. We needed to save PDB at one point !*** further north than the northernmost V in the segment to be able !*** to do 4-pt averaging of PDB onto the V points in order to do !*** hydrostatic updating of V by the parent. Now indicate that !*** reduction in the number of points to be transferred. !------------------------------------------------------------------------ ! !------------- !*** South H !------------- ! NUM_CHILD_TASKS=NUM_TASKS_SEND_H_S(N) ! DO NT=1,NUM_CHILD_TASKS CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)= & !<-- Sbndry I limit for transfer to child CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT)-1 ! NCX=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Count of this child task in list of all its fcst tasks ITE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(2,NCX) IF(CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT)==ITE_CHILD_X)THEN !<-- We do not reduce the area for H data CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)= & ! transfer if the bndry segment reaches CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)+1 ! the physical limit of that bndry ENDIF ENDDO ! !------------- !*** North H !------------- ! NUM_CHILD_TASKS=NUM_TASKS_SEND_H_N(N) ! DO NT=1,NUM_CHILD_TASKS CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)= & !<-- Nbndry I limit for transfer to child CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT)-1 ! NCX=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Count of this child task in list of all its fcst tasks ITE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(2,NCX) IF(CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT)==ITE_CHILD_X)THEN !<-- We do not reduce the area for H data CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)= & ! transfer if the bndry segment reaches CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)+1 ! the physical limit of that bndry ENDIF ENDDO ! !------------ !*** West H !------------ ! NUM_CHILD_TASKS=NUM_TASKS_SEND_H_W(N) ! DO NT=1,NUM_CHILD_TASKS CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)= & !<-- Wbndry J limit for transfer to child CHILDTASK_H_SAVE(N)%J_HI_WEST(NT)-1 ! NCX=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Count of this child task in list of all its fcst tasks JTE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(4,NCX) IF(CHILDTASK_H_SAVE(N)%J_HI_WEST(NT)==JTE_CHILD_X)THEN !<-- We do not reduce the area for H data CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)= & ! transfer if the bndry segment reaches CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)+1 ! the physical limit of that bndry ENDIF ENDDO ! !------------ !*** East H !------------ ! NUM_CHILD_TASKS=NUM_TASKS_SEND_H_E(N) ! DO NT=1,NUM_CHILD_TASKS CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)= & !<-- Ebndry J limit for transfer to child CHILDTASK_H_SAVE(N)%J_HI_EAST(NT)-1 ! NCX=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Count of this child task in list of all its fcst tasks JTE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(4,NCX) IF(CHILDTASK_H_SAVE(N)%J_HI_EAST(NT)==JTE_CHILD_X)THEN !<-- We do not reduce the area for H data CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)= & ! transfer if the bndry segment reaches CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)+1 ! the physical limit of that bndry ENDIF ENDDO ! !------------------------------------------------------------ !*** Compute interpolation indices and weights for V points !------------------------------------------------------------ ! NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) !<-- # of fcst tasks on this parent's Nth child ! CALL PARENT_TO_CHILD_INTERP_FACTORS('V_POINTS' & ,N_CHILD & ,I_PARENT_SW(N) & ,J_PARENT_SW(N) & ,N_BLEND_V_CHILD(N) & ! ,IM_CHILD(N) & ,JM_CHILD(N) & ! ,NUM_CHILD_TASKS & ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & ,CHILD_RANKS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & ! ,CHILD_PARENT_SPACE_RATIO(N) & ! ^ ! | ,ITS,ITE,JTS,JTE & ! | ,IDS,IDE,JDS,JDE & ! Input ! ---------------- ,NUM_TASKS_SEND_V_S(N) & ! Output ,NUM_TASKS_SEND_V_N(N) & ! | ,NUM_TASKS_SEND_V_W(N) & ! | ,NUM_TASKS_SEND_V_E(N) & ! v ! ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & ,CHILDTASK_V_SAVE(N)%J_LO_WEST & ,CHILDTASK_V_SAVE(N)%J_HI_WEST & ,CHILDTASK_V_SAVE(N)%J_LO_EAST & ,CHILDTASK_V_SAVE(N)%J_HI_EAST & ! ,CHILDTASK_BNDRY_V_RANKS(N)%SOUTH & ,CHILDTASK_BNDRY_V_RANKS(N)%NORTH & ,CHILDTASK_BNDRY_V_RANKS(N)%WEST & ,CHILDTASK_BNDRY_V_RANKS(N)%EAST & ! ,PARENT_4_INDICES_V(N)%I_INDX_SBND & ,PARENT_4_INDICES_V(N)%I_INDX_NBND & ,PARENT_4_INDICES_V(N)%I_INDX_WBND & ,PARENT_4_INDICES_V(N)%I_INDX_EBND & ,PARENT_4_INDICES_V(N)%J_INDX_SBND & ,PARENT_4_INDICES_V(N)%J_INDX_NBND & ,PARENT_4_INDICES_V(N)%J_INDX_WBND & ,PARENT_4_INDICES_V(N)%J_INDX_EBND & ! ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND & ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND & ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND & ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND) ! !----------------------------------------------------------------------- !*** For V point variables, the number of points to be transferred !*** from parents to their children's boundaries is the same as !*** the number of computation points (no extensions as is needed !*** for PDB). !----------------------------------------------------------------------- ! NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) ! DO N_CHILD_TASKS=1,NUM_CHILD_TASKS ! CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER(N_CHILD_TASKS)= & CHILDTASK_V_SAVE(N)%I_HI_SOUTH(N_CHILD_TASKS) ! CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER(N_CHILD_TASKS)= & CHILDTASK_V_SAVE(N)%I_HI_NORTH(N_CHILD_TASKS) ! CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER(N_CHILD_TASKS)= & CHILDTASK_V_SAVE(N)%J_HI_WEST(N_CHILD_TASKS) ! CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER(N_CHILD_TASKS)= & CHILDTASK_V_SAVE(N)%J_HI_EAST(N_CHILD_TASKS) ! ENDDO ! !----------------------------------------------------------------------- ! END SUBROUTINE PREPARE_NEST_INTERP_FACTORS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_TO_CHILD_INTERP_FACTORS(FLAG_H_OR_V & ,N_CHILD & ,I_PARENT_SW & ,J_PARENT_SW & ,N_BLEND & ! ,IM_CHILD & ,JM_CHILD & ! ,NUM_CHILD_TASKS & ,LIMITS & ,CHILD_RANKS & ! ,CHILD_PARENT_SPACE_RATIO & ! ^ ! | ,ITS,ITE,JTS,JTE & ! | ,IDS,IDE,JDS,JDE & ! Input ! -------------- ,NUM_TASKS_SEND_S & ! Output ,NUM_TASKS_SEND_N & ! | ,NUM_TASKS_SEND_W & ! | ,NUM_TASKS_SEND_E & ! v ! ,I_SAVE_LO_SOUTH & ,I_SAVE_HI_SOUTH & ,I_SAVE_LO_NORTH & ,I_SAVE_HI_NORTH & ,J_SAVE_LO_WEST & ,J_SAVE_HI_WEST & ,J_SAVE_LO_EAST & ,J_SAVE_HI_EAST & ! ,LOCAL_TASK_RANK_S & ,LOCAL_TASK_RANK_N & ,LOCAL_TASK_RANK_W & ,LOCAL_TASK_RANK_E & ! ,I_INDX_SBND & ,I_INDX_NBND & ,I_INDX_WBND & ,I_INDX_EBND & ,J_INDX_SBND & ,J_INDX_NBND & ,J_INDX_WBND & ,J_INDX_EBND & ! ,WEIGHTS_SBND & ,WEIGHTS_NBND & ,WEIGHTS_WBND & ,WEIGHTS_EBND ) ! !----------------------------------------------------------------------- !*** Parent components compute various indices, weights, etc. !*** needed to generate boundary point data for the given !*** child throughout the upcoming forecast. !*** Only parent tasks execute this routine. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_PARENT_SW,J_PARENT_SW & !<-- SW corner of nest lies on this I,J of parent ,IM_CHILD,JM_CHILD & !<-- Horizontal dimensions of nest domain ,N_BLEND & !<-- Width (in rows) of boundary's blending region ,N_CHILD & !<-- Rank of this child in list of children ,NUM_CHILD_TASKS !<-- # of fcst tasks on the child's domain ! INTEGER(kind=KINT),INTENT(IN) :: ITE,ITS,JTE,JTS & !<-- Index limits on parent task subdomain ,IDE,IDS,JDE,JDS !<-- Full dimensions of parent domain ! INTEGER(kind=KINT),DIMENSION(0:NUM_CHILD_TASKS-1),INTENT(IN) :: & CHILD_RANKS !<-- Child fcst task ranks in parent-child intracommunicator ! INTEGER(kind=KINT),DIMENSION(1:4,1:NUM_CHILD_TASKS),INTENT(IN) :: & LIMITS !<-- ITS,ITE,JTS,JTE on each task of the child ! REAL(kind=KFPT),INTENT(IN) :: CHILD_PARENT_SPACE_RATIO !<-- Ratio of nest grid increment to parent's increment ! CHARACTER(*),INTENT(IN) :: FLAG_H_OR_V !<-- Are we dealing with H or V child boundary points? ! INTEGER(kind=KINT),INTENT(OUT) :: NUM_TASKS_SEND_S & !<-- # of child tasks with S bndry segments on this parent task ,NUM_TASKS_SEND_N & !<-- # of child tasks with N bndry segments on this parent task ,NUM_TASKS_SEND_W & !<-- # of child tasks with W bndry segments on this parent task ,NUM_TASKS_SEND_E !<-- # of child tasks with E bndry segments on this parent task ! INTEGER(kind=KINT),DIMENSION(NUM_CHILD_TASKS),INTENT(OUT) :: & I_SAVE_LO_SOUTH & !<-- Child tasks' westernmost Sbndry I's on this parent task ,I_SAVE_HI_SOUTH & !<-- Child tasks' easternmost Sbndry I's on this parent task ,I_SAVE_LO_NORTH & !<-- Child tasks' westernmost Nbndry I's on this parent task ,I_SAVE_HI_NORTH & !<-- Child tasks' easternmost Nbndry I's on this parent task ,J_SAVE_LO_WEST & !<-- Child tasks' southernmost Wbndry J's on this parent task ,J_SAVE_HI_WEST & !<-- Child tasks' northernmost Wbndry J's on this parent task ,J_SAVE_LO_EAST & !<-- Child tasks' southernmost Ebndry J's on this parent task ,J_SAVE_HI_EAST !<-- Child tasks' northernmost Ebndry J's on this parent task ! INTEGER(kind=KINT),DIMENSION(NUM_CHILD_TASKS,2),INTENT(OUT) :: & LOCAL_TASK_RANK_S & !<-- Child task counts/ranks with S bndry on this parent task ,LOCAL_TASK_RANK_N & !<-- Child task counts/ranks with N bndry on this parent task ,LOCAL_TASK_RANK_W & !<-- Child task counts/ranks with W bndry on this parent task ,LOCAL_TASK_RANK_E !<-- Child task counts/ranks with E bndry on this parent task ! INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & I_INDX_SBND & !<-- Parent I west/east of child south boundary point ,I_INDX_NBND & !<-- Parent I west/east of child north boundary point ,I_INDX_WBND & !<-- Parent I west/east of child west boundary point ,I_INDX_EBND & !<-- Parent I west/east of child east boundary point ,J_INDX_SBND & !<-- Parent J south/north of child south boundary point ,J_INDX_NBND & !<-- Parent J south/north of child north boundary point ,J_INDX_WBND & !<-- Parent J south/north of child west boundary point ,J_INDX_EBND !<-- Parent J south/north of child east boundary point ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & WEIGHTS_SBND & !<-- Sbndry bilinear interp wghts for 4 surrounding parent points ,WEIGHTS_NBND & !<-- Nbndry bilinear interp wghts for 4 surrounding parent points ,WEIGHTS_WBND & !<-- Wbndry bilinear interp wghts for 4 surrounding parent points ,WEIGHTS_EBND !<-- Ebndry bilinear interp wghts for 4 surrounding parent points ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I_CHILD,IM_END & ,J_CHILD,JM_END & ,KOUNT_I,KOUNT_J & ,N,N_ADD,NC & ,NC_LAST_S,NC_LAST_N,NC_LAST_W,NC_LAST_E & ,RATIO_P_C ! INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS) :: I_LIMIT_LO & ,I_LIMIT_HI & ,ITS_CHILD & ,ITE_CHILD & ,J_LIMIT_LO & ,J_LIMIT_HI & ,JTS_CHILD & ,JTE_CHILD & ,NC_HOLD_S & ,NC_HOLD_N & ,NC_HOLD_W & ,NC_HOLD_E ! REAL(kind=KFPT) :: ADD_INC,ARG1,ARG2 & ,R_ITS,R_ITE,R_IEND,R_JTS,R_JTE,R_JEND ! REAL(kind=KFPT) :: PARENT_I_CHILD_EBND,PARENT_I_CHILD_WBND & ,PARENT_J_CHILD_NBND,PARENT_J_CHILD_SBND & ,PARENT_S_TASK_LIM_ON_NEST & ,PARENT_W_TASK_LIM_ON_NEST & ,RATIO_C_P & ,REAL_I_PARENT,REAL_I_START & ,REAL_J_PARENT,REAL_J_START & ,RECIP_SUM ! REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RATIO_C_P=CHILD_PARENT_SPACE_RATIO !<-- Child-to-Parent gridspace ratio RATIO_P_C=NINT(1./RATIO_C_P) !<-- Parent-to-Child gridspace ratio ! !----------------------------------------------------------------------- !*** Create the Real index limits on the parent grid across which !*** the children's boundary point values will be computed. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** !!!!! NOTE !!!!! ! !*** For the purpose of handling child boundaries, parent tasks will !*** "BEGIN" directly on their southernmost/westernmost H or V points. !*** Each parent task covers the gap between itself and the next task !*** on the parent grid in each direction. !*** This means that if a child south boundary point lies exactly on !*** a parent task point that itself is on the westernmost side of !*** that parent task's integration subdomain then that child point !*** will be considered to lie on both that parent task and the !*** parent task to the west simply because it is the intersection !*** of the regions managed by both of those parent tasks. !*** This same notion applies for all other directions and sides. !----------------------------------------------------------------------- ! R_ITE =REAL(ITE) !<-- REAL Iend of parent task's subdomain ! R_JTE =REAL(JTE) !<-- REAL Jend of parent task's subdomain ! !----------------------------------------------------------------------- !*** Because each parent gridpoint covers the gap to the next parent !*** gridpoint as explained above, increase the search limit for !*** child boundary points. That increase would be 1 for both H and V !*** but due to the nature of the B-Grid layout and the fact that !*** the I index of child V points on the west boundary and the !*** J index of the child V points on the south boundary have smaller !*** grid index values in terms of the parent indices, we must search !*** for child H points 1/2+0.5*(space_ratio) grid increments further !*** than for child V points in order to reach the same actual position. !----------------------------------------------------------------------- ! !*** In this diagram the H's and V's are points on the parent task's !*** subdomain while the h's and v's are points on a nest. It shows !*** how each parent point must look eastward. The same goes for !*** looking northwward. A parent/nest ratio of 3:1 is used in this !*** diagram. ! !----------------------------------------------------------------------- ! ! H H H ! ! ! ! V V ! v ! h h h h ! ! H H H ! ! -----------> ----> -> ! 1 1/2 1/6 ! ^ ! | ! This parent ! gridpoint ! must cover ! area to the ! next H. ! But V with ! the same I ! as the next H ! is 1.5 farther ! than this H. ! If nest v at ! 1.5 past this ! H is on the east ! bndry of the nest ! then the east h ! on the bndry is ! 1+1/2+1/6. ! That is how ! far we must ! scan from ! this H. !----------------------------------------------------------------------- ! IF(FLAG_H_OR_V=='H_POINTS')THEN ! ADD_INC=1.5 ADD_INC=1.5+0.5*RATIO_C_P+EPS ELSE ADD_INC=1.0 ENDIF ! !----------------------------------------------------------------------- ! DO N=1,NUM_CHILD_TASKS I_SAVE_LO_SOUTH(N)=-1 I_SAVE_LO_NORTH(N)=-1 J_SAVE_LO_WEST (N)=-1 J_SAVE_LO_EAST (N)=-1 ! NC_HOLD_S(N)=-1 NC_HOLD_N(N)=-1 NC_HOLD_W(N)=-1 NC_HOLD_E(N)=-1 ENDDO ! !----------------------------------------------------------------------- !*** What are the child I and J index limits of any sections of its !*** (the child's) boundary that lie within a parent task's subdomain? ! !*** What are the indices of the four parent gridpoints surrounding !*** each child boundary point? ! !*** What are the bilinear weights associated with each of the four !*** surrounding parent points to obtain the child boundary point? ! !*** The parent will use these pieces of information to interpolate !*** from its grid to its children's boundary points. !----------------------------------------------------------------------- ! !----------------------------------------------------------- !********************** NOTE ***************************** !----------------------------------------------------------- !*** We assume that the WIDTH of the blending region of !*** a child's boundary does NOT cross the border between !*** two parent tasks' subdomains. !----------------------------------------------------------- ! IF(FLAG_H_OR_V=='H_POINTS')THEN PARENT_J_CHILD_SBND=REAL(J_PARENT_SW) !<-- J index of parent H for child's south H boundary PARENT_J_CHILD_NBND=PARENT_J_CHILD_SBND+(JM_CHILD-1)*RATIO_C_P !<-- J index of parent H for child's north H boundary PARENT_I_CHILD_WBND=REAL(I_PARENT_SW) !<-- I index of parent H for child's west H boundary PARENT_I_CHILD_EBND=PARENT_I_CHILD_WBND+(IM_CHILD-1)*RATIO_C_P !<-- I index of parent H for child's east H boundary IM_END=IM_CHILD JM_END=JM_CHILD N_ADD=1 !<-- Blending region along child's boundary ! increased by 1 row to allow 4-pt averaging of PD. ! ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN PARENT_J_CHILD_SBND=REAL(J_PARENT_SW)-0.5+RATIO_C_P*0.5 !<-- J index of parent V for child's south V boundary PARENT_J_CHILD_NBND=PARENT_J_CHILD_SBND+(JM_CHILD-2)*RATIO_C_P !<-- J index of parent V for child's north V boundary PARENT_I_CHILD_WBND=REAL(I_PARENT_SW)-0.5+RATIO_C_P*0.5 !<-- I index of parent V for child's west V boundary PARENT_I_CHILD_EBND=PARENT_I_CHILD_WBND+(IM_CHILD-2)*RATIO_C_P !<-- I index of parent V for child's east V boundary IM_END=IM_CHILD-1 JM_END=JM_CHILD-1 N_ADD=0 !<-- Blending region along child's boundary ! increased only for mass points (for PD averaging) ENDIF ! !----------------------------------------------------------------------- !*** Check to see if the child domain is too near to the parent !*** domain's boundary. !----------------------------------------------------------------------- ! IF(PARENT_J_CHILD_SBND<=JDS+2)THEN WRITE(0,20221)N_CHILD,MY_DOMAIN_ID WRITE(0,20222)PARENT_J_CHILD_SBND,JDS,FLAG_H_OR_V 20221 FORMAT(' Child #',I2,' is within 2 points of the south' & ,' boundary of domain #',I2) 20222 FORMAT(' Parent J of child Sbndry=',e12.5,' parent jds=',i3,' flag_h_or_v=',a) WRITE(0,*)' ABORTING!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(PARENT_J_CHILD_NBND>=JDE-2)THEN WRITE(0,20223)N_CHILD,MY_DOMAIN_ID WRITE(0,20224)PARENT_J_CHILD_NBND,JDE,FLAG_H_OR_V 20223 FORMAT(' Child #',I2,' is within 2 points of the north' & ,' boundary of domain #',I2) 20224 FORMAT(' Parent J of child Nbndry=',e12.5,' parent jde=',i3,' flag_h_or_v=',a) WRITE(0,*)' ABORTING!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(PARENT_I_CHILD_WBND<=IDS+2)THEN WRITE(0,20225)N_CHILD,MY_DOMAIN_ID WRITE(0,20226)PARENT_I_CHILD_WBND,IDS,FLAG_H_OR_V 20225 FORMAT(' Child #',I2,' is within 2 points of the west' & ,' boundary of domain #',I2) 20226 FORMAT(' Parent I of child Wbndry=',e12.5,' parent ids=',i3,' flag_h_or_v=',a) WRITE(0,*)' ABORTING!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(PARENT_I_CHILD_EBND>=IDE+2)THEN WRITE(0,20227)N_CHILD,MY_DOMAIN_ID WRITE(0,20228)PARENT_I_CHILD_EBND,IDE,FLAG_H_OR_V 20227 FORMAT(' Child #',I2,' is within 2 points of the east' & ,' boundary of domain #',I2) 20228 FORMAT(' Parent I of child Ebndry=',e12.5,' parent ide=',i3,' flag_h_or_v=',a) WRITE(0,*)' ABORTING!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! !----------------------------------------------------------------------- ! DO N=1,NUM_CHILD_TASKS !<-- Loop through forecast tasks on the child domain ITS_CHILD(N)=LIMITS(1,N) !<-- ITS on this child task ITE_CHILD(N)=LIMITS(2,N) !<-- ITE on this child task JTS_CHILD(N)=LIMITS(3,N) !<-- JTS on this child task JTE_CHILD(N)=LIMITS(4,N) !<-- JTE on this child task I_LIMIT_LO(N)=MAX(ITS_CHILD(N)-2,1) !<-- Starting I's for each child task on N/S bndries (2-pt halo) I_LIMIT_HI(N)=MIN(ITE_CHILD(N)+2+N_ADD,IM_END) !<-- Ending I's for each child task on N/S bndries (2-pt halo) J_LIMIT_LO(N)=MAX(JTS_CHILD(N)-2,1) !<-- Starting J's for each child task on W/E bndries (2-pt halo) J_LIMIT_HI(N)=MIN(JTE_CHILD(N)+2+N_ADD,JM_END) !<-- Ending J's for each child task on W/E bndries (2-pt halo) ! !----------------------------------------------------------------------- !*** If the northernmost/easternmost extra row of H bndry points !*** on a nest task coincides with the southern/western boundary !*** of a parent task then that parent task will not be associated !*** with the nest since no bndry V points would be seen by the !*** parent task. !----------------------------------------------------------------------- ! IF(FLAG_H_OR_V=='H_POINTS')THEN ! PARENT_S_TASK_LIM_ON_NEST=REAL(JTS-J_PARENT_SW)*RATIO_P_C+1 !<-- South limit of parent task w/r to nest J IF(J_LIMIT_HI(N)-PARENT_S_TASK_LIM_ON_NEST<=0.5)THEN J_LIMIT_HI(N)=J_LIMIT_HI(N)-1 ENDIF ! PARENT_W_TASK_LIM_ON_NEST=REAL(ITS-I_PARENT_SW)*RATIO_P_C+1 !<-- West limit of parent task w/r to nest I IF(I_LIMIT_HI(N)-PARENT_W_TASK_LIM_ON_NEST<=0.5)THEN I_LIMIT_HI(N)=I_LIMIT_HI(N)-1 ENDIF ENDIF ! ENDDO ! !----------------------------------------------------- !----------------------------------------------------- !*** Child's southern/northern boundaries ! !*** Work eastward along these boundaries !*** and save the basic indices and weights !*** needed by the parent. !----------------------------------------------------- !----------------------------------------------------- ! NC_LAST_S=-1 NC_LAST_N=-1 ! NUM_TASKS_SEND_S=0 NUM_TASKS_SEND_N=0 ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_ITS=REAL(ITS)-EPS !<-- REAL Istart of parent task's subdomain for H on B grid ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_ITS=REAL(ITS-0.5)-EPS !<-- REAL Istart of parent task's subdomain for V on B grid ENDIF ! ARG1=REAL(ITE)+ADD_INC ARG2=REAL(IDE) R_IEND=MIN(ARG1,ARG2)-2.*EPS !<-- REAL Iend of parent task's region for child N/S boundaries ! !----------------------------------------------------- ! REAL_I_START=PARENT_I_CHILD_WBND !<-- I index of parent H for child's west H boundary ! !----------------------------------------------------------------------- i_loop: DO I_CHILD=1,IM_END !<-- Loop over child I's across its South/North boundaries !----------------------------------------------------------------------- ! REAL_I_PARENT=REAL_I_START+(I_CHILD-1)*RATIO_C_P !<-- Parent I index coinciding with child domain point ! !----------------------------------------------------------------------- ! ! i_block: IF(REAL_I_PARENT>=R_ITS.AND.REAL_I_PARENT<=R_IEND)THEN !<-- Column (I) of child's S/N bndry point lies on parent task? i_block: IF(REAL_I_PARENT>=R_ITS.AND.REAL_I_PARENT< R_IEND)THEN !<-- Column (I) of child's S/N bndry point lies on parent task? ! !----------- !----------- !*** South !----------- !----------- ! REAL_J_START=PARENT_J_CHILD_SBND !<-- J index of parent H for child's south H boundary KOUNT_J=0 ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_JTS=REAL(JTS)-EPS !<-- REAL Jstart of parent task's subdomain for H on B grid R_JEND=REAL(MIN(JTE+1,JDE))-EPS !<-- Allow search for child H boundary points to go into ! the parent's halo. ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_JTS =REAL(JTS-0.5)-EPS !<-- REAL Jstart of parent task's subdomain for V on B grid ! (-0.5 yields same location on grid as R_JTS for H). R_JEND=REAL(MIN(REAL(JTE+0.5),REAL(JDE)))-EPS !<-- Use JTE+0.5 to stop V search at the row of the ! northernmost H that is searched; this ensures that ! a parent will send both H and V boundary points. ENDIF ! !----------------------------------------------------------------------- ! J_CHILD=1 ! !----------------------------------------------------------------------- !*** Which child task contains this (I_CHILD,J_CHILD) point? !*** Find out then save the I limits of that task's boundary !*** segment on this parent task so that the parent task !*** will know exactly which words to send to the child task. !*** Also remember that the NMM-B boundary update routines go !*** two points into the halo which means that two child !*** tasks will share some boundary points on the parent. !----------------------------------------------------------------------- ! child_ij_s: IF(REAL_J_START >=R_JTS.AND.REAL_J_START < R_JEND)THEN !<-- Does parent task see this row of its child? ! DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain ! IF(I_CHILD>=I_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this I_CHILD<=I_LIMIT_HI(NC) & ! parent task lie on child task "NC"? .AND. & ! J_CHILD>=JTS_CHILD(NC).AND. & ! J_CHILD<=JTE_CHILD(NC))THEN ! IF(NC>NC_LAST_S)THEN !<-- Encountered a new child task holding this S bndry point? NUM_TASKS_SEND_S=NUM_TASKS_SEND_S+1 !<-- Then increment the S bndry counter of the child tasks LOCAL_TASK_RANK_S(NUM_TASKS_SEND_S,1)=NC !<-- This child task's count in list of fcst tasks LOCAL_TASK_RANK_S(NUM_TASKS_SEND_S,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm NC_LAST_S=NC NC_HOLD_S(NC)=NUM_TASKS_SEND_S ENDIF ! IF(I_SAVE_LO_SOUTH(NC_HOLD_S(NC))<0)THEN I_SAVE_LO_SOUTH(NC_HOLD_S(NC))=I_CHILD !<-- Save westernmost Sbndry I of child task NC ! that is on this parent task. ENDIF I_SAVE_HI_SOUTH(NC_HOLD_S(NC))=I_CHILD !<-- Save easternmost Sbndry I of child task NC ! that is on this parent task. ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! j_south: DO J_CHILD=1,N_BLEND+N_ADD !<-- Blending region along child's southern boundary ! KOUNT_J=KOUNT_J+1 REAL_J_PARENT=REAL_J_START+(KOUNT_J-1)*RATIO_C_P !<-- REAL parent J for this child's J ! I_INDX_SBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's south boundary point I_INDX_SBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's south boundary point J_INDX_SBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's south boundary point J_INDX_SBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's south boundary point ! WEIGHT_SW=(I_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (J_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_SE=(REAL_I_PARENT-I_INDX_SBND(I_CHILD,J_CHILD,1))* & (J_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_NW=(I_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (REAL_J_PARENT-J_INDX_SBND(I_CHILD,J_CHILD,1)) WEIGHT_NE=(REAL_I_PARENT-I_INDX_SBND(I_CHILD,J_CHILD,1))* & (REAL_J_PARENT-J_INDX_SBND(I_CHILD,J_CHILD,1)) ! RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) ! WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Bilin interp wght of parent point SW of child bndry point WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Bilin interp wght of parent point SE of child bndry point WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Bilin interp wght of parent point NW of child bndry point WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Bilin interp wght of parent point NE of child bndry point ! ENDDO j_south ! !----------------------------------------------------------------------- ENDIF child_ij_s !----------------------------------------------------------------------- ! ! !----------- !----------- !*** North !----------- !----------- ! REAL_J_START=PARENT_J_CHILD_NBND KOUNT_J=0 ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_JTS=REAL(JTS)+EPS !<-- REAL Jstart of parent task's subdomain for H on B grid R_JEND=REAL(MIN(JTE+1,JDE))+EPS !<-- Allow search for child H boundary points to go into ! the parent's halo. ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_JTS =REAL(JTS-0.5)+EPS !<-- REAL Jstart of parent task's subdomain for V on B grid ! (-0.5 yields same location on grid as R_JTS for H). R_JEND=REAL(MIN(REAL(JTE+0.5),REAL(JDE)))+EPS !<-- Use JTE+0.5 to stop V search at the row of the ! northernmost H that is searched; this ensures that ! a parent will send both H and V boundary points. ENDIF ! !----------------------------------------------------------------------- ! J_CHILD=JM_END ! !----------------------------------------------------------------------- ! child_ij_n: IF(REAL_J_START >=R_JTS.AND.REAL_J_START < R_JEND)THEN !<-- Does parent task see this row of its child? ! !----------------------------------------------------------------------- ! !------------------------------------------------------------- !*** Find the child tasks and their relevant limits !*** along the child's northern boundary. !------------------------------------------------------------- ! DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain IF(I_CHILD>=I_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this I_CHILD<=I_LIMIT_HI(NC) & ! parent task lie on child task "NC"? .AND. & ! J_CHILD>=JTS_CHILD(NC).AND. & ! J_CHILD<=JTE_CHILD(NC))THEN ! IF(NC>NC_LAST_N)THEN !<-- Have we encountered a new child task holding this N bndry? NUM_TASKS_SEND_N=NUM_TASKS_SEND_N+1 !<-- Then increment the N bndry counter of the child tasks LOCAL_TASK_RANK_N(NUM_TASKS_SEND_N,1)=NC !<-- This child task's count in list of fcst tasks LOCAL_TASK_RANK_N(NUM_TASKS_SEND_N,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm NC_LAST_N=NC NC_HOLD_N(NC)=NUM_TASKS_SEND_N ENDIF ! IF(I_SAVE_LO_NORTH(NC_HOLD_N(NC))<0)THEN I_SAVE_LO_NORTH(NC_HOLD_N(NC))=I_CHILD !<-- Save westernmost Nbndry I of child task NC ! that is on this parent task. ENDIF I_SAVE_HI_NORTH(NC_HOLD_N(NC))=I_CHILD !<-- Save easternmost Nbndry I of child task NC ! that is on this parent task. ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! j_north: DO J_CHILD=JM_END,JM_END-N_BLEND+1-N_ADD,-1 !<-- Blending region of child's northern boundary ! !----------------------------------------------------------------------- ! KOUNT_J=KOUNT_J+1 REAL_J_PARENT=REAL_J_START-(KOUNT_J-1)*RATIO_C_P !<-- REAL parent J for this child's J ! I_INDX_NBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's north boundary point I_INDX_NBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's north boundary point J_INDX_NBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's north boundary point J_INDX_NBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's north boundary point ! WEIGHT_SW=(I_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (J_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_SE=(REAL_I_PARENT-I_INDX_NBND(I_CHILD,J_CHILD,1))* & (J_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_NW=(I_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (REAL_J_PARENT-J_INDX_NBND(I_CHILD,J_CHILD,1)) WEIGHT_NE=(REAL_I_PARENT-I_INDX_NBND(I_CHILD,J_CHILD,1))* & (REAL_J_PARENT-J_INDX_NBND(I_CHILD,J_CHILD,1)) ! RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) ! WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point ! ENDDO j_north ! !----------------------------------------------------------------------- ENDIF child_ij_n !----------------------------------------------------------------------- ! ENDIF i_block ! !----------------------------------------------------------------------- ! ENDDO i_loop ! !----------------------------------------------------------------------- ! !----------------------------------------------------- !----------------------------------------------------- !*** Child's western/eastern boundaries ! !*** Work northward along these boundaries !*** and save the basic indices and weights !*** needed by the parent. !----------------------------------------------------- !----------------------------------------------------- ! NC_LAST_W=-1 NC_LAST_E=-1 ! NUM_TASKS_SEND_W=0 !<-- Parent task sends to this many child tasks on W bndry NUM_TASKS_SEND_E=0 !<-- Parent task sends to this many child tasks on E bndry ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_JTS=REAL(JTS)-EPS !<-- REAL Jstart of parent task's subdomain for H on B grid ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_JTS=REAL(JTS-0.5)-EPS !<-- REAL Jstart of parent task's subdomain for V on B grid ENDIF ! ARG1=REAL(JTE)+ADD_INC ARG2=REAL(JDE) R_JEND=MIN(ARG1,ARG2)-2.*EPS !<-- REAL Jend of parent task's region for child W/E boundaries ! REAL_J_START=PARENT_J_CHILD_SBND !<-- J index of parent H for child's south H boundary ! !----------------------------------------------------------------------- j_loop: DO J_CHILD=1,JM_END !<-- Loop through child J's across its W/E boundaries !----------------------------------------------------------------------- REAL_J_PARENT=REAL_J_START+(J_CHILD-1)*RATIO_C_P !<-- Parent J index coinciding with child domain point ! !----------------------------------------------------------------------- ! ! j_block: IF(REAL_J_PARENT>=R_JTS.AND.REAL_J_PARENT<=R_JEND)THEN !<-- Row (J) of child's W/E bndry point lies on parent task? j_block: IF(REAL_J_PARENT>=R_JTS.AND.REAL_J_PARENT< R_JEND)THEN !<-- Row (J) of child's W/E bndry point lies on parent task? ! !---------- !---------- !*** West !---------- !---------- ! REAL_I_START=PARENT_I_CHILD_WBND KOUNT_I=0 ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_ITS=REAL(ITS)-EPS !<-- REAL Istart of parent task's subdomain for H on B grid R_IEND=REAL(MIN(ITE+1,IDE))-EPS !<-- Allow search for child H boundary points to go into ! the parent's halo. ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_ITS =REAL(ITS-0.5)-EPS !<-- REAL Istart of parent task's subdomain for V on B grid ! (-0.5 yields same location on grid as R_JTS for H). R_IEND=REAL(MIN(REAL(ITE+0.5),REAL(IDE)))-EPS !<-- Use ITE+0.5 to stop V search at the row of the ! northernmost H that is searched; this ensures that ! a parent will send both H and V boundary points. ENDIF ! !----------------------------------------------------------------------- ! I_CHILD=1 ! !----------------------------------------------------------------------- ! child_ij_w: IF(REAL_I_START >=R_ITS.AND.REAL_I_START < R_IEND)THEN !<-- Does parent task see this column of its child? ! !----------------------------------------------------------------------- ! !------------------------------------------------------------- !*** Find the child tasks and their relevant limits !*** along the child's western boundary. !------------------------------------------------------------- ! DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain ! IF(J_CHILD>=J_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this J_CHILD<=J_LIMIT_HI(NC) & ! parent task lie on child task "NC"? .AND. & ! I_CHILD>=ITS_CHILD(NC).AND. & ! I_CHILD<=ITE_CHILD(NC))THEN ! IF(NC>NC_LAST_W)THEN !<-- Have we encountered a new child task holding this W bndry? NUM_TASKS_SEND_W=NUM_TASKS_SEND_W+1 !<-- Then increment the W bndry counter of the child tasks LOCAL_TASK_RANK_W(NUM_TASKS_SEND_W,1)=NC !<-- This child task's count in list of fcst tasks LOCAL_TASK_RANK_W(NUM_TASKS_SEND_W,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm NC_LAST_W=NC NC_HOLD_W(NC)=NUM_TASKS_SEND_W ENDIF ! IF(J_SAVE_LO_WEST(NC_HOLD_W(NC))<0)THEN J_SAVE_LO_WEST(NC_HOLD_W(NC))=J_CHILD !<-- Save southernmost Wbndry J of child task NC ! that is on this parent task. ENDIF J_SAVE_HI_WEST(NC_HOLD_W(NC))=J_CHILD !<-- Save northernmost Wbndry J of child task NC ! that is on this parent task. ! ENDIF ! ENDDO ! !------------------------------------------------------------- i_west: DO I_CHILD=1,N_BLEND+N_ADD !<-- Blending region of child's western boundary !------------------------------------------------------------- ! KOUNT_I=KOUNT_I+1 REAL_I_PARENT=REAL_I_START+(KOUNT_I-1)*RATIO_C_P !<-- REAL parent I for this child's I ! I_INDX_WBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's west boundary point I_INDX_WBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's west boundary point J_INDX_WBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's west boundary point J_INDX_WBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's west boundary point ! WEIGHT_SW=(I_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (J_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_SE=(REAL_I_PARENT-I_INDX_WBND(I_CHILD,J_CHILD,1))* & (J_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_NW=(I_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (REAL_J_PARENT-J_INDX_WBND(I_CHILD,J_CHILD,1)) WEIGHT_NE=(REAL_I_PARENT-I_INDX_WBND(I_CHILD,J_CHILD,1))* & (REAL_J_PARENT-J_INDX_WBND(I_CHILD,J_CHILD,1)) ! RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) ! WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point ! ENDDO i_west ! !----------------------------------------------------------------------- ENDIF child_ij_w !----------------------------------------------------------------------- ! !---------- !---------- !*** East !---------- !---------- ! REAL_I_START=PARENT_I_CHILD_EBND !<-- I index of parent H for child's east H boundary KOUNT_I=0 ! IF(FLAG_H_OR_V=='H_POINTS')THEN R_ITS=REAL(ITS)+EPS !<-- REAL Istart of parent task's subdomain for H on B grid R_IEND=REAL(MIN(ITE+1,IDE))+EPS !<-- Allow search for child H boundary points to go into ! the parent's halo. ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN R_ITS =REAL(ITS-0.5)+EPS !<-- REAL Istart of parent task's subdomain for V on B grid ! (-0.5 yields same location on grid as R_JTS for H). R_IEND=REAL(MIN(REAL(ITE+0.5),REAL(IDE)))+EPS !<-- Use ITE+0.5 to stop V search at the row of the ! northernmost H that is searched; this ensures that ! a parent will send both H and V boundary points. ENDIF ! !----------------------------------------------------------------------- !*** Recall that we need an additional row of H points to allow 4-pt !*** averaging of PD to V points. We need only to search for the !*** westernmost child J row of the east boundary blending region with !*** the extra row because if that child I is on a parent task then !*** all of the blending region must be on that task since we are !*** permitting the search to go into the parent tasks' haloes. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! I_CHILD=IM_END ! !----------------------------------------------------------------------- ! child_ij_e: IF(REAL_I_START >=R_ITS.AND.REAL_I_START < R_IEND)THEN !<-- Does parent task see this column of its child? ! !----------------------------------------------------------------------- !------------------------------------------------------------- !*** Find the child tasks and their relevant limits !*** along the child's eastern boundary. !------------------------------------------------------------- ! DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain ! IF(J_CHILD>=J_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this J_CHILD<=J_LIMIT_HI(NC) & ! parent task lie on child task "NC"? .AND. & ! I_CHILD>=ITS_CHILD(NC).AND. & ! I_CHILD<=ITE_CHILD(NC))THEN ! IF(NC>NC_LAST_E)THEN !<-- Have we encountered a new child task holding this E bndry? NUM_TASKS_SEND_E=NUM_TASKS_SEND_E+1 !<-- Then increment the E bndry counter of the child tasks LOCAL_TASK_RANK_E(NUM_TASKS_SEND_E,1)=NC !<-- This child task's count in list of fcst tasks LOCAL_TASK_RANK_E(NUM_TASKS_SEND_E,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm NC_LAST_E=NC NC_HOLD_E(NC)=NUM_TASKS_SEND_E ENDIF ! IF(J_SAVE_LO_EAST(NC_HOLD_E(NC))<0)THEN J_SAVE_LO_EAST(NC_HOLD_E(NC))=J_CHILD !<-- Save southernmost Ebndry J of child task NC ! that is on this parent task. ENDIF J_SAVE_HI_EAST(NC_HOLD_E(NC))=J_CHILD !<-- Save northernmost Ebndry J of child task NC ! that is on this parent task. ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! i_east: DO I_CHILD=IM_END,IM_END-N_BLEND+1-N_ADD,-1 !<-- Blending region of child's eastern boundary ! KOUNT_I=KOUNT_I+1 REAL_I_PARENT=REAL_I_START-(KOUNT_I-1)*RATIO_C_P !<-- REAL parent I for this child's I ! I_INDX_EBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's east boundary point I_INDX_EBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's east boundary point J_INDX_EBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's east boundary point J_INDX_EBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's east boundary point ! WEIGHT_SW=(I_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (J_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_SE=(REAL_I_PARENT-I_INDX_EBND(I_CHILD,J_CHILD,1))* & (J_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) WEIGHT_NW=(I_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & (REAL_J_PARENT-J_INDX_EBND(I_CHILD,J_CHILD,1)) WEIGHT_NE=(REAL_I_PARENT-I_INDX_EBND(I_CHILD,J_CHILD,1))* & (REAL_J_PARENT-J_INDX_EBND(I_CHILD,J_CHILD,1)) ! RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) ! WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point ! ENDDO i_east ! !----------------------------------------------------------------------- ENDIF child_ij_e !----------------------------------------------------------------------- ! ENDIF j_block ! !----------------------------------------------------------------------- ! ENDDO j_loop ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_TO_CHILD_INTERP_FACTORS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE POINT_INTERP_DATA_TO_MEMORY(N_CHILD & ,MY_DOMAIN_ID & ,TIME_FLAG) ! !----------------------------------------------------------------------- !*** Create unallocated working pointers for nest boundary variables !*** and point them into the allocated composite pointer that holds !*** all of a parent task's data it will send to each child boundary !*** task it covers. Nest boundary pressure though must be allocated !*** because it contains more data than is transferred since we need !*** extra points in order to do the 4-pt averaging to the nest !*** boundary V points for hydrostatic balancing of the boundary !*** data. ! !*** Only parents execute this routine. !----------------------------------------------------------------------- ! !----------------------- !*** Argument Variables !----------------------- ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- This child is being handled. ,MY_DOMAIN_ID !<-- The parent domain's ID ! CHARACTER(*),INTENT(IN) :: TIME_FLAG !<-- Current or future boundary data for the child? ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I_END_TRANSFER,ITE_CHILD_X,INDX2 & ,J_END_TRANSFER,JTE_CHILD_X & ,KOUNT_VAR,N,N_TASK & ,NBASE,NBASE_3D,NBASE_4D,NBASE_EXP & ,NCHILD_TASKS & ,NLOC_1,NLOC_2,NLOC_2_EXP & ,NN,NT,NV,NVAR,NWORDS,PROD ! INTEGER(kind=KINT) :: ISTAT ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N=N_CHILD ! !----------------------------------------------------------------------- !*** Select the appropriate part of the working array depending on !*** whether we are now concerned with children's boundaries for !*** their current time or for their future. !----------------------------------------------------------------------- ! IF(TIME_FLAG=='Future')THEN INDX2=1 ELSEIF(TIME_FLAG=='Current')THEN INDX2=2 ENDIF ! !----------------------------------------------------------------------- !*** For each child domain on this parent, create the working pointers !*** for the nest boundary variables for each child boundary task !*** and point them into the allocated composite data pointer that !*** holds all the data for transfer. Nest boundary pressure is !*** treated differently by allocating it and eventually copying it !*** directly into the composite data pointer. ! !*** Set logical flags so parent tasks know if they must send any !*** data at all to any nest boundary tasks. ! !*** Allocate/nullify new MPI handles for the most recent association !*** between parent tasks and nest boundary tasks for the ISends of !*** data to the nest boundaries. !----------------------------------------------------------------------- ! !----------- !*** South !----------- ! south_h: IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has child south boundary H points? ! NCHILD_TASKS=NUM_TASKS_SEND_H_S(N) !<-- # of Sbndry tasks on child N to recv H point data ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Sbndry H points ,stat=ISTAT) ALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Sbndry H point 1-D data string ALLOCATE(PD_B_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_SOUTH for each child task ! DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) ALLOCATE(BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS) & !<-- Working object for each 3D Sbnd H-pt vbl on each child task ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,11101)NVAR,N,NCHILD_TASKS,ISTAT 11101 FORMAT(' POINT_INTERP_DATA_TO_MEMORY failed to allocate' & ,' BND_VAR(',I2,')%CHILD(',I2,')%TASKS(1:',I4,')' & ,' ISTAT=',I4) CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) ENDIF ENDDO ! !----------------------------------------------------------------------- ! nt_south_h: DO NT=1,NCHILD_TASKS ! N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Count of this task in list of all child fcst tasks ! NBASE=CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT) & -CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NT)+1 ! PROD=NBASE*N_BLEND_H_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Sbndry words in 2D,3D H-pt vbls parent sends to child ! KOUNT_VAR=0 IF(NVARS_BC_2D_H>1)THEN DO NV=2,NVARS_BC_2D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_H(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_4D NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Sbndry words in 4-D H-pt variables ENDDO ENDIF ! WORDS_BOUND_H_SOUTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks ! with South boundary H points NLOC_1=1 NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 ! NBASE_EXP=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT) & -CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NT)+1 ! NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* to allow 4-pt averaging to V pts ! PD_B_SOUTH(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_SOUTH(N)%TASKS(NT)%DATA & ,'PD_B_SOUTH(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_SOUTH(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest H-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's south side. !----------------------------------------------------------------------- ! DO NVAR=1,NVARS_NESTBC_H-1 ! NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- Sbndry storage for H-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO nt_south_h ! ELSE south_h !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1:1)) CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_SOUTH(N)%TASKS(1:1)) PD_B_SOUTH(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_SOUTH(N)%TASKS(1)%DATA & ,'PD_B_SOUTH(N)%TASKS(1)%DATA') ALLOCATE(PD_B_SOUTH(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_H-1 ALLOCATE(BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1:1),stat=ISTAT) IF(ISTAT>0)THEN WRITE(0,11201)NVAR,N,ISTAT 11201 FORMAT(' POINT_INTERP_DATA_TO_MEMORY failed to allocate' & ,' dummy BND_VAR(',I2,')%CHILD(',I2,')%TASKS(1:1)' & ,' ISTAT=',I4) ENDIF BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1)%DATA=>NULL() ENDDO ! ALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS(1:1)) ! ENDIF south_h ! !----------------------------------------------------------------------- ! south_v: IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has child south boundary V points? ! NCHILD_TASKS=NUM_TASKS_SEND_V_S(N) ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Sbndry V points ALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Sbndry V point 1-D data string ! ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_SOUTH_V for each child task ! DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables ALLOCATE(BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Sbnd V-pt vbl on each child task ENDDO ! DO NT=1,NCHILD_TASKS NBASE =CHILDTASK_V_SAVE(N)%I_HI_SOUTH(NT) & -CHILDTASK_V_SAVE(N)%I_LO_SOUTH(NT)+1 PROD=NBASE*N_BLEND_V_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Sbndry words in 2D,3D V-pt vbls parent sends to child WORDS_BOUND_V_SOUTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! KOUNT_VAR=0 IF(NVARS_BC_2D_V>0)THEN DO NV=2,NVARS_BC_2D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_V(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_V(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks with Sbndry V points ! PD_B_SOUTH_V(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_SOUTH_V(N)%TASKS(NT)%DATA & ,'PD_B_SOUTH_V(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_SOUTH_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest V-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's south side. !----------------------------------------------------------------------- ! NLOC_2=0 DO NVAR=1,NVARS_NESTBC_V ! NLOC_1=NLOC_2+1 NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- S bndry storage for V-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO ! ELSE south_v !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1:1)) CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1:1)) PD_B_SOUTH_V(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_SOUTH_V(N)%TASKS(1)%DATA & ,'PD_B_SOUTH_V(N)%TASKS(1)%DATA') ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_V ALLOCATE(BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1:1)) BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1)%DATA=>NULL() ENDDO ! ALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS(1:1)) ! ENDIF south_v ! !------------------------------------------------------------------------ ! !----------- !*** North !----------- ! north_h: IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has child north boundary H points? ! NCHILD_TASKS=NUM_TASKS_SEND_H_N(N) ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Nbndry H points ,stat=ISTAT) ALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Nbndry H point 1-D data string ALLOCATE(PD_B_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_NORTH for each child task ! DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) ALLOCATE(BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Nbnd H-pt vbl on each child task ENDDO ! nt_north_h: DO NT=1,NCHILD_TASKS ! N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Count of this task in list of all child fcst tasks ! !------------------------------------------------------------------------ ! NBASE=CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT) & -CHILDTASK_H_SAVE(N)%I_LO_NORTH(NT)+1 ! PROD=NBASE*N_BLEND_H_CHILD(N) NBASE_3D=LM*NBASE*N_BLEND_H_CHILD(N) NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Nbndry words in 2D,3D H-pt vbls parent sends to child WORDS_BOUND_H_NORTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! KOUNT_VAR=0 IF(NVARS_BC_2D_H>1)THEN DO NV=2,NVARS_BC_2D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_H(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_4D NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Nbndry words in 4-D H-pt variables ENDDO ENDIF ! CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks ,stat=ISTAT) ! with north boundary H points. NLOC_1=1 NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 ! NBASE_EXP=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT) & -CHILDTASK_H_SAVE(N)%I_LO_NORTH(NT)+1 ! NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts ! PD_B_NORTH(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_NORTH(N)%TASKS(NT)%DATA & ,'PD_B_NORTH(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_NORTH(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP) & ,stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest H-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's north side. !----------------------------------------------------------------------- ! DO NVAR=1,NVARS_NESTBC_H-1 ! NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- N bndry storage for H-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO nt_north_h ! ELSE north_h !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1:1)) CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA(1:1) & ,stat=ISTAT) ALLOCATE(PD_B_NORTH(N)%TASKS(1:1)) PD_B_NORTH(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_NORTH(N)%TASKS(1)%DATA & ,'PD_B_NORTH(N)%TASKS(1)%DATA') ALLOCATE(PD_B_NORTH(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_H-1 ALLOCATE(BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS(1:1)) ! ENDIF north_h ! !------------------------------------------------------------------------ ! north_v: IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has child north boundary V points? ! NCHILD_TASKS=NUM_TASKS_SEND_V_N(N) ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Nbndry V points ALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Nbndry V point 1-D data string ! ALLOCATE(PD_B_NORTH_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_NORTH_V for each child task ! DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables ALLOCATE(BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Nbnd V-pt vbl on each child task ENDDO ! DO NT=1,NCHILD_TASKS NBASE=CHILDTASK_V_SAVE(N)%I_HI_NORTH(NT) & -CHILDTASK_V_SAVE(N)%I_LO_NORTH(NT)+1 PROD=NBASE*N_BLEND_V_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Nbndry words in 2D,3D V-pt vbls parent sends to child WORDS_BOUND_V_NORTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! KOUNT_VAR=0 IF(NVARS_BC_2D_V>0)THEN DO NV=2,NVARS_BC_2D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_V(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_V(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks with Nbndry V points ,stat=ISTAT) ! PD_B_NORTH_V(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_NORTH_V(N)%TASKS(NT)%DATA & ,'PD_B_NORTH_V(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_NORTH_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)) & ,stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest V-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's north side. !----------------------------------------------------------------------- ! NLOC_2=0 DO NVAR=1,NVARS_NESTBC_V ! NLOC_1=NLOC_2+1 NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- N bndry storage for V-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO ! ELSE north_v !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1:1)) CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA(1:1) & ,stat=ISTAT) ALLOCATE(PD_B_NORTH_V(N)%TASKS(1:1)) PD_B_NORTH_V(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_NORTH_V(N)%TASKS(1)%DATA & ,'PD_B_NORTH_V(N)%TASKS(1)%DATA') ALLOCATE(PD_B_NORTH_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_V ALLOCATE(BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS(1:1)) ! ENDIF north_v ! !------------------------------------------------------------------------ ! !---------- !*** West !---------- ! west_h: IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has child west boundary H points? ! NCHILD_TASKS=NUM_TASKS_SEND_H_W(N) ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Wbndry H points ,stat=ISTAT) ALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Wbndry H point 1-D data string ALLOCATE(PD_B_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_WEST for each child task ! DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) ALLOCATE(BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Wbnd H-pt vbl on each child task ENDDO ! nt_west_h: DO NT=1,NCHILD_TASKS ! N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Count of this task in list of all child fcst tasks ! !----------------------------------------------------------------------- ! NBASE=CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT) & -CHILDTASK_H_SAVE(N)%J_LO_WEST(NT)+1 ! PROD=NBASE*N_BLEND_H_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Wbndry words in 2D,3D H-pt vbls parent sends to child ! KOUNT_VAR=0 IF(NVARS_BC_2D_H>1)THEN DO NV=2,NVARS_BC_2D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_H(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_4D NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Wbndry words in 4-D H-pt variables ENDDO ENDIF ! WORDS_BOUND_H_WEST(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks ! with west boundary H points NLOC_1=1 NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 ! NBASE_EXP=CHILDTASK_H_SAVE(N)%J_HI_WEST(NT) & -CHILDTASK_H_SAVE(N)%J_LO_WEST(NT)+1 ! NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts ! PD_B_WEST(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_WEST(N)%TASKS(NT)%DATA & ,'PD_B_WEST(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_WEST(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest H-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's west side. !----------------------------------------------------------------------- ! DO NVAR=1,NVARS_NESTBC_H-1 ! NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- W bndry storage for H-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO nt_west_h ! ELSE west_h !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1:1)) CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_WEST(N)%TASKS(1:1)) PD_B_WEST(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_WEST(N)%TASKS(1)%DATA & ,'PD_B_WEST(N)%TASKS(1)%DATA') ALLOCATE(PD_B_WEST(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_H-1 ALLOCATE(BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS(1:1)) ! ENDIF west_h ! !----------------------------------------------------------------------- ! west_v: IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has child west boundary V points? ! NCHILD_TASKS=NUM_TASKS_SEND_V_W(N) ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Wbndry V points ALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Wbndry V point 1-D data string ! ALLOCATE(PD_B_WEST_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_WEST_V for each child task ! DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables ALLOCATE(BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS) & !<-- Working object for each 3D Wbnd V-pt vbl on each child task ,stat=ISTAT) ENDDO ! DO NT=1,NCHILD_TASKS NBASE=CHILDTASK_V_SAVE(N)%J_HI_WEST(NT) & -CHILDTASK_V_SAVE(N)%J_LO_WEST(NT)+1 PROD=NBASE*N_BLEND_V_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Wbndry words in 2D,3D V-pt vbls parent sends to child WORDS_BOUND_V_WEST(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! KOUNT_VAR=0 IF(NVARS_BC_2D_V>0)THEN DO NV=2,NVARS_BC_2D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_V(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_V(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks with Wbndry V points ,stat=ISTAT) ! PD_B_WEST_V(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_WEST_V(N)%TASKS(NT)%DATA & ,'PD_B_WEST_V(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_WEST_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest V-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's west side. !----------------------------------------------------------------------- ! NLOC_2=0 DO NVAR=1,NVARS_NESTBC_V ! NLOC_1=NLOC_2+1 NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- W bndry storage for V-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO ! ELSE west_v !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1:1)) CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_WEST_V(N)%TASKS(1:1)) PD_B_WEST_V(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_WEST_V(N)%TASKS(1)%DATA & ,'PD_B_WEST_V(N)%TASKS(1)%DATA') ALLOCATE(PD_B_WEST_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_V ALLOCATE(BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS(1:1)) ! ENDIF west_v ! !----------------------------------------------------------------------- ! !---------- !*** East !---------- ! east_h: IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has child east boundary H points? ! NCHILD_TASKS=NUM_TASKS_SEND_H_E(N) ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Ebndry H points ,stat=ISTAT) ALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Ebndry H point 1-D data string ! ALLOCATE(PD_B_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_EAST for each child task ! DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) ALLOCATE(BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Ebnd H-pt vbl on each child task ENDDO ! nt_east_h: DO NT=1,NCHILD_TASKS ! N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Count of this task in list of all child fcst tasks ! !----------------------------------------------------------------------- ! NBASE=CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT) & -CHILDTASK_H_SAVE(N)%J_LO_EAST(NT)+1 ! PROD=NBASE*N_BLEND_H_CHILD(N) NBASE_3D=LM*NBASE*N_BLEND_H_CHILD(N) NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Ebndry words in 2D,3D H-pt vbls parent sends to child ! KOUNT_VAR=0 IF(NVARS_BC_2D_H>1)THEN DO NV=2,NVARS_BC_2D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_H(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls NBASE_VAR_H(KOUNT_VAR)=NBASE_4D NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Wbndry words in 4-D H-pt variables ENDDO ENDIF ! WORDS_BOUND_H_EAST(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks ! with east boundary H points NLOC_1=1 NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 ! NBASE_EXP=CHILDTASK_H_SAVE(N)%J_HI_EAST(NT) & -CHILDTASK_H_SAVE(N)%J_LO_EAST(NT)+1 ! NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts ! PD_B_EAST(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_EAST(N)%TASKS(NT)%DATA & ,'PD_B_EAST(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_EAST(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest H-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's east side. !----------------------------------------------------------------------- ! DO NVAR=1,NVARS_NESTBC_H-1 ! NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- E bndry storage for H-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO nt_east_h ! ELSE east_h !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1:1)) CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_EAST(N)%TASKS(1:1)) PD_B_EAST(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_EAST(N)%TASKS(1)%DATA & ,'PD_B_EAST(N)%TASKS(1)%DATA') ALLOCATE(PD_B_EAST(N)%TASKS(1)%DATA(1:1)) ! DO NVAR=1,NVARS_NESTBC_H-1 ALLOCATE(BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS(1:1)) ! ENDIF east_h ! !----------------------------------------------------------------------- ! east_v: IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has child east boundary V points? ! NCHILD_TASKS=NUM_TASKS_SEND_V_E(N) ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Ebndry V points ALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Ebndry V point 1-D data string ! ALLOCATE(PD_B_EAST_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_EAST_V for each child task ! DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables ALLOCATE(BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Ebnd V-pt vbl on each child task ENDDO ! DO NT=1,NCHILD_TASKS NBASE=CHILDTASK_V_SAVE(N)%J_HI_EAST(NT) & -CHILDTASK_V_SAVE(N)%J_LO_EAST(NT)+1 PROD=NBASE*N_BLEND_V_CHILD(N) NBASE_3D=LM*PROD NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Ebndry words in 2D,3D V-pt vbls parent sends to child WORDS_BOUND_V_EAST(N)%TASKS(NT)=NWORDS !<-- Save total number of words ! KOUNT_VAR=0 IF(NVARS_BC_2D_V>0)THEN DO NV=2,NVARS_BC_2D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD NBASE_VAR_V(KOUNT_VAR)=NBASE ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls NBASE_VAR_V(KOUNT_VAR)=NBASE_3D ENDDO ENDIF ! CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA & ,'CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA') ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks with Ebndry V points ! PD_B_EAST_V(N)%TASKS(NT)%DATA=>NULL() CALL CHECK_REAL(PD_B_EAST_V(N)%TASKS(NT)%DATA & ,'PD_B_EAST_V(N)%TASKS(NT)%DATA') ALLOCATE(PD_B_EAST_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) ! !----------------------------------------------------------------------- !*** Point the working pointer for each nest V-pt boundary variable !*** into the object that holds all nest BC update data for child N's !*** domain's east side. !----------------------------------------------------------------------- ! NLOC_2=0 DO NVAR=1,NVARS_NESTBC_V ! NLOC_1=NLOC_2+1 NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- E bndry storage for V-pt vbl NVAR, child N, task NT ! ENDDO ! ENDDO ! ELSE east_v !<-- Dummy nonzero length ! ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1:1)) CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA & ,'CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA') ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA(1:1)) ALLOCATE(PD_B_EAST_V(N)%TASKS(1:1)) PD_B_EAST_V(N)%TASKS(1)%DATA=>NULL() CALL CHECK_REAL(PD_B_EAST_V(N)%TASKS(1)%DATA & ,'PD_B_EAST_V(N)%TASKS(1)%DATA') ALLOCATE(PD_B_EAST_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) ! DO NVAR=1,NVARS_NESTBC_V ALLOCATE(BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(1:1)) ENDDO ! ALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS(1:1)) ! ENDIF east_v ! !----------------------------------------------------------------------- !*** Here we set logical flags so each parent tasks knows whether or !*** not it must send data to any side of child N's boundary. !----------------------------------------------------------------------- ! IF(NUM_TASKS_SEND_H_S(N)>0.OR. & NUM_TASKS_SEND_H_N(N)>0.OR. & NUM_TASKS_SEND_H_W(N)>0.OR. & NUM_TASKS_SEND_H_E(N)>0.OR. & NUM_TASKS_SEND_V_S(N)>0.OR. & NUM_TASKS_SEND_V_N(N)>0.OR. & NUM_TASKS_SEND_V_W(N)>0.OR. & NUM_TASKS_SEND_V_E(N)>0)THEN ! SEND_CHILD_DATA(N)=.TRUE. ! ELSE SEND_CHILD_DATA(N)=.FALSE. ENDIF ! !----------------------------------------------------------------------- !*** Allocate and initialize the new handles created for ISends !*** between parent tasks and nest boundary tasks. That association !*** of tasks obviously changes each time the nests move. !----------------------------------------------------------------------- ! !------------------------------- !*** For child boundary, south !------------------------------- ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN ALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_S(N)) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:',NUM_TASKS_SEND_H_S(N) & ,') stat=',ISTAT WRITE(0,*)' N=',N,' INDX2=',INDX2 ! ELSE ! WRITE(0,*)' Allocated HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:',NUM_TASKS_SEND_H_S(N),')' ENDIF DO NN=1,NUM_TASKS_SEND_H_S(N) HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate dummy HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1) stat=',ISTAT WRITE(0,*)' N=',N,' INDX2=',INDX2 ! ELSE ! WRITE(0,*)' Allocated dummy HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1)' ENDIF HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! IF(NUM_TASKS_SEND_V_S(N)>0)THEN ALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_S(N))) DO NN=1,NUM_TASKS_SEND_V_S(N) HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! !------------------------------- !*** For child boundary, north !------------------------------- ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN ALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_N(N))) DO NN=1,NUM_TASKS_SEND_H_N(N) HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! IF(NUM_TASKS_SEND_V_N(N)>0)THEN ALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_N(N))) DO NN=1,NUM_TASKS_SEND_V_N(N) HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! !------------------------------ !*** For child boundary, west !------------------------------ ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN ALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_W(N))) DO NN=1,NUM_TASKS_SEND_H_W(N) HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! IF(NUM_TASKS_SEND_V_W(N)>0)THEN ALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_W(N))) DO NN=1,NUM_TASKS_SEND_V_W(N) HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! !------------------------------ !*** For child boundary, east !------------------------------ ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN ALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_E(N))) DO NN=1,NUM_TASKS_SEND_H_E(N) HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! IF(NUM_TASKS_SEND_V_E(N)>0)THEN ALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_E(N))) DO NN=1,NUM_TASKS_SEND_V_E(N) HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL ENDDO ELSE ALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1:1)) HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE POINT_INTERP_DATA_TO_MEMORY ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_SENDS_CHILD_DATA_LIMITS(N_CHILD & ,MY_DOMAIN_ID & ,TIME_FLAG ) ! !----------------------------------------------------------------------- !*** Parents send children basic bookkeeping information needed !*** for the exchange of boundary data during the integration. !----------------------------------------------------------------------- ! !----------------------- !*** Argument Variables !----------------------- ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The child being considered by this parent ,MY_DOMAIN_ID !<-- Parent's domain ID ! CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- For future or current BC data from parent ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ID,ID_ADD,ID_CHILD,ID_CHILDTASK,IERR,ISTAT & ,MYPE,N,NRANK,NT,NTAG_SEND,NTX ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_PACKET,INFO ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! TYPE(COMPOSITE),POINTER :: CC ! integer(kind=kint) :: lb1,ub1,nz integer(kind=kint),dimension(8) :: values !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Parent tasks send six pieces of information (five for V points) !*** to child tasks on child domain boundaries so those child tasks !*** will be able to receive boundary data and use it properly. The !*** final two are used to serve as checks that the intended child !*** targeted tasks are the actual recipients. ! ! (1) The parent-child intracomm rank of the sending parent task. ! (2) The child boundary tasks' starting (I,J) on the parent task. ! (3) The child boundary tasks' ending (I,J) on the parent task. ! ! (4) The child boundary tasks' ending (I,J) on the parent task <-- Only for H points. ! for the extended data to allow for 4-pt interpolation. <-- ! ! (5) The parent-child intracomm rank of the target child task. ! (6) The domain ID of the target child task. ! !*** The child task must be able to know if the data it receives !*** pertains to south boundary H or V points, north boundary !*** H or V, points, etc. Thus the MPI tag will indicate !*** the boundary's side and variable type. ! ! 11111 --> South H ! 22222 --> South V ! 33333 --> North H ! 44444 --> North V ! 55555 --> West H ! 66666 --> West V ! 77777 --> East H ! 88888 --> East V ! !*** (The child tasks know which side of their domain's boundary they !*** are on of course but since a corner task is on more than one side, !*** the above tags indicating the side are used for all child tasks.) !----------------------------------------------------------------------- ! N=N_CHILD ID=MY_DOMAIN_ID ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- ! CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(N),MYPE,IERR) !<-- Obtain rank of parent task ID_CHILD=MY_CHILDREN_ID(N) ID_ADD=1000*ID_CHILD ! !------------- !*** South H !------------- ! HANDLE_PACKET=>HANDLE_PACKET_S_H(ID)%CHILDREN(N)%DATA ! sh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,1) !<-- South H info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Look for a child task with south boundary H points ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ south boundary H points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=11111+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Save the ending index of expanded boundary segment on child INFO(5)=ID_CHILDTASK !<-- Save the target child task rank INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task ! ! write(0,56561)my_domain_id,n,id_child,nt,nrank,id_childtask ! write(0,56562)ntag_send,id_childtask,id_add,info 56561 format(' PARENT_SENDS_CHILD_DATA_LIMITS my_domain_id=',i2,' to send SH to child #',i2,' domain id=',i2,' task #',i3 & ,' nrank=',i3,' child task rank=',i3) 56562 format(' tag=',i6,' intracomm rank=',i3,' id_add=',i5,' info=',6(1x,i5)) CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Sbndry task ,6 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! write(0,56563)id_childtask 56563 format(' sent SH info to id_childtask=',i3) ! write(0,*)' S_H parent ISent child #',n,' child domain id=',id_child,' task #',nt,' nrank=',nrank,' ntx=',ntx & ! ,' child task count=',CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) & ! ,' intracomm rank=',id_childtask,' ierr=',ierr ! write(0,*)' south_h info=',info ! CYCLE sh_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no south boundary H points NTAG_SEND=11111+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! write(0,*)' PARENT_SENDS_CHILD_DATA_LIMITS my_domain_id=',id,' dummy South H isend to child #',n,' child rank ',ID_CHILDTASK & ! ,' task #',nt ! write(0,25621)id,n,id_childtask,nt,ntag_send,id_add 25621 format(' PARENT_SENDS_CHILD_DATA_LIMITS dummy South H isend my_domain_id=',i2,' child #',i2,' child rank=',i3 & ,' task #',i3,' ntag=',i6,' id_add=',i6) CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! write(0,25622)id,n 25622 format(' PARENT_SENDS_CHILD_DATA_LIMITS dummy South H isent my_domain_id=',i2,' child #',i2) ! ENDDO sh_loop ! !------------- !*** South V !------------- ! HANDLE_PACKET=>HANDLE_PACKET_S_V(ID)%CHILDREN(N)%DATA ! sv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,2) !<-- South V info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_V_S(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_V_S(N) !<-- Look for a child task with south boundary V points ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ south boundary V points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=22222+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_V_SAVE(N)%I_LO_SOUTH(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_V_SAVE(N)%I_HI_SOUTH(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=ID_CHILDTASK !<-- Save the target child task rank INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Sbndry task ,5 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE sv_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no south boundary H points NTAG_SEND=22222+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO sv_loop ! !------------- !*** North H !------------- ! HANDLE_PACKET=>HANDLE_PACKET_N_H(ID)%CHILDREN(N)%DATA ! nh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,3) !<-- North H info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Look for a child task with north boundary H points ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ north boundary H points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=33333+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Save the ending index of expanded boundary segment on child INFO(5)=ID_CHILDTASK !<-- Save the target child task rank INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Nbndry task ,6 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE nh_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no north boundary H points NTAG_SEND=33333+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO nh_loop ! !------------- !*** North V !------------- ! HANDLE_PACKET=>HANDLE_PACKET_N_V(ID)%CHILDREN(N)%DATA ! nv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,4) !<-- North V info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_V_N(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_V_N(N) !<-- Look for a child task with north boundary V points ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%NORTH(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ north boundary V points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=44444+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_V_SAVE(N)%I_LO_NORTH(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_V_SAVE(N)%I_HI_NORTH(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=ID_CHILDTASK !<-- Save the target child task rank INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Nbndry task ,5 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE nv_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no north boundary V points NTAG_SEND=44444+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO nv_loop ! !------------ !*** West H !------------ ! HANDLE_PACKET=>HANDLE_PACKET_W_H(ID)%CHILDREN(N)%DATA ! wh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,5) !<-- West H info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Look for a child task with west boundary H points ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ west boundary H points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=CHILD_RANKS(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=55555+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Save the ending index of expanded boundary segment on child INFO(5)=ID_CHILDTASK !<-- Save the target child task rank INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Wbndry task ,6 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE wh_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no west boundary H points NTAG_SEND=55555+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ! ,55555,COMM_TO_MY_CHILDREN(N) & ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO wh_loop ! !------------ !*** West V !------------ ! HANDLE_PACKET=>HANDLE_PACKET_W_V(ID)%CHILDREN(N)%DATA ! wv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,6) !<-- West V info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_V_W(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_V_W(N) !<-- Look for a child task with west boundary V points ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%WEST(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ west boundary V points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=66666+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_V_SAVE(N)%J_LO_WEST(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_V_SAVE(N)%J_HI_WEST(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=ID_CHILDTASK !<-- Save the target child task rank INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Wbndry task ,5 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE wv_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no west boundary V points NTAG_SEND=66666+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ! ,66666,COMM_TO_MY_CHILDREN(N) & ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO wv_loop ! !------------ !*** East H !------------ ! HANDLE_PACKET=>HANDLE_PACKET_E_H(ID)%CHILDREN(N)%DATA ! eh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,7) !<-- East H info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Look for a child task with east boundary H points ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ east boundary H points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=77777+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Save the ending index of expanded boundary segment on child INFO(5)=ID_CHILDTASK !<-- Save the target child task rank INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Ebndry task ,6 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE eh_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no east boundary H points NTAG_SEND=77777+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO eh_loop ! !------------ !*** East V !------------ ! HANDLE_PACKET=>HANDLE_PACKET_E_V(ID)%CHILDREN(N)%DATA ! ev_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child ! CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. ,JSTAT & ,IERR ) ! INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,8) !<-- East V info to child N's task NT ! INFO(1)=-1 ! IF(NUM_TASKS_SEND_V_E(N)>0)THEN ! DO NTX=1,NUM_TASKS_SEND_V_E(N) !<-- Look for a child task with east boundary V points ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%EAST(NTX,1) !<-- Count of this child task in list of all fcst tasks ! IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ east boundary V points NRANK=ID_CHILDTASK-1 ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm NTAG_SEND=88888+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! INFO(1)=MYPE !<-- Save the parent task rank INFO(2)=CHILDTASK_V_SAVE(N)%J_LO_EAST(NTX) !<-- Save the starting index of boundary segment on child INFO(3)=CHILDTASK_V_SAVE(N)%J_HI_EAST(NTX) !<-- Save the ending index of boundary segment on child INFO(4)=ID_CHILDTASK !<-- Save the target child task rank INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task ! CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Ebndry task ,5 & !<-- # of words ,MPI_INTEGER & !<-- Datatype ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm ,NTAG_SEND & !<-- Tag for south boundary H points ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend ,IERR) ! CYCLE ev_loop !<-- Move on to next child task ENDIF ENDDO ! ENDIF ! ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no east boundary V points NTAG_SEND=88888+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & ,HANDLE_PACKET(NT),IERR) ! ENDDO ev_loop ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_SENDS_CHILD_DATA_LIMITS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE & ,MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Children receive from their parents basic bookkeeping information !*** needed for the exchange of boundary data during the integration. !*** The routine in which the parents send this data is !*** PARENT_SENDS_CHILD_DATA_LIMITS. !----------------------------------------------------------------------- ! !----------------------- !*** Argument Variables !----------------------- ! INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID ! TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE !<-- Parent-Child Coupler export state ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ID_ADD,ID_DOM,KOUNT,LB,LENGTH,N,N1,NBASE & ,NTAG_RECV,NV,UB ! INTEGER(kind=KINT) :: ILIM_HI,ILIM_LO,JLIM_HI,JLIM_LO ! INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_LIMITS ! INTEGER(kind=KINT),DIMENSION(6) :: INFO_R=(/-9999,0,0,0,0,0/) INTEGER(kind=KINT),DIMENSION(4) :: TEMP INTEGER(kind=KINT),DIMENSION(4,2) :: PARENT_INFO ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS ! TYPE(COMPOSITE),POINTER :: CC ! integer(kind=kint),dimension(8) :: values integer(kind=kint) :: my_rank,source,tag !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** The child tasks receive the key information from their !*** parent tasks. At this point the child tasks do not know !*** the local ranks of the parent tasks that will be sending !*** information to them thus MPI_ANY_SOURCE is used in the !*** receive. However this means that when there are two !*** parent tasks sending to a nest task (rather than only one) !*** then the two overlap points on the nest boundary segment !*** computed by the parent tasks will ultimately have values !*** depending on which parent task's preliminary information !*** is received last in the MPI_ANY_SOURCE Recv below. Since !*** the values in those overlap points are not bit identical !*** then any successive runs can have slightly different answers. !*** To avoid that happening when two parent tasks are sending, !*** the child task will receive their ranks and then put them !*** in ascending order so that all subsequent updates of the !*** nest boundary overlap points are always done in the same !*** way regardless of the order the preliminary information !*** is received with MPI_ANY_SOURCE. ! !*** All nests execute this routine once during the Init step and !*** then again on those parent timesteps during the Run step when !*** the child has moved. !----------------------------------------------------------------------- ! CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain local rank of child task in p-c intracomm ID_DOM=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of this child's parent ID_ADD=1000*MY_DOMAIN_ID ! !------------- !*** South H !------------- ! KOUNT=0 INDX_MIN_H%SOUTH= 1000000 INDX_MAX_H%SOUTH=-1000000 NTAG_RECV=11111+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12711)my_domain_id,mype,n,ntag_recv,id_add 12711 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv SH from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,6 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,11111 & !<-- Tag used for south boundary H points ,NTAG_RECV & !<-- Tag used for south boundary H points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12712)n,info_r(1) 12712 format(' recvd SH from parent task ',i3,' info_r(1)=',6(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task sent key preliminary bndry info ! IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd South H data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,4 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ! write(0,*)' CHILD_RECVS_CHILD_DATA_LIMITS south_h info_r=',info_r,' kount=',kount ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,4 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%SOUTH_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Sboundary H data segment PARENT_TASK(N)%SOUTH_H%INDX_START =PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment PARENT_TASK(N)%SOUTH_H%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment PARENT_TASK(N)%SOUTH_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Iend on child grid of the expanded boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H LENGTH=NLEV_H*NBASE ! PARENT_TASK(N)%SOUTH_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%SOUTH_H%STRING(1:LENGTH)) !<-- Sboundary H datastring to be received from parent task ! INDX_MIN_H%SOUTH=MIN(INDX_MIN_H%SOUTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent INDX_MAX_H%SOUTH=MAX(INDX_MAX_H%SOUTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_H%SOUTH=KOUNT !!! LENGTH_BND_SEG_H%SOUTH=INDX_MAX_H%SOUTH-INDX_MIN_H%SOUTH+1 ! south_h: IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Does this child task recv Sboundary H data from parent? ! ALLOCATE(cc%PDB_S(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H)) !<-- Full PDB south H boundary segment on this child task ! IF(NVARS_BC_2D_H>1)THEN DO NV=1,NVARS_BC_2D_H-1 ALLOCATE(cc%MY_BC_VARS_H_S%VAR_2D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H)) !<-- 2-D BC H-pt vbls except PD ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H ALLOCATE(cc%MY_BC_VARS_H_S%VAR_3D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H,1:LM)) !<-- 3-D BC H-pt vbls ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls ENDDO ENDIF ! ILIM_LO=INDX_MIN_H%SOUTH ILIM_HI=INDX_MAX_H%SOUTH JLIM_LO=1 JLIM_HI=N_BLEND_H ! LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_SOUTH_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Sbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_SOUTH_H' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_SOUTH_H' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_SOUTH_H' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_SOUTH_H' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF south_h ! !----------------------------------------------------------------------- ! !------------- !*** South V !------------- ! KOUNT=0 INDX_MIN_V%SOUTH= 1000000 INDX_MAX_V%SOUTH=-1000000 NTAG_RECV=22222+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12713)my_domain_id,mype,n,ntag_recv,id_add 12713 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv SV from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,5 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,22222 & !<-- Tag used for south boundary V points ,NTAG_RECV & !<-- Tag used for south boundary V points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12714)n,info_r(1) 12714 format(' recvd SV from parent task ',i3,' info_r(1)=',5(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd South V data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,3 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,3 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%SOUTH_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Sboundary V data segment PARENT_TASK(N)%SOUTH_V%INDX_START=PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment PARENT_TASK(N)%SOUTH_V%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V LENGTH=NLEV_V*NBASE ! PARENT_TASK(N)%SOUTH_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%SOUTH_V%STRING(1:LENGTH)) !<-- Sboundary V datastring to be received from parent task ! INDX_MIN_V%SOUTH=MIN(INDX_MIN_V%SOUTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent INDX_MAX_V%SOUTH=MAX(INDX_MAX_V%SOUTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_V%SOUTH=KOUNT !!! LENGTH_BND_SEG_V%SOUTH=INDX_MAX_V%SOUTH-INDX_MIN_V%SOUTH+1 ! south_v: IF(NUM_PARENT_TASKS_SENDING_V%SOUTH>0)THEN !<-- Does this child task recv any Sboundary V data from parent? ! IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(NV)%SIDE(INDX_MIN_V%SOUTH:INDX_MAX_V%SOUTH,1:N_BLEND_V)) !<-- 2-D vbls on this child task's ! south V bndry segment. ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V ALLOCATE(cc%MY_BC_VARS_V_S%VAR_3D(NV)%SIDE(INDX_MIN_V%SOUTH:INDX_MAX_V%SOUTH,1:N_BLEND_V,1:LM)) !<-- 3-D vbls on this child task's ! south V bndry segment. ENDDO ENDIF ! ILIM_LO=INDX_MIN_V%SOUTH ILIM_HI=INDX_MAX_V%SOUTH JLIM_LO=1 JLIM_HI=N_BLEND_V ! LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_SOUTH_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Sbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_SOUTH_V' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_SOUTH_V' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_SOUTH_V' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_SOUTH_V' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF south_v ! !----------------------------------------------------------------------- ! !------------- !*** North H !------------- ! KOUNT=0 INDX_MIN_H%NORTH= 1000000 INDX_MAX_H%NORTH=-1000000 NTAG_RECV=33333+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12715)my_domain_id,mype,n,ntag_recv,id_add 12715 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv NH from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,6 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,33333 & !<-- Tag used for north boundary H points ,NTAG_RECV & !<-- Tag used for north boundary H points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12716)n,info_r(1) 12716 format(' recvd NH from parent task ',i3,' info_r(1)=',6(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd North H data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,4 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,4 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%NORTH_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Nboundary H data segment PARENT_TASK(N)%NORTH_H%INDX_START =PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment PARENT_TASK(N)%NORTH_H%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment PARENT_TASK(N)%NORTH_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Iend on child grid of the expanded boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H LENGTH=NLEV_H*NBASE ! PARENT_TASK(N)%NORTH_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%NORTH_H%STRING(1:LENGTH)) !<-- Nboundary H datastring to be received from parent task ! INDX_MIN_H%NORTH=MIN(INDX_MIN_H%NORTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent INDX_MAX_H%NORTH=MAX(INDX_MAX_H%NORTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_H%NORTH=KOUNT !!! LENGTH_BND_SEG_H%NORTH=INDX_MAX_H%NORTH-INDX_MIN_H%NORTH+1 ! north_h: IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Does this child task recv Nboundary H data from parent? ! ALLOCATE(cc%PDB_N(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H)) ! IF(NVARS_BC_2D_H>1)THEN DO NV=1,NVARS_BC_2D_H-1 ALLOCATE(cc%MY_BC_VARS_H_N%VAR_2D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H)) !<-- 2-D BC H-pt vbls except PD ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H ALLOCATE(cc%MY_BC_VARS_H_N%VAR_3D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H,1:LM)) !<-- 3-D BC H-pt vbls ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls ENDDO ENDIF ! ILIM_LO=INDX_MIN_H%NORTH ILIM_HI=INDX_MAX_H%NORTH JLIM_LO=1 JLIM_HI=N_BLEND_H ! LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_NORTH_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Nbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_NORTH_H' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_NORTH_H' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_NORTH_H' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_NORTH_H' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF north_h ! !----------------------------------------------------------------------- ! !------------- !*** North V !------------- ! KOUNT=0 INDX_MIN_V%NORTH= 1000000 INDX_MAX_V%NORTH=-1000000 NTAG_RECV=44444+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12717)my_domain_id,mype,n,ntag_recv,id_add 12717 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv NV from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,5 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,44444 & !<-- Tag used for north boundary V points ,NTAG_RECV & !<-- Tag used for north boundary V points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12718)n,info_r(1) 12718 format(' recvd NV from parent task ',i3,' info_r(1)=',5(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd North V data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 ! if(kount>2)then ! write(0,*)' BUG: exceeded two parent tasks sending to this child bndry task' ! endif DO N1=1,3 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO !!!!!!!!!!!!!!!!!!!!!!!debug ! else ! write(0,*)' PARENT_TO_CHILD_DATA_LIMITS child recvd dummy north V from parent task #n=',n,' with id=',-1*info_r(1) !!!!!!!!!!!!!!!!!!!!!!!debug ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,3 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%NORTH_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Nboundary V data segment PARENT_TASK(N)%NORTH_V%INDX_START=PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment PARENT_TASK(N)%NORTH_V%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V LENGTH=NLEV_V*NBASE ! PARENT_TASK(N)%NORTH_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%NORTH_V%STRING(1:LENGTH)) !<-- Nboundary V datastring to be received from parent task ! INDX_MIN_V%NORTH=MIN(INDX_MIN_V%NORTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent INDX_MAX_V%NORTH=MAX(INDX_MAX_V%NORTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_V%NORTH=KOUNT !!! LENGTH_BND_SEG_V%NORTH=INDX_MAX_V%NORTH-INDX_MIN_V%NORTH+1 ! north_v: IF(NUM_PARENT_TASKS_SENDING_V%NORTH>0)THEN !<-- Does this child task recv any Nboundary V data from parent? ! IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(NV)%SIDE(INDX_MIN_V%NORTH:INDX_MAX_V%NORTH,1:N_BLEND_V)) !<-- 2-D vbls on this child task's ! north V bndry segment. ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V ALLOCATE(cc%MY_BC_VARS_V_N%VAR_3D(NV)%SIDE(INDX_MIN_V%NORTH:INDX_MAX_V%NORTH,1:N_BLEND_V,1:LM)) !<-- 3-D vbls on this child task's ! north V bndry segment. ENDDO ENDIF ! ILIM_LO=INDX_MIN_V%NORTH ILIM_HI=INDX_MAX_V%NORTH JLIM_LO=1 JLIM_HI=N_BLEND_V ! LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_NORTH_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Nbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_NORTH_V' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_NORTH_V' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_NORTH_V' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_NORTH_V' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF north_v ! !----------------------------------------------------------------------- ! !------------ !*** West H !------------ ! KOUNT=0 INDX_MIN_H%WEST= 1000000 INDX_MAX_H%WEST=-1000000 NTAG_RECV=55555+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12719)my_domain_id,mype,n,ntag_recv,id_add 12719 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv WH from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,6 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,55555 & !<-- Tag used for west boundary H points ,NTAG_RECV & !<-- Tag used for west boundary H points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12720)n,info_r(1) 12720 format(' recvd WH from parent task ',i3,' info_r(1)=',6(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd West H data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,4 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,4 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%WEST_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Wboundary H data segment PARENT_TASK(N)%WEST_H%INDX_START =PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment PARENT_TASK(N)%WEST_H%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment PARENT_TASK(N)%WEST_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Jend on child grid of the expanded boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H LENGTH=NLEV_H*NBASE ! PARENT_TASK(N)%WEST_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%WEST_H%STRING(1:LENGTH)) !<-- Wboundary H datastring to be received from parent task ! INDX_MIN_H%WEST=MIN(INDX_MIN_H%WEST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent INDX_MAX_H%WEST=MAX(INDX_MAX_H%WEST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_H%WEST=KOUNT !!! LENGTH_BND_SEG_H%WEST=INDX_MAX_H%WEST-INDX_MIN_H%WEST+1 ! west_h: IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Does this child task recv Wboundary H data from parent? ! ALLOCATE(cc%PDB_W(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST)) ! IF(NVARS_BC_2D_H>1)THEN DO NV=1,NVARS_BC_2D_H-1 ALLOCATE(cc%MY_BC_VARS_H_W%VAR_2D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST)) !<-- 2-D BC H-pt vbls except PD ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H ALLOCATE(cc%MY_BC_VARS_H_W%VAR_3D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST,1:LM)) !<-- 3-D BC H-pt vbls ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls ENDDO ENDIF ! ILIM_LO=1 ILIM_HI=N_BLEND_H JLIM_LO=INDX_MIN_H%WEST JLIM_HI=INDX_MAX_H%WEST ! LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_WEST_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Wbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_WEST_H' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_WEST_H' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_WEST_H' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_WEST_H' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF west_h ! !----------------------------------------------------------------------- ! !------------ !*** West V !------------ ! KOUNT=0 INDX_MIN_V%WEST= 1000000 INDX_MAX_V%WEST=-1000000 NTAG_RECV=66666+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12721)my_domain_id,mype,n,ntag_recv,id_add 12721 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv WV from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,5 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,66666 & !<-- Tag used for west boundary V points ,NTAG_RECV & !<-- Tag used for west boundary V points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12722)n,info_r(1) 12722 format(' recvd WV from parent task ',i3,' info_r(1)=',5(1x,i5)) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd West V data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,3 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,3 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%WEST_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Wboundary V data segment PARENT_TASK(N)%WEST_V%INDX_START=PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment PARENT_TASK(N)%WEST_V%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V LENGTH=NLEV_V*NBASE ! PARENT_TASK(N)%WEST_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%WEST_V%STRING(1:LENGTH)) !<-- Wboundary V datastring to be received from parent task ! INDX_MIN_V%WEST=MIN(INDX_MIN_V%WEST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent INDX_MAX_V%WEST=MAX(INDX_MAX_V%WEST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_V%WEST=KOUNT !!! LENGTH_BND_SEG_V%WEST=INDX_MAX_V%WEST-INDX_MIN_V%WEST+1 ! west_v: IF(NUM_PARENT_TASKS_SENDING_V%WEST>0)THEN !<-- Does this child task recv Wboundary V data from parent? ! IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%WEST:INDX_MAX_V%WEST)) !<-- 2-D vbls on this child task's ! west V bndry segment. ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V ALLOCATE(cc%MY_BC_VARS_V_W%VAR_3D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%WEST:INDX_MAX_V%WEST,1:LM)) !<-- 3-D vbls on this child task's ! west V bndry segment. ENDDO ENDIF ! ILIM_LO=1 ILIM_HI=N_BLEND_V JLIM_LO=INDX_MIN_V%WEST JLIM_HI=INDX_MAX_V%WEST ! LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_WEST_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Wbndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_WEST_V' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_WEST_V' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_WEST_V' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_WEST_V' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF west_v ! !----------------------------------------------------------------------- ! !------------ !*** East H !------------ ! KOUNT=0 INDX_MIN_H%EAST= 1000000 INDX_MAX_H%EAST=-1000000 NTAG_RECV=77777+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! ! call date_and_time(values=values) ! write(0,9876)values(5),values(6),values(7),values(8) 9876 format(' Ready to recv E_H info from parent tasks at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12723)my_domain_id,mype,n,ntag_recv,id_add 12723 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv EH from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,6 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,77777 & !<-- Tag used for east boundary H points ,NTAG_RECV & !<-- Tag used for east boundary H points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12724)n,info_r(1) 12724 format(' recvd EH from parent task ',i3,' info_r(1)=',5(1x,i5)) ! ! source = status(MPI_SOURCE) ! tag = status(MPI_TAG) IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! ! IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? ! WRITE(0,*)' Recvd East H data that is not mine!!' ! WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) ! WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID ! write(0,*)' source=',source,' tag=',tag ! CYCLE !<-- If not then move on to next parent task's data. ! ENDIF ! KOUNT=KOUNT+1 DO N1=1,4 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,4 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT PARENT_TASK(N)%EAST_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Eboundary H data segment PARENT_TASK(N)%EAST_H%INDX_START =PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment PARENT_TASK(N)%EAST_H%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment PARENT_TASK(N)%EAST_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Jend on child grid of the expanded boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H LENGTH=NLEV_H*NBASE ! PARENT_TASK(N)%EAST_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%EAST_H%STRING(1:LENGTH)) !<-- Eboundary H datastring to be received from parent task ! INDX_MIN_H%EAST=MIN(INDX_MIN_H%EAST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent INDX_MAX_H%EAST=MAX(INDX_MAX_H%EAST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_H%EAST=KOUNT !!! LENGTH_BND_SEG_H%EAST=INDX_MAX_H%EAST-INDX_MIN_H%EAST+1 ! east_h: IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Does this child task recv Eboundary H data from parent? ! ALLOCATE(cc%PDB_E(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST)) ! IF(NVARS_BC_2D_H>1)THEN DO NV=1,NVARS_BC_2D_H-1 ALLOCATE(cc%MY_BC_VARS_H_E%VAR_2D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST)) !<-- 2-D BC H-pt vbls except PD ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H ALLOCATE(cc%MY_BC_VARS_H_E%VAR_3D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST,1:LM)) !<-- 3-D BC H-pt vbls ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls ENDDO ENDIF ! ILIM_LO=1 ILIM_HI=N_BLEND_H JLIM_LO=INDX_MIN_H%EAST JLIM_HI=INDX_MAX_H%EAST ! LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) ALLOCATE(cc%BOUND_1D_EAST_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Ebndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_EAST_H' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_EAST_H' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_EAST_H' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_EAST_H' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF east_h ! !----------------------------------------------------------------------- ! !------------ !*** East V !------------ ! KOUNT=0 INDX_MIN_V%EAST= 1000000 INDX_MAX_V%EAST=-1000000 NTAG_RECV=88888+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag ! DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks ! ! write(0,12725)my_domain_id,mype,n,ntag_recv,id_add 12725 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv EV from parent task ',i3,' tag=',i6,' id_add=',i5) CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task ,5 & !<-- # of words in data packet ,MPI_INTEGER & !<-- Datatype ,N & !<-- Rank of parent task that is sending ! ,88888 & !<-- Tag used for east boundary V points ,NTAG_RECV & !<-- Tag used for east boundary V points ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent ,STATUS & !<-- Status of Recv ,IERR) ! write(0,12726)n,info_r(1) 12726 format(' recvd EV from parent task ',i3,' info_r(1)=',5(1x,i5)) ! source=status(mpi_source) ! tag=status(mpi_tag) ! write(0,*)' parent task #',n,' source=',source,' info_r(1)=',info_r(1),' (2)=',info_r(2),' (3)=',info_r(3),' (4)=',info_r(4) & ! ,' (5)=',info_r(5) ! IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info ! IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? WRITE(0,*)' Recvd East V data that is not mine!!' WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID ! WRITE(0,*)' Message was sent from task ',source,' with tag=',tag CYCLE !<-- If not then move on to next parent task's data. ENDIF ! KOUNT=KOUNT+1 DO N1=1,3 PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task ENDDO ENDIF ! ENDDO ! IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks ! DO N1=1,3 !<-- Save parent data in order of ascending task IDs TEMP(N1) =PARENT_INFO(N1,1) ! PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! PARENT_INFO(N1,2)=TEMP(N1) !<-- ENDDO ! ENDIF ENDIF ! IF(KOUNT>0)THEN DO N=1,KOUNT ! PARENT_TASK(N)%EAST_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Eboundary V data segment PARENT_TASK(N)%EAST_V%INDX_START=PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment PARENT_TASK(N)%EAST_V%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment ! NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V LENGTH=NLEV_V*NBASE ! PARENT_TASK(N)%EAST_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry ! ALLOCATE(PARENT_TASK(N)%EAST_V%STRING(1:LENGTH)) !<-- Eboundary V datastring to be received from parent task ! INDX_MIN_V%EAST=MIN(INDX_MIN_V%EAST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent INDX_MAX_V%EAST=MAX(INDX_MAX_V%EAST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent ENDDO ENDIF ! NUM_PARENT_TASKS_SENDING_V%EAST=KOUNT !!! LENGTH_BND_SEG_V%EAST=INDX_MAX_V%EAST-INDX_MIN_V%EAST+1 ! east_v: IF(NUM_PARENT_TASKS_SENDING_V%EAST>0)THEN !<-- Does this child task recv Eboundary V data from parent? ! IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%EAST:INDX_MAX_V%EAST)) !<-- 2-D vbls on this child task's ! east V bndry segment. ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V ALLOCATE(cc%MY_BC_VARS_V_E%VAR_3D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%EAST:INDX_MAX_V%EAST,1:LM)) !<-- 3-D vbls on this child task's ! east V bndry segment. ENDDO ENDIF ! ILIM_LO=1 ILIM_HI=N_BLEND_V JLIM_LO=INDX_MIN_V%EAST JLIM_HI=INDX_MAX_V%EAST ! LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) !<-- All V-pt BC variables are assumed to be 3-D ALLOCATE(cc%BOUND_1D_EAST_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Ebndry segment ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_LO_EAST_V' & !<-- Name of the boundary array's lower I limit ,value=ILIM_LO & !<-- The boundary array's lower I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='ILIM_HI_EAST_V' & !<-- Name of the boundary array's upper I limit ,value=ILIM_HI & !<-- The boundary array's upper I limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_LO_EAST_V' & !<-- Name of the boundary array's lower J limit ,value=JLIM_LO & !<-- The boundary array's lower J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state ,name ='JLIM_HI_EAST_V' & !<-- Name of the boundary array's upper J limit ,value=JLIM_HI & !<-- The boundary array's upper J limit ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ENDIF east_v ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILD_RECVS_CHILD_DATA_LIMITS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHILD_SENDS_TOPO_TO_PARENT(MY_DOMAIN_ID & ,IMP_STATE ) ! !----------------------------------------------------------------------- !*** The children send their boundary surface geopotential to their !*** parents so the parents can properly balance their own data that !*** they interpolate to child boundary gridpoints. !----------------------------------------------------------------------- ! !----------------------- !*** Argument Variables !----------------------- ! INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- This child's domain ID ! TYPE(ESMF_State),INTENT(IN) :: IMP_STATE !<-- Parent-Child Coupler import state ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: IERR,KOUNT,MYPE & ,N,N1,N2,NTAG_SEND,NUM_WORDS & ,RC,RC_FIS ! INTEGER(kind=KINT) :: I_LO,I_HI,I_OFFSET & ,J_LO,J_HI,J_OFFSET ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: FIS_SEND ! TYPE(ESMF_Field) :: HOLD_FIELD ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! ! I_OFFSET=IMS-1+NHALO !<-- Offset of I in unloaded FIS vs. original FIS ! J_OFFSET=JMS-1+NHALO !<-- Offset of J in unloaded FIS vs. original FIS I_OFFSET=0 !<-- ESMF_INDEX now GLOBAL J_OFFSET=0 !<-- ESMF_INDEX now GLOBAL ! !----------------------------------------------------------------------- !*** Extract the Sfc Geopotential from the Coupler's import state. !*** If this child domain is also a parent then it already extracted !*** its FIS in 'parent_block' of PARENT_CHILD_CPL_INITIALIZE but we !*** now extract FIS again in case this child domain is not a parent. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract FIS Field from Parent-Child Coupler Import State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state ,itemName='FIS' & !<-- Extract FIS Field ,field =HOLD_FIELD & !<-- Put the extracted Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract FIS from ESMF Field in Parent-Child Coupler" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer ,localDe =0 & ,farrayPtr=FIS & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain rank of this child task ! !----------------------------------------------------------------------- ! !------------------------------ !*** Child South Boundary FIS !------------------------------ ! ! write(0,*)' CHILD_SENDS_TOPO_TO_PARENT mype=',mype,' NUM_PARENT_TASKS_SENDING_H%SOUTH=',NUM_PARENT_TASKS_SENDING_H%SOUTH IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Child tasks know which parent tasks compute their BCs NTAG_SEND=MYPE+1000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send ! DO N=1,NUM_PARENT_TASKS_SENDING_H%SOUTH !<-- Child sends its FIS to parent tasks that will be ! computing its BCs. I_LO=PARENT_TASK(N)%SOUTH_H%INDX_START !<-- Starting I of child covered by parent task N I_HI=PARENT_TASK(N)%SOUTH_H%INDX_END_EXP !<-- Ending I of child for expanded area covered by parent task N NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N ! with extra row of values for 4-pt interp to V pts KOUNT=0 ! DO N2=1,N_BLEND_H+1 !<-- Extra row for 4-pt interp of PD to V pts DO N1=I_LO,I_HI KOUNT=KOUNT+1 FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN FIS_SEND(KOUNT)=0. ENDIF ENDDO ENDDO ! CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N ,NUM_WORDS & !<-- There are NUM_WORDS words in the data ,MPI_REAL & !<-- Data is type Real ,PARENT_TASK(N)%SOUTH_H%ID_SOURCE & !<-- Data sent to this parent task ! ,MYPE & !<-- Use child task ID as the tag ,NTAG_SEND & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent ,IERR) ! DEALLOCATE(FIS_SEND) ! ENDDO ! ENDIF ! !------------------------------ !*** Child North Boundary FIS !------------------------------ ! IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Child tasks know which parent tasks compute their BCs NTAG_SEND=MYPE+2000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send ! DO N=1,NUM_PARENT_TASKS_SENDING_H%NORTH !<-- Child sends its FIS to parent tasks that will be ! computing its BCs. I_LO=PARENT_TASK(N)%NORTH_H%INDX_START !<-- Starting I of child covered by parent task N I_HI=PARENT_TASK(N)%NORTH_H%INDX_END_EXP !<-- Ending I of child for expanded area covered by parent task N NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N ! with extra row of values for 4-pt interp to V pts KOUNT=0 ! DO N2=JTE-N_BLEND_H ,JTE !<-- Extra row for 4-pt interp of PD to V pts DO N1=I_LO,I_HI KOUNT=KOUNT+1 FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN FIS_SEND(KOUNT)=0. ENDIF ENDDO ENDDO ! CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N ,NUM_WORDS & !<-- There are NUM_WORDS words in the data ,MPI_REAL & !<-- Data is type Real ,PARENT_TASK(N)%NORTH_H%ID_SOURCE & !<-- Data sent to this parent task ! ,MYPE & !<-- Use child task ID as the tag ,NTAG_SEND & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent ,IERR) ! DEALLOCATE(FIS_SEND) ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! !----------------------------- !*** Child West Boundary FIS !----------------------------- ! IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Child tasks know which parent tasks compute their BCs NTAG_SEND=MYPE+3000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send ! DO N=1,NUM_PARENT_TASKS_SENDING_H%WEST !<-- Child sends its FIS to parent tasks that will be ! computing its BCs. J_LO=PARENT_TASK(N)%WEST_H%INDX_START !<-- Starting J of child covered by parent task N J_HI=PARENT_TASK(N)%WEST_H%INDX_END_EXP !<-- Ending J of child for expanded area covered by parent task N NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N ! with extra row of values for 4-pt interp to V pts KOUNT=0 ! DO N2=J_LO,J_HI DO N1=1,N_BLEND_H+1 !<-- Extra row for 4-pt interp of PD to V pts KOUNT=KOUNT+1 FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N IF(ABS(FIS_SEND(KOUNT))<1.E-2)then FIS_SEND(KOUNT)=0. ENDIF ENDDO ENDDO ! CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N ,NUM_WORDS & !<-- There are NUM_WORDS words in the data ,MPI_REAL & !<-- Data is type Real ,PARENT_TASK(N)%WEST_H%ID_SOURCE & !<-- Data sent to this parent task ! ,MYPE & !<-- Use child task ID as the tag ,NTAG_SEND & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent ,IERR) ! DEALLOCATE(FIS_SEND) ENDDO ! ENDIF ! !----------------------------- !*** Child East Boundary FIS !----------------------------- ! IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Child tasks know which parent tasks compute their BCs NTAG_SEND=MYPE+4000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send ! DO N=1,NUM_PARENT_TASKS_SENDING_H%EAST !<-- Child sends its FIS to parent tasks that will be ! computing its BCs. J_LO=PARENT_TASK(N)%EAST_H%INDX_START !<-- Starting J of child covered by parent task N J_HI=PARENT_TASK(N)%EAST_H%INDX_END_EXP !<-- Ending J of child for expanded area covered by parent task N NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N ! with extra row of values for 4-pt interp to V pts KOUNT=0 ! DO N2=J_LO,J_HI DO N1=ITE-N_BLEND_H ,ITE !<-- Extra row for 4-pt interp of PD to V pts KOUNT=KOUNT+1 FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN FIS_SEND(KOUNT)=0. ENDIF ENDDO ENDDO ! CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N ,NUM_WORDS & !<-- There are NUM_WORDS words in the data ,MPI_REAL & !<-- Data is type Real ,PARENT_TASK(N)%EAST_H%ID_SOURCE & !<-- Data sent to this parent task ! ,MYPE & !<-- Use child task ID as the tag ,NTAG_SEND & !<-- MPI tag ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent ,IERR) ! DEALLOCATE(FIS_SEND) ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILD_SENDS_TOPO_TO_PARENT ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_RECVS_CHILD_TOPO(N_CHILD,MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Parents receive the boundary topography from their children !*** so the parents can properly balance their own data that they !*** interpolate to child gridpoints. !----------------------------------------------------------------------- ! !----------------------- !*** Argument Variables !----------------------- ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The child who is sending ,MY_DOMAIN_ID !<-- The parent's domain ID ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: CHILDTASK,ID,IERR,N,NDATA,NRANK & ,NTAG_RECV,NTX,NUM_WORDS ! INTEGER(kind=KINT) :: I_LO,I_HI,J_LO,J_HI ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS ! TYPE(COMPOSITE),POINTER :: CC ! integer(kind=kint) :: nnnn !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N=N_CHILD ID=MY_DOMAIN_ID ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** The parent tasks receive sfc geopotentials from the !*** child boundary tasks. !----------------------------------------------------------------------- ! !------------------------------ !*** Child South Boundary FIS !------------------------------ ! NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S FIS_CHILD_SOUTH=>cc%FIS_CHILD_SOUTH ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- This parent task covers some child Sboundary H points ! NDATA=NUM_TASKS_SEND_H_S(N) ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Sbndry child task on parent task ! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated fis_child_south(',n,')%tasks(1:',ndata,')' ALLOCATE(HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv ! DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Loop through those particular child tasks ! I_LO=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Starting I of child point bndry segment on this parent task I_HI=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Ending I of child point bndry segment on this parent task NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task ! with extra row for 4-pt interpolation of PD to V pts NRANK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) !<-- Count of child task in list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,2) & !<-- A unique MPI tag for this Recv +1000*MY_CHILDREN_ID(N) ! ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child S bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts ! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated fis_child_south(',n,')%tasks(',ntx,')%data(1:',num_words,')' ! write(0,*)' before IRecv S topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv & ! ,' num_words=',num_words ! write(0,*)' i_lo=',i_lo,' i_hi=',i_hi,' n_blend_h_child(n)=',n_blend_h_child(n) ! CALL MPI_IRECV(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Sbndry child task NTX ,NUM_WORDS & !<-- # of FIS values ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- The child task sending ,NTAG_RECV & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N ,HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handle for IRecvs ,IERR) ! write(0,*)' after IRecv S topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !------------------------------ !*** Child North Boundary FIS !------------------------------ ! NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N FIS_CHILD_NORTH=>cc%FIS_CHILD_NORTH ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- This parent task covers some child Nboundary H points ! NDATA=NUM_TASKS_SEND_H_N(N) ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Nbndry child task on parent task ALLOCATE(HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv ! DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Loop through those particular child tasks ! I_LO=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Starting I of child point bndry segment on this parent task I_HI=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Ending I of child point bndry segment on this parent task NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task NRANK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,1) !<-- Count of child task in list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,2) & !<-- A unique MPI tag for this Recv +2000*MY_CHILDREN_ID(N) ! ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child N bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts ! CALL MPI_IRECV(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Nbndry child task NTX ,NUM_WORDS & !<-- # of FIS values ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- The child task sending ,NTAG_RECV & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N ,HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handles for IRecvs ,IERR) ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !----------------------------- !*** Child West Boundary FIS !----------------------------- ! NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W FIS_CHILD_WEST=>cc%FIS_CHILD_WEST ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- This parent task covers some child Wboundary H points ! NDATA=NUM_TASKS_SEND_H_W(N) ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Wbndry child task on parent task ALLOCATE(HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv ! DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Loop through those particular child tasks ! J_LO=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Starting J of child point bndry segment on this parent task J_HI=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Ending J of child point bndry segment on this parent task NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task NRANK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,1) !<-- Count of child task in list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,2) & !<-- A unique MPI tag for this Recv +3000*MY_CHILDREN_ID(N) ! ALLOCATE(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child W bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts CALL MPI_IRECV(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Wbndry child task NTX ,NUM_WORDS & !<-- # of FIS values ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- The child task sending ,NTAG_RECV & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N ,HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handles for IRecvs ,IERR) ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !----------------------------- !*** Child East Boundary FIS !----------------------------- ! NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E FIS_CHILD_EAST=>cc%FIS_CHILD_EAST ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- This parent task covers some child Eboundary H points ! NDATA=NUM_TASKS_SEND_H_E(N) ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Ebndry child task on parent task ALLOCATE(HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv ! DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Loop through those particular child tasks ! J_LO=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Starting J of child point bndry segment on this parent task J_HI=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Ending J of child point bndry segment on this parent task NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task NRANK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,1) !<-- Count of child task in list of fcst tasks CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,2) & !<-- A unique MPI tag for this Recv +4000*MY_CHILDREN_ID(N) ! ALLOCATE(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child E bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts ! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated FIS_CHILD_EAST(',n,')%tasks(',ntx,')%data(1:',num_words,')' ! write(0,*)' j_lo=',j_lo,' j_hi=',j_hi,' n_blend_h_child(',n,')=',n_blend_h_child(n) ! ! write(0,*)' before IRecv E topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv CALL MPI_IRECV(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Ebndry child task NTX ,NUM_WORDS & !<-- # of FIS values ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- The child task sending ,NTAG_RECV & !<-- MPI tag ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N ,HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handle for the IRecv ,IERR) ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_RECVS_CHILD_TOPO ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_COMPUTES_CHILD_TOPO(N_CHILD & ,I_PARENT_SW & ,J_PARENT_SW & ,IM_CHILD & ,JM_CHILD & ,N_BLEND_H_CHILD & ,LBND1,UBND1,LBND2,UBND2 & ,MOVING_NEST_TOPO & ) ! !----------------------------------------------------------------------- !*** Parents fill the working arrays of their moving children's !*** boundary topography. The parents carry full arrays of topography !*** at each of their moving children's resolutions so the data only !*** needs to be lifted from those arrays. This avoids Sends and !*** Recvs of that data which could force the parents to Wait. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- Which child are we considering? ,I_PARENT_SW & !<-- Parent I index of child's SW corner ,J_PARENT_SW & !<-- Parent J index of child's SW corner ,IM_CHILD & !<-- I dimension of child domain ,JM_CHILD & !<-- J dimension of child domain ,N_BLEND_H_CHILD & !<-- Width of child's boundary blending region ! ,LBND1,UBND1 & !<-- I limits of nest-res FIS on this parent task ,LBND2,UBND2 !<-- J limits of nest-res FIS on this parent task ! REAL(kind=KFPT),DIMENSION(LBND1:UBND1,LBND2:UBND2),INTENT(IN) :: & MOVING_NEST_TOPO !<-- Nest-resolution topography on the parent task ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,I_HI,I_LO,I_OFFSET,ISTART & ,J,J_HI,J_LO,J_OFFSET,JSTART & ,KOUNT,N,NTX,NUM_WORDS ! REAL(kind=KFPT),DIMENSION(:),POINTER :: FIS_X ! integer(kind=kint) :: nnnn !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N=N_CHILD ! ISTART=MAX(IMS,IDS) !<-- The SW corner of this parent domain JSTART=MAX(JMS,JDS) !<-- ! !------------------------------ !*** Child South Boundary FIS !------------------------------ ! IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- This parent task covers some child Sboundary H points ! ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:NUM_TASKS_SEND_H_S(N))) !<-- FIS data slot for each Sbndry child task on parent task ! DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Loop through those particular child tasks ! I_LO=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Starting I of child point bndry segment on this parent task I_HI=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Ending I of child point bndry segment on this parent task NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task ! ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child S bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts FIS_X=>FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA ! I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent +LBND1-1 J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent +LBND2-1 KOUNT=0 ! DO J=1,N_BLEND_H_CHILD+1 DO I=I_LO,I_HI KOUNT=KOUNT+1 FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array ENDDO ENDDO ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !------------------------------ !*** Child North Boundary FIS !------------------------------ ! IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- This parent task covers some child Nboundary H points ! ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:NUM_TASKS_SEND_H_N(N))) !<-- FIS data slot for each Nbndry child task on parent task ! DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Loop through those particular child tasks ! I_LO=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Starting I of child point bndry segment on this parent task I_HI=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Ending I of child point bndry segment on this parent task NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task ! ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child N bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts FIS_X=>FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA ! I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent +LBND1-1 J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent +LBND2-1 KOUNT=0 ! DO J=JM_CHILD-N_BLEND_H_CHILD ,JM_CHILD DO I=I_LO,I_HI KOUNT=KOUNT+1 FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array ENDDO ENDDO ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !----------------------------- !*** Child West Boundary FIS !----------------------------- ! IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- This parent task covers some child Wboundary H points ! ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:NUM_TASKS_SEND_H_W(N))) !<-- FIS data slot for each Wbndry child task on parent task ! DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Loop through those particular child tasks ! J_LO=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Starting J of child point bndry segment on this parent task J_HI=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Ending J of child point bndry segment on this parent task NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task ! ALLOCATE(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child W bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts FIS_X=>FIS_CHILD_WEST(N)%TASKS(NTX)%DATA ! I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent +LBND1-1 J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent +LBND2-1 KOUNT=0 ! DO J=J_LO,J_HI DO I=1,N_BLEND_H_CHILD+1 KOUNT=KOUNT+1 FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array ENDDO ENDDO ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! !----------------------------- !*** Child East Boundary FIS !----------------------------- ! IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- This parent task covers some child Eboundary H points ! ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:NUM_TASKS_SEND_H_E(N))) !<-- FIS data slot for each Ebndry child task on parent task ! DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Loop through those particular child tasks ! J_LO=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Starting J of child point bndry segment on this parent task J_HI=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Ending J of child point bndry segment on this parent task NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task ! ALLOCATE(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child E bndry covered by this parent task ! with extra row for 4-pt interpolation of PD to V pts FIS_X=>FIS_CHILD_EAST(N)%TASKS(NTX)%DATA ! I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent +LBND1-1 J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent +LBND2-1 KOUNT=0 ! DO J=J_LO,J_HI !!! DO I=IM_CHILD-N_BLEND_H_CHILD+1,IM_CHILD DO I=IM_CHILD-N_BLEND_H_CHILD ,IM_CHILD KOUNT=KOUNT+1 FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array ENDDO ENDDO ! ENDDO ! ELSE ! ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:1)) ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1)%DATA(1:1)) ! ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_COMPUTES_CHILD_TOPO ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_UPDATE_CHILD_PSFC(FIS,PD,T,Q & ,PT,PDTOP,SG1,SG2 & ,IMS,IME,JMS,JME & ,NLEV & ! ,NUM_CHILD_TASKS & ,LIMITS & ! ,FIS_CHILD_SBND & ,FIS_CHILD_NBND & ,FIS_CHILD_WBND & ,FIS_CHILD_EBND & ! ,NUM_TASKS_SEND_SBND & ,NUM_TASKS_SEND_NBND & ,NUM_TASKS_SEND_WBND & ,NUM_TASKS_SEND_EBND & ! ,I_INDX_PARENT_SBND & ,I_INDX_PARENT_NBND & ,I_INDX_PARENT_WBND & ,I_INDX_PARENT_EBND & ,J_INDX_PARENT_SBND & ,J_INDX_PARENT_NBND & ,J_INDX_PARENT_WBND & ,J_INDX_PARENT_EBND & ! ,I_LO_SOUTH & ,I_HI_SOUTH & ,I_HI_SOUTH_TRANSFER & ,I_LO_NORTH & ,I_HI_NORTH & ,I_HI_NORTH_TRANSFER & ,J_LO_WEST & ,J_HI_WEST & ,J_HI_WEST_TRANSFER & ,J_LO_EAST & ,J_HI_EAST & ,J_HI_EAST_TRANSFER & ! ,WEIGHT_SBND & ,WEIGHT_NBND & ,WEIGHT_WBND & ,WEIGHT_EBND & ! ^ ,N_BLEND & ! | ,IM_CHILD_X & ! | ,JM_CHILD_X & ! Input ! ----------- ,CHILD_H_SBND & ! Output ,CHILD_H_NBND & ! | ,CHILD_H_WBND & ! | ,CHILD_H_EBND & ! v ! ,PDB_SBND & ! ,PDB_NBND & ! ,PDB_WBND & ! ,PDB_EBND ) ! ! !----------------------------------------------------------------------- !*** Given a child's actual surface geopotential, generate a new !*** value of PD for the child boundary points based on the !*** surrounding parent points. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits ,IM_CHILD_X,JM_CHILD_X & !<-- Index limits of the nest domain ,N_BLEND & !<-- # of domain boundary blending rows ,NLEV & !<-- # of vertical levels in parent array ,NUM_CHILD_TASKS & !<-- # of fcst tasks on this child ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sboundary regions on parent task ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nboundary regions on parent task ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wboundary regions on parent task ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Eboundary regions on parent task ! INTEGER(kind=KINT),DIMENSION(1:4,1:NUM_CHILD_TASKS),INTENT(IN) :: & LIMITS !<-- ITS,ITE,JTS,JTE on each task of the child ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & I_LO_SOUTH & !<-- Starting I of Sbndry region on child tasks ,I_HI_SOUTH & !<-- Ending I of Sbndry region on child tasks ,I_HI_SOUTH_TRANSFER & !<-- Ending I of Sbndry region for transfer to child ,I_LO_NORTH & !<-- Starting I of Nbndry region on child tasks ,I_HI_NORTH & !<-- Ending I of Nbndry region on child tasks ,I_HI_NORTH_TRANSFER & !<-- Ending I of Nbndry region for transfer to child ,J_LO_WEST & !<-- Starting J of Wbndry region on child tasks ,J_HI_WEST & !<-- Ending J of Wbndry region on child tasks ,J_HI_WEST_TRANSFER & !<-- Ending J of Wbndry region for transfer to child ,J_LO_EAST & !<-- Starting J of Ebndry region on child tasks ,J_HI_EAST & !<-- Ending J of Ebndry region on child tasks ,J_HI_EAST_TRANSFER !<-- Ending J of Ebndry region for transfer to child ! INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & I_INDX_PARENT_SBND & !<-- I indices of parent points west/east of child Sbndry point ,I_INDX_PARENT_NBND & !<-- I indices of parent points west/east of child Nbndry point ,I_INDX_PARENT_WBND & !<-- I indices of parent points west/east of child Wbndry point ,I_INDX_PARENT_EBND & !<-- I indices of parent points west/east of child Ebndry point ,J_INDX_PARENT_SBND & !<-- J indices of parent points south/north of child Sbndry point ,J_INDX_PARENT_NBND & !<-- J indices of parent points south/north of child Nbndry point ,J_INDX_PARENT_WBND & !<-- J indices of parent points south/north of child Wbndry point ,J_INDX_PARENT_EBND !<-- J indices of parent points south/north of child Ebndry point ! REAL(kind=KFPT),INTENT(IN) :: PT & !<-- Top pressure of model domain (Pa) ,PDTOP !<-- Pressure at top of sigma domain (Pa) ! REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(IN) :: SG1 & !<-- Interface sigmas, pressure domain ,SG2 !<-- Interface sigmas, sigma domain ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Parent FIS ,PD !<-- Parent PD ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: T & !<-- Parent sensible temperature (K) ,Q !<-- Parent specific humidity (kg/kg) ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & WEIGHT_SBND & !<-- Bilinear interp weights of the 4 parent points around ,WEIGHT_NBND & ! each point on child's boundary sides (S,N,W,E). ,WEIGHT_WBND & ! ,WEIGHT_EBND !<-- ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: FIS_CHILD_SBND & !<-- Sfc geopot on Sbndry points of each child task ,FIS_CHILD_NBND & !<-- Sfc geopot on Nbndry points of each child task ,FIS_CHILD_WBND & !<-- Sfc geopot on Wbndry points of each child task ,FIS_CHILD_EBND !<-- Sfc geopot on Ebndry points of each child task ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: CHILD_H_SBND & !<-- All H point data for child Sbndry to be sent by parent ,CHILD_H_NBND & !<-- All H point data for child Nbndry to be sent by parent ,CHILD_H_WBND & !<-- All H point data for child Wbndry to be sent by parent ,CHILD_H_EBND & !<-- All H point data for child Ebndry to be sent by parent ! ,PDB_SBND & !<-- Child boundary PD (Pa) on child domain Sbndry ,PDB_NBND & !<-- Child boundary PD (Pa) on child domain Nbndry ,PDB_WBND & !<-- Child boundary PD (Pa) on child domain Wbndry ,PDB_EBND !<-- Child boundary PD (Pa) on child domain Ebndry ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,J,L & ,I_EAST,I_WEST,J_SOUTH,J_NORTH & ,I_START,I_END,J_START,J_END & ,I_START_TRANSFER,I_END_TRANSFER & ,J_START_TRANSFER,J_END_TRANSFER & ,KOUNT_PTS & ,KOUNT_TRANSFER & ,N_SIDE,NUM_TASKS_SEND,NTX & ,RC ! INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_PARENT_BND & ,J_INDX_PARENT_BND ! REAL(kind=KFPT) :: COEFF_1,COEFF_2,D_LNP_DFI,FIS_CHILD & ,LOG_P1_PARENT,PDTOP_PT,PHI_DIFF,PSFC_CHILD & ,Q_INTERP,T_INTERP ! REAL(kind=KFPT) :: PX_NE,PX_NW,PX_SE,PX_SW & ,WGHT_NE,WGHT_NW,WGHT_SE,WGHT_SW ! REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: LOG_PBOT & ,LOG_PTOP ! REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PHI_INTERP & ,PINT_INTERP ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHT_BND ! TYPE(REAL_DATA),DIMENSION(:),POINTER :: CHILD_BOUND_H & ,FIS_CHILD_BND & ,PDB ! integer,dimension(8) :: values ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Loop through the four sides of the nest domain boundary (S,N,W,E). !*** We use some dummy variables/pointers generically for all four !*** of the sides. !----------------------------------------------------------------------- ! loop_sides: DO N_SIDE=1,4 !<-- Loop through the 4 lateral boundaries (S,N,W,E) ! !----------------------------------------------------------------------- ! IF(N_SIDE==1)THEN IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_SBND I_INDX_PARENT_BND=>I_INDX_PARENT_SBND J_INDX_PARENT_BND=>J_INDX_PARENT_SBND WEIGHT_BND=>WEIGHT_SBND FIS_CHILD_BND=>FIS_CHILD_SBND PDB=>PDB_SBND CHILD_BOUND_H=>CHILD_H_SBND ! ELSEIF(N_SIDE==2)THEN IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_NBND I_INDX_PARENT_BND=>I_INDX_PARENT_NBND J_INDX_PARENT_BND=>J_INDX_PARENT_NBND WEIGHT_BND=>WEIGHT_NBND FIS_CHILD_BND=>FIS_CHILD_NBND PDB=>PDB_NBND CHILD_BOUND_H=>CHILD_H_NBND ! ELSEIF(N_SIDE==3)THEN IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_WBND I_INDX_PARENT_BND=>I_INDX_PARENT_WBND J_INDX_PARENT_BND=>J_INDX_PARENT_WBND WEIGHT_BND=>WEIGHT_WBND FIS_CHILD_BND=>FIS_CHILD_WBND PDB=>PDB_WBND CHILD_BOUND_H=>CHILD_H_WBND ! ELSEIF(N_SIDE==4)THEN IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_EBND I_INDX_PARENT_BND=>I_INDX_PARENT_EBND J_INDX_PARENT_BND=>J_INDX_PARENT_EBND WEIGHT_BND=>WEIGHT_EBND FIS_CHILD_BND=>FIS_CHILD_EBND PDB=>PDB_EBND CHILD_BOUND_H=>CHILD_H_EBND ! ENDIF ! !----------------------------------------------------------------------- !....................................................................... !$omp parallel do private( & !$omp coeff_1,coeff_2,d_lnp_dfi,fis_child, & !$omp i,i_east,i_end,i_end_transfer, & !$omp i_start,i_start_transfer,i_west, & !$omp j,j_end,j_end_transfer,j_north,j_south, & !$omp j_start,j_start_transfer, & !$omp kount_pts,kount_transfer, & !$omp l,log_p1_parent,log_pbot,log_ptop, & !$omp ntx,pdtop_pt,phi_diff,phi_interp,pint_interp,psfc_child, & !$omp px_ne,px_nw,px_se,px_sw, & !$omp q_interp,t_interp,wght_ne,wght_nw,wght_se,wght_sw) !....................................................................... ! child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Fill bndry data for each child task on the child bndry ! segment seen by this parent task. !----------------------------------------------------------------------- ! !---------------------------------------------- !*** South boundary limits on this child task !---------------------------------------------- ! IF(N_SIDE==1)THEN I_START=I_LO_SOUTH(NTX) I_END =I_HI_SOUTH(NTX) J_START=1 ! J_END =N_BLEND J_END =N_BLEND+1 !<-- Extend by one row to allow 4-pt averaging of PD to V pts ! I_START_TRANSFER=I_START I_END_TRANSFER =I_HI_SOUTH_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred ! J_START_TRANSFER=J_START J_END_TRANSFER =J_END-1 !<-- The extra row of PD is not transferred to the nests ! !---------------------------------------------- !*** North boundary limits on this child task !---------------------------------------------- ! ELSEIF(N_SIDE==2)THEN I_START=I_LO_NORTH(NTX) I_END =I_HI_NORTH(NTX) ! J_START=JM_CHILD_X-N_BLEND+1 J_START=JM_CHILD_X-N_BLEND !<-- Extend by one row to allow 4-pt averaging of PD to V pts J_END =JM_CHILD_X ! I_START_TRANSFER=I_START I_END_TRANSFER =I_HI_NORTH_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred ! J_START_TRANSFER=J_START+1 !<-- The extra row of PD is not transferred to the nests J_END_TRANSFER =J_END ! !--------------------------------------------- !*** West boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==3)THEN I_START=1 ! I_END =N_BLEND I_END =N_BLEND+1 !<-- Extend by one row to allow 4-pt averaging of PD to V pts J_START=J_LO_WEST(NTX) J_END =J_HI_WEST(NTX) ! I_START_TRANSFER=I_START I_END_TRANSFER =I_END-1 !<-- The extra row of PD is not transferred to the nests ! J_START_TRANSFER=J_START J_END_TRANSFER =J_HI_WEST_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred ! !--------------------------------------------- !*** East boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==4)THEN ! I_START=IM_CHILD_X-N_BLEND+1 I_START=IM_CHILD_X-N_BLEND !<-- Extend by one row to allow 4-pt averaging of PD to V pts I_END =IM_CHILD_X J_START=J_LO_EAST(NTX) J_END =J_HI_EAST(NTX) ! I_START_TRANSFER=I_START+1 !<-- The extra row of PD is not transferred to the nests I_END_TRANSFER =I_END ! J_START_TRANSFER=J_START J_END_TRANSFER =J_HI_EAST_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred ! ENDIF ! !----------------------------------------------------------------------- !*** Allocate the nest working arrays valid for the current child task !*** on the child's grid. !----------------------------------------------------------------------- ! ALLOCATE(PINT_INTERP(I_START:I_END,J_START:J_END,1:LM+1)) ALLOCATE( PHI_INTERP(I_START:I_END,J_START:J_END,1:LM+1)) ALLOCATE( LOG_PTOP(I_START:I_END,J_START:J_END)) ALLOCATE( LOG_PBOT(I_START:I_END,J_START:J_END)) ! !----------------------------------------------------------------------- !*** Compute parent heights of layer interfaces at the four points !*** surrounding each child boundary point. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** First the bottom layer (L=NLEV). !----------------------------------------------------------------------- ! DO J=J_START,J_END !<-- J limits of child task bndry region on parent task DO I=I_START,I_END !<-- I limits of child task bndry region on parent task ! I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point ! WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of nest's point WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of nest's point WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of nest's point WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of nest's point ! PX_SW=PD(I_WEST,J_SOUTH)+PT !<-- Sfc pressure on parent point SW of nest point PX_SE=PD(I_EAST,J_SOUTH)+PT !<-- Sfc pressure on parent point SE of nest point PX_NW=PD(I_WEST,J_NORTH)+PT !<-- Sfc pressure on parent point NW of nest point PX_NE=PD(I_EAST,J_NORTH)+PT !<-- Sfc pressure on parent point NE of nest point ! PINT_INTERP(I,J,LM+1)=WGHT_SW*PX_SW & !<-- Parent's surface pressure interp'd to this child's +WGHT_SE*PX_SE & ! gridpoint (I,J) along child's boundary +WGHT_NW*PX_NW & ! on child task NTX. +WGHT_NE*PX_NE ! LOG_PBOT(I,J)=LOG(PINT_INTERP(I,J,LM+1)) !<-- Log of parent's horizontally interpolated sfc pressure ! at child boundary point (I,J) ! PHI_INTERP(I,J,LM+1)=WGHT_SW*FIS(I_WEST,J_SOUTH) & !<-- Parent sfc geoptential interp'd to nest bndry point (I,J) +WGHT_SE*FIS(I_EAST,J_SOUTH) & +WGHT_NW*FIS(I_WEST,J_NORTH) & +WGHT_NE*FIS(I_EAST,J_NORTH) ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Now that we have the parent's sfc pressure and sfc geopotential !*** at the child boundary points (I,J), compute the interface heights !*** based on the horizontally interpolated interface pressure and !*** the T and Q. !----------------------------------------------------------------------- ! DO L=NLEV,1,-1 !<-- Work upward to obtain interface geopotentials ! PDTOP_PT=PDTOP*SG1(L)+PT ! DO J=J_START,J_END !<-- J limits of child task bndry region on parent task DO I=I_START,I_END !<-- I limits of child task bndry region on parent task ! I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point ! PX_SW=SG2(L)*PD(I_WEST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SW of nest point PX_SE=SG2(L)*PD(I_EAST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SE of nest point PX_NW=SG2(L)*PD(I_WEST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NW of nest point PX_NE=SG2(L)*PD(I_EAST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NE of nest point ! WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of child's point WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of child's point WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of child's point WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of child's point ! PINT_INTERP(I,J,L)=WGHT_SW*PX_SW & !<-- Top interface pressure interp'd to child gridpoint +WGHT_SE*PX_SE & ! along child's boundary for child task NTX +WGHT_NW*PX_NW & +WGHT_NE*PX_NE ! T_INTERP=WGHT_SW*T(I_WEST,J_SOUTH,L) & !<-- T interp'd to child gridpoint along child's +WGHT_SE*T(I_EAST,J_SOUTH,L) & ! boundary for child task NTX +WGHT_NW*T(I_WEST,J_NORTH,L) & +WGHT_NE*T(I_EAST,J_NORTH,L) ! Q_INTERP=WGHT_SW*Q(I_WEST,J_SOUTH,L) & !<-- Q interp'd to child gridpoint along child's +WGHT_SE*Q(I_EAST,J_SOUTH,L) & ! boundary for child task NTX +WGHT_NW*Q(I_WEST,J_NORTH,L) & +WGHT_NE*Q(I_EAST,J_NORTH,L) ! LOG_PTOP(I,J)=LOG(PINT_INTERP(I,J,L)) !<-- Log of parent (top) interface pressure at child bndry point ! PHI_INTERP(I,J,L)=PHI_INTERP(I,J,L+1) & !<-- Top interface geopotl of parent at child gridpoint (I,J) +R_D*T_INTERP*(1.+P608*Q_INTERP) & *(LOG_PBOT(I,J)-LOG_PTOP(I,J)) ! LOG_PBOT(I,J)=LOG_PTOP(I,J) !<--- Move Log(Ptop) to bottom of next model layer up ! ENDDO ENDDO ! ENDDO ! !----------------------------------------------------------------------- !*** Use the child's actual sfc geopotential to derive the value of !*** PD at the child boundary points based on the parent's heights !*** and pressures at its (the parent's) layer interfaces over the !*** child's boundary points. ! !*** If the child's terrain is lower than the value of the parent's !*** terrain interpolated to the child point then extrapolate the !*** parent's interpolated Sfc Pressure down to the child's terrain !*** quadratically. !----------------------------------------------------------------------- ! KOUNT_PTS=0 KOUNT_TRANSFER=0 ! !----------------------------------------------------------------------- core_loop: DO J=J_START,J_END !<-- J limits of child task bndry region on parent task DO I=I_START,I_END !<-- I limits of child task bndry region on parent task !----------------------------------------------------------------------- ! KOUNT_PTS=KOUNT_PTS+1 FIS_CHILD=FIS_CHILD_BND(NTX)%DATA(KOUNT_PTS) ! IF(FIS_CHILD=I_START_TRANSFER.AND.I<=I_END_TRANSFER & .AND. & J>=J_START_TRANSFER.AND.J<=J_END_TRANSFER)THEN ! KOUNT_TRANSFER=KOUNT_TRANSFER+1 CHILD_BOUND_H(NTX)%DATA(KOUNT_TRANSFER)= & PDB(NTX)%DATA(KOUNT_PTS) ENDIF ! !----------------------------------------------------------------------- ! ENDDO ENDDO core_loop ! !----------------------------------------------------------------------- ! DEALLOCATE(PINT_INTERP) DEALLOCATE(PHI_INTERP) DEALLOCATE(LOG_PTOP) DEALLOCATE(LOG_PBOT) ! !----------------------------------------------------------------------- ! ENDDO child_task_loop ! !....................................................................... !$omp end parallel do !....................................................................... ! !----------------------------------------------------------------------- ! ENDDO loop_sides ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_UPDATE_CHILD_PSFC ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_UPDATE_CHILD_BNDRY(VBL_PARENT & ,VBL_NAME & ! ,PD,PT,PDTOP & ,PSGML1,SGML2,SG1,SG2 & ! ,PD_SBND & ,PD_NBND & ,PD_WBND & ,PD_EBND & ! ,IMS,IME,JMS,JME & ,NLEV & ,N_REMOVE & ! ,NUM_TASKS_SEND_SBND & ,NUM_TASKS_SEND_NBND & ,NUM_TASKS_SEND_WBND & ,NUM_TASKS_SEND_EBND & ! ,I_INDX_PARENT_SBND & ,I_INDX_PARENT_NBND & ,I_INDX_PARENT_WBND & ,I_INDX_PARENT_EBND & ,J_INDX_PARENT_SBND & ,J_INDX_PARENT_NBND & ,J_INDX_PARENT_WBND & ,J_INDX_PARENT_EBND & ! ,I_LO_SOUTH & ,I_HI_SOUTH & ,I_HI_SOUTH_TRANSFER & ,I_LO_NORTH & ,I_HI_NORTH & ,I_HI_NORTH_TRANSFER & ,J_LO_WEST & ,J_HI_WEST & ,J_HI_WEST_TRANSFER & ,J_LO_EAST & ,J_HI_EAST & ,J_HI_EAST_TRANSFER & ! ,WEIGHT_SBND & ,WEIGHT_NBND & ,WEIGHT_WBND & ,WEIGHT_EBND & ! ^ ,N_BLEND & ! | ,IM_CHILD_X & ! | ,JM_CHILD_X & ! Input ! ---------- ,VBL_CHILD_SBND & ! Output ,VBL_CHILD_NBND & ! | ,VBL_CHILD_WBND & ! | ,VBL_CHILD_EBND ) ! v ! !----------------------------------------------------------------------- !*** Parent tasks interpolate their values of variables !*** to child grid points. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits ,IM_CHILD_X,JM_CHILD_X & !<-- Index limits of the nest domain ,N_BLEND & !<-- # of domain boundary blending rows ,NLEV & !<-- # of vertical levels in parent array ,N_REMOVE & !<-- # of rows to ignore on north/east sides (H=>0;V=>1) ! ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sbndry points on parent task ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nbndry points on parent task ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wbndry points on parent task ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Ebndry points on parent task ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & I_LO_SOUTH & !<-- Starting I of Sbndry region on child tasks ,I_HI_SOUTH & !<-- Ending I of Sbndry region on child tasks ,I_HI_SOUTH_TRANSFER & !<-- Ending I of Sbndry for transfer to child ,I_LO_NORTH & !<-- Starting I of Nbndry region on child tasks ,I_HI_NORTH & !<-- Ending I of Nbndry region on child tasks ,I_HI_NORTH_TRANSFER & !<-- Ending I of Nbndry for transfer to child ,J_LO_WEST & !<-- Starting J of Wbndry region on child tasks ,J_HI_WEST & !<-- Ending J of Wbndry region on child tasks ,J_HI_WEST_TRANSFER & !<-- Ending J of Wbndry for transfer to child ,J_LO_EAST & !<-- Starting J of Ebndry region on child tasks ,J_HI_EAST & !<-- Ending J of Ebndry region on child tasks ,J_HI_EAST_TRANSFER !<-- Ending J of Ebndry for transfer to child ! INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & I_INDX_PARENT_SBND & !<-- I indices of parent points west/east of child Sbndry point ,I_INDX_PARENT_NBND & !<-- I indices of parent points west/east of child Nbndry point ,I_INDX_PARENT_WBND & !<-- I indices of parent points west/east of child Wbndry point ,I_INDX_PARENT_EBND & !<-- I indices of parent points west/east of child Ebndry point ,J_INDX_PARENT_SBND & !<-- J indices of parent points south/north of child Sbndry point ,J_INDX_PARENT_NBND & !<-- J indices of parent points south/north of child Nbndry point ,J_INDX_PARENT_WBND & !<-- J indices of parent points south/north of child Wbndry point ,J_INDX_PARENT_EBND !<-- J indices of parent points south/north of child Ebndry point ! REAL(kind=KFPT),INTENT(IN) :: PT & !<-- Top pressure of model domain (Pa) ,PDTOP !<-- Pressure at top of sigma domain (Pa) ! REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(IN) :: PSGML1 & !<-- Midlayer pressures, pressure domain ,SGML2 & !<-- Midlayer sigmas, sigma domain ,SG1 & !<-- Interface sigmas, pressure domain ,SG2 !<-- Interface sigmas, sigma domain ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD !<-- Parent PD ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & VBL_PARENT !<-- Current variable on the parent domain ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & WEIGHT_SBND & !<-- Bilinear interp weights of the 4 parent points around ,WEIGHT_NBND & ! each point on child's boundaries. ,WEIGHT_WBND & ! ,WEIGHT_EBND ! ! CHARACTER(len=*),INTENT(IN) :: VBL_NAME !<-- Which variable is the parent interpolating? Suffix: -nestbc ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: PD_SBND & !<-- Boundary region PD (Pa) (column mass in sigma domain) ,PD_NBND & ! on the four sides of the child boundary. ,PD_WBND & ! ,PD_EBND ! ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: & VBL_CHILD_SBND & !<-- Mass variable in child bndry region as computed ,VBL_CHILD_NBND & !<-- by parent. ,VBL_CHILD_WBND & ! ,VBL_CHILD_EBND ! ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,J,L & ,I_EAST,I_WEST,J_SOUTH,J_NORTH & ,I_START,I_START_EXPAND & ,I_END,I_END_EXPAND & ,J_START,J_START_EXPAND & ,J_END,J_END_EXPAND & ,KNT_PTS,KNT_PTS_X & ,L_VBL,LOC_1,LOC_2 & ,N_ADD,N_EXP,N_SIDE,N_STRIDE,NTX & ,NUM_LEVS_SEC,NUM_LEVS_SPLINE & ,NUM_TASKS_SEND & ,RC ! INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_PARENT_BND & ,J_INDX_PARENT_BND ! REAL(kind=KFPT) :: COEFF_1,DELP_EXTRAP,DP1,DP2,DP3,FACTOR & ,PDTOP_PT,PROD1,PROD2,PROD3,R_DELP ! REAL(kind=KFPT) :: PX_NE,PX_NW,PX_SE,PX_SW & ,WGHT_NE,WGHT_NW,WGHT_SE,WGHT_SW ! REAL(kind=KFPT),DIMENSION(1:LM) :: PMID_CHILD ! REAL(kind=KFPT),DIMENSION(1:LM+1) :: P_INPUT & ,SEC_DERIV & ,VBL_INPUT ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: T_LOWEST ! REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: PINT_INTERP_HI & ,PMID_INTERP & ,VBL_INTERP ! REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PINT_INTERP_LO ! REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL_CHILD ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHT_BND ! LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: INVERSION ! TYPE(REAL_DATA),DIMENSION(:),POINTER :: PDB & ,VBL_CHILD_BND ! integer :: nnn,lll integer,dimension(8) :: values !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N_EXP=1-N_REMOVE !<-- Handle expansion of PDB range (H->1; V->0) NUM_LEVS_SEC=LM+1 !<-- # of levels in spline routine's 2nd derivative array ! !----------------------------------------------------------------------- !*** Loop through the four sides of the nest domain boundary (S,N,W,E). !*** We use some dummy variables/pointers generically for all four !*** of the sides. !----------------------------------------------------------------------- ! loop_sides: DO N_SIDE=1,4 ! !----------------------------------------------------------------------- ! IF(N_SIDE==1)THEN IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_SBND I_INDX_PARENT_BND=>I_INDX_PARENT_SBND J_INDX_PARENT_BND=>J_INDX_PARENT_SBND WEIGHT_BND=>WEIGHT_SBND PDB=>PD_SBND VBL_CHILD_BND=>VBL_CHILD_SBND ! ELSEIF(N_SIDE==2)THEN IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_NBND I_INDX_PARENT_BND=>I_INDX_PARENT_NBND J_INDX_PARENT_BND=>J_INDX_PARENT_NBND WEIGHT_BND=>WEIGHT_NBND PDB=>PD_NBND VBL_CHILD_BND=>VBL_CHILD_NBND ! ELSEIF(N_SIDE==3)THEN IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_WBND I_INDX_PARENT_BND=>I_INDX_PARENT_WBND J_INDX_PARENT_BND=>J_INDX_PARENT_WBND WEIGHT_BND=>WEIGHT_WBND PDB=>PD_WBND VBL_CHILD_BND=>VBL_CHILD_WBND ! ELSEIF(N_SIDE==4)THEN IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_EBND I_INDX_PARENT_BND=>I_INDX_PARENT_EBND J_INDX_PARENT_BND=>J_INDX_PARENT_EBND WEIGHT_BND=>WEIGHT_EBND PDB=>PD_EBND VBL_CHILD_BND=>VBL_CHILD_EBND ! ENDIF ! !----------------------------------------------------------------------- !....................................................................... !$omp parallel do & !$omp private(coeff_1,delp_extrap,dp1,dp2,dp3,factor, & !$omp i,i_east,i_end,i_end_expand,i_start,i_start_expand, & !$omp i_west,inversion, & !$omp j,j_end,j_end_expand,j_north,j_south, & !$omp j_start,j_start_expand, & !$omp knt_pts,knt_pts_x,l,l_vbl,loc_1,loc_2, & !$omp n_add,n_stride,ntx,num_levs_spline, & !$omp p_input,pdtop_pt,pint_interp_hi,pint_interp_lo, & !$omp pmid_child,pmid_interp,prod1,prod2,prod3, & !$omp px_ne,px_nw,px_se,px_sw,r_delp,sec_deriv, & !$omp t_lowest,vbl_col_child,vbl_input,vbl_interp, & !$omp wght_ne,wght_nw,wght_se,wght_sw) !....................................................................... ! child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Fill bndry data for each child task on the child bndry ! segment seen by this parent task. !----------------------------------------------------------------------- ! !---------------------------------------------- !*** South boundary limits on this child task !---------------------------------------------- ! IF(N_SIDE==1)THEN I_START =I_LO_SOUTH(NTX) I_END =I_HI_SOUTH_TRANSFER(NTX) J_START =1 J_END =N_BLEND ! I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging I_END_EXPAND=I_HI_SOUTH(NTX) ! J_START_EXPAND=J_START ! J_END_EXPAND=J_END+N_EXP !<-- ! !---------------------------------------------- !*** North boundary limits on this child task !---------------------------------------------- ! ELSEIF(N_SIDE==2)THEN I_START =I_LO_NORTH(NTX) I_END =I_HI_NORTH_TRANSFER(NTX) J_START =JM_CHILD_X-N_BLEND+1-N_REMOVE J_END =JM_CHILD_X-N_REMOVE ! I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging I_END_EXPAND=I_HI_NORTH(NTX) ! J_START_EXPAND=J_START-N_EXP ! J_END_EXPAND=J_END !<-- ! !--------------------------------------------- !*** West boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==3)THEN I_START =1 I_END =N_BLEND J_START =J_LO_WEST(NTX) J_END =J_HI_WEST_TRANSFER(NTX) ! I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging I_END_EXPAND=I_END+N_EXP ! J_START_EXPAND=J_START ! J_END_EXPAND=J_HI_WEST(NTX) !<-- ! !--------------------------------------------- !*** East boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==4)THEN I_START =IM_CHILD_X-N_BLEND+1-N_REMOVE I_END =IM_CHILD_X-N_REMOVE J_START =J_LO_EAST(NTX) J_END =J_HI_EAST_TRANSFER(NTX) ! I_START_EXPAND=I_START-N_EXP !<-- Expanded limits for extra row of PD for 4-pt averaging I_END_EXPAND=I_END ! J_START_EXPAND=J_START ! J_END_EXPAND=J_HI_EAST(NTX) !<-- ! ENDIF ! !----------------------------------------------------------------------- ! N_STRIDE=(I_END-I_START+1)*(J_END-J_START+1) !<-- # of pts, this side, this child task's bndry region ! ALLOCATE(PMID_INTERP(1:N_STRIDE,1:LM)) ALLOCATE(VBL_INTERP (1:N_STRIDE,1:NLEV)) ALLOCATE(T_LOWEST (1:N_STRIDE)) ALLOCATE(INVERSION (1:N_STRIDE)) ! ALLOCATE(PINT_INTERP_HI(I_START:I_END,J_START:J_END)) ALLOCATE(PINT_INTERP_LO(I_START:I_END,J_START:J_END,1:NLEV+1)) ! !----------------------------------------------------------------------- !*** We need the mid-layer pressure values in the parent layers !*** over the child boundary point locations since those are !*** required for the vertical interpolation of variables !*** to the mid-layers in the child. !*** Compute the interface pressures of the parent layers !*** then take the means to get the mid-layer values. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Start with the bottom layer (L=NLEV). !----------------------------------------------------------------------- ! DO J=J_START,J_END !<-- J limits of child task bndry region on parent task DO I=I_START,I_END !<-- I limits of child task bndry region on parent task ! I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point ! WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of nest's point WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of nest's point WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of nest's point WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of nest's point ! PX_SW=PD(I_WEST,J_SOUTH)+PT !<-- Sfc pressure on parent point SW of nest point PX_SE=PD(I_EAST,J_SOUTH)+PT !<-- Sfc pressure on parent point SE of nest point PX_NW=PD(I_WEST,J_NORTH)+PT !<-- Sfc pressure on parent point NW of nest point PX_NE=PD(I_EAST,J_NORTH)+PT !<-- Sfc pressure on parent point NE of nest point ! PINT_INTERP_LO(I,J,NLEV+1)=WGHT_SW*PX_SW & !<-- Parent's surface pressure interp'd to this child's +WGHT_SE*PX_SE & ! gridpoint (I,J) along child's boundary for +WGHT_NW*PX_NW & ! child task NTX. +WGHT_NE*PX_NE ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Now compute those mid-layer pressures in the parent layers !*** as well as the values of the parent's variable at those !*** pressure levels. !----------------------------------------------------------------------- ! DO L=LM,1,-1 !<-- Work upward to get geopotentials on child layer interfaces ! KNT_PTS=0 PDTOP_PT=SG1(L)*PDTOP+PT ! IF(NLEV==1)THEN L_VBL=1 !<-- Account for possible 2-D boundary variables ELSE L_VBL=L ENDIF ! DO J=J_START,J_END !<-- J limits of child task bndry region on parent task DO I=I_START,I_END !<-- I limits of child task bndry region on parent task ! I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point ! PX_SW=SG2(L)*PD(I_WEST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SW of nest point PX_SE=SG2(L)*PD(I_EAST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SE of nest point PX_NW=SG2(L)*PD(I_WEST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NW of nest point PX_NE=SG2(L)*PD(I_EAST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NE of nest point ! WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of child's point WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of child's point WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of child's point WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of child's point ! PINT_INTERP_HI(I,J)=WGHT_SW*PX_SW & !<-- Top interface pressure interp'd to child gridpoint +WGHT_SE*PX_SE & ! in child's boundary region on child task NTX +WGHT_NW*PX_NW & +WGHT_NE*PX_NE ! KNT_PTS=KNT_PTS+1 ! PMID_INTERP(KNT_PTS,L)=0.5*(PINT_INTERP_HI(I,J) & !<-- Parent midlayer pressure interp'd to child gridpoint +PINT_INTERP_LO(I,J,L+1)) ! in child's boundary region of child task NTX ! VBL_INTERP(KNT_PTS,L_VBL)=WGHT_SW & !<-- Parent variable interp'd to child gridpoint *VBL_PARENT(I_WEST,J_SOUTH,L) & ! in child's boundary region of child task NTX. +WGHT_SE & ! *VBL_PARENT(I_EAST,J_SOUTH,L) & ! +WGHT_NW & ! *VBL_PARENT(I_WEST,J_NORTH,L) & ! +WGHT_NE & ! *VBL_PARENT(I_EAST,J_NORTH,L) !<-- ! if(i==isee.and.j==jsee.and.l==ksee)then ! if(n_side==2)then ! write(0,44370)trim(vbl_name) ! write(0,44371)vbl_interp(knt_pts,l_vbl),knt_pts,i_west,i_east,j_south,j_north ! write(0,44372)wght_sw,wght_se,wght_nw,wght_ne ! write(0,44373)vbl_parent(i_west,j_south,l),vbl_parent(i_east,j_south,l) & ! ,vbl_parent(i_west,j_north,l),vbl_parent(i_east,j_north,l) 44370 format(' PARENT_UPDATE_CHILD_BNDRY vbl_name=',a) 44371 format(' vbl_interp=',f6.2,' knt_pnts=',i6,' i_west=',i3,' i_east=',i3,' j_south=',i3,' j_north=',i3) 44372 format(' wgts=',4(1x,f6.3)) 44373 format(' parent values=',4(1x,f6.2)) ! endif ! endif ! if(n_side==3.and.i==5.and.j==7.and.l==1.and.trim(vbl_flag)=='T-nestbc')THEN ! write(0,33891)knt_pts,vbl_interp(knt_pts,l) ! write(0,33892)vbl_parent(i_west,j_south,l),vbl_parent(i_east,j_south,l) & ! ,vbl_parent(i_west,j_north,l),vbl_parent(i_east,j_north,l) ! write(0,33893)wght_sw,wght_se,wght_nw,wght_ne ! write(0,33894)i_west,i_east,j_south,j_north 33891 format(' PARENT_UPDATE_CHILD_BNDRY knt_pts=',i6,' vbl_interp=',z8) 33892 format(' vbl_parent=',4(1x,z8)) 33893 format(' wght=',4(1x,z8)) 33894 format(' i_west=',i3,' i_east=',i3,' j_south=',i3,' j_north=',i3) ! endif PINT_INTERP_LO(I,J,L)=PINT_INTERP_HI(I,J) ! ENDDO ENDDO ! IF(NLEV==1)EXIT ! ENDDO ! !----------------------------------------------------------------------- !*** The parent uses mass-weighted averages of the lowest and !*** 2nd lowest layer temperatures to avoid extrapolation problems !*** when there is an inversion present. !----------------------------------------------------------------------- ! IF(TRIM(VBL_NAME)=='T-nestbc')THEN KNT_PTS=0 ! DO J=J_START,J_END DO I=I_START,I_END KNT_PTS=KNT_PTS+1 INVERSION(KNT_PTS)=.FALSE. IF(VBL_INTERP(KNT_PTS,NLEV)I_END & .OR. & JJ_END)CYCLE ! KNT_PTS=KNT_PTS+1 !<-- Location in 1-D datastring of child bndry variable LOC_1=LOC_1+1 !<-- Next storage location in the final BC object ! !----------------------------------------------------------------------- !*** For 2-D boundary variables the parent simply inserts the !*** given I,J value for the single level into the final output !*** object. !----------------------------------------------------------------------- ! IF(NLEV==1)THEN VBL_CHILD_BND(NTX)%DATA(LOC_1)=VBL_INTERP(KNT_PTS,1) CYCLE !<-- Move through the I,J locations disregarding the vertical. ENDIF ! !----------------------------------------------------------------------- !*** Midlayer pressures for the nest boundary points. !----------------------------------------------------------------------- ! DO L=1,LM PMID_CHILD(L)=PSGML1(L)+SGML2(L)*PDB(NTX)%DATA(KNT_PTS_X) !<-- Nest midlayer pressure ENDDO ! !----------------------------------------------------------------------- !*** Use spline interpolation to move variables from their !*** vertical locations in the column after horizontal interpolation !*** from the surrounding parent points to child boundary point levels. !*** The target locations are the new midlayer pressures in the !*** nest boundary point columns based on the new surface pressure !*** for the nest's terrain. ! !*** If the target location lies below the middle of the lowest parent !*** layer in the newly created child column then extrapolate linearly !*** in pressure to obtain a value at the lowest child mid-layer and !*** fill in the remaining 'underground' levels using the call to !*** 'SPLINE' just as with all the other higher levels. !----------------------------------------------------------------------- ! DO L=1,LM !<-- Extract mid-layer values of parent in nest column P_INPUT (L)=PMID_INTERP(KNT_PTS,L) VBL_INPUT(L)= VBL_INTERP(KNT_PTS,L) ENDDO ! LOC_2=LOC_1+N_ADD VBL_COL_CHILD=>VBL_CHILD_BND(NTX)%DATA(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into 1-D horizontal ! output pointer for this variable. NUM_LEVS_SPLINE=LM ! IF(PMID_CHILD(LM)>P_INPUT(LM))THEN !<-- Nest's lowest mid-layer is lower than parent's NUM_LEVS_SPLINE=LM+1 !<-- Add another input level at nest's lowest P_INPUT(LM+1)=PMID_CHILD(LM) ! mid-layer. ! ! IF(TRIM(VBL_FLAG)=='T'.AND.INVERSION(KNT_PTS))THEN !<-- For temperature inversions place the parent's ! VBL_INPUT(LM+1)=T_LOWEST(KNT_PTS) ! original cold sfc lyr into the new bottom lyr. ! ELSE R_DELP=1./(P_INPUT(LM)-P_INPUT(LM-1)) DELP_EXTRAP=PMID_CHILD(LM)-P_INPUT(LM) ! COEFF_1=(VBL_INPUT(LM)-VBL_INPUT(LM-1))*R_DELP FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) VBL_INPUT(LM+1)=VBL_INPUT(LM) & !<-- Extrapolated value at nest's new bottom +COEFF_1*DELP_EXTRAP*FACTOR ! midlayer. ! ENDIF ! ENDIF ! DO L=1,LM+1 SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. ENDDO ! CALL SPLINE(NUM_LEVS_SPLINE & !<-- # of input levels ,P_INPUT(1:NUM_LEVS_SPLINE) & !<-- Input mid-layer pressures ,VBL_INPUT(1:NUM_LEVS_SPLINE) & !<-- Input mid-layer mass variable value ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent points ,NUM_LEVS_SEC & ,LM & !<-- # of child mid-layers to interpolate to ,PMID_CHILD & !<-- Child mid-layer pressures to interpolate to ,VBL_COL_CHILD) !<-- Child mid-layer variable value returned ! if(n_side==2.and.i==isee.and.j==jsee.and.trim(vbl_name)=='T-nestbc')THEN ! write(0,69471)ntx,loc_1,loc_2,n_stride,vbl_child_bnd(ntx)%data(loc_1) ! write(0,69476)knt_pts,vbl_input(1),vbl_input(2),vbl_input(3) ! write(0,69477)p_input(1),p_input(2),p_input(3) 69471 format(' PARENT_UPDATE_CHILD_BNDRY T after SPLINE ntx=',i2,' loc_1=',i5,' loc_2=',i5,' n_stride=',i5 & ,' vbl_child_bnd(ntx)%data(loc_1)=',f6.2) 69476 format(' knt_pts=',i6,' vbl_input=',3(1x,f6.2)) 69477 format(' p_input=',3(1x,f9.2)) ! endif ! !----------------------------------------------------------------------- ! ENDDO ENDDO main_loop ! !----------------------------------------------------------------------- ! DEALLOCATE(PMID_INTERP) DEALLOCATE(VBL_INTERP) DEALLOCATE(INVERSION) DEALLOCATE(T_LOWEST) ! DEALLOCATE(PINT_INTERP_HI) DEALLOCATE(PINT_INTERP_LO) ! !----------------------------------------------------------------------- ! ENDDO child_task_loop ! !....................................................................... !$omp end parallel do !....................................................................... ! !----------------------------------------------------------------------- ! ENDDO loop_sides ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_UPDATE_CHILD_BNDRY ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PRESSURE_ON_NEST_BNDRY_V(PD_H & ,IMS,IME,JMS,JME & ! ,PDB_S_H & ,PDB_N_H & ,PDB_W_H & ,PDB_E_H & ! ,NUM_TASKS_SEND_SBND & ,NUM_TASKS_SEND_NBND & ,NUM_TASKS_SEND_WBND & ,NUM_TASKS_SEND_EBND & ! ,I_LO_SOUTH_V & ,I_HI_SOUTH_V & ,I_LO_NORTH_V & ,I_HI_NORTH_V & ,J_LO_WEST_V & ,J_HI_WEST_V & ,J_LO_EAST_V & ,J_HI_EAST_V & ! ,I_LO_SOUTH_H & ,I_HI_SOUTH_H & ,I_LO_NORTH_H & ,I_HI_NORTH_H & ,J_LO_WEST_H & ,J_HI_WEST_H & ,J_LO_EAST_H & ,J_HI_EAST_H & ! ^ ,N_BLEND_H_CHILD & ! | ,N_BLEND_V_CHILD & ! | ,IM_CHILD & ! | ,JM_CHILD & ! | ! | ,INC_FIX_N & ! Input ! --------- ,PD_V & ! Output ,PDB_S_V & ! | ,PDB_N_V & ! | ,PDB_W_V & ! v ,PDB_E_V ) ! ! !----------------------------------------------------------------------- !*** Use 4-pt horizontal interpolation to compute PD on V points !*** of the parent domain and of the nest boundary given those !*** values on H points. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits ,IM_CHILD,JM_CHILD & !<-- Nest domain limits ,INC_FIX_N & !<-- Increment for selecting nest tasks for averaging H to V ,N_BLEND_H_CHILD & !<-- H rows in nest's boundary region ,N_BLEND_V_CHILD & !<-- V rows in nest's boundary region ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sbndry V points on parent task ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nbndry V points on parent task ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wbndry V points on parent task ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Ebndry V points on parent task ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & I_LO_SOUTH_H & !<-- Starting I of Sbndry region H points on child tasks ,I_HI_SOUTH_H & !<-- Ending I of Sbndry region H points on child tasks ,I_LO_NORTH_H & !<-- Starting I of Nbndry region H points on child tasks ,I_HI_NORTH_H & !<-- Ending I of Nbndry region H points on child tasks ,J_LO_WEST_H & !<-- Starting J of Wbndry region H points on child tasks ,J_HI_WEST_H & !<-- Ending J of Wbndry region H points on child tasks ,J_LO_EAST_H & !<-- Starting J of Ebndry region H points on child tasks ,J_HI_EAST_H !<-- Ending J of Ebndry region H points on child tasks ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & I_LO_SOUTH_V & !<-- Starting I of Sbndry region V points on child tasks ,I_HI_SOUTH_V & !<-- Ending I of Sbndry region V points on child tasks ,I_LO_NORTH_V & !<-- Starting I of Nbndry region V points on child tasks ,I_HI_NORTH_V & !<-- Ending I of Nbndry region V points on child tasks ,J_LO_WEST_V & !<-- Starting J of Wbndry region V points on child tasks ,J_HI_WEST_V & !<-- Ending J of Wbndry region V points on child tasks ,J_LO_EAST_V & !<-- Starting J of Ebndry region V points on child tasks ,J_HI_EAST_V !<-- Ending J of Ebndry region V points on child tasks ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD_H !<-- Parent PD (Pa) (column mass in sigma domain) on H points ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: PDB_S_H & !<-- Boundary region PD (Pa) (column mass in sigma domain) ,PDB_N_H & ! on mass points on the four sides of the child boundary. ,PDB_W_H & ! ,PDB_E_H !<-- ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PD_V !<-- Parent PD (Pa) (column mass in sigma domain) on V points ! TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: PDB_S_V & !<-- Child boundary PD (Pa) on child domain Sbndry V points ,PDB_N_V & !<-- Child boundary PD (Pa) on child domain Nbndry V points ,PDB_W_V & !<-- Child boundary PD (Pa) on child domain Wbndry V points ,PDB_E_V !<-- Child boundary PD (Pa) on child domain Ebndry V points ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: DIFF_START,DIFF_START_PTS & ,I,J & ,I_ADD_H,I_INC_H & ,I_START_H,I_START_V & ,I_END_H,I_END_V & ,I_HI_H,I_LO_H & ,J_START_H,J_START_V & ,J_END_H,J_END_V & ,KNT_H,KNT_V & ,N_ADD_H,N_OFFSET_H,N_SIDE & ,NTX,NTX_H,NUM_TASKS_SEND ! INTEGER(kind=KINT),DIMENSION(4) :: NTX_ADD ! TYPE(REAL_DATA),DIMENSION(:),POINTER :: PDB_H & ,PDB_V ! integer,dimension(8) :: values !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! DO N_SIDE=1,4 NTX_ADD(N_SIDE)=0 ENDDO ! !----------------------------------------------------------------------- !*** First obtain PD on the parent's V points. !----------------------------------------------------------------------- ! DO J=JMS,JME-1 DO I=IMS,IME-1 PD_V(I,J)=0.25*(PD_H(I,J)+PD_H(I+1,J)+PD_H(I,J+1)+PD_H(I+1,J+1)) ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Now average values of PD on and adjacent to the nests' boundary !*** to obtain PD on the nests' boundary V points. !----------------------------------------------------------------------- ! loop_sides: DO N_SIDE=1,4 !<-- Loop through the 4 lateral boundaries (S,N,W,E) ! !----------------------------------------------------------------------- ! IF(N_SIDE==1)THEN IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_SBND !<-- # of Sbndry nest tasks to which parent sends PDB on V PDB_H=>PDB_S_H !<-- String of Sbndry PDB on H for this nest task PDB_V=>PDB_S_V !<-- String of Sbndry PDB on V for this nest task ! ! ELSEIF(N_SIDE==2)THEN IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_NBND !<-- # of Nbndry nest tasks to which parent sends PDB on V PDB_H=>PDB_N_H !<-- String of Nbndry PDB on H for this nest task PDB_V=>PDB_N_V !<-- String of Nbndry PDB on V for this nest task ! ELSEIF(N_SIDE==3)THEN IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_WBND !<-- # of Wbndry nest tasks to which parent sends PDB on V PDB_H=>PDB_W_H !<-- String of Wbndry PDB on H for this nest task PDB_V=>PDB_W_V !<-- String of Wbndry PDB on V for this nest task ! ELSEIF(N_SIDE==4)THEN IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry ! NUM_TASKS_SEND=NUM_TASKS_SEND_EBND !<-- # of Ebndry nest tasks to which parent sends PDB on V PDB_H=>PDB_E_H !<-- String of Ebndry PDB on H for this nest task PDB_V=>PDB_E_V !<-- String of Ebndry PDB on V for this nest task ! ENDIF ! !----------------------------------------------------------------------- ! child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Compute PD on V points for each child task with ! bndry segments seen by this parent task. !----------------------------------------------------------------------- ! !---------------------------------------------- !*** South boundary limits on this child task !---------------------------------------------- ! IF(N_SIDE==1)THEN I_START_V=I_LO_SOUTH_V(NTX) !<-- I index of first Sbndry V point on this child task I_END_V =I_HI_SOUTH_V(NTX) !<-- I index of last Sbndry V point on this child task J_START_V=1 !<-- J index of first Sbndry V point on this child task J_END_V =N_BLEND_V_CHILD !<-- J index of last Sbndry V point on this child task ! I_END_H =I_HI_SOUTH_H(NTX) !<-- I index of last Sbndry H point east of last Sbndry V point ! IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN IF(I_START_V==I_LO_SOUTH_H(NTX+1)+INC_FIX_N & .AND. & I_END_V>=I_END_H)THEN NTX_ADD(N_SIDE)=1 ENDIF ENDIF ! NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points DIFF_START=I_START_V-I_LO_SOUTH_H(NTX_H) I_HI_H=I_HI_SOUTH_H(NTX_H) I_LO_H=I_LO_SOUTH_H(NTX_H) N_ADD_H=I_HI_H-I_LO_H+1 ! !---------------------------------------------- !*** North boundary limits on this child task !---------------------------------------------- ! ELSEIF(N_SIDE==2)THEN I_START_V=I_LO_NORTH_V(NTX) !<-- I index of first Nbndry V point on this child task I_END_V =I_HI_NORTH_V(NTX) !<-- I index of last Nbndry V point on this child task J_START_V=JM_CHILD-N_BLEND_V_CHILD !<-- J index of first Nbndry V point on this child task J_END_V =JM_CHILD-1 !<-- J index of last Nbndry V point on this child task ! I_END_H =I_HI_NORTH_H(NTX) !<-- I index of last Nbndry H point east of last Nbndry V point ! IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN IF(I_START_V==I_LO_NORTH_H(NTX+1)+INC_FIX_N & .AND. & I_END_V>=I_END_H)THEN NTX_ADD(N_SIDE)=1 ENDIF ENDIF ! NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points DIFF_START=I_START_V-I_LO_NORTH_H(NTX_H) I_HI_H=I_HI_NORTH_H(NTX_H) I_LO_H=I_LO_NORTH_H(NTX_H) N_ADD_H=I_HI_H-I_LO_H+1 ! !---------------------------------------------- !*** West boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==3)THEN I_START_V=1 !<-- I index of first Wbndry V point on this child task I_END_V =N_BLEND_V_CHILD !<-- I index of last Wbndry V point on this child task J_START_V=J_LO_WEST_V(NTX) !<-- J index of first Wbndry V point on this child task J_END_V =J_HI_WEST_V(NTX) !<-- J index of last Wbndry V point on this child task ! J_END_H =J_HI_WEST_H(NTX) !<-- J index of last Wbndry H point east of last Wbndry V point ! IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN IF(J_START_V==J_LO_WEST_H(NTX+1)+INC_FIX_N & .AND. & J_END_V>=J_END_H)THEN NTX_ADD(N_SIDE)=1 ENDIF ENDIF ! NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points DIFF_START=J_START_V-J_LO_WEST_H(NTX_H) DIFF_START_PTS=DIFF_START*(N_BLEND_H_CHILD+1) N_ADD_H=N_BLEND_H_CHILD+1 ! !--------------------------------------------- !*** East boundary limits on this child task !--------------------------------------------- ! ELSEIF(N_SIDE==4)THEN I_START_V=IM_CHILD-N_BLEND_V_CHILD !<-- I index of first Ebndry V point on this child task I_END_V =IM_CHILD-1 !<-- I index of last Ebndry V point on this child task J_START_V=J_LO_EAST_V(NTX) !<-- J index of first Ebndry V point on this child task J_END_V =J_HI_EAST_V(NTX) !<-- J index of last Ebndry V point on this child task ! J_END_H =J_HI_EAST_H(NTX) !<-- J index of last Ebndry H point east of last Ebndry V point ! IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN IF(J_START_V==J_LO_EAST_H(NTX+1)+INC_FIX_N & .AND. & J_END_V>=J_END_H)THEN NTX_ADD(N_SIDE)=1 ENDIF ENDIF ! NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points DIFF_START=J_START_V-J_LO_EAST_H(NTX_H) DIFF_START_PTS=DIFF_START*(N_BLEND_H_CHILD+1) N_ADD_H=N_BLEND_H_CHILD+1 ! ENDIF ! !----------------------------------------------------------------------- !*** Ready to average nest boundary PD on H to PD on V. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Recall that the PDB_H pointer contains data for one extra row !*** beyond the child boundary on all sides since we need the !*** ability to do 4-pt averages of PD to V points. !*** Here we must use PDB_H but the values for PDB_V (and thus U,V) !*** are only generated on the true boundary points. To address PDB_H !*** correctly we must take into account those extra points in PDB_H !*** as we march through the V point locations. ! !*** Also we must be aware that the nest boundary V segments that are !*** being considered for each nest task must correspond to the same !*** nest task H point values of PDB. Because of overlap that can !*** occur due to the segments of PDB on H being larger than PBD on !*** V we must explicitly check to be sure that nest PDB on V is !*** being filled by nest PDB on H for the same nest task. !----------------------------------------------------------------------- ! KNT_V=0 ! DO J=J_START_V,J_END_V IF(N_SIDE<=2)THEN N_OFFSET_H=(DIFF_START+1)*(J-J_START_V+1)-1 ELSEIF(N_SIDE>=3)THEN N_OFFSET_H=J-J_START_V+DIFF_START_PTS ENDIF ! DO I=I_START_V,I_END_V KNT_V=KNT_V+1 KNT_H=KNT_V+N_OFFSET_H PDB_V(NTX)%DATA(KNT_V)=(PDB_H(NTX_H)%DATA(KNT_H) & +PDB_H(NTX_H)%DATA(KNT_H+1) & +PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H) & +PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H+1)) & *0.25 ! if(i==36.and.n_side==2)then ! write(0,*)' PRESSURE_ON_NEST_BNDRY_V j=',j,' ntx=',ntx,' n_offset_h=',n_offset_h ! write(0,*)' pdb_v=',pdb_v(ntx)%data(knt_v),' knt_v=',knt_v,' knt_h=',knt_h ! write(0,*)' pdb_h=',PDB_H(NTX_H)%DATA(KNT_H),PDB_H(NTX_H)%DATA(KNT_H+1) & ! ,PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H),PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H+1) ! endif ENDDO ENDDO ! !----------------------------------------------------------------------- ! ENDDO child_task_loop ! !----------------------------------------------------------------------- ! ENDDO loop_sides ! !----------------------------------------------------------------------- ! END SUBROUTINE PRESSURE_ON_NEST_BNDRY_V ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_2WAY_UPDATE(I_2WAY_UPDATE_START & ,I_2WAY_UPDATE_END & ,J_2WAY_UPDATE_START & ,J_2WAY_UPDATE_END & ,LM & ,NPTS_UPDATE_HORIZ & ,NPTS_UPDATE_TOTAL & ,NVARS_2WAY_UPDATE & ,VAR_2WAY & ,CHILD_SFC_ON_PARENT_GRID & ,WGT_CHILD & ,FIS & ,PD,PDTOP,PT & ! ^ ,SG1,SG2 & ! | ,IMS,IME,JMS,JME & ! | ! input ! ----- ,BUNDLE_2WAY & ! output ) ! !----------------------------------------------------------------------- !*** Parent tasks incorporate new 2-way exchange data sent from the !*** children. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_2WAY_UPDATE_START & !<-- Starting parent I of its 2-way update region ,I_2WAY_UPDATE_END & !<-- Ending parent I of its 2-way update region ,J_2WAY_UPDATE_START & !<-- Starting parent J of its 2-way update region ,J_2WAY_UPDATE_END & !<-- Ending parent J of its 2-way update region ,LM !<-- # of model layers (all domains) ! INTEGER(kind=KINT),INTENT(IN) :: NPTS_UPDATE_HORIZ & !<-- # of parent sfc H,V points updated in the horizontal ,NPTS_UPDATE_TOTAL & !<-- Total # of words in 2-way 3D update data from child ,NVARS_2WAY_UPDATE !<-- # of variables updated in 2-way exchange ! INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME !<-- Parent subdomain memory limits ! REAL(kind=KFPT),INTENT(IN) :: PDTOP & !<-- Pressure at top of the sigma domain (Pa) ,PT & !<-- Pressure at the top of the domain (Pa) ,WGT_CHILD !<-- Weight (0-1) given to child 2-way data in the update ! REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_HORIZ,1:2),INTENT(IN) :: & CHILD_SFC_ON_PARENT_GRID !<-- Child's FIS(:,1),PD(:,2) interpolated to parent update pts ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Parent's sfc geopotential (m2/s2) ,PD !<-- Parent's PD (Pa) ! REAL(kind=KFPT),DIMENSION(1:LM+1),INTENT(IN) :: SG1,SG2 !<-- Interface 'sigma' values in pressure and hybrid regions ! REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_TOTAL),TARGET & ,INTENT(INOUT):: VAR_2WAY !<-- String of all 2-way update data from child ! TYPE(ESMF_FieldBundle),INTENT(INOUT) :: BUNDLE_2WAY !<-- Object holding pointes to the 2-way exchange variables ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: I,IPTS,J,JPTS,KNT,KNT_HZ & ,L,L1,L2,LOC1_2WAY,LOC2_2WAY & ,N_STRIDE,NL,NPTS_3D,NPTS_HZ & ,NUM_DIMS,NUM_LEVS_SEC,NUM_LEVS_SPLINE,NV ! INTEGER(kind=KINT) :: RC,RC_UPD ! REAL(kind=KFPT) :: COEFF_1,DELP_EXTRAP,FACTOR,PDTOP_PT & ,PINT_HI_CHILD,PINT_HI_PARENT,PINT_LO & ,R_DELP,WGT_PARENT ! REAL(kind=KFPT),DIMENSION(1:LM) :: PMID_PARENT & ,VBL_OUT ! REAL(kind=KFPT),DIMENSION(1:LM+1) :: PMID_CHILD & ,SEC_DERIV ! REAL(kind=KFPT) :: PMID_CHILD_LM,PMID_CHILD_LM1 & ,PROD_LM,PROD_LM1,PROD_LM2 & ,VBL_LM,VBL_LM1 ! REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL,VBL_X ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VAR_PARENT_2D ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VAR_PARENT_3D & ,VAR_3D ! REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: VAR_PARENT_4D ! LOGICAL(kind=KLOG) :: EXTRAPOLATE ! CHARACTER(len=99) :: FIELD_NAME ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** The parent does not incorporate data sent from the child if !*** this is a parent timestep that immediately follows the writing !*** of a restart file. This ensures bit-reproducible restarts. !*** A child sends 2-way data to its parent at the end of parent !*** timestep N and the parent receives that data early in timestep !*** N+1. Two-way data is not in the restart files so in a restart !*** the parent sees no 2-way data coming from its children in the !*** first timestep. Therefore the parent must not use 2-way data !*** from the children in any parent timestep that follows the !*** writing of a restart file. !----------------------------------------------------------------------- ! NUM_LEVS_SEC=LM+1 WGT_PARENT=1.-WGT_CHILD ! !----------------------------------------------------------------------- ! IPTS=I_2WAY_UPDATE_END-I_2WAY_UPDATE_START+1 !<-- # of parent points updated in I dimension JPTS=J_2WAY_UPDATE_END-J_2WAY_UPDATE_START+1 !<-- # of parent points updated in J dimension NPTS_HZ=IPTS*JPTS !<-- # of parent update points in the horizontal NPTS_3D=NPTS_HZ*LM !<-- # of parent points updated for each 3D variable ! KNT=0 !<-- Count words in 2-D string of 2-way exchange variables ! !----------------------------------------------------------------------- !*** Loop through all the 2-way exchange variables. !----------------------------------------------------------------------- ! vars: DO NV=1,NVARS_2WAY_UPDATE ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vbls" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding the arrays for move updates ,fieldIndex =NV & !<-- Index of the Field in the Bundle ,field =HOLD_FIELD & !<-- Field NV in the Bundle ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) !----------------------------------------------------------------------- ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Info about this 2-way Variable" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? ,name =FIELD_NAME & !<-- This variable's name. ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ndim: IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 2-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_2D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END ! KNT=KNT+1 ! VAR_PARENT_2D(I,J)=VAR_2WAY(KNT)*WGT_CHILD & !<-- The 2-way data from the child provides the fraction +VAR_PARENT_2D(I,J)*WGT_PARENT ! WGT_CHILD of the final updated parent value. ! ENDDO ENDDO ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS>=3)THEN ! !----------------------------------------------------------------------- ! IF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 3-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_3D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=1 L2=1 ! !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==4)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Real 2-way 4-D Array from the Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer ,localDe =0 & ,farrayPtr=VAR_PARENT_4D & !<-- Put the pointer here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! L1=LBOUND(VAR_PARENT_4D,4) L2=UBOUND(VAR_PARENT_4D,4) ! ENDIF ! !----------------------------------------------------------------------- ! nl_loop: DO NL=L1,L2 !<-- Loop through exchange variable's 4th dimension ! if it exists. KNT_HZ=0 ! DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END ! !----------------------------------------------------------------------- ! KNT_HZ=KNT_HZ+1 EXTRAPOLATE=.FALSE. ! !----------------------------------------------------------------------- !*** If either the interpolated nest sfc or the parent sfc lies !*** above sea level then the parent adjusts the child data in !*** the vertical to account for different topographies. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- adjust: IF(CHILD_SFC_ON_PARENT_GRID(KNT_HZ,1)>1. & !<-- Child's interpolated sfc is above sea level .OR. & FIS(I,J)>1.)THEN !<-- Parent's sfc is above sea level !----------------------------------------------------------------------- ! PDTOP_PT=SG1(1)*PDTOP+PT PINT_HI_CHILD=SG2(1)*CHILD_SFC_ON_PARENT_GRID(KNT_HZ,2)+PDTOP_PT PINT_HI_PARENT=SG2(1)*PD(I,J)+PDTOP_PT ! DO L=1,LM PDTOP_PT=SG1(L+1)*PDTOP+PT PINT_LO=SG2(L+1)*CHILD_SFC_ON_PARENT_GRID(KNT_HZ,2)+PDTOP_PT PMID_CHILD(L)=0.5*(PINT_HI_CHILD+PINT_LO) !<-- Midlayer P of 2-way data from child at parent I,J PINT_HI_CHILD=PINT_LO ! PINT_LO=SG2(L+1)*PD(I,J)+PDTOP_PT PMID_PARENT(L)=0.5*(PINT_HI_PARENT+PINT_LO) !<-- Current midlayer pressure at parent I,J PINT_HI_PARENT=PINT_LO ENDDO ! NUM_LEVS_SPLINE=LM ! DO L=1,NUM_LEVS_SEC SEC_DERIV(L)=0. !<-- Needed in the SPLINE subroutine ENDDO ! !----------------------------------------------------------------------- !*** If the target parent midlayer pressure level lies below the !*** lowest child input midlayer (interpolated) pressure then !*** extrapolate linearly downward in pressure to obtain an !*** artificial child input value at the lowest parent midlayer !*** pressure then fill in the remaining 'underground' parent levels !*** using SPLINE just as is done with all the higher levels. ! !*** In order to reduce the effects of the ground surface, the lowest !*** input layer is changed to be the mass-weighted average of the !*** original two lowest layers while the 2nd lowest input layer is !*** changed to be the mass-weighted average of the three original !*** lowest layers. !----------------------------------------------------------------------- ! IF(PMID_PARENT(LM)>PMID_CHILD(LM))THEN EXTRAPOLATE=.TRUE. NUM_LEVS_SPLINE=LM+1 !<-- Insert 'underground' artificial input level from child ! PMID_CHILD(LM+1)=PMID_PARENT(LM) !<-- 'Underground' child P is the parent's bottom midlayer P ALLOCATE(VBL_X(1:LM+1)) !<-- Allocate 2-way data input column with extra bottom layer ENDIF ! LOC1_2WAY=(NV-1)*NPTS_3D & !<-- The 1st word of the column of 2-way data in 1-D data +(J-J_2WAY_UPDATE_START)*IPTS & ! recvd from child for variable NV at parent I,J. +(I-I_2WAY_UPDATE_START+1) LOC2_2WAY=LOC1_2WAY+(LM-1)*NPTS_HZ !<-- The last word of parent I,J column in 2-way exchange data. N_STRIDE=NPTS_HZ !<-- Stride between points in this I,J column. ! VBL_COL=>VAR_2WAY(LOC1_2WAY:LOC2_2WAY:N_STRIDE) !<-- Pre-adjusted values in this column of the input 2-way data ! IF(.NOT.EXTRAPOLATE)THEN VBL_X=>VBL_COL !<-- No extrapolation so no need to copy values ! ELSEIF(EXTRAPOLATE)THEN DO L=1,LM-2 VBL_X(L)=VBL_COL(L) !<-- Copy the genuine values from the input column ENDDO ! PROD_LM=VBL_COL(LM)*PMID_CHILD(LM) PROD_LM1=VBL_COL(LM-1)*PMID_CHILD(LM-1) PROD_LM2=VBL_COL(LM-2)*PMID_CHILD(LM-2) VBL_LM=(PROD_LM+PROD_LM1) & /(PMID_CHILD(LM)+PMID_CHILD(LM-1)) VBL_LM1=(PROD_LM+PROD_LM1+PROD_LM2) & /(PMID_CHILD(LM)+PMID_CHILD(LM-1) & +PMID_CHILD(LM-2)) VBL_X(LM)=VBL_LM VBL_X(LM-1)=VBL_LM1 PMID_CHILD_LM=0.5*(PMID_CHILD(LM-1)+PMID_CHILD(LM)) PMID_CHILD_LM1=(PMID_CHILD(LM-2)+PMID_CHILD(LM-1) & +PMID_CHILD(LM))/3. PMID_CHILD(LM)=PMID_CHILD_LM PMID_CHILD(LM-1)=PMID_CHILD_LM1 R_DELP=1./(PMID_CHILD(LM)-PMID_CHILD(LM-1)) DELP_EXTRAP=PMID_PARENT(LM)-PMID_CHILD(LM) ! COEFF_1=(VBL_X(LM)-VBL_X(LM-1))*R_DELP FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) VBL_X(LM+1)=VBL_X(LM) & !<-- Fill in the extra artificial underground value +COEFF_1*DELP_EXTRAP*FACTOR ! in 2-way input. ! ENDIF ! CALL SPLINE(NUM_LEVS_SPLINE & !<-- # of midlayers in column of child input 2-way data ,PMID_CHILD & !<-- Interpolated input pressures at child's midlayers ,VBL_X & !<-- Input values of variable in column at parent I,J ,SEC_DERIV & ,NUM_LEVS_SEC & ,LM & !<-- Interpolate to this many parent midlayers ,PMID_PARENT & !<-- Target output pressures at parent's midlayers ,VBL_OUT) !<-- Values in the column at I,J adjusted for topo differences ! DO L=1,LM VBL_COL(L)=VBL_OUT(L) !<-- Transfer adjusted column values back into 2-way data ENDDO ! IF(EXTRAPOLATE)THEN !<-- VBL_X is explicitly allocated only if EXTRAPOLATE is true. DEALLOCATE(VBL_X) ENDIF ! !----------------------------------------------------------------------- ! ENDIF adjust ! !----------------------------------------------------------------------- ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Now the parent simply updates its values of the exchange !*** variables at its update points using a weighted average !*** between its original values and those coming from the child. !----------------------------------------------------------------------- ! IF(NUM_DIMS==3)THEN VAR_3D=>VAR_PARENT_3D ELSEIF(NUM_DIMS==4)THEN VAR_3D=>VAR_PARENT_4D(:,:,:,NL) ENDIF ! DO L=1,LM DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END ! KNT=KNT+1 ! VAR_3D(I,J,L)=VAR_2WAY(KNT)*WGT_CHILD & !<-- The 2-way data from the child provides the fraction +VAR_3D(I,J,L)*WGT_PARENT ! WGT_CHILD of the final updated parent value. ! ENDDO ENDDO ! ENDDO ! !----------------------------------------------------------------------- ! ENDDO nl_loop ! !----------------------------------------------------------------------- ! ENDIF ndim ! !----------------------------------------------------------------------- ! ENDDO vars ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_2WAY_UPDATE ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHILD_DATA_FROM_STRING(LENGTH_DATA & ,DATASTRING & ,ILIM_LO,ILIM_HI & ,JLIM_LO,JLIM_HI & ,I_START,I_END & ,J_START,J_END & ,NVARS_BC_2D_H & ,NVARS_BC_3D_H & ,NVARS_BC_4D_H & ,LBND_4D & ,UBND_4D & ,NVARS_BC_2D_V & ,NVARS_BC_3D_V & ,PDB & ,BC_VARS_H & ,BC_VARS_V ) ! !----------------------------------------------------------------------- !*** Extract variables for a nest's boundary from the datastring !*** received by the child from its parent. A child task might !*** receive segments of boundary data from two parent tasks in !*** which case the pieces are be combined. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: LENGTH_DATA & !<-- # of words in datastring ,I_START & !<-- Starting I of data segment in string on child's grid ,I_END & !<-- Ending I of data segment in string on child's grid ,J_START & !<-- Starting J of data segment in string on child's grid ,J_END & !<-- Ending J of data segment in string on child's grid ,ILIM_LO & !<-- Lower I limit of full boundary segment ,ILIM_HI & !<-- Upper I limit of full boundary segment ,JLIM_LO & !<-- Lower J limit of full boundary segment ,JLIM_HI !<-- Upper J limit of full boundary segment ! REAL(kind=KFPT),DIMENSION(:),INTENT(IN) :: DATASTRING !<-- The string of boundary data from the parent ! INTEGER(kind=KINT),INTENT(IN) :: NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,NVARS_BC_3D_V !<-- # of 3-D V-pt vbls on child boundary ! INTEGER(kind=KINT),DIMENSION(:),INTENT(IN) :: LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension ,UBND_4D !<-- Upper bounds of 4-D variables' 4th dimension ! REAL(kind=KFPT),DIMENSION(ILIM_LO:ILIM_HI,JLIM_LO:JLIM_HI) & ,INTENT(OUT),OPTIONAL :: PDB !<-- PD for segment of the child boundary ! TYPE(BC_H),INTENT(INOUT),OPTIONAL :: BC_VARS_H !<-- Child's 1-D segment of other H-pt vbls on bndry segment ! TYPE(BC_V),INTENT(INOUT),OPTIONAL :: BC_VARS_V !<-- Child's 1-D segment of V-pt vbls on bndry segment ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,J,K,L,LB,N,NV,UB ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Extract the appropriate boundary variables from the datastring !*** provided by the parent. !*** Here we transfer from the 1-D string to the 2-D and 3-D arrays. !*** This easily allows for proper combining of separate strings !*** whose ends may overlap that are arriving from different parent !*** tasks. To export these boundary arrays out of the coupler !*** though the data must be put back into 1-D. ! !*** The 2-D pressure array PD is always the first variable in the !*** datastring from the parent. !----------------------------------------------------------------------- ! N=0 ! IF(PRESENT(BC_VARS_H))THEN !<-- Parent datastring for H-pt variables has been sent in ! DO J=J_START,J_END DO I=I_START,I_END N=N+1 PDB(I,J)=DATASTRING(N) !<-- The 2-D PD array is handled separately ENDDO ENDDO ! IF(NVARS_BC_2D_H>1)THEN !<-- Loop through remaining 2-D H-pt boundary variables DO NV=1,NVARS_BC_2D_H-1 DO J=J_START,J_END DO I=I_START,I_END N=N+1 BC_VARS_H%VAR_2D(NV)%SIDE(I,J)=DATASTRING(N) ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN !<-- Loop through 3-D H-pt boundary variables DO NV=1,NVARS_BC_3D_H DO K=1,LM DO J=J_START,J_END DO I=I_START,I_END N=N+1 BC_VARS_H%VAR_3D(NV)%SIDE(I,J,K)=DATASTRING(N) ENDDO ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN !<-- Loop through 3-D H-pt boundary variables DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) DO L=LB,UB DO K=1,LM DO J=J_START,J_END DO I=I_START,I_END N=N+1 BC_VARS_H%VAR_4D(NV)%SIDE(I,J,K,L)=DATASTRING(N) ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF ! ELSEIF(PRESENT(BC_VARS_V))THEN !<-- Parent datastring for V-pt variables has been sent in ! IF(NVARS_BC_2D_V>1)THEN !<-- Loop through 2-D V-pt boundary variables DO NV=1,NVARS_BC_2D_V DO J=J_START,J_END DO I=I_START,I_END N=N+1 BC_VARS_V%VAR_2D(NV)%SIDE(I,J)=DATASTRING(N) ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_3D_V>1)THEN !<-- Loop through all the 3-D V-pt boundary variables DO NV=1,NVARS_BC_3D_V DO K=1,LM DO J=J_START,J_END DO I=I_START,I_END N=N+1 BC_VARS_V%VAR_3D(NV)%SIDE(I,J,K)=DATASTRING(N) ENDDO ENDDO ENDDO ENDDO ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILD_DATA_FROM_STRING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE EXPORT_CHILD_BOUNDARY(NVARS_BC_2D_H & ,NVARS_BC_3D_H & ,NVARS_BC_4D_H & ,LBND_4D & ,UBND_4D & ,NVARS_BC_2D_V & ,NVARS_BC_3D_V & ,PDB & ,BC_VARS_H & ,BC_VARS_V & ! ,ILIM_LO,ILIM_HI & ,JLIM_LO,JLIM_HI & ! ,DATA_NAME & ! ,DATA_EXP & ! ,EXPORT_STATE ) ! !----------------------------------------------------------------------- !*** Load the child boundary values received from the parent !*** into the Parent-Child coupler export state. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary ,NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary ,NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary ,NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary ,NVARS_BC_3D_V !<-- # of 3-D V-pt vbls on child boundary ! INTEGER(kind=KINT),INTENT(IN) :: ILIM_LO & !<-- Lower I limit of full boundary segment ,ILIM_HI & !<-- Upper I limit of full boundary segment ,JLIM_LO & !<-- Lower J limit of full boundary segment ,JLIM_HI !<-- Upper J limit of full boundary segment ! INTEGER(kind=KINT),DIMENSION(:),INTENT(IN) :: LBND_4D & !<-- Lower bound of 4-D variables' 4th dimension ,UBND_4D !<-- Upper bound of 4-D variables' 4th dimension ! REAL(kind=KFPT),DIMENSION(ILIM_LO:ILIM_HI,JLIM_LO:JLIM_HI) & ,INTENT(IN),OPTIONAL :: PDB !<-- PD for segment of the child boundary ! TYPE(BC_H),INTENT(IN),OPTIONAL :: BC_VARS_H !<-- Child's 1-D segment of other H-pt vbls on bndry segment ! TYPE(BC_V),INTENT(IN),OPTIONAL :: BC_VARS_V !<-- Child's 1-D segment of V-pt vbls on bndry segment ! CHARACTER(*),INTENT(IN) :: DATA_NAME !<-- Name used for each child task's boundary segment ! REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(INOUT) :: DATA_EXP !<-- Combined boundary segment data on child task ! TYPE(ESMF_State),INTENT(INOUT) :: EXPORT_STATE !<-- The Parent-Child Coupler export state ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,J,K,L,LB,NV,UB & ,ISTAT,RC,RC_EXP_BNDRY ! INTEGER(kind=KINT),SAVE :: NN ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_EXP_BNDRY=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** The children's final boundary data will be loaded into the !*** Parent-Child Coupler's export state as 1-D arrays (Attributes) !*** since they are not spanning the childrens' ESMF Grids (as Fields). !*** But because they are Attributes and not Fields, they will need !*** to be reset every time. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- main: IF(PRESENT(BC_VARS_H))THEN !<-- If true then H-point variables were sent in !----------------------------------------------------------------------- ! NN=0 !<-- The data always begins with H points ! DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=PDB(I,J) !<-- First insert complete PDB into the 1-D H boundary data ENDDO ENDDO ! ! IF(NVARS_BC_2D_H>1)THEN DO NV=1,NVARS_BC_2D_H-1 DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=BC_VARS_H%VAR_2D(NV)%SIDE(I,J) !<-- Insert 2-D H-pt BC vbls into the 1-D H boundary data ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H DO K=1,LM DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=BC_VARS_H%VAR_3D(NV)%SIDE(I,J,K) !<-- Insert 3-D H-pt BC vbls into the 1-D H boundary data ENDDO ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H LB=LBND_4D(NV) UB=UBND_4D(NV) DO L=LB,UB DO K=1,LM DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=BC_VARS_H%VAR_4D(NV)%SIDE(I,J,K,L) !<-- Insert 4-D H-pt BC vbls into the 1-D H boundary data ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry Data "//DATA_NAME//" Into Coupler Export" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- This Parent_child Coupler export state ,name =DATA_NAME & !<-- Name of the children's new boundary H data ,itemCount=NN & !<-- # of words in the data ,valueList=DATA_EXP & !<-- The children's new boundary H data ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_EXP_BNDRY) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ELSEIF(PRESENT(BC_VARS_V))THEN !<-- If true then V-point variables were sent in ! !----------------------------------------------------------------------- ! NN=0 ! IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=BC_VARS_V%VAR_2D(NV)%SIDE(I,J) !<-- Insert 2-D V-pt BC vbls into the 1-D V boundary data ENDDO ENDDO ENDDO ENDIF ! IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V DO K=1,LM DO J=JLIM_LO,JLIM_HI DO I=ILIM_LO,ILIM_HI NN=NN+1 DATA_EXP(NN)=BC_VARS_V%VAR_3D(NV)%SIDE(I,J,K) !<-- Insert 3-D V-pt BC vbls into the 1-D V boundary data ENDDO ENDDO ENDDO ENDDO ENDIF ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Child Bndry Data "//DATA_NAME//" Into Coupler Export" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- This Parent_child Coupler export state ,name =DATA_NAME & !<-- Name of the children's new boundary V data ,itemCount=NN & !<-- # of words in the data ,valueList=DATA_EXP & !<-- The children's new boundary V data ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_EXP_BNDRY) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ENDIF main ! !----------------------------------------------------------------------- ! END SUBROUTINE EXPORT_CHILD_BOUNDARY ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE DEALLOC_WORK_PARENTS(N,TIME_FLAG) ! !----------------------------------------------------------------------- !*** Parents deallocate all working pointers that needed to be !*** allocated with unique dimensions at the outset of the forecast !*** and again each time a nest moves. Those allocations took place !*** in subroutine POINT_INTERP_DATA_TO_MEMORY. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: N !<-- Which child of this parent ! CHARACTER(*),INTENT(IN) :: TIME_FLAG !<-- Current or future boundary data for children? ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: IERR,INDX2,ISTAT,NCHILD_TASKS,NMAX,NT,NV ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Select the appropriate part of the working array depending on !*** whether we are now concerned with children's boundaries for !*** their current time or for their future. !----------------------------------------------------------------------- ! IF(TIME_FLAG=='Future')THEN INDX2=1 ELSEIF(TIME_FLAG=='Current')THEN INDX2=2 ENDIF ! !----------------------------------------------------------------------- !*** The parent must not deallocate the actual BC update buffers !*** until it knows that they have been Recvd by the children. !*** That is the reason for the Waits below. !----------------------------------------------------------------------- ! !----------- !*** South !----------- ! NMAX=UBOUND(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! south_h: IF(ASSOCIATED(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd H point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS,stat=ISTAT) ! IF(ASSOCIATED(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF south_h ! NCHILD_TASKS=UBOUND(PD_B_SOUTH(N)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd H point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_SOUTH(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_SOUTH(N)%TASKS(NT)%DATA) ENDIF DEALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NT)%DATA) ENDDO ! DEALLOCATE(PD_B_SOUTH(N)%TASKS) ! DO NV=1,NVARS_NESTBC_H-1 DEALLOCATE(BND_VAR_H_SOUTH(NV)%CHILD(N)%TASKS,stat=ISTAT) IF(ISTAT>0)THEN WRITE(0,11011)NV,N,ISTAT 11011 FORMAT(' DEALLOC_WORK_PARENTS failed to deallocate' & ,' BND_VAR_H_SOUTH(',I2,')%CHILD(',I2,')%TASKS' & ,' ISTAT=',I4) ENDIF ENDDO ! DEALLOCATE(FIS_CHILD_SOUTH(N)%TASKS) DEALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS) ! NMAX=UBOUND(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! south_v: IF(ASSOCIATED(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd V point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF south_v ! NCHILD_TASKS=UBOUND(PD_B_SOUTH_V(N)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd V point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_SOUTH_V(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_SOUTH_V(N)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS) DEALLOCATE(PD_B_SOUTH_V(N)%TASKS) ! DO NV=1,NVARS_NESTBC_V DEALLOCATE(BND_VAR_V_SOUTH(NV)%CHILD(N)%TASKS) ENDDO ! !----------------------------------------------------------------------- ! !----------- !*** North !----------- ! NMAX=UBOUND(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! north_h: IF(ASSOCIATED(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd H point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ,' Failed to deallocate CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA' ELSE ! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ! ,' Succeeded in deallocating CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA' ENDIF ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF north_h ! NCHILD_TASKS=UBOUND(PD_B_NORTH(N)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd H point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_NORTH(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_NORTH(N)%TASKS(NT)%DATA,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ,' Failed to deallocate PD_B_NORTH(N)%TASKS(NT)%DATA' ELSE ! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ! ,' Succeeded in deallocating PD_B_NORTH(N)%TASKS(NT)%DATA' ENDIF ENDIF DEALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NT)%DATA) ENDDO ! DEALLOCATE(PD_B_NORTH(N)%TASKS) ! DO NV=1,NVARS_NESTBC_H-1 DEALLOCATE(BND_VAR_H_NORTH(NV)%CHILD(N)%TASKS) ENDDO ! DEALLOCATE(FIS_CHILD_NORTH(N)%TASKS) DEALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS) ! NMAX=UBOUND(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! north_v: IF(ASSOCIATED(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd V point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ,' Failed to deallocate CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA' ELSE ! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ! ,' Succeeded in deallocating CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA' ENDIF ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF north_v ! NCHILD_TASKS=UBOUND(PD_B_NORTH_V(N)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd V point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_NORTH_V(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_NORTH_V(N)%TASKS(NT)%DATA,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ,' Failed to deallocate PD_B_NORTH_V(N)%TASKS(NT)%DATA' ELSE ! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & ! ,' Succeeded in deallocating PD_B_NORTH_V(N)%TASKS(NT)%DATA' ENDIF ENDIF ENDDO ! DEALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS) DEALLOCATE(PD_B_NORTH_V(N)%TASKS) ! DO NV=1,NVARS_NESTBC_V DEALLOCATE(BND_VAR_V_NORTH(NV)%CHILD(N)%TASKS) ENDDO ! !----------------------------------------------------------------------- ! !---------- !*** West !---------- ! NMAX=UBOUND(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! west_h: IF(ASSOCIATED(CHILD_BOUND_H_WEST(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_H_WEST(N,INDX2)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd H point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF west_h ! NCHILD_TASKS=UBOUND(PD_B_WEST(N)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd H point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_WEST(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_WEST(N)%TASKS(NT)%DATA) ENDIF DEALLOCATE(FIS_CHILD_WEST(N)%TASKS(NT)%DATA) ENDDO ! DEALLOCATE(PD_B_WEST(N)%TASKS) ! DO NV=1,NVARS_NESTBC_H-1 DEALLOCATE(BND_VAR_H_WEST(NV)%CHILD(N)%TASKS) ENDDO ! DEALLOCATE(FIS_CHILD_WEST(N)%TASKS) DEALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS) ! NMAX=UBOUND(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! west_v: IF(ASSOCIATED(CHILD_BOUND_V_WEST(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_V_WEST(N,INDX2)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd V point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF west_v ! NCHILD_TASKS=UBOUND(PD_B_WEST_V(N)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd V point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_WEST_V(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_WEST_V(N)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS) DEALLOCATE(PD_B_WEST_V(N)%TASKS) ! DO NV=1,NVARS_NESTBC_V DEALLOCATE(BND_VAR_V_WEST(NV)%CHILD(N)%TASKS) ENDDO ! !----------------------------------------------------------------------- ! !---------- !*** East !---------- ! NMAX=UBOUND(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! east_h: IF(ASSOCIATED(CHILD_BOUND_H_EAST(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_H_EAST(N,INDX2)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd H point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF east_h ! NCHILD_TASKS=UBOUND(PD_B_EAST(N)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd H point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_EAST(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_EAST(N)%TASKS(NT)%DATA) ENDIF DEALLOCATE(FIS_CHILD_EAST(N)%TASKS(NT)%DATA) ENDDO ! DEALLOCATE(PD_B_EAST(N)%TASKS) ! DO NV=1,NVARS_NESTBC_H-1 DEALLOCATE(BND_VAR_H_EAST(NV)%CHILD(N)%TASKS) ENDDO ! DEALLOCATE(FIS_CHILD_EAST(N)%TASKS) DEALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS) ! NMAX=UBOUND(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV,1) IF(NMAX>0)THEN DO NT=1,NMAX CALL MPI_WAIT(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT ,JSTAT & !<-- MPI status ,IERR ) ENDDO ENDIF ! east_v: IF(ASSOCIATED(CHILD_BOUND_V_EAST(N,INDX2)%TASKS))THEN ! NCHILD_TASKS=UBOUND(CHILD_BOUND_V_EAST(N,INDX2)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd V point data ! DO NT=1,NCHILD_TASKS IF(ASSOCIATED(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA))THEN DEALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS) ! IF(ASSOCIATED(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV))THEN DEALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV) ENDIF ! ENDIF east_v ! NCHILD_TASKS=UBOUND(PD_B_EAST_V(N)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd V point data DO NT=1,NCHILD_TASKS IF(ASSOCIATED(PD_B_EAST_V(N)%TASKS(NT)%DATA))THEN DEALLOCATE(PD_B_EAST_V(N)%TASKS(NT)%DATA) ENDIF ENDDO ! DEALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS) DEALLOCATE(PD_B_EAST_V(N)%TASKS) ! DO NV=1,NVARS_NESTBC_V DEALLOCATE(BND_VAR_V_EAST(NV)%CHILD(N)%TASKS) ENDDO ! !----------------------------------------------------------------------- ! END SUBROUTINE DEALLOC_WORK_PARENTS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) ! !----------------------------------------------------------------------- !*** Children deallocate all working pointers that need to be allocated !*** with unique dimensions at the outset of the forecast and again !*** each time a nest moves. These allocations took place in !*** subroutine CHILD_RECVS_CHILD_DATA_LIMITS. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ID_DOM,LIM_HI,N,NV ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) ! ID_DOM=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of this child's parent LIM_HI=FTASKS_DOMAIN(ID_DOM) !<-- # of fcst tasks on this nest's parent domain ! DO N=1,LIM_HI IF(ALLOCATED(PARENT_TASK(N)%SOUTH_H%STRING))THEN DEALLOCATE(PARENT_TASK(N)%SOUTH_H%STRING) !<-- Sboundary H datastring from parent 'N' ENDIF IF(ALLOCATED(PARENT_TASK(N)%SOUTH_V%STRING))THEN DEALLOCATE(PARENT_TASK(N)%SOUTH_V%STRING) !<-- Sboundary V datastring from parent 'N' ENDIF ! IF(ALLOCATED(PARENT_TASK(N)%NORTH_H%STRING))THEN DEALLOCATE(PARENT_TASK(N)%NORTH_H%STRING) !<-- Nboundary H datastring from parent 'N' ENDIF IF(ALLOCATED(PARENT_TASK(N)%NORTH_V%STRING))THEN DEALLOCATE(PARENT_TASK(N)%NORTH_V%STRING) !<-- Nboundary V datastring from parent 'N' ENDIF ! IF(ALLOCATED(PARENT_TASK(N)%WEST_H%STRING))THEN DEALLOCATE(PARENT_TASK(N)%WEST_H%STRING) !<-- Wboundary H datastring from parent 'N' ENDIF IF(ALLOCATED(PARENT_TASK(N)%WEST_V%STRING))THEN DEALLOCATE(PARENT_TASK(N)%WEST_V%STRING) !<-- Wboundary V datastring from parent 'N' ENDIF ! IF(ALLOCATED(PARENT_TASK(N)%EAST_H%STRING))THEN DEALLOCATE(PARENT_TASK(N)%EAST_H%STRING) !<-- Eboundary H datastring from parent 'N' ENDIF IF(ALLOCATED(PARENT_TASK(N)%EAST_V%STRING))THEN DEALLOCATE(PARENT_TASK(N)%EAST_V%STRING) !<-- Eboundary V datastring from parent 'N' ENDIF ! ENDDO ! IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Did this child task recv Sboundary H data from parent? IF(NVARS_BC_2D_H>0)THEN DO NV=1,NVARS_BC_2D_H-1 DEALLOCATE(MY_BC_VARS_H_S%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H DEALLOCATE(MY_BC_VARS_H_S%VAR_3D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H DEALLOCATE(MY_BC_VARS_H_S%VAR_4D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%PDB_S) DEALLOCATE(cc%BOUND_1D_SOUTH_H) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_V%SOUTH>0)THEN !<-- Did this child task recv Sboundary V data from parent? IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V DEALLOCATE(MY_BC_VARS_V_S%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V DEALLOCATE(MY_BC_VARS_V_S%VAR_3D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%BOUND_1D_SOUTH_V) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Did this child task recv Nboundary H data from parent? IF(NVARS_BC_2D_H>0)THEN DO NV=1,NVARS_BC_2D_H-1 DEALLOCATE(MY_BC_VARS_H_N%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H DEALLOCATE(MY_BC_VARS_H_N%VAR_3D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H DEALLOCATE(MY_BC_VARS_H_N%VAR_4D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%BOUND_1D_NORTH_H) DEALLOCATE(cc%PDB_N) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_V%NORTH>0)THEN !<-- Did this child task recv Nboundary V data from parent? IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V DEALLOCATE(MY_BC_VARS_V_N%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V DEALLOCATE(MY_BC_VARS_V_N%VAR_3D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%BOUND_1D_NORTH_V) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Did this child task recv Wboundary H data from parent? IF(NVARS_BC_2D_H>0)THEN DO NV=1,NVARS_BC_2D_H-1 DEALLOCATE(MY_BC_VARS_H_W%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H DEALLOCATE(MY_BC_VARS_H_W%VAR_3D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H DEALLOCATE(MY_BC_VARS_H_W%VAR_4D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%PDB_W) DEALLOCATE(cc%BOUND_1D_WEST_H) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_V%WEST>0)THEN !<-- Did this child task recv Wboundary V data from parent? IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V DEALLOCATE(MY_BC_VARS_V_W%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V DEALLOCATE(MY_BC_VARS_V_W%VAR_3D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%BOUND_1D_WEST_V) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Did this child task recv Eboundary H data from parent? IF(NVARS_BC_2D_H>0)THEN DO NV=1,NVARS_BC_2D_H-1 DEALLOCATE(MY_BC_VARS_H_E%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_H>0)THEN DO NV=1,NVARS_BC_3D_H DEALLOCATE(MY_BC_VARS_H_E%VAR_3D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_4D_H>0)THEN DO NV=1,NVARS_BC_4D_H DEALLOCATE(MY_BC_VARS_H_E%VAR_4D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%PDB_E) DEALLOCATE(cc%BOUND_1D_EAST_H) ENDIF ! IF(NUM_PARENT_TASKS_SENDING_V%EAST>0)THEN !<-- Did this child task recv Eboundary V data from parent? IF(NVARS_BC_2D_V>0)THEN DO NV=1,NVARS_BC_2D_V DEALLOCATE(MY_BC_VARS_V_E%VAR_2D(NV)%SIDE) ENDDO ENDIF IF(NVARS_BC_3D_V>0)THEN DO NV=1,NVARS_BC_3D_V DEALLOCATE(MY_BC_VARS_V_E%VAR_3D(NV)%SIDE) ENDDO ENDIF DEALLOCATE(cc%BOUND_1D_EAST_V) ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE DEALLOC_WORK_CHILDREN ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE COMPUTE_STORM_MOTION(NTIMESTEP & ,LAST_STEP_MOVED & ,DT & ,NUM_PES_FCST & ,COMM_FCST_TASKS & ,FIS & ,PD & ,PINT & ,T & ,Q & ,CW & ,U & ,V & ,DSG2 & ,PDSG1 & ,DX,DY & ,SEA_MASK & ,I_SW_PARENT_CURRENT & ,J_SW_PARENT_CURRENT & ,I_WANT_TO_MOVE & ,I_SW_PARENT_NEW & ,J_SW_PARENT_NEW & ,MY_DOMAIN_ID ) ! !----------------------------------------------------------------------- !*** The nest computes the location of the center of the storm !*** on its grid and decides if it should move. This routine !*** is called at the end of each timestep. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: COMM_FCST_TASKS & !<-- Intracommunicator for domain's forecast tasks ,I_SW_PARENT_CURRENT & !<-- Parent I of nest domain's SW corner; current position ,J_SW_PARENT_CURRENT & !<-- Parent J of nest domain's SW corner; current position ,LAST_STEP_MOVED & !<-- Most recent timestep the nest moved ,MY_DOMAIN_ID & !<-- This domain's ID ,NTIMESTEP & !<-- The nest's current timestep ,NUM_PES_FCST !<-- # of forecast tasks ! INTEGER(kind=KINT),INTENT(OUT) :: I_SW_PARENT_NEW & !<-- Parent I of nest domain's SW corner; new position ,J_SW_PARENT_NEW !<-- Parent J of nest domain's SW corner; new position ! REAL(kind=KFPT),INTENT(IN) :: DT & !<-- This domain's timestep ,DY !<-- Delta Y (m) on the nest grid ! REAL(kind=KFPT),DIMENSION(JDS:JDE),INTENT(IN) :: DX !<-- Delta X (m) on the nest grid ! REAL(kind=KFPT),DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1 ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Sfc geopotential (m2/s2) ,PD & !<-- Psfc minus PTOP (Pa) ,SEA_MASK !<-- Sea mask (1->water) ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: CW & !<-- Cloud condensate (kg/kg) ,Q & !<-- Specific humidity (kg/kg) ,T & !<-- Sensible temperature (K) ,U & !<-- U component of wind (m/s) ,V !<-- V component of wind (m/s) ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: & PINT !<-- Layer interface pressures (Pa) ! LOGICAL(kind=KLOG),INTENT(OUT) :: I_WANT_TO_MOVE !<-- Does nest want to move to a new position? ! !--------------------- !*** Local Variables !--------------------- ! ! INTEGER(kind=KINT),SAVE :: I_EAST,I_WEST & !<-- These define the nest domain search limits ! ,J_NORTH,J_SOUTH ! within the central window. ! INTEGER(kind=KINT),SAVE :: ID_DUMMY=-999 & !<-- Dummy value for task ID ,ITAG_PG=200 !<-- Hardwire this tag for Sends/Recvs of Pgrad values ! ! INTEGER(kind=KINT),SAVE :: I_MAX,I_MIN & ! ,J_MAX,J_MIN & ! ,NPTS_NS,NPTS_WE ! INTEGER(kind=KINT) :: I,I_CENTER_CURRENT,I_CENTER_NEW & ,I_DIFF,ID_PE_MIN & ,J,J_CENTER_CURRENT,J_CENTER_NEW & ,J_DIFF & ,L,L1,L2,L3,MYPE_DOM,N,N_SEND ! INTEGER(kind=KINT) :: IERR,ISTAT ! ! INTEGER(kind=KINT),DIMENSION(1:4),SAVE :: I_PG,J_PG ! INTEGER(kind=KINT),DIMENSION(1:4) :: HANDLE_PVAL ! INTEGER(kind=KINT),DIMENSION(0:NUM_PES_FCST-1) :: HANDLE_PDYN & ,HANDLE_WIN ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT),SAVE :: DIST_GRAD=100000. & !<-- Distance (m) for checking storm-scale pressure gradient ,DIST_LAND=100000. & !<-- Distance (m) for checking shift over land ,ELAPSED_TIME_MAX=30000. & !<-- Maximum time (sec) between nest shifts over land ,GI=1./G & ,PGRD_MIN=200. & !<-- Minimum storm scale pressure gradient (Pa) ,PGRD_MIN_LAND=400. & !<-- Minimum storm scale pressure gradient (Pa) over land ,STD_LAPSE=6.5E-3 & !<-- Standard atmospheric lapse rate ,THIRD=1./3. & ,Z1=2000. & !<-- In computing the dynamic pressure use the winds ,Z2=1500. & ! at around 2km, 1.5km and 1km. ,Z3=1000. !<-- ! ! REAL(kind=KFPT),SAVE :: COEF & ! ,ELAPSED_TIME_MIN & ! ,RNPTS_HZ ! REAL(kind=KFPT) :: APELP,DFDP,DIST_I,DIST_J,DZ & ,ELAPSED_TIME,FACTOR,FRAC_SEA & ,PARENT_DIFF,PCHECK & ,PDYN_MIN_GBL,PMAX,PVAL,PVAL_N & ,SLP_MIN,SQWS,SUM_SEA,TSFC & ,ZDIFF,ZLOW,ZSAVE1,ZSAVE2,ZSAVE3 ! REAL(kind=KFPT),DIMENSION(:),POINTER :: PDYN_MIN_VALS !<-- Minimum PDYN on each task subdomain ! REAL(kind=KFPT),DIMENSION(1:3,0:NUM_PES_FCST-1),TARGET :: & PDYN_MIN !<-- Minimum PDYN and its I,J on each nest task subdomain ! REAL(kind=KFPT),DIMENSION(1:LM) :: ZMEAN ! REAL(kind=KFPT),DIMENSION(ITS:ITE,JTS:JTE) :: PDYN,SLP ! REAL(kind=KFPT),DIMENSION(ITS:ITE,JTS:JTE,1:LM+1) :: Z ! ! LOGICAL(kind=KLOG),SAVE :: FIRST_PASS=.TRUE. & ! ,I_HOLD_CENTER_POINT ! ! LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE,SAVE :: IN_WINDOW ! LOGICAL(kind=KLOG),DIMENSION(1:4) :: NO_VALUE ! ! LOGICAL(kind=KLOG),DIMENSION(1:4),SAVE :: I_HOLD_PG_POINT ! TYPE(COMPOSITE),POINTER :: CC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite ! CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_DOM,IERR) !<-- Task's local rank on this domain ! I_WANT_TO_MOVE=.FALSE. !<-- Begin with this assumption ! !----------------------------------------------------------------------- ! I_CENTER_CURRENT=IDS+INT(0.5*(IDE-IDS)+EPS) J_CENTER_CURRENT=JDS+INT(0.5*(JDE-JDS)+EPS) ! !----------------------------------------------------------------------- !*** In the first pass through this routine the nest tasks !*** determine which of their subdomains contain points within !*** the nest domain's central search window over the storm. Then !*** they exchange that information with each other. !----------------------------------------------------------------------- ! prelim: IF(FIRST_PASS_M)THEN !<-- Work needs to be done only once during the forecast ! !----------------------------------------------------------------------- ! FIRST_PASS_M=.FALSE. ! I_WEST_M =IDE/2-IDE/3 !<-- These define the nest domain search limits I_EAST_M =IDE/2+IDE/3 ! within the central window. J_SOUTH_M=JDE/2-JDE/3 ! J_NORTH_M=JDE/2+JDE/3 !<-- ! IF(.NOT.ASSOCIATED(cc%IN_WINDOW))THEN ALLOCATE(cc%IN_WINDOW(0:NUM_PES_FCST-1),stat=ISTAT) !<-- Must be allocated since 0:NUM_PES_FCST is passed in IF(ISTAT/=0)THEN WRITE(0,*)' COMPUTE_STORM_MOTION: ERROR' WRITE(0,*)' Failed to allocate IN_WINDOW stat=',ISTAT ENDIF ENDIF ! IN_WINDOW=>cc%IN_WINDOW IN_WINDOW(MYPE_DOM)=.FALSE. ! IF(ITS<=I_EAST_M.AND.ITE>=I_WEST_M & !<-- Does any of nest task N's subdomain .AND. & ! lie within the central window? JTS<=J_NORTH_M.AND.JTE>=J_SOUTH_M)THEN ! IN_WINDOW(MYPE_DOM)=.TRUE. !<-- Yes, this task lies in the search window ! I_MIN=MAX(ITS,I_WEST_M) !<-- Index limits of this task's subdomain I_MAX=MIN(ITE,I_EAST_M) ! that lie inside the search window. J_MIN=MAX(JTS,J_SOUTH_M) ! J_MAX=MIN(JTE,J_NORTH_M) !<-- ! RNPTS_HZ=1./REAL((I_MAX-I_MIN+1)*(J_MAX-J_MIN+1)) !<-- Reciprocal of # of task's points in search window ! ENDIF ! DO N=0,NUM_PES_FCST-1 !<-- Nest fcst tasks send their window status to each other IF(N/=MYPE_DOM)THEN !<-- But not to themselves CALL MPI_ISSEND(IN_WINDOW(MYPE_DOM) & !<-- This task's central window status ,1 & !<-- Sending this many words ,MPI_LOGICAL & !<-- Datatype ,N & !<-- Sending to this local nest task ID ,MYPE_DOM & !<-- Use this task's ID as the tag ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,HANDLE_WIN(N) & !<-- Communication request handle for task N's Recv ,IERR ) ENDIF ENDDO ! DO N=0,NUM_PES_FCST-1 !<-- Nest fcst tasks recv window status from each other IF(N/=MYPE_DOM)THEN !<-- But not from themselves CALL MPI_RECV(IN_WINDOW(N) & !<-- Nest task N's central window status ,1 & !<-- Receiving this many words ,MPI_LOGICAL & !<-- Datatype ,N & !<-- Data was sent by this nest task ,N & !<-- Tag is the sender's rank ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,JSTAT & !<-- MPI status ,IERR ) ENDIF ENDDO ! DO N=0,NUM_PES_FCST-1 IF(N/=MYPE_DOM)THEN CALL MPI_WAIT(HANDLE_WIN(N) & !<-- Proceed only after all ISSends have completed ,JSTAT & ,IERR ) ENDIF ENDDO ! !----------------------------------------------------------------------- !*** We will need an approximation of the maximum pressure gradient !*** around the storm center. Use SLP values roughly DIST_GRAD meters !*** N, S, W, and E of the center. What is the relative distance !*** in gridpoints that this distance represents? !----------------------------------------------------------------------- ! NPTS_NS=NINT(DIST_GRAD/DY) !<-- # grid points to N/S of center to check SLP NPTS_WE=NINT(DIST_GRAD/DX(J_CENTER_CURRENT)) !<-- # grid points to W/E of center to check SLP ! !----------------------------------------------------------------------- ! COEF=-G/(R_D*STD_LAPSE) ! !----------------------------------------------------------------------- !*** Set the minimum time between domain shifts. For now make it a !*** linear relationship where the 9km nest must wait at least 15 min !*** to move. !----------------------------------------------------------------------- ! ELAPSED_TIME_MIN=45.*DT !<-- Equals 900s for a 9 km nest. ! !----------------------------------------------------------------------- !*** Allow the minimum pressure gradient between the storm center !*** and the cardinal points to be smaller for higher resolution. !----------------------------------------------------------------------- ! IF(DY<8999.)THEN PGRD_MIN=PGRD_MIN*DY/9000. ENDIF ! !----------------------------------------------------------------------- ! ENDIF prelim ! !----------------------------------------------------------------------- !*** Allow the nest to move only in one of its physics timesteps. !----------------------------------------------------------------------- ! IF(MOD(NTIMESTEP,NPHS)/=0)THEN RETURN ENDIF ! !----------------------------------------------------------------------- !*** Never let the nest move until a minimum amount of time !*** has passed. !----------------------------------------------------------------------- ! ELAPSED_TIME=(NTIMESTEP-LAST_STEP_MOVED)*DT ! IF(ELAPSED_TIMEELAPSED_TIME_MAX)THEN IF(MYPE_DOM==0)THEN WRITE(0,*)' SKIP MOTION COMPUTATION: Storm stationary over land.' ENDIF RETURN ENDIF ! !----------------------------------------------------------------------- ! DO N=0,NUM_PES_FCST-1 PDYN_MIN(1,N)=110000. !<-- Initialize the minimum value of PDYN. PDYN_MIN(2,N)=-1000. !<-- Initialize the I index of minimum PDYN PDYN_MIN(3,N)=-1000. !<-- Initialize the J index of minimum PDYN ENDDO ! DO J=JTS,JTE DO I=ITS,ITE SLP(I,J)=0. !<-- Initialize the SLP array. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Begin the search for the new storm center location. !*** Search inside the central window. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- window: IF(IN_WINDOW(MYPE_DOM))THEN !<-- Only those tasks within the search window proceed !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Compute a 'dynamic pressure' using vertically averaged winds !*** around Z1, Z2, and Z3 meters as well as the sea level pressure. !----------------------------------------------------------------------- ! DO J=J_MIN,J_MAX DO I=I_MIN,I_MAX Z(I,J,LM+1)=FIS(I,J)*GI !<-- The surface elevation (m) ENDDO ENDDO ! DO L=LM,1,-1 ZMEAN(L)=0. DO J=J_MIN,J_MAX DO I=I_MIN,I_MAX APELP=(PINT(I,J,L)+PINT(I,J,L+1))*0.5 DFDP=(Q(I,J,L)*P608+(1.-CW(I,J,L)))*T(I,J,L)*R_D/APELP DZ=GI*DFDP*(DSG2(L)*PD(I,J)+PDSG1(L)) Z(I,J,L)=Z(I,J,L+1)+DZ ZMEAN(L)=ZMEAN(L)+0.5*(Z(I,J,L)+Z(I,J,L+1)) ENDDO ENDDO ZMEAN(L)=ZMEAN(L)*RNPTS_HZ !<-- The mean height (m) of midlayer L in search window ENDDO ! ZSAVE1=1.E10 ZSAVE2=1.E10 ZSAVE3=1.E10 ! !----------------------------------------------------------------------- !*** Find and save the model midlayer indices nearest to the !*** prescribed heights of Z1, Z2, and Z3 meters above the ground. !----------------------------------------------------------------------- ! DO L=1,LM ! ZDIFF=ABS(ZMEAN(L)-Z1) IF(ZDIFFPDYN_MIN(1,0:NUM_PES_FCST-1) !<-- Select only the PDYN values from the array ! ID_PE_MIN=MINLOC(PDYN_MIN_VALS,1)-1 !<-- ID of nest task with minimum value of PDYN ! SLP_MIN=PDYN_MIN(1,ID_PE_MIN) !<-- Minimum value of PDYN for all tasks I_CENTER_NEW=INT(PDYN_MIN(2,ID_PE_MIN)) !<-- I index of minimum PDYN on the nest domain J_CENTER_NEW=INT(PDYN_MIN(3,ID_PE_MIN)) !<-- J index of minimum PDYN on the nest domain ! I_DIFF=I_CENTER_NEW-I_CENTER_CURRENT !<-- Shift in I to potential new center J_DIFF=J_CENTER_NEW-J_CENTER_CURRENT !<-- Shift in J to potential new center ! !----------------------------------------------------------------------- !*** If the nest moves then its SW corner must shift from one parent !*** H point to another which means the I and J shifts must be in !*** integer multiples of SPACE_RATIO_MY_PARENT. Adjust I_DIFF and !*** J_DIFF given this constraint. !----------------------------------------------------------------------- ! IF(MOD(I_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN PARENT_DIFF=REAL(I_DIFF)/REAL(SPACE_RATIO_MY_PARENT) IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN I_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ELSE I_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ENDIF I_CENTER_NEW=I_CENTER_CURRENT+I_DIFF ENDIF ! IF(MOD(J_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN PARENT_DIFF=REAL(J_DIFF)/REAL(SPACE_RATIO_MY_PARENT) IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN J_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ELSE J_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT ENDIF J_CENTER_NEW=J_CENTER_CURRENT+J_DIFF ENDIF ! IF(ABS(I_DIFF)==0.AND.ABS(J_DIFF)==0)THEN IF(MYPE_DOM==0)THEN ! WRITE(0,*)' NO MOTION: Less than one parent grid increment.' ENDIF RETURN !<-- No motion so exit. ENDIF ! !----------------------------------------------------------------------- !*** Tasks learn if they contain any of the four cardinal direction !*** points to be used for the storm-gradient check. !----------------------------------------------------------------------- ! N_SEND=4 DO N=1,4 NO_VALUE(N)=.FALSE. !<-- Start with all cardinal directions having values inside ENDDO ! I_PG(1)=I_CENTER_NEW !<-- I coordinate of north pressure point J_PG(1)=J_CENTER_NEW+NPTS_NS !<-- J coordinate of north pressure point IF(I_PG(1)IDE.OR.J_PG(1)JDE)THEN NO_VALUE(1)=.TRUE. !<-- North point is outside nest domain N_SEND=N_SEND-1 ELSE CALL LOCATE_POINT_ON_TASKS(I_PG(1) & ,J_PG(1) & ,I_HOLD_PG_POINT(1)) !<-- Does this task subdomain contain north PG point? ENDIF ! I_PG(2)=I_CENTER_NEW !<-- I coordinate of south pressure point J_PG(2)=J_CENTER_NEW-NPTS_NS !<-- J coordinate of south pressure point IF(I_PG(2)IDE.OR.J_PG(2)JDE)THEN NO_VALUE(2)=.TRUE. !<-- South point is outside nest domain N_SEND=N_SEND-1 ELSE CALL LOCATE_POINT_ON_TASKS(I_PG(2) & ,J_PG(2) & ,I_HOLD_PG_POINT(2)) !<-- Does this task subdomain contain south PG point? ENDIF ! I_PG(3)=I_CENTER_NEW-NPTS_WE !<-- I coordinate of west pressure point J_PG(3)=J_CENTER_NEW !<-- J coordinate of west pressure point IF(I_PG(3)IDE.OR.J_PG(3)JDE)THEN NO_VALUE(3)=.TRUE. !<-- West point is outside nest domain N_SEND=N_SEND-1 ELSE CALL LOCATE_POINT_ON_TASKS(I_PG(3) & ,J_PG(3) & ,I_HOLD_PG_POINT(3)) !<-- Does this task subdomain contain west PG point? ENDIF ! I_PG(4)=I_CENTER_NEW+NPTS_WE !<-- I coordinate of east pressure point J_PG(4)=J_CENTER_NEW !<-- J coordinate of east pressure point IF(I_PG(4)IDE.OR.J_PG(4)JDE)THEN NO_VALUE(4)=.TRUE. !<-- East point is outside nest domain N_SEND=N_SEND-1 ELSE CALL LOCATE_POINT_ON_TASKS(I_PG(4) & ,J_PG(4) & ,I_HOLD_PG_POINT(4)) !<-- Does this task subdomain contain east PG point? ENDIF ! !----------------------------------------------------------------------- !*** Those tasks that hold the four points N, S, W, and E of the !*** new storm center send their pressure values to the task !*** whose subdomain contains the new storm center. !----------------------------------------------------------------------- ! IF(N_SEND>0)THEN DO N=1,4 !<-- The 4 cardinal direction points IF(NO_VALUE(N))CYCLE IF(I_HOLD_PG_POINT(N))THEN PVAL=SLP(I_PG(N),J_PG(N)) CALL MPI_ISSEND(PVAL & !<-- SLP at cardinal point N around storm center ,1 & !<-- It is one word ,MPI_REAL & !<-- Datatype ,ID_PE_MIN & !<-- ID of task holding the new storm center ,ITAG_PG & !<-- Tag used for exchange of pressure data for gradient ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,HANDLE_PVAL(N) & !<-- Communication request handle for task N's Recv ,IERR ) ENDIF ENDDO ELSE WRITE(0,*)' ALERT: Storm has moved more than DIST_GRAD beyond' & ,' moving nest boundary!' RETURN ENDIF ! !----------------------------------------------------------------------- !*** The task holding the new storm center saves the maximum !*** pressure among the four cardinal points then informs all !*** other tasks of that value. !----------------------------------------------------------------------- ! IF(MYPE_DOM==ID_PE_MIN)THEN PMAX=-100000. DO N=1,4 IF(NO_VALUE(N))CYCLE CALL MPI_RECV(PVAL_N & !<-- Pressure from cardinal point N ,1 & !<-- It is one word ,MPI_REAL & !<-- Datatype ,MPI_ANY_SOURCE & !<-- Does not know ID of the sending task ,ITAG_PG & !<-- Tag used for exchange of pressure data for gradient ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,JSTAT & !<-- MPI status ,IERR ) ! IF(PVAL_N>PMAX)THEN PMAX=PVAL_N !<-- Save the maximum pressure. ENDIF ! ENDDO ENDIF ! DO N=1,4 !<-- The 4 cardinal directions IF(NO_VALUE(N))CYCLE IF(I_HOLD_PG_POINT(N))THEN CALL MPI_WAIT(HANDLE_PVAL(N) & !<-- Proceed only after all Recvs have completed ,JSTAT & ,IERR ) ENDIF ENDDO ! IF(N_SEND>0)THEN CALL MPI_BCAST(PMAX & !<-- Max cardinal pressure around storm ,1 & !<-- It is one word ,MPI_REAL & !<-- Datatype ,ID_PE_MIN & !<-- The root sender ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks ,IERR ) IF(PMAX<50000.)PMAX=1000000. ELSE PMAX=1000000. ENDIF ! !----------------------------------------------------------------------- !*** Now that a new central pressure and its location have been !*** identified several conditions must be met before the move !*** can be allowed to execute. We have already made certain !*** that the nest domain's SW corner remains on a parent H point !*** if the shift is executed. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** (1) Did the vortex disappear? !----------------------------------------------------------------------- ! IF(PMAXDIST_LAND.AND.DIST_J>DIST_LAND)THEN IF(MYPE_DOM==0)THEN WRITE(0,*)' CANNOT MOVE: Vortex lost over land.' ENDIF RETURN ENDIF ! !----------------------------------------------------------------------- !*** (4) Is the vortex too weak over land? !----------------------------------------------------------------------- ! IF(FRAC_SEA<=0.2.AND.PMAX-SLP_MIN=ITS.AND.I_PG<=ITE.AND.J_PG>=JTS.AND.J_PG<=JTE)THEN I_HOLD_THIS_POINT=.TRUE. ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE LOCATE_POINT_ON_TASKS ! !----------------------------------------------------------------------- ! END SUBROUTINE COMPUTE_STORM_MOTION ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- SUBROUTINE SPLINE(NOLD,XOLD,YOLD,Y2,Y2_K,NNEW,XNEW,YNEW) !----------------------------------------------------------------------- ! ! ****************************************************************** ! * * ! * This is a one-dimensional cubic spline fitting routine * ! * programmed for a small scalar machine. * ! * * ! * Programmer: Z. Janjic, Yugoslav Fed. Hydromet. Inst., Beograd * ! * * ! * NOLD - Number of given values of the function. Must be >= 3. * ! * XOLD - Locations of the points at which the values of the * ! * function are given. Must be in ascending order. * ! * YOLD - The given values of the function at the points XOLD. * ! * Y2 - The second derivatives at the points XOLD. If natural * ! * spline is fitted Y2(1)=0 and Y2(nold)=0. Must be * ! * specified. * ! * Y2_K - Vertical dimension of Y2 array. * ! * NNEW - Number of values of the function to be calculated. * ! * XNEW - Locations of the points at which the values of the * ! * function are calculated. XNEW(K) must be >= XOLD(1) * ! * and <= XOLD(NOLD). * ! * YNEW - The values of the function to be calculated. * ! * * ! ****************************************************************** ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: NNEW,NOLD,Y2_K ! REAL(kind=KFPT),DIMENSION(1:NOLD),INTENT(IN) :: XOLD,YOLD REAL(kind=KFPT),DIMENSION(1:NNEW),INTENT(IN) :: XNEW ! REAL(kind=KFPT),DIMENSION(1:Y2_K),INTENT(INOUT) :: Y2 ! REAL(kind=KFPT),DIMENSION(1:NNEW),INTENT(OUT) :: YNEW ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: K,K1,K2,KOLD,NOLDM1 ! REAL(kind=KFPT) :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR & ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1 ! REAL(kind=KFPT),DIMENSION(1:NOLD-2) :: P,Q ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! NOLDM1=NOLD-1 ! DXL=XOLD(2)-XOLD(1) DXR=XOLD(3)-XOLD(2) DYDXL=(YOLD(2)-YOLD(1))/DXL DYDXR=(YOLD(3)-YOLD(2))/DXR RTDXC=0.5/(DXL+DXR) ! P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) Q(1)=-RTDXC*DXR ! IF(NOLD==3) GO TO 700 ! !----------------------------------------------------------------------- ! K=3 ! 100 CONTINUE DXL=DXR DYDXL=DYDXR DXR=XOLD(K+1)-XOLD(K) DYDXR=(YOLD(K+1)-YOLD(K))/DXR DXC=DXL+DXR DEN=1./(DXL*Q(K-2)+DXC+DXC) ! P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) Q(K-1)=-DEN*DXR ! K=K+1 IF(K1) GO TO 200 ! !----------------------------------------------------------------------- ! K1=1 ! 300 CONTINUE XK=XNEW(K1) ! DO 400 K2=2,NOLD IF(XOLD(K2)<=XK) GO TO 400 KOLD=K2-1 GO TO 450 400 CONTINUE ! YNEW(K1)=YOLD(NOLD) GO TO 600 ! 450 CONTINUE IF(K1==1) GO TO 500 IF(K==KOLD) GO TO 550 ! 500 CONTINUE K=KOLD ! Y2K=Y2(K) Y2KP1=Y2(K+1) DX=XOLD(K+1)-XOLD(K) RDX=1./DX ! AK=0.1666667*RDX*(Y2KP1-Y2K) BK=0.5*Y2K CK=RDX*(YOLD(K+1)-YOLD(K))-0.1666667*DX*(Y2KP1+Y2K+Y2K) ! 550 CONTINUE X=XK-XOLD(K) XSQ=X*X ! YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) ! 600 CONTINUE K1=K1+1 ! IF(K1<=NNEW) GO TO 300 ! !----------------------------------------------------------------------- ! END SUBROUTINE SPLINE ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine artificial_move(ntimestep & ,kount_moves & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,kount_moves & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. ! write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves if(ntimestep>0.and.mod(ntimestep,51)==0)then i_want_to_move=.true. write(0,*)' artificial set i_want_to_move=',i_want_to_move if(mod(kount_moves,16)<= 1)then !<-- NW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NW' elseif(mod(kount_moves,16)<= 3)then !<-- N i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to N' elseif(mod(kount_moves,16)<= 5)then !<-- NE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NE' elseif(mod(kount_moves,16)<= 7)then !<-- E i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to E' elseif(mod(kount_moves,16)<= 9)then !<-- SE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SE' elseif(mod(kount_moves,16)<=11)then !<-- S i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to S' elseif(mod(kount_moves,16)<=13)then !<-- SW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW' elseif(mod(kount_moves,16)<=15)then !<-- W i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to W' endif endif write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & ,' i_want_to_move=',i_want_to_move ! !----------------------------------------------------------------------- end subroutine artificial_move !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine artificial_move2(ntimestep & ,kount_moves & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,kount_moves & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! integer(kind=kint) :: mod_km ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. ! write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves !!! if(ntimestep>3.and.mod(ntimestep,14)<=2)then if(ntimestep>0.and.mod(ntimestep+3,51)==0)then i_want_to_move=.true. write(0,*)' artificial set i_want_to_move=',i_want_to_move mod_km=mod(kount_moves,16) if(mod_km<=01)then !<-- E i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to E mod_km=',mod_km elseif(mod_km<=03)then !<-- NE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NE mod_km=',mod_km elseif(mod_km<=05)then !<-- N i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to N mod_km=',mod_km elseif(mod_km<=07)then !<-- NW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NW mod_km=',mod_km elseif(mod_km<=09)then !<-- W i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to W mod_km=',mod_km elseif(mod_km<=11)then !<-- SW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW mod_km=',mod_km elseif(mod_km<=13)then !<-- S i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to S mod_km=',mod_km elseif(mod_km<=15)then !<-- SE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SE mod_km=',mod_km endif endif write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep+3,51) & ,' i_want_to_move=',i_want_to_move ! !----------------------------------------------------------------------- end subroutine artificial_move2 !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine artificial_move3(ntimestep & ,kount_moves & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,kount_moves & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! integer(kind=kint) :: mod_km ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. ! write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves !!! if(ntimestep>3.and.mod(ntimestep,14)<=2)then if(ntimestep>0.and.mod(ntimestep+3,51)==0)then i_want_to_move=.true. write(0,*)' artificial set i_want_to_move=',i_want_to_move mod_km=mod(kount_moves,16) if(mod_km<=01)then !<-- NW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NW mod_km=',mod_km elseif(mod_km<=03)then !<-- N i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to N mod_km=',mod_km elseif(mod_km<=05)then !<-- NE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NE mod_km=',mod_km elseif(mod_km<=07)then !<-- E i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to E mod_km=',mod_km elseif(mod_km<=09)then !<-- SE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SE mod_km=',mod_km elseif(mod_km<=11)then !<-- S i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to S mod_km=',mod_km elseif(mod_km<=13)then !<-- SW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW mod_km=',mod_km elseif(mod_km<=15)then !<-- W i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to W mod_km=',mod_km endif endif write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep+3,51) & ,' i_want_to_move=',i_want_to_move ! !----------------------------------------------------------------------- end subroutine artificial_move3 !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine artificial_move4(ntimestep & ,kount_moves & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,kount_moves & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. ! write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves if(ntimestep>3.and.mod(ntimestep,14)<=2)then i_want_to_move=.true. write(0,*)' artificial set i_want_to_move=',i_want_to_move if(mod(kount_moves,45)<=5)then !<-- E i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to NW' elseif(mod(kount_moves,45)<=11)then !<-- NE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to N' elseif(mod(kount_moves,45)<=16)then !<-- N i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NE' elseif(mod(kount_moves,45)<=22)then !<-- NW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to E' elseif(mod(kount_moves,45)<=27)then !<-- W i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to SE' elseif(mod(kount_moves,45)<=33)then !<-- SW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to S' elseif(mod(kount_moves,45)<=38)then !<-- S i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW' elseif(mod(kount_moves,45)<=44)then !<-- SW i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to W' endif endif write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & ,' i_want_to_move=',i_want_to_move ! !----------------------------------------------------------------------- end subroutine artificial_move4 !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine artificial_move5(ntimestep & ,kount_moves & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,kount_moves & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. ! write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves if(ntimestep>3.and.mod(ntimestep,15)==0)then i_want_to_move=.true. write(0,*)' artificial set i_want_to_move=',i_want_to_move if(mod(kount_moves,40)<5)then !<-- E i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to E',kount_moves elseif(mod(kount_moves,40)<10)then !<-- NE i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NE',kount_moves elseif(mod(kount_moves,40)<15)then !<-- N i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to N',kount_moves elseif(mod(kount_moves,40)<20)then !<-- NW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current+1 write(0,*)' artificial to NW',kount_moves elseif(mod(kount_moves,40)<25)then !<-- W i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current write(0,*)' artificial to W',kount_moves elseif(mod(kount_moves,40)<30)then !<-- SW i_sw_parent_new=i_sw_parent_current-1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW',kount_moves elseif(mod(kount_moves,40)<35)then !<-- S i_sw_parent_new=i_sw_parent_current j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to S',kount_moves elseif(mod(kount_moves,40)<40)then !<-- SW i_sw_parent_new=i_sw_parent_current+1 j_sw_parent_new=j_sw_parent_current-1 write(0,*)' artificial to SW',kount_moves endif endif write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & ,' i_want_to_move=',i_want_to_move ! !----------------------------------------------------------------------- end subroutine artificial_move5 !----------------------------------------------------------------------- ! ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! subroutine prescribed_move(ntimestep,dt & ,i_want_to_move & ,i_sw_parent_current & ,j_sw_parent_current & ,i_sw_parent_new & ,j_sw_parent_new ) ! !----------------------------------------------------------------------- ! real(KIND=kfpt),intent(in) :: dt ! integer(kind=kint),intent(in) :: i_sw_parent_current & ,j_sw_parent_current & ,ntimestep ! integer(kind=kint),intent(out) :: i_sw_parent_new & ,j_sw_parent_new ! logical(kind=klog),intent(out) :: i_want_to_move ! integer, save :: kount_moves = 1 integer :: nsteps_move !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! i_want_to_move=.false. i_sw_parent_new = 0 j_sw_parent_new = 0 nsteps_move = MOVE_INTERVAL_MINUTES*60/DT if ( ntimestep>0 .and. mod(ntimestep,nsteps_move)<3 ) then kount_moves=kount_moves+1 if (kount_moves > size(MOVE_I_SW) ) return write(0,"(A,4I6)")' WILL_MOVE_NOW ',ntimestep,kount_moves, & MOVE_I_SW(kount_moves),MOVE_J_SW(kount_moves) i_want_to_move=.true. i_sw_parent_new = MOVE_I_SW(kount_moves) j_sw_parent_new = MOVE_J_SW(kount_moves) end if ! !----------------------------------------------------------------------- end subroutine prescribed_move !----------------------------------------------------------------------- ! END MODULE MODULE_PARENT_CHILD_CPL_COMP ! !-----------------------------------------------------------------------