!----------------------------------------------------------------------- ! MODULE MODULE_NESTING ! !----------------------------------------------------------------------- ! !*** This module contains routines that perform various interactions !*** between parent domains and their children. ! !----------------------------------------------------------------------- ! ! PROGRAM HISTORY LOG: ! ! 2008-02-07 Black - PARENT_TO_CHILD_FILL ! 2008-03-05 Black - PARENT_CHILD_SPLIT ! 2008-03-25 Black - PARENT_TO_CHILD_INIT_NMM ! 2008-04-22 Black - Replace PARENT_CHILD_SPLIT with _COMMS ! 2008-06-18 Black - PARENT_TO_CHILD_COMPUTE ! 2008-06-18 Black - PREPARE_PARENT_TO_CHILD_INTERP ! 2008-08-14 Black - Added BOUNDARY_DATA_STATE_TO_STATE ! 2009-03-12 Black - Added Z0BASE and STDH now needed for NPS. ! 2009-10-12 Black - Fix for generalized of parent-child space ratios. ! 2010-03-31 Black - Add parent computation of child boundary topo. ! 2011-05-17 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. ! 2011-07-16 Black - Moving nest capability. ! 2012-07-20 Black - Generational use of MPI tasks. ! !----------------------------------------------------------------------- ! ! USAGE: ! !----------------------------------------------------------------------- ! USE MPI USE ESMF USE netcdf ! USE module_KINDS ! USE module_DERIVED_TYPES,ONLY: BNDS_2D & ,CHILD_UPDATE_LINK & ,COMMS_FAMILY & ,DOMAIN_DATA & ,INTEGER_DATA & ,INTERIOR_DATA_FROM_PARENT & ,MIXED_DATA_TASKS & ,REAL_DATA_2D ! USE module_VARS,ONLY: VAR ! USE module_LS_NOAHLSM,ONLY: NUM_SOIL_LAYERS ! USE module_CONSTANTS,ONLY: P608,R_D ! USE module_CONTROL,ONLY: NUM_DOMAINS_MAX,TIMEF ! USE module_EXCHANGE,ONLY: HALO_EXCH ! USE module_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK ! !----------------------------------------------------------------------- ! IMPLICIT NONE ! !----------------------------------------------------------------------- ! PRIVATE ! PUBLIC :: BOUNDARY_DATA_STATE_TO_STATE & ,CHECK & ,CHECK_REAL & ,CHILD_2WAY_BOOKKEEPING & ,CHILD_RANKS & ,GENERATE_2WAY_DATA & ,HYPERBOLA & ,INTERNAL_DATA_TO_DOMAIN & ,INTERIOR_DATA_STATE_TO_STATE & ,LAG_STEPS & ,LATLON_TO_IJ & ,MOVING_NEST_BOOKKEEPING & ,MOVING_NEST_RECV_DATA & ,PARENT_2WAY_BOOKKEEPING & ,PARENT_BOOKKEEPING_MOVING & ,PARENT_CHILD_COMMS & ,PARENT_READS_MOVING_CHILD_TOPO & ,PARENT_TO_CHILD_INIT_NMM & ,PARENT_UPDATES_HALOS & ,PARENT_UPDATES_MOVING & ,READ_NETCDF_LATLON & ,REAL_IJ_TO_LATLON & ,SET_NEST_GRIDS & ,STENCIL_H_EVEN,STENCIL_SFC_H_EVEN & ,STENCIL_V_EVEN,STENCIL_SFC_V_EVEN & ,STENCIL_H_ODD,STENCIL_SFC_H_ODD & ,STENCIL_V_ODD,STENCIL_SFC_V_ODD & ,SUFFIX_MOVE & ,SUFFIX_NESTBC & ,SUFFIX_TWOWAY ! !----------------------------------------------------------------------- ! INTEGER(kind=KINT),PARAMETER :: NEAREST=0 & !<-- Flag for nearest neighbor interpolation (parent to child) ,BILINEAR=1 !<-- Flag for bilinear interpolation (parent to child) ! INTEGER(kind=KINT),SAVE :: LM,N8=8 ! INTEGER(kind=KINT),SAVE :: LAG_STEPS=4 !<-- Nest moves this many parent timesteps after deciding ! INTEGER(kind=KINT),SAVE :: STENCIL_H_EVEN=3 & ,STENCIL_V_EVEN=2 & ,STENCIL_SFC_H_EVEN=3 & ,STENCIL_SFC_V_EVEN=3 & ,STENCIL_H_ODD=3 & ,STENCIL_V_ODD=3 & ,STENCIL_SFC_H_ODD=3 & ,STENCIL_SFC_V_ODD=2 ! REAL(kind=KFPT),SAVE :: CHILD_PARENT_SPACE_RATIO & ,EPS=1.E-4 ! CHARACTER(len=5) :: SUFFIX_MOVE='-move' CHARACTER(len=5) :: SUFFIX_TWOWAY='-2way' CHARACTER(len=7) :: SUFFIX_NESTBC='-nestbc' ! !----------------------------------------------------------------------- ! REAL(kind=KDBL) :: btim,btim0 ! TYPE(CHILD_UPDATE_LINK),POINTER,SAVE :: TAIL ! TYPE(DOMAIN_DATA),DIMENSION(:),POINTER,SAVE :: CHILD_RANKS !<-- Lists of child tasks' local ranks in p-c intracomms ! integer(kind=kint) :: iprt=01,jprt=61 !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_CHILD_COMMS(MYPE & ,NUM_DOMAINS_TOTAL & ,NUM_TASKS_TOTAL & ,COMM_WORLD & ,RANK_TO_DOMAIN_ID & ,CF & ,TASK_MODE & ,QUILTING & ,DOMAIN_GEN & ,FULL_GEN & ,MY_DOMAIN_ID_N & ,ID_DOMAINS & ,ID_PARENTS & ,NUM_CHILDREN & ,ID_CHILDREN & ,COMMS_DOMAIN & ,FTASKS_DOMAIN & ,NTASKS_DOMAIN & ,PETLIST_DOM & ,NUM_GENS & ) ! !----------------------------------------------------------------------- !*** Create MPI intracommunicators between the tasks of a parent domain !*** and those of all its 1st generation nests (children). !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: COMM_WORLD & !<-- MPI intracommunicator for ALL tasks ,FULL_GEN & !<-- For 2-way nesting, the generation using all tasks ,MYPE & !<-- My task ID (global) ,NUM_DOMAINS_TOTAL & !<-- Total number of domains ,NUM_TASKS_TOTAL !<-- Total number of tasks in the run ! INTEGER(kind=KINT),DIMENSION(*),INTENT(IN) :: DOMAIN_GEN & !<-- For 2-way nesting, each domain's generation ,RANK_TO_DOMAIN_ID !<-- Domain ID for each configure file ! CHARACTER(len=12),INTENT(IN) :: TASK_MODE !<-- Unique or generational task assignment ! LOGICAL(kind=KLOG),INTENT(IN) :: QUILTING !<-- Was quilting specified in the configure files? ! TYPE(ESMF_Config),DIMENSION(*),INTENT(INOUT) :: CF !<-- The config objects (one per domain) ! INTEGER(kind=KINT),INTENT(OUT) :: NUM_GENS !<-- The # of generations of domains ! INTEGER(kind=KINT),DIMENSION(:,:),POINTER,INTENT(OUT) :: ID_CHILDREN & !<-- Domain IDs of all domains' children ,PETLIST_DOM !<-- List of task IDs on each domain ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(OUT) :: ID_DOMAINS & !<-- Array of the domain IDs ,ID_PARENTS & !<-- Array of the domains' parent IDs ,FTASKS_DOMAIN & !<-- # of forecast tasks on each domain ,MY_DOMAIN_ID_N & !<-- IDs of the domains on which current task resides ,NTASKS_DOMAIN & !<-- # of tasks on each domain excluding descendents ,NUM_CHILDREN !<-- # of children on each domain ! TYPE(COMMS_FAMILY),DIMENSION(:),POINTER,INTENT(OUT) :: COMMS_DOMAIN !<-- Intracommunicators between parent and child domains ! and between each domains' forecast tasks. ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,IERR,ISTAT & ,N,N1,N2,N3,NN,RC ! INTEGER(kind=KINT) :: COMM_INTRA & ,GROUP_UNION & ,GROUP_WORLD & ,ID_CHILD & ,ID_DOM & ,ID_FULL & ,ID_PARENT & ,INPES & ,JNPES & ,KOUNT & ,KOUNT_DOMS & ,KOUNT_TASKS & ,LAST_FCST_TASK_X & ,LAST_WRITE_TASK_X & ,LEAD_REMOTE & ,N_CHILDREN & ,N_GEN & ,NDOMS_FULL & ,NMAX & ,NSAVE & ,NTASKS_CONTRIB & ,NTASKS_PARENT & ,NTASKS_X & ,NUM_FCST_TASKS & ,NUM_TASKS_FULL & ,NUM_WRITE_TASKS & ,RC_COMMS & ,TASK_X & ,WRITE_GROUPS & ,WRITE_TASKS_PER_GROUP ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: DOMS_PER_GEN & !<-- Domain count per generation ,DOMS_FULL & !<-- IDs of domains in the full generation ,GLOBAL_UNION & !<-- Union of parent and child tasks in intracomms ,GROUP & !<-- MPI group for each domain ,KOUNT_FULL & !<-- 1st task on each domain of the full generation ,LAST_FCST_TASK & !<-- ID of last forecast task on each domain ,LAST_WRITE_TASK & !<-- ID of last write task on each domain ,LAST_TASK & !<-- ID of last task on each domain ,LEAD_FCST_TASK & !<-- ID of first task on each domain ,LEAD_WRITE_TASK & !<-- ID of first write on each domain ,LEAD_TASK & !<-- ID of first task on each domain ,WTASKS_DOMAIN !<-- # of write/quilt tasks on each domain ! REAL(kind=KFPT) :: RECIP_NUM_TASKS_FULL ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: FRAC_FULL !<-- Fraction of tasks on each domain in full generation ! CHARACTER(2) :: NUM_DOMAIN CHARACTER(6),SAVE :: FMT='(I2.2)' ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC_COMMS=ESMF_SUCCESS ! !----------------------------------------------------------------------- ! ALLOCATE(ID_DOMAINS (1:NUM_DOMAINS_TOTAL)) ALLOCATE(ID_PARENTS (1:NUM_DOMAINS_TOTAL)) ALLOCATE(LEAD_TASK (1:NUM_DOMAINS_TOTAL)) ALLOCATE(LAST_TASK (1:NUM_DOMAINS_TOTAL)) ALLOCATE(FTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) ALLOCATE(WTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) ALLOCATE(NTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) ALLOCATE(NUM_CHILDREN (1:NUM_DOMAINS_TOTAL)) ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- !*** Incoming tasks extract relevant information from all config files. ! !*** This loop is general thus the domain IDs do not need to correspond !*** to the number in the configure file name. The user may assign !*** IDs monotonically to the domains starting with 1 and in any order !*** desired except that the uppermost parent must have an ID of 1. !*** However the rank/element of each domain in the CF array is equal !*** to the given domain's ID. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! read_configs: DO N=1,NUM_DOMAINS_TOTAL !<-- Loop through all configure objects ! !----------------------------------------------------------------------- !*** Save the domain IDs. !*** These are simply integers each domain will use to keep track !*** of itself with respect to others. !----------------------------------------------------------------------- ! ID_DOMAINS(N)=RANK_TO_DOMAIN_ID(N) ID_DOM=ID_DOMAINS(N) ! !----------------------------------------------------------------------- !*** Who is the parent of each domain? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract ID of Parent of this Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =ID_PARENTS(ID_DOM) & !<-- The ID of the parent of this domain ,label ='my_parent_id:' & !<-- Take values from this config label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !----------------------------------------------------------------------- !*** How many children does each domain have? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract # of Children of this Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =NUM_CHILDREN(ID_DOM) & !<-- # of children on this domain ,label ='n_children:' & !<-- Take value from this config label ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** How many Forecast/Write tasks will be active on each domain? !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent_Child_Comms: Extract INPES From Config File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =INPES & !<-- The domain's fcst tasks in I ,label ='inpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent_Child_Comms: Extract JNPES From Config File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =JNPES & !<-- The domain's fcst tasks in J ,label ='jnpes:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent_Child_Comms: Extract Write_Groups From Config File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =WRITE_GROUPS & !<-- The number of Write groups on this domain ,label ='write_groups:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Parent_Child_Comms: Extract Write_Task_Per_Group From Config File" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object ,value =WRITE_TASKS_PER_GROUP & !<-- The number of tasks per Write group ,label ='write_tasks_per_group:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! IF(.NOT.QUILTING)THEN WRITE_GROUPS=0 WRITE_TASKS_PER_GROUP=0 ENDIF ! !----------------------------------------------------------------------- ! FTASKS_DOMAIN(ID_DOM)=INPES*JNPES !<-- # of compute/forecast tasks on domain ID_DOM ! WTASKS_DOMAIN(ID_DOM)=WRITE_GROUPS*WRITE_TASKS_PER_GROUP !<-- # of write/quilt tasks on domain ID_DOM ! NTASKS_DOMAIN(ID_DOM)=FTASKS_DOMAIN(ID_DOM) & !<-- Total # of tasks on each domain +WTASKS_DOMAIN(ID_DOM) ! !----------------------------------------------------------------------- ! ENDDO read_configs ! ALLOCATE(PETLIST_DOM(1:NUM_TASKS_TOTAL,1:NUM_DOMAINS_TOTAL)) ! !----------------------------------------------------------------------- !*** Assign tasks to all domains. !*** For 1-way nesting each task is uniquely assigned to a single !*** domain. For 2-way nesting each forecast task can be assigned !*** to more than one domain but cannot lie on more than one domain !*** in each generation. The write/quilt tasks in 2-way nesting !*** must be assigned uniquely to a single domain and they cannot !*** also be forecast tasks or else the asynchronous writing of !*** the history/restart files would not always be independent of !*** the forecast integration. !----------------------------------------------------------------------- ! ALLOCATE(MY_DOMAIN_ID_N(1:NUM_DOMAINS_TOTAL),stat=ISTAT) ! DO N=1,NUM_DOMAINS_TOTAL MY_DOMAIN_ID_N(N)=0 ENDDO ! IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate MY_DOMAIN_ID_N rc=',ISTAT ENDIF ! !----------------------------------------------------------------------- ! task_assign: IF(TASK_MODE=='unique')THEN ! !----------------------------------------------------------------------- ! DO N=1,NUM_DOMAINS_TOTAL ! ID_DOM=RANK_TO_DOMAIN_ID(N) ! !----------------------------------------------------------------------- !*** Determine the global IDs of the lead and last tasks on each !*** domain which in turn lets us fill the PETLIST for each domain. !*** These include the I/O tasks. !----------------------------------------------------------------------- ! IF(N==1)THEN LEAD_TASK(N)=0 !<-- Task 0 is first in line ELSE LEAD_TASK(ID_DOM)=LAST_TASK(ID_DOMAINS(N-1))+1 !<-- Lead task on domain follows last task on previous domain ENDIF ! LAST_TASK(ID_DOM)=LEAD_TASK(ID_DOM)+NTASKS_DOMAIN(ID_DOM)-1 !<-- The last task on each domain ! IF(MYPE>=LEAD_TASK(ID_DOM).AND.MYPE<=LAST_TASK(ID_DOM))THEN !<-- Associate tasks with each domain MY_DOMAIN_ID_N(1)=ID_DOM !<-- Tell this task the ID of the single domain it is on ENDIF ! KOUNT_TASKS=0 DO N2=LEAD_TASK(ID_DOM),LAST_TASK(ID_DOM) KOUNT_TASKS=KOUNT_TASKS+1 PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 ENDDO ! ENDDO ! NUM_GENS=1 !<-- This is a dummy value; only relevant for 2-way ! !----------------------------------------------------------------------- ! ELSEIF(TASK_MODE=='generational')THEN ! !----------------------------------------------------------------------- !*** First determine how many domains are in each generation. !----------------------------------------------------------------------- ! NUM_GENS=0 NUM_WRITE_TASKS=0 ! ALLOCATE(DOMS_PER_GEN(1:NUM_DOMAINS_TOTAL)) ! DO N=1,NUM_DOMAINS_TOTAL DOMS_PER_GEN(N)=0 ENDDO ! DO N=1,NUM_DOMAINS_TOTAL ID_DOM=RANK_TO_DOMAIN_ID(N) N_GEN=DOMAIN_GEN(ID_DOM) !<-- The generation that domain ID_DOM is in IF(N_GEN>NUM_GENS)NUM_GENS=N_GEN !<-- Determining the # of generations DOMS_PER_GEN(N_GEN)=DOMS_PER_GEN(N_GEN)+1 !<-- Determining the # of domains per generation NUM_WRITE_TASKS=NUM_WRITE_TASKS+WTASKS_DOMAIN(ID_DOM) !<-- Sum write tasks for all domains ENDDO ! !----------------------------------------------------------------------- !*** Assign all the run's forecast tasks across the first generation !*** that uses all of them. This is the first 'full' generation. !----------------------------------------------------------------------- ! ALLOCATE(LEAD_FCST_TASK(1:NUM_DOMAINS_TOTAL)) ALLOCATE(LAST_FCST_TASK(1:NUM_DOMAINS_TOTAL)) ALLOCATE(LEAD_WRITE_TASK(1:NUM_DOMAINS_TOTAL)) ALLOCATE(LAST_WRITE_TASK(1:NUM_DOMAINS_TOTAL)) ! KOUNT_DOMS=0 ! NUM_FCST_TASKS=NUM_TASKS_TOTAL-NUM_WRITE_TASKS !<-- Total # of forecast tasks available ! DO N=1,NUM_DOMAINS_TOTAL ! ID_DOM=RANK_TO_DOMAIN_ID(N) ! IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE !<-- Only interested in the domains of the 'full' generation KOUNT_DOMS=KOUNT_DOMS+1 !<-- Counting domains in the 'full' generation ! IF(KOUNT_DOMS==1)THEN LEAD_FCST_TASK(ID_DOM)=0 !<-- Task 0 is first in line LEAD_WRITE_TASK(ID_DOM)=NUM_FCST_TASKS !<-- 1st write task follows the last forecast task ELSE LEAD_FCST_TASK(ID_DOM)=LAST_FCST_TASK_X+1 !<-- Lead fcst task on domain follows last on previous domain LEAD_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X+1 !<-- Lead write task on domain follows last on previous domain ENDIF ! LAST_FCST_TASK_X=LEAD_FCST_TASK(ID_DOM)+FTASKS_DOMAIN(ID_DOM)-1 LAST_FCST_TASK(ID_DOM)=LAST_FCST_TASK_X !<-- The last forecast task on this domain ! LAST_WRITE_TASK_X=LEAD_WRITE_TASK(ID_DOM)+WTASKS_DOMAIN(ID_DOM)-1 LAST_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X !<-- The last write task on this domain ! IF(MYPE>=LEAD_FCST_TASK(ID_DOM) & !<-- .AND. & ! MYPE<=LAST_FCST_TASK(ID_DOM) & ! Associate tasks with each domain. .OR. & ! Write tasks can be tied to only one domain. MYPE>=LEAD_WRITE_TASK(ID_DOM) & ! .AND. & ! MYPE<=LAST_WRITE_TASK(ID_DOM))THEN !<--- ! MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This task collects its domain ID in this generation. ENDIF ! KOUNT_TASKS=0 DO N2=LEAD_FCST_TASK(ID_DOM),LAST_FCST_TASK(ID_DOM) !<-- Loop through this domain's fcst tasks. KOUNT_TASKS=KOUNT_TASKS+1 PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert this fcst task into the domain's task list. ENDDO ! DO N2=LEAD_WRITE_TASK(ID_DOM),LAST_WRITE_TASK(ID_DOM) !<-- Loop through this domain's quilt/write tasks. KOUNT_TASKS=KOUNT_TASKS+1 PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert this write task into the domain's task list. ENDDO ! ENDDO ! !----------------------------------------------------------------------- !*** Now assign the tasks on all the domains in the remaining !*** generations. In order to balance the work load as evenly !*** as possible the domains in each of these generations will !*** take their tasks equally from each of the domains in the !*** full generation. !----------------------------------------------------------------------- ! NDOMS_FULL=DOMS_PER_GEN(FULL_GEN) !<-- # of domains in 1st full generation ! ALLOCATE(DOMS_FULL(1:NDOMS_FULL)) ALLOCATE(FRAC_FULL(1:NDOMS_FULL)) ALLOCATE(KOUNT_FULL(1:NDOMS_FULL)) ! DO N=1,NDOMS_FULL FRAC_FULL(N)=0. KOUNT_FULL(N)=-1 ENDDO ! !----------------------------------------------------------------------- ! NUM_TASKS_FULL=0 DO N=1,NUM_DOMAINS_TOTAL ID_DOM=RANK_TO_DOMAIN_ID(N) !<-- Domain #N's domain ID (selected by the user) IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE NUM_TASKS_FULL=NUM_TASKS_FULL+FTASKS_DOMAIN(ID_DOM) !<-- Add up the # of compute tasks in the full generation. ENDDO ! RECIP_NUM_TASKS_FULL=1./REAL(NUM_TASKS_FULL) KOUNT=0 ! DO N=1,NUM_DOMAINS_TOTAL ID_DOM=RANK_TO_DOMAIN_ID(N) IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE !<-- Consider only the first full generation ! KOUNT=KOUNT+1 DOMS_FULL(KOUNT)=ID_DOM !<-- IDs of domains in the full generation FRAC_FULL(KOUNT)=FTASKS_DOMAIN(ID_DOM)*RECIP_NUM_TASKS_FULL !<-- Fraction of all tasks on each domain in full generation KOUNT_FULL(KOUNT)=PETLIST_DOM(1,ID_DOM) !<-- 1st task on each domain of the full generation ENDDO ! !----------------------------------------------------------------------- !*** In each of the remaining generations fill the domain's compute !*** tasks proportionately with tasks from each domain in the full !*** generation in order to spread the work load evenly. !----------------------------------------------------------------------- ! gens_loop: DO N=1,NUM_GENS !<-- Loop through the generations ! dom_loop: DO N1=1,NUM_DOMAINS_TOTAL ! ID_DOM=RANK_TO_DOMAIN_ID(N1) !<-- Domain ID of domain #N1 IF(DOMAIN_GEN(ID_DOM)/=N.OR.DOMAIN_GEN(ID_DOM)==FULL_GEN)THEN !<-- Consider domains in gen #N and not in the full generation CYCLE dom_loop ENDIF ! !----------------------------------------------------------------------- !*** First assign the write/quilt tasks since they are totally !*** separate from the fcst/compute tasks and are always assigned !*** monotonically. !----------------------------------------------------------------------- ! LEAD_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X+1 !<-- Lead write task on domain follows last on previous domain LAST_WRITE_TASK(ID_DOM)=LEAD_WRITE_TASK(ID_DOM) & !<-- Last write task on this domain +WTASKS_DOMAIN(ID_DOM)-1 KOUNT_TASKS=FTASKS_DOMAIN(ID_DOM) !<-- Write/quilt tasks follow the compute tasks in the PETList ! DO N2=LEAD_WRITE_TASK(ID_DOM),LAST_WRITE_TASK(ID_DOM) KOUNT_TASKS=KOUNT_TASKS+1 PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert write task into domain's task list IF(MYPE==PETLIST_DOM(KOUNT_TASKS,ID_DOM))THEN MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This write task collects its domain ID in this generation. ENDIF ENDDO LAST_WRITE_TASK_X=LAST_WRITE_TASK(ID_DOM) ! !----------------------------------------------------------------------- !*** Now proceed with the assignment of forecast/compute tasks. !----------------------------------------------------------------------- ! KOUNT_TASKS=0 DO N2=1,NDOMS_FULL !<-- Loop through the domains in the full generation. ID_FULL=DOMS_FULL(N2) !<-- ID of domain #N2 in full generation NTASKS_CONTRIB=NINT(FRAC_FULL(N2)*FTASKS_DOMAIN(ID_DOM)) !<-- # of tasks contributed by domain #N2 in full generation ! DO N3=1,NTASKS_CONTRIB !<-- Apply the contributed tasks to domain ID_DOM. KOUNT_TASKS=KOUNT_TASKS+1 PETLIST_DOM(KOUNT_TASKS,ID_DOM)=KOUNT_FULL(N2) !<-- Add this fcst task to this domain's task list. IF(MYPE==PETLIST_DOM(KOUNT_TASKS,ID_DOM))THEN MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This fcst task collects its domain ID in this generation. ENDIF ! KOUNT_FULL(N2)=KOUNT_FULL(N2)+1 IF(KOUNT_FULL(N2)>PETLIST_DOM(FTASKS_DOMAIN(ID_FULL),ID_FULL))THEN KOUNT_FULL(N2)=PETLIST_DOM(1,ID_FULL) !<-- Cycle around contributed tasks from domain ID_FULL. ENDIF ! IF(KOUNT_TASKS==FTASKS_DOMAIN(ID_DOM))THEN !<-- If so, domain ID_DOM has filled its compute tasks. LEAD_FCST_TASK(ID_DOM)=PETLIST_DOM(1,ID_DOM) !<-- Save identity of this domain's lead compute task. LAST_FCST_TASK(ID_DOM)=PETLIST_DOM(KOUNT_TASKS,ID_DOM) !<-- Save identity of this domain's last compute task. CYCLE dom_loop ENDIF ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** If we reach this point then all of domain ID_DOM's compute tasks !*** still have not been assigned. This is simply due to fractional !*** roundoff in computing the number of tasks contributed by each !*** of the domains in the full generation. Finish assigning this !*** domain's tasks by taking them from the first domain in the full !*** generation. !----------------------------------------------------------------------- ! ID_FULL=DOMS_FULL(1) !<-- Take the tasks from the 1st domain in the full generation. ! DO N2=KOUNT_TASKS+1,FTASKS_DOMAIN(ID_DOM) PETLIST_DOM(N2,ID_DOM)=KOUNT_FULL(1) !<-- Add remaining fcst tasks to this domain's task list. IF(MYPE==PETLIST_DOM(N2,ID_DOM))THEN MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This fcst task collects its domain ID in this generation. ENDIF ! KOUNT_FULL(1)=KOUNT_FULL(1)+1 IF(KOUNT_FULL(1)>PETLIST_DOM(FTASKS_DOMAIN(ID_FULL),ID_FULL))THEN KOUNT_FULL(1)=PETLIST_DOM(1,ID_FULL) !<-- Cycle around contributed tasks from domain ID_FULL. ENDIF ENDDO ! LEAD_FCST_TASK(ID_DOM)=PETLIST_DOM(1,ID_DOM) !<-- Save identity of this domain's lead compute task. LAST_FCST_TASK(ID_DOM)=PETLIST_DOM(FTASKS_DOMAIN(ID_DOM),ID_DOM) !<-- Save identity of this domain's last compute task. ! !----------------------------------------------------------------------- ! ENDDO dom_loop ! ENDDO gens_loop ! DEALLOCATE(DOMS_FULL) DEALLOCATE(FRAC_FULL) DEALLOCATE(KOUNT_FULL) ! !----------------------------------------------------------------------- ! ENDIF task_assign ! !----------------------------------------------------------------------- !*** All tasks know the task counts and IDs of all domains as well as !*** the parents of each domain. ! !*** Loop through all domains in order to associate all parents !*** with their children through intracommunicators. We cannot use !*** intercommunicators in general since parent and child domains !*** can contain some of the same forecast tasks in 2-way nesting !*** and MPI dictates that intercommunicators can only link disjoint !*** sets of tasks. !----------------------------------------------------------------------- ! ALLOCATE(ID_CHILDREN(1:NUM_DOMAINS_TOTAL,1:NUM_DOMAINS_TOTAL)) !<-- Array to hold all domains' children's IDs ! DO N1=1,NUM_DOMAINS_TOTAL DO N2=1,NUM_DOMAINS_TOTAL ID_CHILDREN(N1,N2)=0 !<-- All valid Domain IDs are >0 ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Allocate intracommunicators between parents and children for !*** all of the domains since some forecast tasks may lie on more !*** than one parent and/or child domain. The same is true for !*** the lists of ranks of children's local task ranks in the !*** intracommunicators. !----------------------------------------------------------------------- ! ALLOCATE(COMMS_DOMAIN(1:NUM_DOMAINS_TOTAL),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate COMMS_DOMAIN!' CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) ENDIF ! DO N=1,NUM_DOMAINS_TOTAL comms_domain(N)%TO_PARENT=-999 !<-- Initialize to nonsense the intracommunicator to parent ENDDO ! ALLOCATE(CHILD_RANKS(1:NUM_DOMAINS_TOTAL),stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate CHILD_RANKS!' CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) ENDIF ! DO N=1,NUM_DOMAINS_TOTAL child_ranks(N)%CHILDREN=>NULL() ENDDO ! !----------------------------------------------------------------------- !*** Next we need to create MPI groups for the task sets on each !*** of the domains. !----------------------------------------------------------------------- ! ALLOCATE(GROUP(1:NUM_DOMAINS_TOTAL)) ! CALL MPI_COMM_GROUP(COMM_WORLD & !<-- Intracommunicator between all tasks in the run ,GROUP_WORLD & !<-- The MPI group of all tasks in the run ,IERR ) ! DO N=1,NUM_DOMAINS_TOTAL ID_DOM=RANK_TO_DOMAIN_ID(N) NTASKS_X=NTASKS_DOMAIN(ID_DOM) !<-- Total # of tasks on domain ID_DOM ! CALL MPI_GROUP_INCL(GROUP_WORLD & !<-- MPI group with all tasks in the run ,NTASKS_X & !<-- # of fcst tasks on domain ID_DOM ,PETLIST_DOM(1:NTASKS_X,ID_DOM) & !<-- The global ranks of tasks that lie on ID_DOM ,GROUP(ID_DOM) & !<-- The new group containing the tasks on ID_DOM ,IERR ) ENDDO ! !----------------------------------------------------------------------- !*** Loop through all domains. Parent domains will create !*** intracommunicators with each of their children and vice versa. !----------------------------------------------------------------------- ! main_loop: DO N=1,NUM_DOMAINS_TOTAL ! !----------------------------------------------------------------------- ! ID_DOM=RANK_TO_DOMAIN_ID(N) ! !----------------------------------------------------------------------- ! ID_PARENT=-999 !<-- Initialize to nonsense the parent's domain ID ! N_CHILDREN=NUM_CHILDREN(ID_DOM) !<-- The # of children on this domain ! !----------------------------------------------------------------------- ! has_children: IF(N_CHILDREN>0)THEN ! !----------------------------------------------------------------------- ! ID_PARENT=ID_DOM !<-- ID_DOM is a parent domain NTASKS_PARENT=NTASKS_DOMAIN(ID_PARENT) !<-- Total # of fcst and write tasks on this parent domain ! !----------------------------------------------------------------------- !*** All domain IDs will be searched to find matches between the !*** current domain's ID and the parent IDs of the other domains. !*** Matches will identify Parent-Child couplets. !----------------------------------------------------------------------- ! NN=0 ! DO N2=1,NUM_DOMAINS_TOTAL !<-- Search for children who have parent ID_PARENT ID_CHILD=ID_DOMAINS(N2) !<-- Check if this domain ID is that of a child ! IF(ID_PARENTS(ID_CHILD)==ID_PARENT.AND.ID_PARENT/=-999)THEN !<-- If yes then we found a nest that is this domain's child NN=NN+1 !<-- Increment index of children of the parent domain ID_CHILDREN(NN,ID_PARENT)=ID_CHILD !<-- IDs of this parent's (ID_PARENT's) children's domains ENDIF ! IF(NN==N_CHILDREN)THEN !<-- We have found all of this domain's children ALLOCATE(comms_domain(ID_PARENT)%TO_CHILDREN(1:N_CHILDREN) & !<-- Parent allocates intracommunicators with each child ,stat=ISTAT) ! DO N3=1,N_CHILDREN comms_domain(ID_PARENT)%TO_CHILDREN(N3)=-999 !<-- Parent initializes intracommunicators with each child ENDDO ! EXIT ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! ENDIF has_children ! !----------------------------------------------------------------------- !*** Now create groups that are unions of each parent with each !*** of their children. From those unions create the final !*** parent-child intracommunicators. !----------------------------------------------------------------------- ! IF(N_CHILDREN>0)THEN ! ALLOCATE(child_ranks(ID_PARENT)%CHILDREN(1:N_CHILDREN) & ,stat=ISTAT) ! IF(ISTAT/=0)THEN WRITE(0,*)' Failed to allocate child_ranks%CHILDREN!' CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) ENDIF ! !----------------------------------------------------------------------- ! intra_comm: DO N2=1,N_CHILDREN !<-- Loop through the given parent's children ! !----------------------------------------------------------------------- ! ID_CHILD=ID_CHILDREN(N2,ID_PARENT) !<-- Domain ID of child N2 of domain ID_PARENT ! CALL MPI_GROUP_UNION(GROUP(ID_PARENT) & !<-- The group containing the parent tasks (in) ,GROUP(ID_CHILD) & !<-- The group containing the child tasks (in) ,GROUP_UNION & !<-- The union of the parent and child groups (out) ,IERR ) ! CALL MPI_COMM_CREATE(COMM_WORLD & !<-- Intracommunicator between all tasks in the run (in) ,GROUP_UNION & !<-- The union of the parent and child groups (in) ,COMM_INTRA & !<-- Intracommunicator between tasks in the union (out) ,IERR ) ! comms_domain(ID_PARENT)%TO_CHILDREN(N2)=COMM_INTRA !<-- Parent: The intracommunicator with its child N2 comms_domain(ID_CHILD)%TO_PARENT=COMM_INTRA !<-- Child: The intracommunicator with its parent ! !----------------------------------------------------------------------- !*** The parent's tasks were listed first in the creation of the union !*** with child tasks so the parent task ranks in the union go from !*** 0 to FTASKS_DOMAIN(ID_PARENT)-1. However the child task ranks !*** in the union can be rather jumbled depending on how they overlie !*** the parent tasks. Therefore parents must store the union ranks !*** of their children's forecast tasks in order to use the !*** intracommunicators. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** First we need to produce the list of global parent and child !*** tasks equivalent to that which MPI produces but is not seen !*** when the union of the parent and child groups is created. !----------------------------------------------------------------------- ! NMAX=NTASKS_DOMAIN(ID_PARENT)+NTASKS_DOMAIN(ID_CHILD) !<-- Max # of tasks that can be in parent-child union ALLOCATE(GLOBAL_UNION(1:NMAX)) !<-- For holding global ranks in the union ! DO N3=1,NTASKS_DOMAIN(ID_PARENT) GLOBAL_UNION(N3)=PETLIST_DOM(N3,ID_PARENT) !<-- Insert parent's global task ranks into list first ENDDO ! KOUNT=NTASKS_DOMAIN(ID_PARENT) !<-- We just inserted this many values into GLOBAL_UNION ! child_loop1: DO N3=1,NTASKS_DOMAIN(ID_CHILD) !<-- Now loop through all child tasks ! DO NN=1,NTASKS_DOMAIN(ID_PARENT) !<-- Compare against the parent task ranks IF(PETLIST_DOM(N3,ID_CHILD)==GLOBAL_UNION(NN))THEN CYCLE child_loop1 !<-- No task rank can appear twice in the union ENDIF ENDDO ! KOUNT=KOUNT+1 !<-- Accumulating # of unique global task ranks in the union GLOBAL_UNION(KOUNT)=PETLIST_DOM(N3,ID_CHILD) !<-- Add this child global rank to the union list ! ENDDO child_loop1 ! !----------------------------------------------------------------------- !*** The GLOBAL_UNION array now holds the union of the parent and !*** child global task ranks with no ranks appearing more than once. !*** Now the parent creates a list of the child's tasks in the union !*** but using ranks as they exist in the intracommunicator which !*** start with 0 for the parent's lead task and simply increase !*** one by one in a monotonic sequence. !----------------------------------------------------------------------- ! ALLOCATE(child_ranks(ID_PARENT)%CHILDREN(N2)%DATA(0:NTASKS_DOMAIN(ID_CHILD)-1)) !<-- Local ranks of child N2's tasks ! in parent-child intracomm child_loop2: DO N3=0,NTASKS_DOMAIN(ID_CHILD)-1 ! DO NN=1,KOUNT !<-- Loop through all global task ranks in the union list IF(PETLIST_DOM(N3+1,ID_CHILD)==GLOBAL_UNION(NN))THEN !<-- Search for child task N3's global rank in the union list child_ranks(ID_PARENT)%CHILDREN(N2)%DATA(N3)=NN-1 !<-- Save its local rank in the parent-child intracommunicator CYCLE child_loop2 ENDIF IF(NN=NUM_PES_PARENT)RETURN !<-- Parent's quilt/write tasks may leave ! !----------------------------------------------------------------------- !*** We need the spatial resolution of the parent grid so extract !*** its dimensions and its bounds. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract IM From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object ,value =IM_PARENT & !<-- The variable filled (I dimension of parent grid) ,label ='im:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract JM From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object ,value =JM_PARENT & !<-- The variable filled (J dimension of parent grid) ,label ='jm:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract SBD From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object !!!! ,value =SBD_PARENT & !<-- The variable filled (South boundary of parent grid) !!!! ,label ='sbd:' & !<-- Give this label's value to the previous variable !!!! ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract WBD From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object !!!! ,value =WBD_PARENT & !<-- The variable filled (West boundary of parent grid) !!!! ,label ='wbd:' & !<-- Give this label's value to the previous variable !!!! ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract TPH0D From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object !!!! ,value =TPH0D_PARENT & !<-- The variable filled (Central lat of parent grid) !!!! ,label ='tph0d:' & !<-- Give this label's value to the previous variable !!!! ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract TLM0D From Config File" !!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object !!!! ,value =TLM0D_PARENT & !<-- The variable filled (Central lon of parent grid) !!!! ,label ='tlm0d:' & !<-- Give this label's value to the previous variable !!!! ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Global Flag for Parent Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object of my parent ,value =GLOBAL_FLAG & !<-- The variable filled ,label ='global:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** The parent grid resolution. !----------------------------------------------------------------------- ! IF(TRIM(GLOBAL_FLAG)=='true')THEN !<-- Parent is global GLOBAL=.TRUE. IDE=IM_PARENT+2 JDE=JM_PARENT+2 !!!! DPHD_PARENT=-SBD_PARENT*2./REAL(JDE-3) !!!! DLMD_PARENT=-WBD_PARENT*2./REAL(IDE-3) ELSE !<-- Parent is regional GLOBAL=.FALSE. IDE=IM_PARENT JDE=JM_PARENT !!!! DPHD_PARENT=-SBD_PARENT*2./REAL(JDE-1) !!!! DLMD_PARENT=-WBD_PARENT*2./REAL(IDE-1) ENDIF ! ROW_0=0.5*(JDE+1) COL_0=0.5*(IDE+1) ! !----------------------------------------------------------------------- !*** Extract the Solver internal state of the parent !*** so we can use their data for the nests. !----------------------------------------------------------------------- ! CALL ESMF_GridCompGetInternalState(SOLVER_GRID_COMP & ,WRAP_SOLVER & ,RC ) ! !----------------------------------------------------------------------- ! SOLVER_INT_STATE=>wrap_solver%INT_STATE ! IMS=solver_int_state%IMS !<-- Horizontal memory limits on parent tasks IME=solver_int_state%IME ! JMS=solver_int_state%JMS ! JME=solver_int_state%JME !<-- ! ITS=solver_int_state%ITS !<-- Horizontal integration limits on parent tasks ITE=solver_int_state%ITE ! JTS=solver_int_state%JTS ! JTE=solver_int_state%JTE !<-- ! LM=solver_int_state%LM !<-- Number of atmospheric layers ! LOCAL_ISTART=>solver_int_state%LOCAL_ISTART !<-- Local integration limits for all parent tasks LOCAL_IEND =>solver_int_state%LOCAL_IEND ! LOCAL_JSTART=>solver_int_state%LOCAL_JSTART ! LOCAL_JEND =>solver_int_state%LOCAL_JEND !<-- ! !----------------------------------------------------------------------- !*** DPHD/DLMD and SBD/WBD are used only for stand-alone, independent !*** rotated parent/nest grids (i.e., not grid-associated nests). !----------------------------------------------------------------------- ! DPHD_PARENT=solver_int_state%DPHD DLMD_PARENT=solver_int_state%DLMD SBD_PARENT=solver_int_state%SBD WBD_PARENT=solver_int_state%WBD TPH0D_PARENT=solver_int_state%TPH0D TLM0D_PARENT=solver_int_state%TLM0D ! !----------------------------------------------------------------------- !*** Extract relevant information from this child's configure file. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract I of SW Point on Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object ,value =I_PARENT_START & !<-- The variable filled (parent I of child's SW corner) ,label ='i_parent_start:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract J of SW Point on Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object ,value =J_PARENT_START & !<-- The variable filled (parent J of child's SW corner) ,label ='j_parent_start:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract Child/Parent Grid Ratio" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object ,value =PARENT_CHILD_SPACE_RATIO & !<-- The variable filled (child grid increment / 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_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CHILD_PARENT_SPACE_RATIO=1./REAL(PARENT_CHILD_SPACE_RATIO) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract Global IM of Child" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object ,value =IM_CHILD & !<-- The variable filled (IM of child domain) ,label ='im:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Child_Init: Extract Global JM of Child" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object ,value =JM_CHILD & !<-- 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_CHILD) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Only for free-standing nests: ! !*** What is the parent lat/lon of the SW corner H point of the !*** child grid? !*** Find the resolution, bounds, and center of the child grid. !----------------------------------------------------------------------- ! ! CALL CONVERT_IJ_TO_LATLON (I_PARENT_START & ! ,J_PARENT_START & ! ,IM_PARENT & ! ,JM_PARENT & ! ,TPH0D_PARENT & ! ,TLM0D_PARENT & ! ,DPHD_PARENT & ! ,DLMD_PARENT & ! ,SW_LATD_CHILD & ! ,SW_LOND_CHILD ) ! !!! DPHD_CHILD=DPHD_PARENT*CHILD_PARENT_SPACE_RATIO !!! DLMD_CHILD=DLMD_PARENT*CHILD_PARENT_SPACE_RATIO ! !!! SBD_CHILD=-0.5*(JM_CHILD-1)*DPHD_CHILD !!! WBD_CHILD=-0.5*(IM_CHILD-1)*DLMD_CHILD ! !!! CALL CENTER_NEST(SBD_CHILD & !!! ,WBD_CHILD & !!! ,SW_LATD_CHILD & !!! ,SW_LOND_CHILD & !!! ,TPH0D_CHILD & !!! ,TLM0D_CHILD ) ! !----------------------------------------------------------------------- !*** Allocate 2-D and 3-D dummy arrays for child quantities. !----------------------------------------------------------------------- ! ALLOCATE(SEA_MASK(1:IM_CHILD,1:JM_CHILD)) ALLOCATE(SEA_ICE(1:IM_CHILD,1:JM_CHILD)) ! ALLOCATE(IDUMMY_2D(1:IM_CHILD,1:JM_CHILD)) ALLOCATE(DUMMY_2D_IN (IMS:IME,JMS:JME,1:1)) ALLOCATE(DUMMY_2D_OUT(1:IM_CHILD,1:JM_CHILD,1:1)) ALLOCATE(DUMMY_3D (1:IM_CHILD,1:JM_CHILD,1:LM)) ALLOCATE(DUMMY_3DS(1:IM_CHILD,1:JM_CHILD,1:NUM_SOIL_LAYERS)) ALLOCATE(DUMMY_SOIL(1:NUM_SOIL_LAYERS)) ALLOCATE(TEMPSOIL (1:NUM_SOIL_LAYERS,1:IM_CHILD,1:JM_CHILD)) ! ALLOCATE(PD_NEAREST (1:IM_CHILD,1:JM_CHILD,1:1)) ALLOCATE(PD_BILINEAR(1:IM_CHILD,1:JM_CHILD,1:1)) ! ALLOCATE(LOWER_TOPO(1:IM_CHILD,1:JM_CHILD)) DO J=1,JM_CHILD DO I=1,IM_CHILD LOWER_TOPO(I,J)=.FALSE. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Parent task 0 opens a file for writing out the child's input. !----------------------------------------------------------------------- ! IF(MYPE==0)THEN ! select_unit: DO N=51,59 INQUIRE(N,OPENED=OPENED) IF(.NOT.OPENED)THEN NFCST=N EXIT select_unit ENDIF ENDDO select_unit ! FMT='(I2.2)' WRITE(INT_TO_CHAR,FMT)THIS_CHILD_ID OUTFILE='input_domain_'//INT_TO_CHAR ! OPEN(unit=NFCST,file=OUTFILE,status='replace',form='unformatted') ! !----------------------------------------------------------------------- !*** The following variables are for the vertical grid structure !*** and are shared by the parent and its children. !----------------------------------------------------------------------- ! IHREND=0 !<-- Not used NTSD =0 !<-- Not used ! WRITE(NFCST)solver_int_state%RUN & ,solver_int_state%IDAT & ,solver_int_state%IHRST & ! ,solver_int_state%IHREND & ! ,solver_int_state%NTSD ,IHREND & ,NTSD ! WRITE(NFCST)solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%LPT2 & ,solver_int_state%SGM & ,solver_int_state%SG1 & ,solver_int_state%DSG1 & ,solver_int_state%SGML1 & ,solver_int_state%SG2 & ,solver_int_state%DSG2 & ,solver_int_state%SGML2 ! WRITE(NFCST)I_PARENT_START,J_PARENT_START ! DLMD=DLMD_PARENT*CHILD_PARENT_SPACE_RATIO DPHD=DPHD_PARENT*CHILD_PARENT_SPACE_RATIO ! IF(GLOBAL)THEN SBD=SBD_PARENT+(J_PARENT_START-2)*DPHD_PARENT WBD=WBD_PARENT+(I_PARENT_START-2)*DLMD_PARENT ELSE SBD=SBD_PARENT+(J_PARENT_START-1)*DPHD_PARENT WBD=WBD_PARENT+(I_PARENT_START-1)*DLMD_PARENT ENDIF ! WRITE(NFCST)DLMD,DPHD & ,WBD,SBD & ,TLM0D_PARENT,TPH0D_PARENT ! WRITE(NFCST)IM_CHILD,JM_CHILD,LM,LNSH ! !----------------------------------------------------------------------- ! ENDIF ! NLEV=1 ! !----------------------------------------------------------------------- !*** Sea Mask !----------------------------------------------------------------------- !*** The Sea Mask is needed for the Sfc Geopotential so compute it now. !*** If there are adjacent water points with different elevations !*** after Sfc Geopotential is computed then the WATERFALL routine !*** will level them by changing the sfc elevations. At such points !*** the atmospheric column will need adjusting so save the locations !*** of those points along with the preliminary values of the nest's !*** PD, T, Q, CW, U, and V which will then be modified. !*** The Sea Mask will be written out in its proper place following !*** the Stnd Deviation of Sfc Height. !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SM(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SeaMask' & ,DUMMY_2D_OUT & ,NEAREST) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD SEA_MASK(I,J)=REAL(NINT(DUMMY_2D_OUT(I,J,1))) ENDDO ENDDO ENDIF ! !----------------------------------------------------------------------- !*** Sfc Geopotential !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%FIS(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'FIS' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)THEN CALL WATERFALLS(DUMMY_2D_OUT & !<-- Level adjacent water points with different elevations ,SEA_MASK & ,LOWER_TOPO & ,1,IM_CHILD,1,JM_CHILD) ! WRITE(NFCST)DUMMY_2D_OUT ENDIF ! ! write(0,*)' after Sfc Geo' ! !----------------------------------------------------------------------- !*** Stnd Deviation of Sfc Height !----------------------------------------------------------------------- DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%STDH(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'STDH' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after STDH' ! !----------------------------------------------------------------------- !*** Sea Mask !----------------------------------------------------------------------- ! IF(MYPE==0)THEN WRITE(NFCST)SEA_MASK ENDIF ! write(0,*)' after Sea Mask' ! !----------------------------------------------------------------------- !*** PD !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%PD(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'PD' & ,PD_BILINEAR & ,BILINEAR) ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & !<-- Save nearest neighbors for topo adjustment ,NLEV & ,'PD' & ,PD_NEAREST & ,NEAREST) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD IF(LOWER_TOPO(I,J))THEN DUMMY_2D_OUT(I,J,1)=PD_NEAREST(I,J,1) ELSE DUMMY_2D_OUT(I,J,1)=PD_BILINEAR(I,J,1) ENDIF ENDDO ENDDO ENDIF ! ! write(0,*)' after PD' ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! !----------------------------------------------------------------------- !*** U !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%U, LM & ,'Uwind' & ,DUMMY_3D & ,BILINEAR) ! IF(MYPE==0)THEN CALL ADJUST_COLUMNS(PD_NEAREST & ,PD_BILINEAR & ,LOWER_TOPO & ,DUMMY_3D & ,solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%SG1 & ,solver_int_state%SG2 & ,IM_CHILD,JM_CHILD) ENDIF ! DO L=1,LM IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after U' ! !----------------------------------------------------------------------- !*** V !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%V, LM & ,'Vwind' & ,DUMMY_3D & ,BILINEAR) ! IF(MYPE==0)THEN CALL ADJUST_COLUMNS(PD_NEAREST & ,PD_BILINEAR & ,LOWER_TOPO & ,DUMMY_3D & ,solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%SG1 & ,solver_int_state%SG2 & ,IM_CHILD,JM_CHILD) ENDIF ! DO L=1,LM IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after V' ! !----------------------------------------------------------------------- !*** T !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%T, LM & ,'Temperature' & ,DUMMY_3D & ,BILINEAR) ! IF(MYPE==0)THEN CALL ADJUST_COLUMNS(PD_NEAREST & ,PD_BILINEAR & ,LOWER_TOPO & ,DUMMY_3D & ,solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%SG1 & ,solver_int_state%SG2 & ,IM_CHILD,JM_CHILD) ENDIF ! DO L=1,LM IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after T' ! !----------------------------------------------------------------------- !*** Q !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%Q, LM & ,'SpecHum' & ,DUMMY_3D & ,BILINEAR) ! IF(MYPE==0)THEN CALL ADJUST_COLUMNS(PD_NEAREST & ,PD_BILINEAR & ,LOWER_TOPO & ,DUMMY_3D & ,solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%SG1 & ,solver_int_state%SG2 & ,IM_CHILD,JM_CHILD) ENDIF ! DO L=1,LM IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after Q' ! !----------------------------------------------------------------------- !*** CW !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%CW, LM & ,'CW' & ,DUMMY_3D & ,BILINEAR) ! IF(MYPE==0)THEN CALL ADJUST_COLUMNS(PD_NEAREST & ,PD_BILINEAR & ,LOWER_TOPO & ,DUMMY_3D & ,solver_int_state%PT & ,solver_int_state%PDTOP & ,solver_int_state%SG1 & ,solver_int_state%SG2 & ,IM_CHILD,JM_CHILD) ENDIF ! DO L=1,LM IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after CW' ! !----------------------------------------------------------------------- !*** O3 !----------------------------------------------------------------------- ! ! CALL PARENT_TO_CHILD_FILL(solver_int_state%O3, LM & ! ,'O3' & ! ,DUMMY_3D & ! ,BILINEAR) ! ! IF(MYPE==0)THEN ! CALL ADJUST_COLUMNS(PD_NEAREST & ! ,PD_BILINEAR & ! ,LOWER_TOPO & ! ,DUMMY_3D & ! ,solver_int_state%PT & ! ,solver_int_state%PDTOP & ! ,solver_int_state%SG1 & ! ,solver_int_state%SG2 & ! ,IM_CHILD,JM_CHILD) ! ENDIF ! DO L=1,LM DO J=1,JM_CHILD DO I=1,IM_CHILD DUMMY_3D(I,J,L)=0. ! for now keep O3 = 0. ENDDO ENDDO IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) ENDDO ! write(0,*)' after O3' ! !----------------------------------------------------------------------- !*** ALBEDO !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%ALBEDO(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'ALBEDO' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after Albedo' ! !----------------------------------------------------------------------- !*** ALBASE !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%ALBASE(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN, 1 & ,'ALBASE' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! !----------------------------------------------------------------------- !*** EPSR !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%EPSR(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'EPSR' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after EPSR' ! !----------------------------------------------------------------------- !*** MXSNAL !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%MXSNAL(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'MXSNAL' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after MXSNAL' ! !----------------------------------------------------------------------- !*** TSKIN !----------------------------------------------------------------------- ! ! write(0,*)' before TSKIN' DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%TSKIN(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'TSKIN' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD IF(DUMMY_2D_OUT(I,J,1)<150.)THEN SEA_MASK(I,J)=1.0 DUMMY_2D_OUT(I,J,1)=0. ENDIF if(dummy_2d_out(i,j,1)<173..and.sea_mask(i,j)<0.5)then write(0,*)' Very cold TSKIN=',dummy_2d_out(i,j,1) & ,' at (',i,',',j,')' endif ENDDO ENDDO ENDIF ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after TSKIN' ! !----------------------------------------------------------------------- !*** SST !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SST(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SST' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after SST' ! !----------------------------------------------------------------------- !*** SNO !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SNO(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SNO' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after SNO' ! !----------------------------------------------------------------------- !*** SI !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SI(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SI' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after SI' ! !----------------------------------------------------------------------- !*** SICE !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SICE(I,J) ENDDO ENDDO ! ! write(0,*)' PARENT_TO_CHILD_INIT SICE max=',maxval(DUMMY_2D_IN(IMS:IME,JMS:JME,1)) & ! ,' min=',minval(DUMMY_2D_IN(IMS:IME,JMS:JME,1)) CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SICE' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD SEA_ICE(I,J)=DUMMY_2D_OUT(I,J,1) ENDDO ENDDO ENDIF ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after SICE' ! !----------------------------------------------------------------------- !*** TG !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%TG(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'TG' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after TG' ! !----------------------------------------------------------------------- !*** CMC !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%CMC(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'CMC' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after CMC' ! !----------------------------------------------------------------------- !*** SR !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%SR(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'SR' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after SR' ! !----------------------------------------------------------------------- !*** USTAR !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%USTAR(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'USTAR' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after USTAR' ! !----------------------------------------------------------------------- !*** Z0 !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%Z0(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'Z0' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after Z0' ! !----------------------------------------------------------------------- !*** Z0BASE !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%Z0BASE(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'Z0BASE' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after Z0BASE' ! !----------------------------------------------------------------------- !*** STC !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%STC, NUM_SOIL_LAYERS & ,'STC' & ,DUMMY_3DS & ,BILINEAR) ! IF(MYPE==0)THEN DO L=1,NUM_SOIL_LAYERS DO J=1,JM_CHILD DO I=1,IM_CHILD TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) ENDDO ENDDO ENDDO ! WRITE(NFCST)TEMPSOIL ENDIF ! write(0,*)' after STC' ! !----------------------------------------------------------------------- !*** SMC !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%SMC, NUM_SOIL_LAYERS & ,'SMC' & ,DUMMY_3DS & ,BILINEAR) ! IF(MYPE==0)THEN DO L=1,NUM_SOIL_LAYERS DO J=1,JM_CHILD DO I=1,IM_CHILD TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) ENDDO ENDDO ENDDO ! WRITE(NFCST)TEMPSOIL ENDIF ! write(0,*)' after SMC' ! !----------------------------------------------------------------------- !*** SH2O !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_FILL(solver_int_state%SH2O, NUM_SOIL_LAYERS & ,'SH2O' & ,DUMMY_3DS & ,BILINEAR) ! IF(MYPE==0)THEN DO L=1,NUM_SOIL_LAYERS DO J=1,JM_CHILD DO I=1,IM_CHILD TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) ENDDO ENDDO ENDDO ! WRITE(NFCST)TEMPSOIL ENDIF ! write(0,*)' after SH2O' ! !----------------------------------------------------------------------- !*** ISLTYP !----------------------------------------------------------------------- ! CALL PARENT_TO_CHILD_IFILL(solver_int_state%ISLTYP & ,'ISLTYP' & ,IDUMMY_2D ) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD IF(IDUMMY_2D(I,J)<1.AND.SEA_MASK(I,J)<0.5)THEN IDUMMY_2D(I,J)=1 !<--------- Bandaid for interpolated soil value=0 while interpolated seamask=0 (i.e, a land point) ! if(abs(IDUMMY_2D(I,J))>50)write(0,*)' write ISLTYP i=',i,' j=',j,' sea_mask=',SEA_MASK(I,J),' isltyp=',IDUMMY_2D(I,J) ENDIF ENDDO ENDDO ! WRITE(NFCST)IDUMMY_2D ENDIF ! write(0,*)' after ISLTYP' ! !----------------------------------------------------------------------- !*** IVGTYP !----------------------------------------------------------------------- ! ! write(0,*)' PARENT_TO_CHILD_INIT IVGTYP max=',maxval(solver_int_state%IVGTYP) & ! ,' min=',minval(solver_int_state%IVGTYP),' maxloc=',maxloc(solver_int_state%IVGTYP) & ! ,' minloc=',minloc(solver_int_state%IVGTYP) CALL PARENT_TO_CHILD_IFILL(solver_int_state%IVGTYP & ,'IVGTYP' & ,IDUMMY_2D ) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD IF(IDUMMY_2D(I,J)<1.AND.SEA_MASK(I,J)<0.5)THEN IDUMMY_2D(I,J)=1 !<--------- Bandaid for interpolated vegetation value=0 while interpolated seamask=0 (i.e, a land point) ENDIF ENDDO ENDDO ! WRITE(NFCST)IDUMMY_2D ENDIF ! write(0,*)' after IVGTYP' ! !----------------------------------------------------------------------- !*** VEGFRC !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME DUMMY_2D_IN(I,J,1)=solver_int_state%VEGFRC(I,J) ENDDO ENDDO ! CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & ,NLEV & ,'VEGFRC' & ,DUMMY_2D_OUT & ,BILINEAR) ! IF(MYPE==0)THEN DO J=1,JM_CHILD DO I=1,IM_CHILD IF(DUMMY_2D_OUT(I,J,1)>0..AND.(SEA_MASK(I,J)>0.5.OR.SEA_ICE(I,J)>0.))THEN DUMMY_2D_OUT(I,J,1)=0. !<--------- Bandaid for interpolated veg frac value >0 while interpolated seamask or sice >0 ENDIF ENDDO ENDDO ENDIF ! IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT ! write(0,*)' after VEGFRC' ! !----------------------------------------------------------------------- ! IF(MYPE==0)WRITE(NFCST)DUMMY_SOIL IF(MYPE==0)WRITE(NFCST)DUMMY_SOIL ! !----------------------------------------------------------------------- ! IF(MYPE==0)CLOSE(NFCST) ! !----------------------------------------------------------------------- ! DEALLOCATE(IDUMMY_2D) DEALLOCATE(DUMMY_2D_IN) DEALLOCATE(DUMMY_2D_OUT) DEALLOCATE(DUMMY_3D) DEALLOCATE(DUMMY_3DS) DEALLOCATE(DUMMY_SOIL) DEALLOCATE(TEMPSOIL) DEALLOCATE(SEA_MASK) DEALLOCATE(PD_BILINEAR) DEALLOCATE(PD_NEAREST) DEALLOCATE(LOWER_TOPO) ! !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !!! SUBROUTINE PARENT_TO_CHILD_FILL_ASSOC(PARENT_ARRAY & SUBROUTINE PARENT_TO_CHILD_FILL (PARENT_ARRAY & ,NLEV & ,VBL_NAME & ,CHILD_ARRAY & ,METHOD) ! !----------------------------------------------------------------------- !*** Rows and columns of the child's grid lie directly on top of !*** rows and colums of the parent (thus 'ASSOCIATED'). ! !*** Fill a child's domain with data from the parent. Only the parent !*** tasks are needed in this routine. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: METHOD & !<-- Interpolaton method (bilinear or nearest neighbor) ,NLEV !<-- Vertical dimension of the data array ! !!! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(INOUT) :: & !!! DATA_ARRAY !<-- The parent array that will initialize the child array ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & PARENT_ARRAY !<-- The parent array that will initialize the child array ! CHARACTER(*),INTENT(IN) :: VBL_NAME ! REAL(kind=KFPT),DIMENSION(1:IM_CHILD,1:JM_CHILD,1:NLEV),INTENT(OUT) :: & !<-- Data from parent tasks interpolated to child grid CHILD_ARRAY ! but still on parent task 0 ! ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,IERR,II,IPE,IPE_LOCAL,ISTAT,J,JJ,L,N,NN INTEGER(kind=KINT) :: I_COPY,I_END,I_END_COPY,I_EXTENT,I_PARENT_END & ,I_START_COPY INTEGER(kind=KINT) :: J_COPY,J_END,J_END_COPY,J_EXTENT,J_PARENT_END & ,J_START_COPY INTEGER(kind=KINT) :: INDX_EAST,INDX_NORTH,INDX_SOUTH,INDX_WEST INTEGER(kind=KINT) :: NWORDS_RECV,NWORDS_SEND ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: DELTA_I_EAST,DELTA_I_WEST & ,DELTA_J_NORTH,DELTA_J_SOUTH REAL(kind=KFPT) :: RATIO,REAL_INDX_I_PARENT,REAL_INDX_J_PARENT REAL(kind=KFPT) :: WEIGHT_EAST,WEIGHT_NORTH & ,WEIGHT_SOUTH,WEIGHT_WEST REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW REAL(kind=KFPT) :: WEIGHT_MAX,WEIGHT_SUM ! REAL(kind=KFPT),DIMENSION(:) ,ALLOCATABLE :: DATA_BUFFER REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: ARRAY_STAGE_PARENT ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** To simplify matters somewhat, isolate the minimum subset of !*** points on the parent domain that underlie the child's domain. ! !*** The southwest corner of the child always lies directly on a !*** point in the parent domain. We already know the I,J of that !*** parent point since it was specified in the configure file. !*** The number of parent points that are covered by the child is !*** determined by the child-to-parent grid ratio and the lateral !*** dimensions of the child's domain. !----------------------------------------------------------------------- ! I_PARENT_END=I_PARENT_START & !<-- Easternmost I on parent domain surrounding child domain +INT((IM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 ! I_EXTENT=I_PARENT_END-I_PARENT_START+1 ! J_PARENT_END=J_PARENT_START & !<-- Northernmost J on parent domain surrounding child domain +INT((JM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 ! J_EXTENT=J_PARENT_END-J_PARENT_START+1 ! !----------------------------------------------------------------------- !*** Create a staging array on parent task 0 that will hold the entire !*** subset of the parent domain underlying the child. !*** Then all parent tasks with points in the intersecting region !*** send their data to parent task 0. !----------------------------------------------------------------------- ! parent_stage: IF(MYPE==0)THEN !<-- Parent task 0 ! !----------------------------------------------------------------------- ! ALLOCATE(ARRAY_STAGE_PARENT(1:I_EXTENT,1:J_EXTENT,1:NLEV)) !<-- Array holding all parent points in staging region ! Note that this array begins at (1,1,1), i.e., ! its indices are relative to the nest. ! !----------------------------------------------------------------------- !*** If parent task 0 holds some of the staging region, copy it to !*** the staging array. !----------------------------------------------------------------------- ! IF(I_PARENT_START<=ITE.AND.J_PARENT_START<=JTE)THEN I_END=MIN(ITE,I_PARENT_END) J_END=MIN(JTE,J_PARENT_END) ! DO L=1,NLEV JJ=0 DO J=J_PARENT_START,J_END JJ=JJ+1 ! II=0 DO I=I_PARENT_START,I_END II=II+1 ARRAY_STAGE_PARENT(II,JJ,L)=PARENT_ARRAY(I,J,L) ENDDO ENDDO ENDDO ! ENDIF ! !----------------------------------------------------------------------- !*** If there are points in the staging region outside of parent task 0 !*** then task 0 receives those points from the other parent tasks that !*** contain those points. !----------------------------------------------------------------------- ! parent_search: DO IPE=1,NUM_PES_PARENT-1 !<-- Parent task 0 checks other parent fcst tasks for points ! remote_stage: IF(I_PARENT_START<=LOCAL_IEND (IPE).AND. & !<-- Does remote parent task IPE contain any staging region? I_PARENT_END >=LOCAL_ISTART(IPE) & ! .AND. & ! J_PARENT_START<=LOCAL_JEND (IPE).AND. & ! J_PARENT_END >=LOCAL_JSTART(IPE))THEN !<-- ! I_START_COPY=MAX(I_PARENT_START,LOCAL_ISTART(IPE)) !<-- I index of first point in staging region on remote parent task I_END_COPY =MIN(I_PARENT_END ,LOCAL_IEND (IPE)) !<-- I index of last point in staging region on remote parent task I_COPY =I_END_COPY-I_START_COPY+1 !<-- I range of points to receive ! J_START_COPY=MAX(J_PARENT_START,LOCAL_JSTART(IPE)) !<-- J index of first point in staging region on remote parent task J_END_COPY =MIN(J_PARENT_END ,LOCAL_JEND (IPE)) !<-- J index of last point in staging region on remote parent task J_COPY =J_END_COPY-J_START_COPY+1 !<-- J range of points to receive ! NWORDS_RECV=I_COPY*J_COPY*NLEV !<-- Total # of words from remote parent task in staging region ! ALLOCATE(DATA_BUFFER(1:NWORDS_RECV)) !<-- Allocate buffer array to hold remote task's staging data CALL MPI_RECV(DATA_BUFFER & !<-- The staging region data from remote parent task IPE ,NWORDS_RECV & !<-- Total words received ,MPI_REAL & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! NN=0 !<-- Counter for received words ! DO L=1,NLEV ! JJ=J_START_COPY-J_PARENT_START DO J=1,J_COPY JJ=JJ+1 ! II=I_START_COPY-I_PARENT_START DO I=1,I_COPY II=II+1 NN=NN+1 ARRAY_STAGE_PARENT(II,JJ,L)=DATA_BUFFER(NN) !<-- Fill in array with staging region data from parent task IPE ENDDO ENDDO ENDDO ! DEALLOCATE(DATA_BUFFER) ! ENDIF remote_stage ! ENDDO parent_search ! !----------------------------------------------------------------------- !*** Now the remaining parent tasks check to see if they contain !*** any points in the staging region. If they do, gather them !*** and send them to parent task 0. !----------------------------------------------------------------------- ! ELSEIF(MYPE>0.AND.MYPE<=NUM_PES_PARENT-1)THEN parent_stage !<-- All parent forecast tasks other than 0 ! !----------------------------------------------------------------------- IF(I_PARENT_START<=ITE.AND.I_PARENT_END>=ITS & !<-- Does this parent task contain any staging region? .AND. & ! J_PARENT_START<=JTE.AND.J_PARENT_END>=JTS)THEN !<-- ! I_START_COPY=MAX(I_PARENT_START,ITS) !<-- I index of first point in staging region on this parent task I_END_COPY =MIN(I_PARENT_END ,ITE) !<-- I index of last point in staging region on this parent task I_COPY=I_END_COPY-I_START_COPY+1 !<-- I range of points to send to parent task 0 ! J_START_COPY=MAX(J_PARENT_START,JTS) !<-- J index of first point in staging region on remote parent task J_END_COPY =MIN(J_PARENT_END ,JTE) !<-- J index of last point in staging region on remote parent task J_COPY=J_END_COPY-J_START_COPY+1 !<-- J range of copied points ! NWORDS_SEND=I_COPY*J_COPY*NLEV !<-- Total number of words from this parent task in staging region ALLOCATE(DATA_BUFFER(1:NWORDS_SEND),stat=ISTAT) !<-- Allocate the buffer array to hold this task's staging data ! NN=0 ! DO L=1,NLEV DO J=J_START_COPY,J_END_COPY DO I=I_START_COPY,I_END_COPY NN=NN+1 DATA_BUFFER(NN)=PARENT_ARRAY(I,J,L) ENDDO ENDDO ENDDO ! CALL MPI_SEND(DATA_BUFFER & !<-- The staging region data from this parent task to parent task 0 ,NWORDS_SEND & !<-- Total words sent ,MPI_REAL & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! DEALLOCATE(DATA_BUFFER) ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parent_stage ! !----------------------------------------------------------------------- !*** The subset of the input array on the parent domain that lies !*** under the child's domain has been mirrored onto parent task 0. !*** Parent task 0 will fill out the array to match the child !*** domain's horizontal grid increments and then parcel out the !*** appropriate pieces to the corresponding tasks of the child. !----------------------------------------------------------------------- ! ! !----------------------------------------------------------------------- !*** First fill in the southern and western sides of the array. !*** If bilinear interpolation is specified then only linear !*** interpolation needs to be used. !----------------------------------------------------------------------- ! parent_task_0: IF(MYPE==0)THEN !<-- Parent task 0 ! !----------------------------------------------------------------------- ! RATIO=CHILD_PARENT_SPACE_RATIO ! DO L=1,NLEV ! CHILD_ARRAY(1,1,L)=ARRAY_STAGE_PARENT(1,1,L) !<-- SW corner of child's array coincides with a parent point ! DO I=2,IM_CHILD !<-- Move along southern boundary of child's domain REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point on parent INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point WEIGHT_WEST=INDX_EAST-REAL_INDX_I_PARENT !<-- Interpolation weight given parent's point to the west WEIGHT_EAST=1.-WEIGHT_WEST !<-- Interpolation weight given parent's point to the east ! IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors WEIGHT_MAX=MAX(WEIGHT_WEST,WEIGHT_EAST) IF(WEIGHT_WEST==WEIGHT_MAX)THEN CHILD_ARRAY(I,1,L)=ARRAY_STAGE_PARENT(INDX_WEST,1,L) ELSEIF(WEIGHT_EAST==WEIGHT_MAX)THEN CHILD_ARRAY(I,1,L)=ARRAY_STAGE_PARENT(INDX_EAST,1,L) ENDIF ! ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using (bi)linear interpolation CHILD_ARRAY(I,1,L)=WEIGHT_WEST*ARRAY_STAGE_PARENT(INDX_WEST,1,L) & !<-- Value at points along child's southern boundary +WEIGHT_EAST*ARRAY_STAGE_PARENT(INDX_EAST,1,L) ELSE WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ! ENDIF ! ENDDO ! DO J=2,JM_CHILD !<-- Move along western boundary of child's domain REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point on parent INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point WEIGHT_SOUTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Interpolation weight of parent's point to the south WEIGHT_NORTH=1.-WEIGHT_SOUTH !<-- Interpolation weight of parent's point to the north ! IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors WEIGHT_MAX=MAX(WEIGHT_SOUTH,WEIGHT_NORTH) IF(WEIGHT_SOUTH==WEIGHT_MAX)THEN CHILD_ARRAY(1,J,L)=ARRAY_STAGE_PARENT(1,INDX_SOUTH,L) ELSE CHILD_ARRAY(1,J,L)=ARRAY_STAGE_PARENT(1,INDX_NORTH,L) ENDIF ! ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using (bi)linear interpolation CHILD_ARRAY(1,J,L)=WEIGHT_SOUTH*ARRAY_STAGE_PARENT(1,INDX_SOUTH,L) & !<-- Value at points along child's western boundary +WEIGHT_NORTH*ARRAY_STAGE_PARENT(1,INDX_NORTH,L) ELSE WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ! ENDIF ! ENDDO ! !----------------------------------------------------------------------- !*** Fill in the interior of the staging array. !----------------------------------------------------------------------- ! DO J=2,JM_CHILD REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point in parent staging region INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point ! DELTA_J_NORTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Parent grid increment from child point to parent point north DELTA_J_SOUTH=REAL_INDX_J_PARENT-INDX_SOUTH !<-- Parent grid increment from child point to parent point south ! DO I=2,IM_CHILD REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point in parent staging region INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point ! DELTA_I_EAST=INDX_EAST-REAL_INDX_I_PARENT DELTA_I_WEST=REAL_INDX_I_PARENT-INDX_WEST ! WEIGHT_SW=DELTA_I_EAST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SW WEIGHT_SE=DELTA_I_WEST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SE WEIGHT_NW=DELTA_I_EAST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NW WEIGHT_NE=DELTA_I_WEST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NE ! !----------------------------------------------------------------------- ! assign: IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE & ,WEIGHT_NW,WEIGHT_NE) IF(WEIGHT_SW==WEIGHT_MAX)THEN CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) ENDIF ! ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using bilinear interpolation IF(VBL_NAME/='FIS')THEN IF(ABS(ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L))<1.E-12)WEIGHT_SW=0. IF(ABS(ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L))<1.E-12)WEIGHT_SE=0. IF(ABS(ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L))<1.E-12)WEIGHT_NW=0. IF(ABS(ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L))<1.E-12)WEIGHT_NE=0. ENDIF ! CHILD_ARRAY(I,J,L)=WEIGHT_SW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) & !<-- Value at points in child's interior +WEIGHT_SE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) & +WEIGHT_NW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) & +WEIGHT_NE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) ! WEIGHT_SUM=WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN CHILD_ARRAY(I,J,L)=CHILD_ARRAY(I,J,L)/WEIGHT_SUM !<-- Normalize if some weights are zero (e.g., coastal land Temp) ENDIF ! IF(VBL_NAME=='SST')THEN !<-- Include only realistic SST temperatures WEIGHT_SUM=0. CHILD_ARRAY(I,J,L)=0. IF(ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L)>200.)THEN WEIGHT_SUM=WEIGHT_SUM+WEIGHT_SW CHILD_ARRAY(I,J,L)=WEIGHT_SW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) & +CHILD_ARRAY(I,J,L) ENDIF IF(ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L)>200.)THEN WEIGHT_SUM=WEIGHT_SUM+WEIGHT_SE CHILD_ARRAY(I,J,L)=WEIGHT_SE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) & +CHILD_ARRAY(I,J,L) ENDIF IF(ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L)>200.)THEN WEIGHT_SUM=WEIGHT_SUM+WEIGHT_NW CHILD_ARRAY(I,J,L)=WEIGHT_NW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) & +CHILD_ARRAY(I,J,L) ENDIF IF(ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L)>200.)THEN WEIGHT_SUM=WEIGHT_SUM+WEIGHT_NE CHILD_ARRAY(I,J,L)=WEIGHT_NE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) & +CHILD_ARRAY(I,J,L) ENDIF IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN CHILD_ARRAY(I,J,L)=CHILD_ARRAY(I,J,L)/WEIGHT_SUM ENDIF ENDIF ! ELSE WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ! ENDIF assign ! !----------------------------------------------------------------------- ! ENDDO ENDDO ! ENDDO ! DEALLOCATE(ARRAY_STAGE_PARENT) ! !----------------------------------------------------------------------- ! ENDIF parent_task_0 ! !----------------------------------------------------------------------- ! !!! END SUBROUTINE PARENT_TO_CHILD_FILL_ASSOC END SUBROUTINE PARENT_TO_CHILD_FILL ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !!! SUBROUTINE PARENT_TO_CHILD_IFILL_ASSOC(PARENT_ARRAY & SUBROUTINE PARENT_TO_CHILD_IFILL (PARENT_ARRAY & ,VBL_NAME & ,CHILD_ARRAY) ! !----------------------------------------------------------------------- !*** Rows and columns of the child's grid lie directly on top of !*** rows and colums of the parent (thus 'ASSOCIATED'). !*** Fill a child's domain with data from the parent. Only the parent !*** tasks are needed in this routine. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: & PARENT_ARRAY !<-- The parent array that will initialize the child array ! INTEGER(kind=KINT),DIMENSION(1:IM_CHILD,1:JM_CHILD),INTENT(OUT) :: & !<-- Data from parent tasks interpolated to child grid CHILD_ARRAY ! but still on parent task 0 ! CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,IERR,II,IPE,IPE_LOCAL,J,JJ,N,NN INTEGER(kind=KINT) :: I_COPY,I_END,I_END_COPY,I_EXTENT,I_PARENT_END & ,I_START_COPY INTEGER(kind=KINT) :: J_COPY,J_END,J_END_COPY,J_EXTENT,J_PARENT_END & ,J_START_COPY INTEGER(kind=KINT) :: INDX_EAST,INDX_NORTH,INDX_SOUTH,INDX_WEST INTEGER(kind=KINT) :: NWORDS_RECV,NWORDS_SEND ! INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! INTEGER,DIMENSION(:) ,ALLOCATABLE :: DATA_BUFFER INTEGER,DIMENSION(:,:),ALLOCATABLE :: ARRAY_STAGE_PARENT ! REAL(kind=KFPT) :: DELTA_I_EAST,DELTA_I_WEST,DELTA_J_NORTH,DELTA_J_SOUTH REAL(kind=KFPT) :: RATIO,REAL_INDX_I_PARENT,REAL_INDX_J_PARENT REAL(kind=KFPT) :: WEIGHT_EAST,WEIGHT_NORTH,WEIGHT_SOUTH,WEIGHT_WEST REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW REAL(kind=KFPT) :: WEIGHT_MAX ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** To simplify matters somewhat, isolate the minimum subset of !*** points on the parent domain that underlie the child's domain. ! !*** The southwest corner of the child always lies directly on a !*** point in the parent domain. We already know the I,J of that !*** parent point since it was specified in the configure file. !*** The number of parent points that are covered by the child is !*** determined by the child-to-parent grid ratio and the lateral !*** dimensions of the child's domain. !----------------------------------------------------------------------- ! I_PARENT_END=I_PARENT_START & !<-- Easternmost I on parent domain surrounding child domain +INT((IM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 ! I_EXTENT=I_PARENT_END-I_PARENT_START+1 ! J_PARENT_END=J_PARENT_START & !<-- Northernmost J on parent domain surrounding child domain +INT((JM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 ! J_EXTENT=J_PARENT_END-J_PARENT_START+1 ! !----------------------------------------------------------------------- !*** Create a staging array on parent task 0 that will hold the entire !*** subset of the parent domain underlying the child. !*** Then all parent tasks with points in the intersecting region !*** send their data to parent task 0. !----------------------------------------------------------------------- ! parent_stage: IF(MYPE==0)THEN !<-- Parent task 0 ! !----------------------------------------------------------------------- ! ALLOCATE(ARRAY_STAGE_PARENT(1:I_EXTENT,1:J_EXTENT)) !<-- Array holding all parent points in staging region ! Note that this array begins at (1,1,1), i.e., ! its indices are relative to the nest. ! !----------------------------------------------------------------------- !*** If parent task 0 holds some of the staging region, copy it to !*** the staging array. !----------------------------------------------------------------------- ! IF(I_PARENT_START<=ITE.AND.J_PARENT_START<=JTE)THEN I_END=MIN(ITE,I_PARENT_END) J_END=MIN(JTE,J_PARENT_END) ! JJ=0 DO J=J_PARENT_START,J_END JJ=JJ+1 ! II=0 DO I=I_PARENT_START,I_END II=II+1 ARRAY_STAGE_PARENT(II,JJ)=PARENT_ARRAY(I,J) ENDDO ENDDO ! ENDIF ! !----------------------------------------------------------------------- !*** If there are points in the staging region outside of parent task 0 !*** then task 0 receives those points from the other parent tasks that !*** contain those points. !----------------------------------------------------------------------- ! parent_search: DO IPE=1,NUM_PES_PARENT-1 !<-- Parent task 0 checks other parent tasks for points ! remote_stage: IF(I_PARENT_START<=LOCAL_IEND (IPE).AND. & !<-- Does remote parent task IPE contain any staging region? I_PARENT_END >=LOCAL_ISTART(IPE) & ! .AND. & ! J_PARENT_START<=LOCAL_JEND (IPE).AND. & ! J_PARENT_END >=LOCAL_JSTART(IPE))THEN !<-- ! I_START_COPY=MAX(I_PARENT_START,LOCAL_ISTART(IPE)) !<-- I index of first point in staging region on remote parent task I_END_COPY =MIN(I_PARENT_END ,LOCAL_IEND (IPE)) !<-- I index of last point in staging region on remote parent task I_COPY =I_END_COPY-I_START_COPY+1 !<-- I range of points to receive ! J_START_COPY=MAX(J_PARENT_START,LOCAL_JSTART(IPE)) !<-- J index of first point in staging region on remote parent task J_END_COPY =MIN(J_PARENT_END ,LOCAL_JEND (IPE)) !<-- J index of last point in staging region on remote parent task J_COPY =J_END_COPY-J_START_COPY+1 !<-- J range of points to receive ! NWORDS_RECV=I_COPY*J_COPY !<-- Total # of words from remote parent task in staging region ! ALLOCATE(DATA_BUFFER(1:NWORDS_RECV)) !<-- Allocate buffer array to hold remote task's staging data CALL MPI_RECV(DATA_BUFFER & !<-- The staging region data from remote parent task IPE ,NWORDS_RECV & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! NN=0 !<-- Counter for received words ! JJ=J_START_COPY-J_PARENT_START DO J=1,J_COPY JJ=JJ+1 ! II=I_START_COPY-I_PARENT_START DO I=1,I_COPY II=II+1 NN=NN+1 ARRAY_STAGE_PARENT(II,JJ)=DATA_BUFFER(NN) !<-- Fill in array with staging region data from parent task IPE ENDDO ENDDO ! DEALLOCATE(DATA_BUFFER) ! ENDIF remote_stage ! ENDDO parent_search ! !----------------------------------------------------------------------- !*** Now the remaining parent tasks check to see if they contain !*** any points in the staging region. If they do, gather them !*** and send them to parent task 0. !----------------------------------------------------------------------- ! ELSEIF(MYPE>0.AND.MYPE<=NUM_PES_PARENT-1)THEN parent_stage !<-- All parent tasks other than 0 ! !----------------------------------------------------------------------- IF(I_PARENT_START<=ITE.AND.I_PARENT_END>=ITS & !<-- Does this parent task contain any staging region? .AND. & ! J_PARENT_START<=JTE.AND.J_PARENT_END>=JTS)THEN !<-- ! I_START_COPY=MAX(I_PARENT_START,ITS) !<-- I index of first point in staging region on this parent task I_END_COPY =MIN(I_PARENT_END ,ITE) !<-- I index of last point in staging region on this parent task I_COPY=I_END_COPY-I_START_COPY+1 !<-- I range of points to send to parent task 0 ! J_START_COPY=MAX(J_PARENT_START,JTS) !<-- J index of first point in staging region on remote parent task J_END_COPY =MIN(J_PARENT_END ,JTE) !<-- J index of last point in staging region on remote parent task J_COPY=J_END_COPY-J_START_COPY+1 !<-- J range of copied points ! NWORDS_SEND=I_COPY*J_COPY !<-- Total number of words from this parent task in staging region ALLOCATE(DATA_BUFFER(1:NWORDS_SEND)) !<-- Allocate the buffer array to hold this task's staging data ! NN=0 ! DO J=J_START_COPY,J_END_COPY DO I=I_START_COPY,I_END_COPY NN=NN+1 DATA_BUFFER(NN)=PARENT_ARRAY(I,J) ENDDO ENDDO ! CALL MPI_SEND(DATA_BUFFER & !<-- The staging region data from this parent task to parent task 0 ,NWORDS_SEND & !<-- Total words sent ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! DEALLOCATE(DATA_BUFFER) ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parent_stage ! !----------------------------------------------------------------------- !*** The subset of the input array on the parent domain that lies !*** under the child's domain has been mirrored onto parent task 0. !*** Parent task 0 will fill out the array to match the child !*** domain's horizontal grid increments and then parcel out the !*** appropriate pieces to the corresponding tasks of the child. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** First fill in the southern and western sides of the array !*** choosing the nearest parent points. !----------------------------------------------------------------------- ! parent_task_0: IF(MYPE==0)THEN !<-- Parent task 0 ! !----------------------------------------------------------------------- ! RATIO=CHILD_PARENT_SPACE_RATIO ! CHILD_ARRAY(1,1)=ARRAY_STAGE_PARENT(1,1) !<-- SW corner of child's array coincides with a parent point ! !*** Choose nearest parent point along child's southern boundary ! DO I=2,IM_CHILD !<-- Move along southern boundary of child's domain REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point on parent INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point WEIGHT_WEST=INDX_EAST-REAL_INDX_I_PARENT !<-- Interpolation weight given parent's point to the west WEIGHT_EAST=1.-WEIGHT_WEST !<-- Interpolation weight given parent's point to the east ! WEIGHT_MAX=MAX(WEIGHT_WEST,WEIGHT_EAST) IF(WEIGHT_WEST==WEIGHT_MAX)THEN CHILD_ARRAY(I,1)=ARRAY_STAGE_PARENT(INDX_WEST,1) ELSEIF(WEIGHT_EAST==WEIGHT_MAX)THEN CHILD_ARRAY(I,1)=ARRAY_STAGE_PARENT(INDX_EAST,1) ENDIF ENDDO ! !*** Choose nearest parent point along child's western boundary ! DO J=2,JM_CHILD !<-- Move along western boundary of child's domain REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point on parent INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point WEIGHT_SOUTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Interpolation weight of parent's point to the south WEIGHT_NORTH=1.-WEIGHT_SOUTH !<-- Interpolation weight of parent's point to the north WEIGHT_MAX=MAX(WEIGHT_SOUTH,WEIGHT_NORTH) ! IF(WEIGHT_SOUTH==WEIGHT_MAX)THEN CHILD_ARRAY(1,J)=ARRAY_STAGE_PARENT(1,INDX_SOUTH) ELSE CHILD_ARRAY(1,J)=ARRAY_STAGE_PARENT(1,INDX_NORTH) ENDIF ! ENDDO ! !----------------------------------------------------------------------- !*** Fill in the interior of the staging array choosing the !*** nearest parent point. !----------------------------------------------------------------------- ! DO J=2,JM_CHILD REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point in parent staging region INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point ! DELTA_J_NORTH=INDX_NORTH-REAL_INDX_J_PARENT DELTA_J_SOUTH=REAL_INDX_J_PARENT-INDX_SOUTH ! DO I=2,IM_CHILD REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point in parent staging region INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point ! DELTA_I_EAST=INDX_EAST-REAL_INDX_I_PARENT DELTA_I_WEST=REAL_INDX_I_PARENT-INDX_WEST ! WEIGHT_SW=DELTA_I_EAST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SW WEIGHT_SE=DELTA_I_WEST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SE WEIGHT_NW=DELTA_I_EAST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NW WEIGHT_NE=DELTA_I_WEST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NE ! WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE & ,WEIGHT_NW,WEIGHT_NE) ! IF(WEIGHT_SW==WEIGHT_MAX)THEN CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH) ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH) ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH) ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH) ENDIF ENDDO ENDDO ! DEALLOCATE(ARRAY_STAGE_PARENT) ! !----------------------------------------------------------------------- ! ENDIF parent_task_0 ! !----------------------------------------------------------------------- ! !!! END SUBROUTINE PARENT_TO_CHILD_IFILL_ASSOC END SUBROUTINE PARENT_TO_CHILD_IFILL ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE PARENT_TO_CHILD_FILL_GENERAL(PARENT_ARRAY & !!! SUBROUTINE PARENT_TO_CHILD_FILL (PARENT_ARRAY & ,NLEV & ,VBL_NAME & ,CHILD_ARRAY) ! !----------------------------------------------------------------------- !*** Parent tasks interpolate their data to the locations of their !*** children's gridpoints. The child grids are unique rotated !*** lat/lon grids with their own centers. The southwest H point !*** of the child grid lies directly on an H point of the parent. ! !*** Only parent tasks participate in this work. !----------------------------------------------------------------------- ! USE module_CONSTANTS,ONLY: PI ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: NLEV !<-- Vertical dimension of the data array ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & PARENT_ARRAY !<-- The parent array that will initialize the child array ! CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name ! REAL(kind=KFPT),DIMENSION(1:IM_CHILD,1:JM_CHILD,1:NLEV),INTENT(OUT) :: & CHILD_ARRAY !<-- Data from parent tasks interpolated to child grid ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,I_END,ISTART,J,J_END,JSTART & ,KOUNT,L,NIJ,NN,NTOT & ,NUM_DATA & ,NUM_CHILD_POINTS & ,NUM_IJ & ,NUM_POINTS_REMOTE ! INTEGER(kind=KINT) :: I_PARENT_SW,I_PARENT_SE & ,I_PARENT_NW,I_PARENT_NE & ,J_PARENT_SW,J_PARENT_SE & ,J_PARENT_NW,J_PARENT_NE ! INTEGER(kind=KINT) :: IERR,IPE,ISTAT ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: CHILD_POINT_INDICES & ,IJ_REMOTE ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: CHILD_LATD_ON_PARENT & ,CHILD_LOND_ON_PARENT & ,DEG_TO_RAD & ,DIST & ,R_DLMD,R_DPHD & ,REAL_I_PARENT & ,REAL_J_PARENT & ,RLATD_SW,RLOND_SW & ,RLATD_SE,RLOND_SE & ,RLATD_NW,RLOND_NW & ,RLATD_NE,RLOND_NE & ,SUM,SUM_RECIP & ,WEIGHT_SW,WEIGHT_SE & ,WEIGHT_NW,WEIGHT_NE & ,WEIGHT_SUM,WEIGHT_SUM_RECIP ! REAL(kind=KFPT),DIMENSION(4) :: RLATD,RLOND,WGT ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: CHILD_STRING & ,DATA_REMOTE ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! R_DPHD=1./DPHD_PARENT R_DLMD=1./DLMD_PARENT DEG_TO_RAD=PI/180. ! NUM_CHILD_POINTS=0 ! ISTART=1 JSTART=1 IF(GLOBAL)THEN ISTART=2 JSTART=2 ENDIF ! !----------------------------------------------------------------------- !*** Each parent task is responsible for searching the parent domain !*** extending from ITS and JTS to ITE+1 and JTE+1. Those latter +1's !*** are needed in order to reach the next gridpoint in each direction. !*** We cannot go outside the full domain of course plus the wind !*** points have no values at IDE and JDE. !----------------------------------------------------------------------- ! IF(VBL_NAME=='Uwind'.OR.VBL_NAME=='Vwind')THEN I_END=MIN(ITE+1,IDE-1) J_END=MIN(JTE+1,JDE-1) ELSE I_END=MIN(ITE+1,IDE) J_END=MIN(JTE+1,JDE) ENDIF ! !----------------------------------------------------------------------- ! NTOT=2*IM_CHILD*JM_CHILD ALLOCATE(CHILD_POINT_INDICES(1:NTOT),stat=ISTAT) IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_POINT_INDICES in PARENT_TO_CHILD_FILL_GENERAL' ! NTOT=IM_CHILD*JM_CHILD*NLEV ALLOCATE(CHILD_STRING(1:NTOT),stat=ISTAT) IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_STRING in PARENT_TO_CHILD_FILL_GENERAL' ! !----------------------------------------------------------------------- !*** Compute the parent's lat/lon of each child gridpoint in order to !*** determine if that gridpoint lies on a given parent task. !*** Save the I,J of each gridpoint found since ultimately parent !*** task 0 will need that to properly place all interpolated child !*** data onto the full child grid for writing out. !----------------------------------------------------------------------- ! NN=0 ! DO J=1,JM_CHILD DO I=1,IM_CHILD ! CALL CONVERT_IJ_TO_LATLON(I,J & !<-- A point on the child grid ,IM_CHILD,JM_CHILD & !<-- Dimensions of child grid ,TPH0D_CHILD,TLM0D_CHILD & !<-- Parent lat/lon (deg) of child grid central point ,DPHD_CHILD,DLMD_CHILD & !<-- Angular grid increments (deg) on child grid ,CHILD_LATD_ON_PARENT & !<-- Parent latitude of child point ,CHILD_LOND_ON_PARENT ) !<-- Parent longitude of child point ! REAL_I_PARENT=(CHILD_LOND_ON_PARENT-WBD_PARENT)*R_DLMD+ISTART !<-- REAL I index of child point on parent grid REAL_J_PARENT=(CHILD_LATD_ON_PARENT-SBD_PARENT)*R_DPHD+JSTART !<-- REAL J index of child point on parent grid ! !----------------------------------------------------------------------- ! IF(REAL(ITS)<=REAL_I_PARENT.AND.REAL(I_END)>REAL_I_PARENT.AND. & !<-- Is child gridpoint on this parent task? REAL(JTS)<=REAL_J_PARENT.AND.REAL(J_END)>REAL_J_PARENT)THEN !<-- ! NUM_CHILD_POINTS=NUM_CHILD_POINTS+1 !<-- Add up number of child points on this parent task ! CHILD_POINT_INDICES(2*NUM_CHILD_POINTS-1)=I !<-- Save I index of this child CHILD_POINT_INDICES(2*NUM_CHILD_POINTS )=J !<-- Save J index of this child point ! !----------------------------------------------------------------------- !*** Compute the distance from the child point location to each of !*** the four surrounding parent points and generate the bilinear !*** interpolation weights. !*** The indices 1-->4 indicate the parent points to the SW, SE, !*** NW, and NE in that order. !----------------------------------------------------------------------- ! I_PARENT_SW=INT(REAL_I_PARENT) J_PARENT_SW=INT(REAL_J_PARENT) RLATD(1)=(J_PARENT_SW-ROW_0)*DPHD_PARENT !<-- Parent latitude (deg) of parent point SW of child point RLOND(1)=(I_PARENT_SW-COL_0)*DLMD_PARENT !<-- Parent longitude (deg) of parent point SW of child point ! I_PARENT_SE=I_PARENT_SW+1 J_PARENT_SE=J_PARENT_SW RLATD(2)=RLATD(1) !<-- SE and SW on same line of parent latitude RLOND(2)=RLOND(1)+DLMD_PARENT !<-- SE is one gridpoint east of SW parent point ! I_PARENT_NW=I_PARENT_SW J_PARENT_NW=J_PARENT_SW+1 RLATD(3)=RLATD(1)+DPHD_PARENT !<-- NW is one gridpoint north of SW parent point RLOND(3)=RLOND(1) !<-- NW and SW on same line of parent longitude ! I_PARENT_NE=I_PARENT_SE J_PARENT_NE=J_PARENT_NW RLATD(4)=RLATD(3) !<-- NE and NW on same line of parent latitude RLOND(4)=RLOND(2) !<-- NE and SE on same line of parent longitude ! SUM=0. ! DO N=1,4 !<-- Loop over SW, SE, NW, and NE parent points ! CALL DISTANCE_ON_SPHERE(CHILD_LATD_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint ,CHILD_LOND_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint ,RLATD(N)*DEG_TO_RAD & !<-- Latitude (deg) of surrounding parent point N ,RLOND(N)*DEG_TO_RAD & !<-- Longitude (deg) of surrounding parent point N ,DIST ) !<-- Distance (radians) from child point to parent point N ! WGT(N)=1./DIST SUM=SUM+WGT(N) ! ENDDO ! SUM_RECIP=1./SUM ! !----------------------------------------------------------------------- !*** The bilinear interpolation weights of the four parent points !*** surrounding the child point. !----------------------------------------------------------------------- ! WEIGHT_SW=WGT(1)*SUM_RECIP WEIGHT_SE=WGT(2)*SUM_RECIP WEIGHT_NW=WGT(3)*SUM_RECIP WEIGHT_NE=WGT(4)*SUM_RECIP ! IF(ABS(PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW,1))<1.E-12)WEIGHT_SW=0. IF(ABS(PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE,1))<1.E-12)WEIGHT_SE=0. IF(ABS(PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW,1))<1.E-12)WEIGHT_NW=0. IF(ABS(PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE,1))<1.E-12)WEIGHT_NE=0. WEIGHT_SUM=WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE WEIGHT_SUM_RECIP=1./WEIGHT_SUM ! DO L=1,NLEV NN=NN+1 ! CHILD_STRING(NN)=WEIGHT_SW*PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW,L) & !<-- Value at points on child's grid +WEIGHT_SE*PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE,L) & +WEIGHT_NW*PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW,L) & +WEIGHT_NE*PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE,L) ! IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN CHILD_STRING(NN)=CHILD_STRING(NN)*WEIGHT_SUM_RECIP !<-- Normalize if some weights are zero (e.g., coastal land Temp) ENDIF ! IF(VBL_NAME=='SeaMask')THEN IF(CHILD_STRING(NN)>=0.5)CHILD_STRING(NN)=1.0 IF(CHILD_STRING(NN)< 0.5)CHILD_STRING(NN)=0.0 ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Each parent task that contains a child grid point has now done !*** the horizontal interpolation of the parent variable to the child. !*** Now parent task 0 receives all the interpolated data from the !*** other parent tasks. !----------------------------------------------------------------------- ! data_fill: IF(MYPE==0)THEN ! !----------------------------------------------------------------------- ! remote_tasks: DO IPE=1,NUM_PES_PARENT-1 ! CALL MPI_RECV(NUM_POINTS_REMOTE & !<-- # of child points on parent task IPE ,1 & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! IF(NUM_POINTS_REMOTE==0)CYCLE remote_tasks ! NUM_IJ =2*NUM_POINTS_REMOTE NUM_DATA=NUM_POINTS_REMOTE*NLEV ! ALLOCATE(DATA_REMOTE(1:NUM_DATA)) ALLOCATE(IJ_REMOTE (1:NUM_IJ )) ! CALL MPI_RECV(DATA_REMOTE & !<-- Interpolated data on child grid from parent task IPE ,NUM_DATA & !<-- Total words received ,MPI_REAL & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! CALL MPI_RECV(IJ_REMOTE & !<-- Interpolated data on child grid from parent task IPE ,NUM_IJ & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! !----------------------------------------------------------------------- !*** Parent task 0 fills in section of child data from remote !*** parent task IPE. !----------------------------------------------------------------------- ! KOUNT=0 ! DO L=1,NLEV DO NIJ=1,NUM_POINTS_REMOTE KOUNT=KOUNT+1 I=IJ_REMOTE(2*NIJ-1) J=IJ_REMOTE(2*NIJ ) CHILD_ARRAY(I,J,L)=DATA_REMOTE(KOUNT) ENDDO ENDDO ! !----------------------------------------------------------------------- ! DEALLOCATE(DATA_REMOTE) DEALLOCATE(IJ_REMOTE) ! !----------------------------------------------------------------------- ! ENDDO remote_tasks ! !----------------------------------------------------------------------- !*** Finally parent task 0 fills in its own section of the child array. !----------------------------------------------------------------------- ! IF(NUM_CHILD_POINTS>0)THEN ! KOUNT=0 DO L=1,NLEV DO N=1,NUM_CHILD_POINTS KOUNT=KOUNT+1 I=CHILD_POINT_INDICES(2*N-1) J=CHILD_POINT_INDICES(2*N ) CHILD_ARRAY(I,J,L)=CHILD_STRING(KOUNT) ENDDO ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! ELSE data_fill ! !----------------------------------------------------------------------- !*** Remote parent tasks send their sections of interpolated child !*** data to parent task 0. !----------------------------------------------------------------------- ! CALL MPI_SEND(NUM_CHILD_POINTS & !<-- # of child points on this parent task ,1 & ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! IF(NUM_CHILD_POINTS>0)THEN NUM_IJ =2*NUM_CHILD_POINTS NUM_DATA=NUM_CHILD_POINTS*NLEV ! CALL MPI_SEND(CHILD_STRING & !<-- Interpolated data on child grid for this parent task ,NUM_DATA & !<-- Total words sent ,MPI_REAL & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! CALL MPI_SEND(CHILD_POINT_INDICES & !<-- Indices of child points for this parent task ,NUM_IJ & !<-- Total words sent ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF data_fill ! !----------------------------------------------------------------------- ! DEALLOCATE(CHILD_POINT_INDICES) DEALLOCATE(CHILD_STRING) ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_TO_CHILD_FILL_GENERAL !!! END SUBROUTINE PARENT_TO_CHILD_FILL ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE PARENT_TO_CHILD_IFILL_GENERAL(PARENT_ARRAY & !!! SUBROUTINE PARENT_TO_CHILD_IFILL (PARENT_ARRAY & ,VBL_NAME & ,CHILD_ARRAY) ! !----------------------------------------------------------------------- !*** Parent tasks interpolate their data to the locations of their !*** children's gridpoints. The child grids are unique rotated !*** lat/lon grids with their own centers. The southwest H point !*** of the child grid lies directly on an H point of the parent. ! !*** Only parent tasks participate in this work. !----------------------------------------------------------------------- ! USE module_CONSTANTS,ONLY: PI ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: & PARENT_ARRAY !<-- The parent array that will initialize the child array ! CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name ! INTEGER(kind=KINT),DIMENSION(1:IM_CHILD,1:JM_CHILD),INTENT(OUT) :: & CHILD_ARRAY !<-- Data from parent tasks interpolated to child grid ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,I_END,ISTART,J,J_END,JSTART & ,KOUNT,NIJ,NN,NTOT & ,NUM_DATA & ,NUM_CHILD_POINTS & ,NUM_IJ & ,NUM_POINTS_REMOTE ! INTEGER(kind=KINT) :: I_PARENT_SW,I_PARENT_SE & ,I_PARENT_NW,I_PARENT_NE & ,J_PARENT_SW,J_PARENT_SE & ,J_PARENT_NW,J_PARENT_NE ! INTEGER(kind=KINT) :: IERR,IPE,ISTAT ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: CHILD_POINT_INDICES & ,CHILD_STRING & ,DATA_REMOTE & ,IJ_REMOTE ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: CHILD_LATD_ON_PARENT & ,CHILD_LOND_ON_PARENT & ,DEG_TO_RAD & ,DIST & ,R_DLMD,R_DPHD & ,REAL_I_PARENT & ,REAL_J_PARENT & ,RLATD_SW,RLOND_SW & ,RLATD_SE,RLOND_SE & ,RLATD_NW,RLOND_NW & ,RLATD_NE,RLOND_NE & ,SUM,SUM_RECIP & ,WEIGHT_SW,WEIGHT_SE & ,WEIGHT_NW,WEIGHT_NE & ,WEIGHT_MAX ! REAL(kind=KFPT),DIMENSION(4) :: RLATD,RLOND,WGT ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! R_DPHD=1./DPHD_PARENT R_DLMD=1./DLMD_PARENT DEG_TO_RAD=PI/180. ! NUM_CHILD_POINTS=0 ! ISTART=1 JSTART=1 IF(GLOBAL)THEN ISTART=2 JSTART=2 ENDIF ! !----------------------------------------------------------------------- !*** Each parent task is responsible for searching the parent domain !*** extending from ITS and JTS to ITE+1 and JTE+1. Those latter +1's !*** are needed in order to reach the next gridpoint in each direction. !*** We cannot go outside the full domain of course. !----------------------------------------------------------------------- ! I_END=MIN(ITE+1,IDE) J_END=MIN(JTE+1,JDE) ! !----------------------------------------------------------------------- ! NTOT=2*IM_CHILD*JM_CHILD ALLOCATE(CHILD_POINT_INDICES(1:NTOT),stat=ISTAT) IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_POINT_INDICES in PARENT_TO_CHILD_IFILL_GENERAL' ! NTOT=IM_CHILD*JM_CHILD ALLOCATE(CHILD_STRING(1:NTOT),stat=ISTAT) IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_STRING in PARENT_TO_CHILD_IFILL_GENERAL' ! !----------------------------------------------------------------------- !*** Compute the parent's lat/lon of each child gridpoint in order to !*** determine if that gridpoint lies on a given parent task. !*** Save the I,J of each gridpoint found since ultimately parent !*** task 0 will need that to properly place all interpolated child !*** data onto the full child grid for writing out. !----------------------------------------------------------------------- ! NN=0 ! DO J=1,JM_CHILD DO I=1,IM_CHILD ! CALL CONVERT_IJ_TO_LATLON(I,J & !<-- A point on the child grid ,IM_CHILD,JM_CHILD & !<-- Dimensions of child grid ,TPH0D_CHILD,TLM0D_CHILD & !<-- Parent lat/lon (deg) of child grid central point ,DPHD_CHILD,DLMD_CHILD & !<-- Angular grid increments (deg) on child grid ,CHILD_LATD_ON_PARENT & !<-- Parent latitude of child point ,CHILD_LOND_ON_PARENT ) !<-- Parent longitude of child point ! REAL_I_PARENT=(CHILD_LOND_ON_PARENT-WBD_PARENT)*R_DLMD+ISTART !<-- REAL I index of child point on parent grid REAL_J_PARENT=(CHILD_LATD_ON_PARENT-SBD_PARENT)*R_DPHD+JSTART !<-- REAL J index of child point on parent grid ! !----------------------------------------------------------------------- ! IF(REAL(ITS)<=REAL_I_PARENT.AND.REAL(I_END)>REAL_I_PARENT.AND. & !<-- Is child gridpoint on this parent task? REAL(JTS)<=REAL_J_PARENT.AND.REAL(J_END)>REAL_J_PARENT)THEN !<-- ! NUM_CHILD_POINTS=NUM_CHILD_POINTS+1 !<-- Add up number of child points on this parent task ! CHILD_POINT_INDICES(2*NUM_CHILD_POINTS-1)=I !<-- Save I index of this child CHILD_POINT_INDICES(2*NUM_CHILD_POINTS )=J !<-- Save J index of this child point ! !----------------------------------------------------------------------- !*** Compute the distance from the child point location to each of !*** the four surrounding parent points and generate the bilinear !*** interpolation weights. !*** The indices 1-->4 indicate the parent points to the SW, SE, !*** NW, and NE in that order. !----------------------------------------------------------------------- ! I_PARENT_SW=INT(REAL_I_PARENT) J_PARENT_SW=INT(REAL_J_PARENT) RLATD(1)=(J_PARENT_SW-ROW_0)*DPHD_PARENT !<-- Parent latitude (deg) of parent point SW of child point RLOND(1)=(I_PARENT_SW-COL_0)*DLMD_PARENT !<-- Parent longitude (deg) of parent point SW of child point ! I_PARENT_SE=I_PARENT_SW+1 J_PARENT_SE=J_PARENT_SW RLATD(2)=RLATD(1) !<-- SE and SW on same line of parent latitude RLOND(2)=RLOND(1)+DLMD_PARENT !<-- SE is one gridpoint east of SW parent point ! I_PARENT_NW=I_PARENT_SW J_PARENT_NW=J_PARENT_SW+1 RLATD(3)=RLATD(1)+DPHD_PARENT !<-- NW is one gridpoint north of SW parent point RLOND(3)=RLOND(1) !<-- NW and SW on same line of parent longitude ! I_PARENT_NE=I_PARENT_SE J_PARENT_NE=J_PARENT_NW RLATD(4)=RLATD(3) !<-- NE and NW on same line of parent latitude RLOND(4)=RLOND(2) !<-- NE and SE on same line of parent longitude ! SUM=0. ! DO N=1,4 !<-- Loop over SW, SE, NW, and NE parent points ! CALL DISTANCE_ON_SPHERE(CHILD_LATD_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint ,CHILD_LOND_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint ,RLATD(N)*DEG_TO_RAD & !<-- Latitude (deg) of surrounding parent point N ,RLOND(N)*DEG_TO_RAD & !<-- Longitude (deg) of surrounding parent point N ,DIST ) !<-- Distance (radians) from child point to parent point N ! WGT(N)=1./DIST SUM=SUM+WGT(N) ! ENDDO ! SUM_RECIP=1./SUM ! !----------------------------------------------------------------------- !*** The bilinear interpolation weights of the four parent points !*** surrounding the child point. !----------------------------------------------------------------------- ! WEIGHT_SW=WGT(1)*SUM_RECIP WEIGHT_SE=WGT(2)*SUM_RECIP WEIGHT_NW=WGT(3)*SUM_RECIP WEIGHT_NE=WGT(4)*SUM_RECIP WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE,WEIGHT_NW,WEIGHT_NE) ! !----------------------------------------------------------------------- !*** Using the bilinear interpolation weights, assign the value of !*** the nearest parent point to the child point. !----------------------------------------------------------------------- ! NN=NN+1 ! IF(WEIGHT_SW==WEIGHT_MAX)THEN CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW) ! write(0,*)' SW parent=',PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW),' nn=',nn,' i=',i,' j=',j ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE) ! write(0,*)' SE parent=',PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE),' nn=',nn,' i=',i,' j=',j ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW) ! write(0,*)' NW parent=',PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW),' nn=',nn,' i=',i,' j=',j ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE) ! write(0,*)' NE parent=',PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE),' nn=',nn,' i=',i,' j=',j ENDIF ! if(i==01.and.j==01.and.vbl_name=='ISLTYP')then ! write(0,*)' parent interp value to ISLTYP is ',CHILD_STRING(NN),' nn=',nn ! endif ! if(vbl_name=='ISLTYP'.and.child_string(nn)<1.and.sea_mask(i,j)<0.5)then ! write(0,*)' Parent creating bad value of ISLTYP=',CHILD_STRING(NN),' nn=',nn,' i=',i,' j=',j & ! ,' SeaMask=',sea_mask(i,j) ! endif ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Each parent task that contains a child grid point has now done !*** the horizontal interpolation of the parent variable to the child. !*** Now parent task 0 receives all the interpolated data from the !*** other parent tasks. !----------------------------------------------------------------------- ! data_fill: IF(MYPE==0)THEN ! !----------------------------------------------------------------------- ! remote_tasks: DO IPE=1,NUM_PES_PARENT-1 ! CALL MPI_RECV(NUM_POINTS_REMOTE & !<-- # of child points on parent task IPE ,1 & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! IF(NUM_POINTS_REMOTE==0)CYCLE remote_tasks ! NUM_IJ =2*NUM_POINTS_REMOTE NUM_DATA=NUM_POINTS_REMOTE ! ALLOCATE(DATA_REMOTE(1:NUM_DATA)) ALLOCATE(IJ_REMOTE (1:NUM_IJ )) ! CALL MPI_RECV(DATA_REMOTE & !<-- Interpolated data on child grid from parent task IPE ,NUM_DATA & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! CALL MPI_RECV(IJ_REMOTE & !<-- Interpolated data on child grid from parent task IPE ,NUM_IJ & !<-- Total words received ,MPI_INTEGER & !<-- Datatype ,IPE & !<-- Receive from this parent task ,IPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,JSTAT & !<-- MPI status object ,IERR ) ! !----------------------------------------------------------------------- !*** Parent task 0 fills in section of child data from remote !*** parent task IPE. !----------------------------------------------------------------------- ! KOUNT=0 ! DO NIJ=1,NUM_POINTS_REMOTE KOUNT=KOUNT+1 I=IJ_REMOTE(2*NIJ-1) J=IJ_REMOTE(2*NIJ ) CHILD_ARRAY(I,J)=DATA_REMOTE(KOUNT) ! write(0,*)' new child i=',i,' j=',j,' kount=',kount,' data=',data_remote(kount) ! if(vbl_name=='ISLTYP'.and.i==01.and.j==01)then ! write(0,*)' parent fills ISLTYP with ',DATA_REMOTE(KOUNT),' kount=',kount ! endif ENDDO ! !----------------------------------------------------------------------- ! DEALLOCATE(DATA_REMOTE) DEALLOCATE(IJ_REMOTE) ! !----------------------------------------------------------------------- ! ENDDO remote_tasks ! !----------------------------------------------------------------------- !*** Finally parent task 0 fills in its own section of the child array. !----------------------------------------------------------------------- ! IF(NUM_CHILD_POINTS>0)THEN ! KOUNT=0 DO N=1,NUM_CHILD_POINTS KOUNT=KOUNT+1 I=CHILD_POINT_INDICES(2*N-1) J=CHILD_POINT_INDICES(2*N ) CHILD_ARRAY(I,J)=CHILD_STRING(KOUNT) ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! ELSE data_fill ! !----------------------------------------------------------------------- !*** Remote parent tasks send their sections of interpolated child !*** data to parent task 0. !----------------------------------------------------------------------- ! CALL MPI_SEND(NUM_CHILD_POINTS & !<-- # of child points on this parent task ,1 & ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! IF(NUM_CHILD_POINTS>0)THEN NUM_IJ =2*NUM_CHILD_POINTS NUM_DATA=NUM_CHILD_POINTS ! CALL MPI_SEND(CHILD_STRING & !<-- Interpolated data on child grid for this parent task ,NUM_DATA & !<-- Total words sent ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! CALL MPI_SEND(CHILD_POINT_INDICES & !<-- Indices of child points for this parent task ,NUM_IJ & !<-- Total words sent ,MPI_INTEGER & !<-- Datatype ,0 & !<-- Send to parent task 0 ,MYPE & !<-- MPI tag ,COMM_MY_DOMAIN & !<-- The MPI communicator ,IERR ) ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF data_fill ! !----------------------------------------------------------------------- ! DEALLOCATE(CHILD_POINT_INDICES) DEALLOCATE(CHILD_STRING) ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_TO_CHILD_IFILL_GENERAL !!! END SUBROUTINE PARENT_TO_CHILD_IFILL ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_TO_CHILD_INIT_NMM ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE CONVERT_IJ_TO_LATLON (I_INDEX & ,J_INDEX & ,IM & ,JM & ,TPH0D & ,TLM0D & ,DPHD & ,DLMD & ,RLATD & ,RLOND) ! !----------------------------------------------------------------------- !*** Given the (I,J) of mass points on an Arakawa B-Grid, !*** compute the latitudes and longitudes before rotation. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_INDEX & !<-- I value on the grid ,J_INDEX & !<-- J value on the grid ,IM & !<-- Full I dimension ,JM !<-- Full J dimension ! REAL(kind=KFPT),INTENT(IN) :: DPHD & !<-- Latitude grid increment (degrees) ,DLMD & !<-- Longitude grid increment (degrees) ,TPH0D & ! Central latitude (deg, positive north), unrotated system ,TLM0D ! Central longitude (deg, positive east), unrotated system ! REAL(kind=KFPT),INTENT(OUT) :: RLATD & !<-- Latitude (deg, positive north) of point, unrotated system ,RLOND !<-- Longitude (deg, positive east) of point, unrotated system ! !----------------------------------------------------------------------- ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,IEND,ISTART,J,JEND,JSTART ! REAL(kind=KDBL) :: ARG1,ARG2,COL_MID,D2R,FCTR,GLATR,GLATD,GLOND & ,HALF,ONE,PI,R2D,ROW_MID,TLATD,TLOND & ,TLATR,TLONR,TLM0,TPH0 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- !*** Convert from transformed grid location (I,J) !*** to geographic coordinates (degrees). !----------------------------------------------------------------------- ! ONE=1.0 HALF=1./2. PI=DACOS(-ONE) D2R=PI/180. R2D=1./D2R TPH0=TPH0D*D2R TLM0=TLM0D*D2R ! ROW_MID=(JM+ONE)*HALF COL_MID=(IM+ONE)*HALF ! !----------------------------------------------------------------------- ! J=J_INDEX I=I_INDEX ! !----------------------------------------------------------------------- !*** Find the rotated latitude (positive north) and !*** longitude (positive east). !----------------------------------------------------------------------- ! TLATD=(J-ROW_MID)*DPHD TLOND=(I-COL_MID)*DLMD ! ! WRITE(0,50)I,J,TLATD,TLOND 50 FORMAT(' I=',I4,' J=',I4,' ROTATED LATITUDE IS',F8.3 & ,4X,'LONGITUDE IS',F8.3) ! !----------------------------------------------------------------------- !*** Now convert to geographic latitude (positive north) and !*** longitude (positive west) in degrees. !----------------------------------------------------------------------- ! TLATR=TLATD*D2R TLONR=TLOND*D2R ARG1=SIN(TLATR)*COS(TPH0)+COS(TLATR)*SIN(TPH0)*COS(TLONR) GLATR=ASIN(ARG1) ! GLATD=GLATR*R2D ! ARG2=DCOS(TLATR)*DCOS(TLONR)/(DCOS(GLATR)*DCOS(TPH0))- & DTAN(GLATR)*DTAN(TPH0) IF(ABS(ARG2)>1.)ARG2=ABS(ARG2)/ARG2 FCTR=1. IF(TLOND>0.)FCTR=1. IF(TLOND>180.)FCTR=-1. ! GLOND=-TLM0D+FCTR*DACOS(ARG2)*R2D ! ! WRITE(6,100)I,J,GLATD,GLOND 100 FORMAT(' I=',I3,' J=',I3 & ,' PARENT LATITUDE=',F9.5,' LONGITUDE=',F10.5) !----------------------------------------------------------------------- ! RLATD=GLATD RLOND=-GLOND IF(RLOND<-180.)RLOND=RLOND+360. ! !----------------------------------------------------------------------- ! END SUBROUTINE CONVERT_IJ_TO_LATLON ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE REAL_IJ_TO_LATLON (I_INDEX & ,J_INDEX & ,IM & ,JM & ,TPH0 & ,TLM0 & ,DPH & ,DLM & ,RLAT & ,RLON ) ! !----------------------------------------------------------------------- !*** Given the (I,J) of mass points on an Arakawa B-Grid, compute !*** the latitudes and longitudes on the given projection. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IM & !<-- Full I dimension ,JM !<-- Full J dimension ! REAL(kind=KFPT),INTENT(IN) :: I_INDEX & !<-- Real I value on the grid ,J_INDEX & !<-- Real J value on the grid ,DPH & !<-- Latitude grid increment (radians) ,DLM & !<-- Longitude grid increment (radians) ,TPH0 & !<-- Central latitude (rad, positive north) of projection ,TLM0 !<-- Central longitude (rad, positive east) of projection ! REAL(kind=KFPT),INTENT(OUT) :: RLAT & !<-- Latitude (rad, positive north) of point on projection ,RLON !<-- Longitude (rad, positive east) of point on projection ! !----------------------------------------------------------------------- ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,IEND,ISTART,J,JEND,JSTART ! REAL(kind=KDBL) :: ARG1,ARG2,COL_MID,FCTR,GLATR,GLATD,GLOND & ,HALF,ONE,PI,R2D,ROW_MID,TLAT,TLON ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- !*** Convert from transformed grid location (I,J) !*** to geographic coordinates (degrees). !----------------------------------------------------------------------- ! ONE=1.0 HALF=1./2. PI=DACOS(-ONE) R2D=180./PI ! ROW_MID=(JM+ONE)*HALF COL_MID=(IM+ONE)*HALF ! !----------------------------------------------------------------------- ! J=J_INDEX I=I_INDEX ! !----------------------------------------------------------------------- !*** Find the rotated latitude (positive north) and !*** longitude (positive east). !----------------------------------------------------------------------- ! TLAT=(J-ROW_MID)*DPH TLON=(I-COL_MID)*DLM ! ! WRITE(0,50)I,J,TLAT*R2D,TLOND*R2D 50 FORMAT(' I=',I4,' J=',I4,' Projection latitude=',F8.3 & ,4X,'longitude=',F8.3) ! !----------------------------------------------------------------------- !*** Now convert to geographic latitude (positive north) and !*** longitude (positive west) in degrees. !----------------------------------------------------------------------- ! ARG1=DSIN(TLAT)*COS(TPH0)+DCOS(TLAT)*SIN(TPH0)*DCOS(TLON) RLAT=ASIN(ARG1) ! ARG2=DCOS(TLAT)*DCOS(TLON)/(DCOS(TLAT)*COS(TPH0))- & DTAN(TLAT)*TAN(TPH0) IF(ABS(ARG2)>1.)ARG2=ABS(ARG2)/ARG2 FCTR=1. IF(TLON>0.)FCTR=1. IF(TLON>PI)FCTR=-1. ! RLON=-TLM0+FCTR*DACOS(ARG2) RLON=-RLON IF(RLON<-PI)RLON=RLON+PI*2. ! ! WRITE(6,100)I,J,RLAT*R2D,RLON*R2D 100 FORMAT(' I=',I4,' J=',I4 & ,' Geographic latitude=',F9.5,' longitude=',F10.5) ! !----------------------------------------------------------------------- ! END SUBROUTINE REAL_IJ_TO_LATLON ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE GEO_TO_ROT_LATLON(GLAT,GLON,TPH0,TLM0 & ,RLAT,RLON ) ! !----------------------------------------------------------------------- !*** Convert from geographic coordinates to latitude/longitude on !*** a rotated projection. !----------------------------------------------------------------------- ! USE module_CONSTANTS,ONLY: PI ! !------------------------ !*** Argument Variables !------------------------ ! REAL(kind=KFPT),INTENT(IN) :: GLAT,GLON & !<-- Geographic lat/lon (rad, +east) of point ,TPH0,TLM0 !<-- Geographic lat/lon (rad, +east) of projection center ! REAL(kind=KFPT),INTENT(OUT) :: RLAT,RLON !<-- Lat/lon (rad) of point on the projection ! !----------------------------------------------------------------------- ! !-------------------- !*** Local Variables !-------------------- ! REAL(kind=KFPT) :: X,Y,Z ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT) Y=COS(GLAT)*SIN(GLON-TLM0) Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0) RLAT=ATAN(Z/SQRT(X*X+Y*Y)) RLON=ATAN(Y/X) IF(X<0.)THEN RLON=RLON+PI ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE GEO_TO_ROT_LATLON ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE DISTANCE_ON_SPHERE(RLAT_1,RLON_1 & ,RLAT_2,RLON_2 & ,DISTANCE ) ! !----------------------------------------------------------------------- !*** Compute the great circle distance between two points on the !*** spherical earth. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! REAL(kind=KFPT),INTENT(IN) :: RLAT_1,RLON_1 & !<-- Lat/lon (rad, +east) of point 1 ,RLAT_2,RLON_2 !<-- Lat/lon (rad, +east) of point 2 ! REAL(kind=KFPT),INTENT(OUT) :: DISTANCE !<-- Distance (radians) between points 1 and 2 ! !----------------------------------------------------------------------- ! !-------------------- !*** Local Variables !-------------------- ! REAL(kind=KDBL) :: ALPHA,ARG,BETA,CROSS,DLON,PI_H ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! PI_H=ACOS(0.) ! !----------------------------------------------------------------------- ! DLON=RLON_2-RLON_1 ! CROSS=ACOS(COS(DLON)*COS(RLAT_2)) ARG=TAN(RLAT_2)/SIN(DLON) ALPHA=ATAN(ARG) IF(DLON<0.)ALPHA=-ALPHA BETA=PI_H-ALPHA ! DISTANCE=ACOS(COS(RLAT_1)*COS(RLAT_2)*COS(DLON) & +SIN(RLAT_1)*SIN(CROSS)*COS(BETA)) ! !----------------------------------------------------------------------- ! END SUBROUTINE DISTANCE_ON_SPHERE ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- SUBROUTINE CENTER_NEST(SBD_DOMAIN & ,WBD_DOMAIN & ,SW_CORNER_LATD & ,SW_CORNER_LOND & ,TPH0D_DOMAIN & ,TLM0D_DOMAIN ) !----------------------------------------------------------------------- !*** Given the southern and western boundaries of a rotated lat/lon !*** grid as well as the coordinates of the southwest corner point, !*** find the coordinates of the grid's central point with respect !*** to the grid upon which the rotated grid lies. !----------------------------------------------------------------------- ! !--------------- !*** Arguments !--------------- ! REAL(kind=KFPT),INTENT(IN) :: SBD_DOMAIN & !<-- Latitude (deg) of domain's southern boundary ,WBD_DOMAIN & !<-- Longitude (deg, +east) of domain's western boundary ,SW_CORNER_LATD & !<-- Latitude (deg) of domain's southwest corner point ,SW_CORNER_LOND !<-- Longitude (deg, +east) of domain's southwest corner point ! REAL(kind=KFPT),INTENT(OUT) :: TPH0D_DOMAIN & !<-- Latitude (deg) of domain's center ,TLM0D_DOMAIN !<-- Longitude (deg) of domain's center ! !----------------------------------------------------------------------- ! !--------------------- !*** Local Variables !--------------------- ! REAL(kind=KFPT) :: ALPHA,BETA,CENTRAL_LAT,CENTRAL_LON & ,DEG_RAD,DELTA,GAMMA & ,PI_2,SB_R,SIDE1,SIDE2,SIDE3,SIDE4,SIDE5 & ,SW_LAT,SW_LON,WB_R ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! PI_2=ACOS(0.) DEG_RAD=PI_2/90. ! !----------------------------------------------------------------------- !*** Southern and western boundaries of the rotated domain in radians. !----------------------------------------------------------------------- ! SB_R=-SBD_DOMAIN*DEG_RAD WB_R=-WBD_DOMAIN*DEG_RAD ! !----------------------------------------------------------------------- !*** Southwest corner of the domain in radians. !----------------------------------------------------------------------- ! SW_LAT=SW_CORNER_LATD*DEG_RAD SW_LON=SW_CORNER_LOND*DEG_RAD ! !----------------------------------------------------------------------- !*** SIDE1 is the arc from the southwest corner to the center !*** of the domain. !----------------------------------------------------------------------- ! SIDE1=ACOS(COS(SB_R)*COS(WB_R)) ! !----------------------------------------------------------------------- !*** ALPHA is the angle between SIDE1 and the domain's equator west of !*** the central point. !----------------------------------------------------------------------- ! ALPHA=ATAN(TAN(SB_R)/SIN(WB_R)) ! !----------------------------------------------------------------------- !*** BETA is the angle between SIDE1 and the domain's prime meridian !*** south of the central point. !----------------------------------------------------------------------- ! BETA=PI_2-ALPHA ! !----------------------------------------------------------------------- !*** SIDE2 is the arc from the central point southward along the !*** domain's prime meridian to the great circle that intersects !*** both the SW and SE corners of the domain. !----------------------------------------------------------------------- ! SIDE2=ATAN(COS(BETA)*TAN(SIDE1)) ! !----------------------------------------------------------------------- !*** SIDE3 is the arc between the domain's prime meridian and the SW !*** corner along the great circle that connects the domain's SW and !*** SE corners. !----------------------------------------------------------------------- ! SIDE3=ASIN(SIN(BETA)*SIN(SIDE1)) ! !----------------------------------------------------------------------- !*** SIDE4 is the arc along the outer grid's equator that lies between !*** its western intersection with the above mentioned great circle !*** and the outer grid's meridian that passes through the domain's !*** SW corner. !----------------------------------------------------------------------- ! SIDE4=ACOS(SIN(SIDE3)/COS(SW_LAT)) ! !----------------------------------------------------------------------- !*** GAMMA is the angle between the outer grid's equator and the arc !*** that connects the domain's SW corner with the point where the !*** domain's central meridian crosses the outer grid's equator. !----------------------------------------------------------------------- ! GAMMA=ATAN(TAN(SW_LAT)/COS(SIDE4)) ! !----------------------------------------------------------------------- !*** DELTA is the angle between the arc that connects the domain's SW !*** corner with the point where the domain's central meridian crosses !*** the outer grid's equator and the domain's central meridian itself. !----------------------------------------------------------------------- ! DELTA=PI_2-GAMMA ! !----------------------------------------------------------------------- !*** SIDE5 is the arc along the domain's central meridian that lies !*** between the outer grid's equator and the great circle that passes !*** through the SW and SE corners of the domain. !----------------------------------------------------------------------- ! SIDE5=ASIN(TAN(SIDE3)/TAN(DELTA)) ! !----------------------------------------------------------------------- !*** The central latitude and longitude of the domain in terms of !*** the coordinates of the outer grid. !----------------------------------------------------------------------- ! CENTRAL_LAT=SIDE2+SIDE5 CENTRAL_LON=SW_LON+PI_2-SIDE4 ! TPH0D_DOMAIN=CENTRAL_LAT/DEG_RAD TLM0D_DOMAIN=CENTRAL_LON/DEG_RAD ! !----------------------------------------------------------------------- ! END SUBROUTINE CENTER_NEST ! !----------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !----------------------------------------------------------------------- ! SUBROUTINE SET_NEST_GRIDS(DOMAIN_ID_MINE & ,TPH0D,TLM0D & !!! ,SBD_MINE,WBD_MINE & ,DPHD_MINE,DLMD_MINE) ! !----------------------------------------------------------------------- !*** Basic grid characteristics for nests are based upon those of !*** the uppermost parent grid. Use those parent values to compute !*** appropriate analogs for the nests. !*** This subroutine is relevant only to grid-associated nests. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: DOMAIN_ID_MINE !<-- Domain ID for this nested domain ! REAL(kind=KFPT),INTENT(OUT) :: DPHD_MINE & !<-- Delta phi of this nested domain (degrees) ,DLMD_MINE & !<-- Delta lambda of this nested domain (degrees) ,TLM0D & !<-- Central rotated longitude of all domains (degrees) ,TPH0D !<-- Central rotated latitude of all domains (degrees) !!! ,SBD_MINE & !<-- Southern boundary this nested domain (degrees) !!! ,WBD_MINE !<-- Western boundary this nested domain (degrees) ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT),PARAMETER :: MAX_DOMAINS=99 ! INTEGER(kind=KINT) :: IM_1,JM_1 & ,ID_ANCESTOR,ID_DOMAIN & ,IDE_1,JDE_1 & ,I_BOUND,J_BOUND & ,I_PARENT_SW,J_PARENT_SW & ,I_START_SW,J_START_SW & ,N,NUM_ANCESTORS ! INTEGER(kind=KINT) :: RC,RC_SET ! INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS) :: ID_ANCESTORS=0 ! INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS) :: PARENT_CHILD_SPACE_RATIO ! INTEGER(kind=KINT),DIMENSION(2,MAX_DOMAINS) :: SW_CORNER ! REAL(kind=KFPT) :: DPHD_1,DLMD_1,TLM_BASE_1,TPH_BASE_1,SBD_1,WBD_1 REAL(kind=KFPT) :: DPHD_X,DLMD_X,TLM_BASE,TPH_BASE,SBD_X,WBD_X ! CHARACTER(2) :: INT_TO_CHAR CHARACTER(6) :: FMT='(I2.2)' CHARACTER(50) :: GLOBAL CHARACTER(99) :: CONFIG_FILE_NAME ! TYPE(ESMF_Config),DIMENSION(MAX_DOMAINS) :: CF ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_SET=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** First load all of the domains' configure files. !----------------------------------------------------------------------- ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !******* See NMM_ATM_INIT where !******* CF(N) is made to be !******* CF(ID of domain). !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! DO N=1,MAX_DOMAINS CF(N)=ESMF_ConfigCreate(rc=RC) ! WRITE(INT_TO_CHAR,FMT)N CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file names ! CALL ESMF_ConfigLoadFile(config =CF(N) & ,filename=CONFIG_FILE_NAME & ,rc =RC) IF(RC/=0)EXIT !<-- Exit loop after running out of config files ENDDO ! !----------------------------------------------------------------------- !*** We must loop through the configure files of all of the current !*** domain's ancestors to collect information needed to properly !*** describe the current grid. This is necessary because all !*** grids' rows and columns lie parallel to those of the uppermost !*** grid. !----------------------------------------------------------------------- ! ID_DOMAIN=DOMAIN_ID_MINE ! N=0 ! !----------------------------------------------------------------------- main_loop: DO !----------------------------------------------------------------------- ! N=N+1 ! !----------------------------- !*** Domain IDs of Ancestors !----------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Domain ID of Ancestor" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object ,value =ID_ANCESTOR & !<-- The variable filled ,label ='my_parent_id:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !-------------------------------------- !*** SW Corner Locations on Ancestors !-------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Get SW Corner I and J on Ancestor Grid" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object ,value =I_START_SW & !<-- The variable filled ,label ='i_parent_start:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object ,value =J_START_SW & !<-- The variable filled ,label ='j_parent_start:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !---------------------------- !*** Parent-to-Child Ratios !---------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Child-to-Parent Ratio of Ancestor" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object ,value =PARENT_CHILD_SPACE_RATIO(N) & !<-- The variable filled ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ID_ANCESTORS(N)=ID_ANCESTOR !<-- Store domain IDs of all ancestors SW_CORNER(1,N)=I_START_SW !<-- Store parent I of SW corner of its child SW_CORNER(2,N)=J_START_SW !<-- Store parent J of SW corner of its child ! IF(ID_ANCESTOR==1)EXIT !<-- We have reached the uppermost domain ! ID_DOMAIN=ID_ANCESTOR ! !----------------------------------------------------------------------- ! ENDDO main_loop ! !----------------------------------------------------------------------- ! NUM_ANCESTORS=N !<-- How many ancestors are there? ! !----------------------------------------------------------------------- !*** Rows and columns of all nests' grids lie parallel to those of !*** uppermost parent grid. Thus the central rotated latitude and !*** longitude of all nests must be those of the uppermost domain. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Central Lat/Lon of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,value =TPH0D & !<-- The variable filled ,label ='tph0d:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,value =TLM0D & !<-- The variable filled ,label ='tlm0d:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Get dimensions of uppermost domain as the baseline. !*** We must also know southern and western boundary locations !*** as well as whether it is global or not. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Baseline Dimensions of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,value =IM_1 & !<-- The variable filled ,label ='im:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,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_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Southern/Western Boundary of Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,value =SBD_1 & !<-- The variable filled ,label ='sbd:' & !<-- Give this label's value to the previous variable ,rc =RC) ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,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_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Global Flag for Uppermost Domain" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object ,value =GLOBAL & !<-- The variable filled ,label ='global:' & !<-- Give this label's value to the previous variable ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Full grid dimensions; delta phi and delta lambda !*** for uppermost domain. !----------------------------------------------------------------------- ! IF(TRIM(GLOBAL)=='true')THEN !<-- Uppermost domain is global IDE_1=IM_1+2 JDE_1=JM_1+2 DPHD_1=-SBD_1*2./REAL(JDE_1-3) DLMD_1=-WBD_1*2./REAL(IDE_1-3) TPH_BASE_1=SBD_1-2.*DPHD_1 TLM_BASE_1=WBD_1-2.*DLMD_1 ELSE !<-- Uppermost domain is regional IDE_1=IM_1 JDE_1=JM_1 DPHD_1=-SBD_1*2./REAL(JDE_1-1) DLMD_1=-WBD_1*2./REAL(IDE_1-1) TPH_BASE_1=SBD_1-DPHD_1 TLM_BASE_1=WBD_1-DLMD_1 ENDIF ! !----------------------------------------------------------------------- !*** Loop through this nest's ancestors in order to obtain its: !*** (1) delta phi and delta lambda !*** (2) southern/western boundary locations ! !*** We must work downward through the ancestors because !*** the uppermost domain is the foundation. !----------------------------------------------------------------------- ! DPHD_X=DPHD_1 DLMD_X=DLMD_1 TPH_BASE=TPH_BASE_1 TLM_BASE=TLM_BASE_1 ! !----------------------------------------------------------------------- ! work_loop: DO N=NUM_ANCESTORS,1,-1 ! I_START_SW=SW_CORNER(1,N) J_START_SW=SW_CORNER(2,N) ! SBD_X=TPH_BASE+J_START_SW*DPHD_X !<-- Southern boundary of ancestor N WBD_X=TLM_BASE+I_START_SW*DLMD_X !<-- Western boundary of ancestor N ! DPHD_X=DPHD_X/REAL(PARENT_CHILD_SPACE_RATIO(N)) !<-- Delta phi for child of ancestor N DLMD_X=DLMD_X/REAL(PARENT_CHILD_SPACE_RATIO(N)) !<-- Delta lambda for child of ancestor N ! TPH_BASE=SBD_X-DPHD_X TLM_BASE=WBD_X-DLMD_X ! ENDDO work_loop ! DPHD_MINE=DPHD_X DLMD_MINE=DLMD_X !!! SBD_MINE=SBD_X !!! WBD_MINE=WBD_X ! !----------------------------------------------------------------------- ! END SUBROUTINE SET_NEST_GRIDS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE WATERFALLS(FIS & ,SEA_MASK & ,LOWER_TOPO & ,IDS,IDE,JDS,JDE) ! !----------------------------------------------------------------------- !*** When a parent initializes its child, the sea mask had to be done !*** with nearest neighbor logic while FIS should be done bilinearly. !*** This can lead to adjacent water points having different values !*** of FIS. when that is the case, make the elevation of all !*** adjacent water points equal to the lowest of their values. !*** Save the I,J of all lowered points so the atmospheric column !*** can ultimately be adjusted. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE !<-- Lateral dimensions of nest grid ! REAL(kind=KFPT),DIMENSION(IDS:IDE,JDS:JDE),INTENT(IN) :: SEA_MASK !<-- Sea mask of nest grid points ! REAL(kind=KFPT),DIMENSION(IDS:IDE,JDS:JDE,1),INTENT(INOUT) :: FIS !<-- Sfc geopotential on nest grid points ! LOGICAL(kind=KLOG),DIMENSION(IDS:IDE,JDS:JDE),INTENT(OUT) :: & LOWER_TOPO !<-- Flag points where topography is lowered ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I,ITER,J,KOUNT_CHANGE ! REAL(kind=KFPT) :: FIS_0 & ,FIS_E,FIS_N,FIS_W,FIS_S & ,FIS_NE,FIS_NW,FIS_SW,FIS_SE & ,FIS_NEW ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! iter_loop: DO ITER=1,500 ! KOUNT_CHANGE=0 ! !----------------------------------------------------------------------- ! DO J=JDS,JDE DO I=IDS,IDE ! IF(SEA_MASK(I,J)<0.01)CYCLE !<-- We are adjusting only water points ! !----------------------------------------------------------------------- ! FIS_0=FIS(I,J,1) ! !---------- !*** East !---------- ! FIS_E=FIS_0 ! IF(I+1<=IDE)THEN IF(SEA_MASK(I+1,J)>0.99)FIS_E=FIS(I+1,J,1) ENDIF ! !--------------- !*** Northeast !--------------- ! FIS_NE=FIS_0 ! IF(I+1<=IDE.AND.J+1<=JDE)THEN IF(SEA_MASK(I+1,J+1)>0.99)FIS_NE=FIS(I+1,J+1,1) ENDIF ! !----------- !*** North !----------- ! FIS_N=FIS_0 ! IF(J+1<=JDE)THEN IF(SEA_MASK(I,J+1)>0.99)FIS_N=FIS(I,J+1,1) ENDIF ! !--------------- !*** Northwest !--------------- ! FIS_NW=FIS_0 ! IF(I-1>=IDS.AND.J+1<=JDE)THEN IF(SEA_MASK(I-1,J+1)>0.99)FIS_NW=FIS(I-1,J+1,1) ENDIF ! !---------- !*** West !---------- ! FIS_W=FIS_0 ! IF(I-1>=IDS)THEN IF(SEA_MASK(I-1,J)>0.99)FIS_W=FIS(I-1,J,1) ENDIF ! !--------------- !*** Southwest !--------------- ! FIS_SW=FIS_0 ! IF(I-1>=IDS.AND.J-1>=JDS)THEN IF(SEA_MASK(I-1,J-1)>0.99)FIS_SW=FIS(I-1,J-1,1) ENDIF ! !----------- !*** South !----------- ! FIS_S=FIS_0 ! IF(J-1>=JDS)THEN IF(SEA_MASK(I,J-1)>0.99)FIS_S=FIS(I,J-1,1) ENDIF ! !--------------- !*** Southeast !--------------- ! FIS_SE=FIS_0 ! IF(I+1<=IDE.AND.J-1>=JDS)THEN IF(SEA_MASK(I+1,J-1)>0.99)FIS_SE=FIS(I+1,J-1,1) ENDIF ! !----------------------------------------------------------------------- !*** Lower the point in question to the lowest value of itself and !*** its neighbors if it is a water point. !*** Also save all I,J locations where FIS is changed so that we !*** can adjust the atmospheric column appropriately later. !----------------------------------------------------------------------- ! FIS_NEW=MIN(FIS_0 & ,FIS_E,FIS_N,FIS_W,FIS_E & ,FIS_NE,FIS_NW,FIS_SW,FIS_SE) ! IF(FIS_NEW+0.10)THEN ! !----------------------------------------------------------------------- ! parent_tasks: DO N=1,NUM_PTASK_UPDATE ! !----------------------------------------------------------------------- ! WRITE(N_PTASK,'(I1)')N ! NAME_INTEGER='PTASK_INTEGER_DATA_'//N_PTASK NAME_REAL ='PTASK_REAL_DATA_'//N_PTASK NAME ='PTASK_DATA_'//N_PTASK ! !----------------------------------------------------------------------- ! !------------ !*** Integer !------------ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload # of Words in Integer Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State ,name =NAME_INTEGER//' Words' & !<-- Name of the variable ,value=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load # of Words in Integer Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State ,name =NAME_INTEGER//' Words' & !<-- Name of the variable ,value=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! transfer_int: IF(NUM_INTEGER_WORDS>0)THEN ! !----------------------------------------------------------------------- ! ALLOCATE(UPDATE_INTEGER_DATA(1:NUM_INTEGER_WORDS)) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload Interior Integer Update Data from Input State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State ,name =NAME_INTEGER & !<-- Name of the variable ,itemCount=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Interior Integer Update Data into Output State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State ,name =NAME_INTEGER & !<-- Name of the variable ,itemCount=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(UPDATE_INTEGER_DATA) ! !----------------------------------------------------------------------- ! ENDIF transfer_int ! !----------------------------------------------------------------------- ! !---------- !*** Real !---------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload # of Words in Real Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State ,name =NAME_REAL//' Words' & !<-- Name of the variable ,value=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load # of Words in Real Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State ,name =NAME_REAL//' Words' & !<-- Name of the variable ,value=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ALLOCATE(UPDATE_REAL_DATA(1:NUM_REAL_WORDS)) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload Interior Real Update Data from Input State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State ,name =NAME_REAL & !<-- Name of the variable ,itemCount=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task ,valueList=UPDATE_REAL_DATA & !<-- The real update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Interior Real Update Data into Output State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State ,name =NAME_REAL & !<-- Name of the variable ,itemCount=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task ,valueList=UPDATE_REAL_DATA & !<-- The real update data from Nth parent task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(UPDATE_REAL_DATA) ! !----------------------------------------------------------------------- !*** Transfer the H and V loop limits for the nest update regions. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload Index Limits for H Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State ,name =NAME//' Indices H' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_H & !<-- The update data index specifications for H ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Index Limits for H Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State ,name =NAME//' Indices H' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_H & !<-- The update data index specifications for H ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Unload Index Limits for V Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State ,name =NAME//' Indices V' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_V & !<-- The update data index specifications for V ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Index Limits for V Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State ,name =NAME//' Indices V' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_V & !<-- The update data index specifications for V ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ENDDO parent_tasks ! !----------------------------------------------------------------------- ! ENDIF transfer ! !----------------------------------------------------------------------- ! ENDIF move_check ! !----------------------------------------------------------------------- !*** Finally transfer the value of the domain's next move timestep. !*** This variable is part of the Solver internal state and is thus !*** defined for all domains. Its value is a dummy if not relevant. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="INTERIOR_DATA_STATE_TO_STATE: Unload the Next Move Timestep" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of the variable ,value=NEXT_MOVE_TIMESTEP & !<-- Timestep of domain's next shift. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="INTERIOR_DATA_STATE_TO_STATE: Load the Next Move Timestep" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of the variable ,value=NEXT_MOVE_TIMESTEP & !<-- Timestep of domain's next shift. ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! END SUBROUTINE INTERIOR_DATA_STATE_TO_STATE ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE MOVING_NEST_BOOKKEEPING(I_SHIFT_CHILD & ,J_SHIFT_CHILD & ,I_SW_PARENT_NEW & ,J_SW_PARENT_NEW & ,NUM_TASKS_PARENT & ,INPES_PARENT & ,ITS_PARENT & ,ITE_PARENT & ,JTS_PARENT & ,JTE_PARENT & ,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 & ) ! !----------------------------------------------------------------------- !*** Nest tasks determine which parent tasks will send them update !*** data and on which points following a move by the nest domain. !*** The data is for all nest task subdomain points including haloes !*** that lie outside of the footprint of the nest domain's location !*** preceding the move. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_SHIFT_CHILD & !<-- Nest domain moved this far in I in nest space ,J_SHIFT_CHILD & !<-- Nest domain moved this far in J in nest space ,I_SW_PARENT_NEW & !<-- SW corner of nest on this parent I after the move ,J_SW_PARENT_NEW & !<-- SW corner of nest on this parent J after the move ,INPES_PARENT & !<-- # of tasks in E/W direction on parent domain ,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 ,NUM_TASKS_PARENT & !<-- Number of fcst tasks on this nest's parent domain ,SPACE_RATIO_MY_PARENT & !<-- Ratio of parent grid increment to this child's ! ,ITS,ITE,JTS,JTE & !<-- Integration limits of nest task ,IMS,IME,JMS,JME & !<-- Memory limits of nest task ,IDS,IDE,JDS,JDE !<-- Nest's domain limits ! INTEGER(kind=KINT),DIMENSION(0:NUM_TASKS_PARENT-1),INTENT(IN) :: & ITS_PARENT & !<-- Starting I of all parent integration subdomains ,ITE_PARENT & !<-- Ending I of all parent integration subdomains ,JTS_PARENT & !<-- Starting J of all parent integration subdomains ,JTE_PARENT !<-- Ending J of all parent integration subdomains ! TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4),INTENT(OUT) :: & SEND_TASK !<-- Specifics about interior data from sending parent tasks ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I_END_X,I_SHIFT,I_START_X & ,ID_1,ID_E,ID_N,ID_NE & ,J_END_X,J_SHIFT,J_START_X & ,KOUNT_PARENT_TASKS,KP,N,NI,NJ ! INTEGER(kind=KINT),DIMENSION(1:4) :: I_UPDATE & ,J_UPDATE ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: ITS_PARENT_ON_CHILD & ,ITE_PARENT_ON_CHILD & ,JTS_PARENT_ON_CHILD & ,JTE_PARENT_ON_CHILD ! CHARACTER(2) :: CORNER ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Initialize working variables. !----------------------------------------------------------------------- ! DO N=1,4 !<-- 4 is maximum # of parent tasks that can send data SEND_TASK(N)%ID=-9999 SEND_TASK(N)%ISTART(1)=-9999 SEND_TASK(N)%IEND (1)=-9999 SEND_TASK(N)%JSTART(1)=-9999 SEND_TASK(N)%JEND (1)=-9999 SEND_TASK(N)%ISTART(2)=-9999 SEND_TASK(N)%IEND (2)=-9999 SEND_TASK(N)%JSTART(2)=-9999 SEND_TASK(N)%JEND (2)=-9999 ENDDO ! !----------------------------------------------------------------------- !*** Each nest task needs to determine if it has moved outside of !*** the footprint of the nest domain's previous position. If it !*** has then that task next finds out from which parent tasks it !*** must receive data. Finally it receives and incorporates that !*** data. ! !*** If no part of a nest task's subdomain has moved outside of the !*** footprint of the nest domain's previous location then that task !*** may RETURN now from this routine since none of its points will !*** be updated by the parent. !*** !*** Note that the north and east domain limits are not considered !*** to be part of the nest's pre-move footprint because those points !*** cannot be updated by intra-task or inter-task shifts. The reason !*** is that V-pt variables at those points are not part of the nest's !*** integration thus their values are not valid. Although the H-pt !*** variables are valid at those points, we cannot use them for !*** intra- or inter-task updates or else the nest tasks being updated !*** for H points would sometimes differ from the nest tasks being !*** updated for V points. We do not allow that to happen or else !*** the bookkeeping would be even more complex. Therefore the !*** parent updates nest points that would otherwise have been updated !*** from the north and east domain limits of the nest's pre-move !*** footprint. But since a variety of variables do not have valid !*** integration values on the domain boundary then we also must not !*** allow the intra- and inter-task shift to handle the updating !*** of the southern and western boundaries of the nest but instead !*** must let the parent handle those points as well. Moreover some !*** key dynamical tendenies are not computed one row inside the !*** domain boundary which thus means that the parent must provide !*** updates for all nest points that not only move beyond the !*** nest's pre-move footprint but also for those nest points that !*** move onto IDE and IDE-1 and JDE and JDE-1. Variables read !*** from the configure file now specify how deeply the parent will !*** update nest points with respect to the pre-move footprint. !----------------------------------------------------------------------- ! I_START_X=MAX(IMS,IDS) I_END_X =MIN(IME,IDE) J_START_X=MAX(JMS,JDS) J_END_X =MIN(JME,JDE) ! IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT_CHILD & !<-- If the entire nest task subdomain including its .AND. & ! halo is inside the footprint of the nest domain I_END_X<=IDE-NROWS_P_UPD_E-I_SHIFT_CHILD & ! (the domain's position prior to the move) then .AND. & ! no update from the parent is done. J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT_CHILD & ! .AND. & ! J_END_X<=JDE-NROWS_P_UPD_N-J_SHIFT_CHILD )THEN !<--- ! RETURN !<-- Therefore exit. ! ENDIF ! !----------------------------------------------------------------------- ! I_SHIFT=I_SHIFT_CHILD J_SHIFT=J_SHIFT_CHILD CORNER=' ' KOUNT_PARENT_TASKS=0 ! !----------------------------------------------------------------------- !*** The parent is going to send data interpolated to the nest grid !*** since that is simpler than handling sparse parent grid data on !*** the nest domain. Which points on this nest task now lie outside !*** the footprint of the pre-move nest domain? Do a search relative !*** to the indices on the post-move nest task position since it is !*** that location at which parent data are received. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Following the move most nest tasks that lie along the boundary !*** of the footprint of the nest domain will have simple !*** rectangular update regions in which they will receive !*** update data from parent tasks. However if a nest task's new !*** position is over a corner of the nest domain's pre-move footprint !*** then there will be an update region in the nest task that has a !*** wedge missing in the intersection with the footprint corner. !*** This greatly complicates the situation. ! !*** The diagram below shows a nest task after the nest has moved. !*** That task now lies over the northeast corner of the footprint !*** of the domain's pre-move position. In this case the task !*** receives update data from four parent tasks (the maximum). !*** Note that the southwest update region in that nest task !*** subdomain has the missing wedge. To handle this situation !*** when it arises, the I and J limits on the nest task subdomain !*** update region will be dimensioned (1:4). See how the missing !*** wedge in the update region goes from I_UPDATE(1) to I_UPDATE(2) !*** and from J_UPDATE(1) to J_UPDATE(2). The 3rd and 4th elements !*** of these arrays are filled only for tasks that are on the !*** footprint's corners. !----------------------------------------------------------------------- ! ! ' ! ' ! ' ! '<-- parent task boundary ! ' ! ' ! + + + + + + + + + + + + + + + + + + + + + --- J_UPDATE(4) ! + ' + ! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ! ^ + ' + ! | + ' nest task position + ! parent task + ' after the move + ! boundary + ' + --- J_UPDATE(3) ! ------------------------------------------ + --- J_UPDATE(2) ! / /| + ! I_UPDATE(1) / | + ! I_UPDATE(2) |+ + + + + + + + + + + + + + + + --- J_UPDATE(1) ! | \ \ ! footprint of the nest domain | \ \ ! in its pre-move location | I_UPDATE(3) I_UPDATE(4) ! | ! | ! | ! !----------------------------------------------------------------------- !*** Compute I_UPDATE(1-2) and J_UPDATE(1-2) as well as I_UPDATE(3-4) !*** and J_UPDATE(3-4) if they exist. !----------------------------------------------------------------------- ! update_limits: IF( & I_START_XIDE-NROWS_P_UPD_E-I_SHIFT & ! then we only have I and J indices 1 and 2 which .AND. & ! are the starting and ending indices for the I_END_X >IDE-NROWS_P_UPD_E-I_SHIFT & ! nest task's entire subdomain including the halo. .OR. & ! J_START_XJDE-NROWS_P_UPD_N-J_SHIFT & ! .AND. & ! J_END_X >JDE-NROWS_P_UPD_N-J_SHIFT & !<-- )THEN ! I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X I_UPDATE(3)=-9999 I_UPDATE(4)=-9999 ! J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X J_UPDATE(3)=-9999 J_UPDATE(4)=-9999 ! !----------------------------------------------------------------------- ! ELSE update_limits !<-- Nest task lies on footprint boundary after move ! !----------------------------------------------------------------------- ! i_block: IF(I_SHIFT>0)THEN !<-- Shift has eastward component ! !----------------------------------------------------------------------- ! !--------------------- !*** Northeast shift !--------------------- ! IF(J_SHIFT>0)THEN ! IF(I_END_X>IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- NE shift, nest task on east side of footprint I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ! IF(J_END_X>JDE-NROWS_P_UPD_N-J_SHIFT)THEN !<-- NE shift, nest task on NE corner of footprint CORNER='NE' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDE-NROWS_P_UPD_E-I_SHIFT I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ELSEIF(I_END_X<=IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- NE shift, nest task on north side of footprint; not corner I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint J_UPDATE(2)=J_END_X ! ENDIF ! !--------------------- !*** Southeast shift !--------------------- ! ELSEIF(J_SHIFT<0)THEN ! IF(I_END_X>IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- SE shift, nest task on east side of footprint; not corner I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ! IF(J_START_X general IF(JME>=JDE-NROWS_P_UPD_N+1)THEN IF(I_END_XJDS)THEN !<-- Nest task only on east edge of footprint !-> general ELSEIF(JMS>JDS+NROWS_P_UPD_S-1)THEN !<-- Nest task only on east edge of footprint I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ! ELSEIF(JTS==JDS)THEN !-> general ELSEIF(JMS<=JDS+NROWS_P_UPD_S-1)THEN IF(I_END_X general J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 ELSE !<-- Nest task on S bndry of footprint; extends east of it CORNER='SE' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDE-NROWS_P_UPD_E-I_SHIFT I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ELSEIF(I_SHIFT<0)THEN i_block !<-- Shift has westard component ! !----------------------------------------------------------------------- ! !--------------------- !*** Northwest shift !--------------------- ! IF(J_SHIFT>0)THEN ! IF(I_START_XJDE-NROWS_P_UPD_N-J_SHIFT)THEN !<-- NW shift, nest task on NW corner of footprint CORNER='NW' I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ELSEIF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- NW shift, nest tasks on north side of footprint; not corner I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint J_UPDATE(2)=J_END_X ! ENDIF ! !--------------------- !*** Southwest shift !--------------------- ! ELSEIF(J_SHIFT<0)THEN ! IF(I_START_X=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- SW shift, nest tasks on south side; not corner I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT ! ENDIF ! !----------------------- !*** Shift is due west !----------------------- ! ELSEIF(J_SHIFT==0)THEN IF(JTE==JDE)THEN !-> general IF(JME>=JDE-NROWS_P_UPD_N+1)THEN IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- Nest task on N bndry of footprint; no part west of it I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=JDE-NROWS_P_UPD_N+1 J_UPDATE(2)=J_END_X ELSE !<-- Nest task on N bndry of footprint; extends west of it CORNER='NW' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X-1 J_UPDATE(2)=JDE-NROWS_P_UPD_N J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ELSEIF(JTS>JDS)THEN !<-- Nest task only on west edge of footprint !-> general ELSEIF(JMS>JDS+NROWS_P_UPD_S-1)THEN !<-- Nest task only on west edge of footprint I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT !<-- End on the west edge of footprint J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ! ELSEIF(JTS==JDS)THEN !-> general ELSEIF(JMS<=JDS+NROWS_P_UPD_S-1)THEN IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- Nest task on S bndry of footprint; no part west of it I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=JDS !-> general J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 ELSE !<-- Nest task on S bndry of footprint; extends west of it CORNER='SW' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=JDS !-> general J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ELSEIF(I_SHIFT==0)THEN !<-- Shift has no eastward or westward component ! !------------------------ !*** Shift is due north !------------------------ ! IF(J_SHIFT>0)THEN IF(ITE==IDE)THEN !-> general IF(IME>=IDE-NROWS_P_UPD_E+1)THEN IF(J_END_XIDS)THEN !<-- Nest task only on north edge of footprint !-> general ELSEIF(IMS>IDS+NROWS_P_UPD_W-1)THEN !<-- Nest task only on north edge of footprint I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint J_UPDATE(2)=J_END_X ! ELSEIF(ITS==IDS)THEN !-> general ELSEIF(IMS<=IDS+NROWS_P_UPD_W-1)THEN IF(J_END_X general I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ELSE !<-- Nest task on W bndry of footprint; extends north of it CORNER='NW' I_UPDATE(1)=IDS !-> general I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ENDIF ! !------------------------ !*** Shift is due south !------------------------ ! ELSEIF(J_SHIFT<0)THEN IF(ITE==IDE)THEN !-> general IF(IME>=IDE-NROWS_P_UPD_E+1)THEN IF(J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT)THEN !<-- Nest task on E bndry of footprint; no part south of it I_UPDATE(1)=IDE-NROWS_P_UPD_E+1 I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ELSE !<-- Nest task on E bndry of footprint; extends south of it CORNER='SE' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDE-NROWS_P_UPD_E I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ELSEIF(ITS>IDS)THEN !<-- Nest task only on south edge of footprint !-> general ELSEIF(IMS>IDS+NROWS_P_UPD_W-1)THEN !<-- Nest task only on south edge of footprint I_UPDATE(1)=I_START_X I_UPDATE(2)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT !<-- End on south edge of footprint ! ELSEIF(ITS==IDS)THEN !-> general ELSEIF(IMS<=IDS+NROWS_P_UPD_W-1)THEN IF(J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT)THEN !<-- Nest task on W bndry of footprint; no part south of it I_UPDATE(1)=IDS !-> general I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 J_UPDATE(1)=J_START_X J_UPDATE(2)=J_END_X ELSE !<-- Nest task on W bndry of footprint; extends south of it CORNER='SW' I_UPDATE(1)=I_START_X I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 I_UPDATE(3)=I_UPDATE(2)+1 I_UPDATE(4)=I_END_X J_UPDATE(1)=J_START_X J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT J_UPDATE(3)=J_UPDATE(2)+1 J_UPDATE(4)=J_END_X ENDIF ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF i_block ! !----------------------------------------------------------------------- ! ENDIF update_limits ! !----------------------------------------------------------------------- !*** Now we know which portion of each task's subdomain on the !*** moving nest lies outside of the nest domain's pre-move !*** footprint location and it is that portion that must be !*** updated from the parent tasks. ! !*** To receive data from its parent, each moving nest task must !*** know how many parent tasks it will receive from. Nest tasks !*** could do this blindly by receiving a message from all parent !*** tasks which would inform them which parent tasks had actual !*** data, or they could receive all that information from parent !*** task 0 if that task had first been sent all that information !*** from the other parent tasks, or each nest task could compute !*** which parent tasks will send it data and how much. The third !*** option involves the least overall communication and serves to !*** double check the parent's bookkeeping therefore that option !*** is the one used here. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** The nest tasks determine all of their parent tasks' integration !*** limits in terms of their own (the nest tasks') indices so they !*** will know where to put the data they receive from the parent. !*** This must be done for all parent tasks since the nest tasks !*** can make no assumptions about which parent tasks will have !*** update data for them and that is because there is no limit !*** imposed on the distance the nest can traverse in any single !*** move. ! !*** See the explanation and accompanying diagrams in subroutine !*** PARENT_BOOKKEEPING_MOVING for more details. The results must !*** be the same for both H and V points. !----------------------------------------------------------------------- ! ALLOCATE(ITS_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) ALLOCATE(ITE_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) ALLOCATE(JTS_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) ALLOCATE(JTE_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) ! DO N=0,NUM_TASKS_PARENT-1 ! ITS_PARENT_ON_CHILD(N)=REAL(IDS & !<-- ITS of parent task N in child's coordinate space -(I_SW_PARENT_NEW-ITS_PARENT(N)) & *SPACE_RATIO_MY_PARENT) ! ITE_PARENT_ON_CHILD(N)=REAL(IDS & !<-- ITE of parent task N in child's coordinate space -(I_SW_PARENT_NEW-ITE_PARENT(N)) & *SPACE_RATIO_MY_PARENT & +SPACE_RATIO_MY_PARENT-1) !<-- Filling in gap beyond last parent point on nest grid ! JTS_PARENT_ON_CHILD(N)=REAL(JDS & !<-- JTS of parent task N in child's coordinate space -(J_SW_PARENT_NEW-JTS_PARENT(N)) & *SPACE_RATIO_MY_PARENT) ! JTE_PARENT_ON_CHILD(N)=REAL(JDS & !<-- JTE of parent task N in child's coordinate space -(J_SW_PARENT_NEW-JTE_PARENT(N)) & *SPACE_RATIO_MY_PARENT & +SPACE_RATIO_MY_PARENT-1) !<-- Filling in gap beyond last parent point on nest grid ! ENDDO ! !----------------------------------------------------------------------- !*** Find the parent task whose subdomain contains the nest point !*** [I_UPDATE(1),J_UPDATE(1)]. This parent task will be referred !*** to as parent task #1 since up to four parent tasks might !*** provide update data to the nest task. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- search_i: DO NI=0,INPES_PARENT-1 !<-- Look eastward for parent task. !----------------------------------------------------------------------- ! update_i: IF(REAL(I_UPDATE(1))>=ITS_PARENT_ON_CHILD(NI)-EPS & !<-- Search for 1st parent task that covers .AND. & ! nest index I_UPDATE(1). REAL(I_UPDATE(1))<=ITE_PARENT_ON_CHILD(NI)+EPS) & THEN !<-- ! !----------------------------------------------------------------------- search_j: DO NJ=NI,NUM_TASKS_PARENT-1,INPES_PARENT !<-- Look northward for parent task. !----------------------------------------------------------------------- ! update_j: IF(REAL(J_UPDATE(1))>=JTS_PARENT_ON_CHILD(NJ)-EPS & !<-- Search for parent task that covers nest point .AND. & ! I_UPDATE(1),J_UPDATE(1). REAL(J_UPDATE(1))<=JTE_PARENT_ON_CHILD(NJ)+EPS) & !<-- THEN !<-- ! SEND_TASK(1)%ID=NJ !<-- Store the ID of this parent task who will send data. ID_1=NJ !<-- Local task ID of the identified parent task. KOUNT_PARENT_TASKS=1 !<-- Count how many parent tasks send to this nest task. ! !----------------------------------------------------------------------- !*** First consider all nest tasks that either lie totally outside !*** of the footprint or lie on the footprint's edge but not on a !*** corner. Corners can be very complicated and are each treated !*** separately. !----------------------------------------------------------------------- ! not_a_corner: IF(CORNER==' ')THEN ! !----------------------------------------------------------------------- !*** I and J limits on the nest task of data received from the !*** parent task #1 that covers [I_UPDATE(1),J_UPDATE(1)]. !----------------------------------------------------------------------- ! SEND_TASK(1)%ISTART(1)=I_UPDATE(1) !<-- Nest index limits updated by parent task 1. SEND_TASK(1)%IEND (1)=MIN(I_UPDATE(2) & ! ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! SEND_TASK(1)%JSTART(1)=J_UPDATE(1) ! SEND_TASK(1)%JEND (1)=MIN(J_UPDATE(2) & ! ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! !----------------------------------------------------------------------- !*** Is there a parent task to the the north of the first that covers !*** points on this nest task's subdomain? !----------------------------------------------------------------------- ! IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN ! IF(ITE_PARENT_ON_CHILD(ID_1)-EPS<=I_UPDATE(2))THEN SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! ELSEIF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN !<-- Parent task 1 covers SW corner of footprint too. ! SEND_TASK(1)%JEND(1)=J_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task's ! first region. SEND_TASK(1)%ISTART(2)=I_START_X !<-- 2nd region on nest task updated by parent task 1 SEND_TASK(1)%IEND(2)=I_UPDATE(2) ! SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! ENDIF ! ENDIF ! !----------------------------------------------------------------------- !*** The points in this nest task subdomain being updated by the first !*** identified parent task have been demarcated. Now identify any !*** other parent tasks updating this nest task lying on the SW corner !*** of the footprint. !----------------------------------------------------------------------- ! !------------------------------------------------------ !*** Is there a parent task to the north of the first !*** that provides update data? !------------------------------------------------------ ! sw_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN ! if either of these statements is true. ! SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(2) & !<-- Ending I on nest task where parent task ID_N updates. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J on nest task where parent task ID_N updates. SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. ! ELSEIF(ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(3).AND. & !<-- Parent task ID_N covers SW corner of JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN ! footprint too. ! ! | ! | ! | ! | ! + + + + + + + + + + + +.| footprint of nest domain ! + .| in its pre-move location ! + parent task 2's .| ! + 2nd update region .| ! + .| ! +.......................---------------------------------- ! +.............................. + ! + parent task 2's ' <------- parent task 3's update region ! + 1st update region ' + ! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' <--- parent task boundary ! + ' + ! + parent task 1's ' <------- parent task 4's update region ! + update region ' + ! + ' + ! + + + + + + + + + + + + + + + ' + + + + ! ^ ' ! | ' ! nest task '<--- parent task boundary ! boundary ' ! after move ' ! ' ! SEND_TASK(KP)%IEND(1)=MIN(I_END_X & !<-- Ending I on nest task where parent task ID_N updates ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J of parent task ID_N in nest task 1st region. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Starting I of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(2) & !<-- Ending I of parent task ID_N in nest task 2nd region. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. ! ENDIF !<-- End contingencies of parent task north of first one. ! !----------------------------------------------- !*** Does a parent task northeast of the first !*** provide any update data? This can only !*** happen if there was already a parent task !*** to the north of the first one providing !*** update data. !----------------------------------------------- ! ! IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3))THEN !<-- not cover the SW corner of the footprint. ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first ID_NE=SEND_TASK(KP)%ID ! (i.e. east of the parent task to the north of the first). SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I where parent task ID_NE updates nest task. SEND_TASK(KP)%IEND (1)=I_UPDATE(2) !<-- Ending I where parent task ID_NE updates nest task. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J where parent task ID_NE updates nest task. SEND_TASK(KP)%JEND (1)=J_END_X !<-- Ending J where parent task ID_NE updates nest task. ! ENDIF ! IF(ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(2) & !<-- 2nd scenario of parent update task to northeast of .AND. & ! the first update parent task. The NE parent task ITE_PARENT_ON_CHILD(ID_N)+EPS< I_END_X & ! does not cover the SW corner of the footprint. .AND. & ! JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN !<-- ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. ID_NE=SEND_TASK(KP)%ID SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I where parent task ID_NE updates nest task. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_NE updates nest task. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J where parent task ID_NE updates nest task. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J where parent task ID_NE updates nest task. ! ENDIF ! IF(ITE_PARENT_ON_CHILD(ID_N)+EPS ' .| ! + '.......................---------------------------------- ! + '.................................+ ! + ' parent task 3's + ! + ' 1st update region + ! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' <--- parent task boundary ! + ' + ! parent task 1's + ' parent task 4's + ! update region ----------> ' update region + ! + ' + <--- nest task boundary after move ! + + + + + ' + + + + + + + + + + + + + + + + + ! ' ! ' ! '<----- parent task boundary ! ' ! ' ! ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment the parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. ID_NE=SEND_TASK(KP)%ID SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's 1st region updated by parent. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I in nest task's 1st region updated by parent. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J in nest task's 1st region updated by parent. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J in nest task's 1st region updated by parent. SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's 2nd region updated by parent. SEND_TASK(KP)%IEND (2)=I_UPDATE(2) !<-- Ending I in nest task's 2nd region updated by parent. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J in nest task's 2nd region updated by parent. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J in nest task's 2nd region updated by parent. ! ENDIF ! ENDIF sw_north ! !---------------------------------------------- !*** Is there a parent task east of the first !*** that provides update data? !---------------------------------------------- ! sw_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN ! IF(ITS_PARENT_ON_CHILD(ID_E)+EPS>=I_UPDATE(3))THEN !<-- 2nd scenario of parent update task to east of first. ! ! | ! | ! | ! | ! + + + + + + + + + + + +.| footprint of nest domain ! + .| in its pre-move location ! + parent task 1's .| ! + 2nd update region .| ! + .| ! +.......................---------------------------------- ! +.............................. + ! + ' + ! + ' + ! + parent task 1's ' + ! + 1st upate region ' <------- parent task 2's update region ! + ' + ! + ' + ! + ' + ! + + + + + + + + + + + + + + + ' + + + + ! ^ ' ! | ' ! nest task '<--- parent task boundary ! boundary ' ! after move ' ! ' ! SEND_TASK(KP)%IEND(1)=I_END_X SEND_TASK(KP)%JSTART(1)=J_START_X SEND_TASK(KP)%JEND(1)=J_UPDATE(2) ! ELSEIF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2))THEN !<-- 3rd scenario of parent update task to east of first. ! ! | ! ' | ! ' | ! ' | ! + + + + + ' + + + + + + + + + + +.| ! parent task 2's + ' .| ! update region ----------> ' parent task 3's .| footprint of nest domain ! + ' update region .| in its pre-move location ! + ' .| ! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ! ^ + ' .| ! parent task | + ' parent task 4's .| ! boundary + ' 2nd update region .| ! + ' .| ! + '.......................---------------------------------- ! parent task 1's + '.................................+ ! update region ----------> ' + ! + ' + ! + ' parent task 4's + ! + ' 1st update region + ! + ' + <--- nest task boundary after move ! + ' + ! + ' + ! + + + + + ' + + + + + + + + + + + + + + + + + ! ' ! ' ! '<----- parent task boundary ! ' ! ' ! ! SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I of 1st update region in nest task by parent. SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Starting J of 1st update region in nest task by parent. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of 1st update region in nest task by parent. SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I of 2nd update region in nest task by parent. SEND_TASK(KP)%IEND (2)=I_UPDATE(2) !<-- Ending I of 2nd update region in nest task by parent. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of 2nd update region in nest task by parent. SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ENDIF ! ENDIF ! ENDIF sw_east ! EXIT search_i ! ENDIF sw ! !------------------------------------------------------ !------------------------------------------------------ !*** The nest task on the SE corner of the footprint. !------------------------------------------------------ !------------------------------------------------------ ! se: IF(CORNER=='SE')THEN !<-- This nest task lies on the SE corner of the footprint. ! SEND_TASK(1)%ISTART(1)=I_START_X !<-- Nest I where parent task 1 begins updating nest task. SEND_TASK(1)%IEND(1)=MIN(I_UPDATE(4) & !<-- Nest I where parent task 1 ends updating nest task. ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. ! IF(JTE_PARENT_ON_CHILD(ID_1)-EPS<=J_UPDATE(2))THEN SEND_TASK(1)%JEND(1)=NINT(JTE_PARENT_ON_CHILD(ID_1)) !<-- Nest J where parent task 1 ends updating nest task. ! ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN SEND_TASK(1)%JEND(1)=J_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task. ! IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN !<-- Parent task 1 covers SE corner of footprint too. ! SEND_TASK(1)%ISTART(2)=I_UPDATE(3) !<-- 2nd region on nest task updated by parent task 1 SEND_TASK(1)%IEND(2)=MIN(I_END_X & ! ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! ENDIF ENDIF ! !----------------------------------------------------------------------- !*** The points in this nest task subdomain being updated by the first !*** identified parent task have been demarcated. Now identify any !*** other parent tasks updating this nest task lying on the SE corner !*** of the footprint. !----------------------------------------------------------------------- ! !------------------------------------------------------ !*** Is there a parent task to the north of the first !*** that provides update data? !------------------------------------------------------ ! se_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- east side. ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_1+INPES_PARENT !<-- Store the ID of this parent task to the north. ID_N=SEND_TASK(KP)%ID ! IF(JTS_PARENT_ON_CHILD(ID_N)+EPS>=J_UPDATE(3))THEN !<-- Parent task ID_N does not cover SE corner of footprint. SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Starting I on nest task where parent task ID_N updates. SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(4) & !<-- Ending I on nest task where parent task ID_N updates. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J on nest task where parent task ID_N updates. SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. ! ELSEIF(JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN !<-- Parent task ID_N covers SE corner of footprint too. ! SEND_TASK(KP)%ISTART(1)=I_START_X !<-- Starting I on nest task where parent task ID_N updates SEND_TASK(KP)%IEND(1)=MIN(I_END_X & !<-- Ending I on nest task where parent task ID_N updates ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J of parent task ID_N in nest task 1st region. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. SEND_TASK(KP)%ISTART(2)=I_UPDATE(3) !<-- Starting I of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(4) & !<-- Ending I of parent task ID_N in nest task 2nd region. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. ! ENDIF ! ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(2) & ! does not cover the SE corner of the footprint. .AND. & ! JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(2) & !<-- is north of the SE corner of the footprint. .AND. & ! JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- 2nd scenario of parent update task E of first. No corner. ! SEND_TASK(KP)%JEND(1)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) !<-- ! ELSEIF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2) & !<-- 2nd scenario of parent update task to E of first. .AND. & ! The east parent task covers the SE corner of the JTE_PARENT_ON_CHILD(ID_E)+EPS>=J_UPDATE(3))THEN !<-- footprint. ! SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of 1st update region in nest task by parent. SEND_TASK(KP)%ISTART(2)=I_UPDATE(3) !<-- Starting I of 2nd update region in nest task by parent. SEND_TASK(KP)%IEND (2)=I_END_X !<-- Ending I of 2nd update region in nest task by parent. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of 2nd update region in nest task by parent. SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) !<-- ENDIF !<-- Finished with parent task east of the first one. ! ENDIF se_east ! EXIT search_i ! ENDIF se ! !----------------------------------------------------------------------- ! !------------------------------------------------------ !------------------------------------------------------ !*** The nest task on the NW corner of the footprint. !------------------------------------------------------ !------------------------------------------------------ ! nw: IF(CORNER=='NW')THEN !<-- This nest task lies on the NW corner of the footprint. ! SEND_TASK(1)%ISTART(1)=I_START_X !<-- Nest I where parent task 1 begins updating nest task. SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. ! IF(ITE_PARENT_ON_CHILD(ID_1)-EPS<=I_UPDATE(2))THEN SEND_TASK(1)%IEND(1)=NINT(ITE_PARENT_ON_CHILD(ID_1)) !<-- Nest I where parent task 1 ends updating nest task. SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! ELSEIF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN SEND_TASK(1)%IEND(1)=I_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task. SEND_TASK(1)%JEND(1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task 1 ends updating nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ! IF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN !<-- Parent task 1 covers NW corner of footprint too. SEND_TASK(1)%ISTART(2)=I_START_X !<-- 2nd region on nest task updated by parent task 1 SEND_TASK(1)%IEND(2)=MIN(I_END_X & ! ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- ENDIF ENDIF ! !----------------------------------------------------------------------- !*** The points in this nest task subdomain being updated by the first !*** identified parent task have been demarcated. Now identify any !*** other parent tasks updating this nest task lying on the NW corner !*** of the footprint. !----------------------------------------------------------------------- ! !------------------------------------------------------ !*** Is there a parent task to the north of the first !*** that provides update data? !------------------------------------------------------ ! nw_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3) & !<-- Parent task ID_N does not cover NW corner of footprint. .OR. & ! ITE_PARENT_ON_CHILD(ID_N)-EPS<=I_UPDATE(2))THEN !<-- ! SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(4) & !<-- Ending I on nest task where parent task ID_N updates. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. ! ELSEIF(JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2) & !<-- Parent task ID_N covers NW corner of footprint too. .AND. & ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(3))THEN ! SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(2) & !<-- Ending I on nest task where parent task ID_N updates ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Starting I of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(4) & !<-- Ending I of parent task ID_N in nest task 2nd region. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. ENDIF !<-- End contingencies of parent task north of first one. ! !----------------------------------------------- !*** Does a parent task northeast of the first !*** provide any update data? For this to be !*** true there must be a parent task to the !*** north of the first so we remain in the !*** nw_north IF block. !----------------------------------------------- ! IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3) & ! .OR. & ! ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(2) & ! .AND. & ! JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2)))THEN !<-- ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. ID_NE=SEND_TASK(KP)%ID SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's update region. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I in nest task's update region. SEND_TASK(KP)%JSTART(1)=MAX(J_UPDATE(3) & !<-- Starting J where parent task ID_NE updates nest. ,NINT(JTS_PARENT_ON_CHILD(ID_NE))) SEND_TASK(KP)%JEND (1)=J_END_X !<-- Ending J in nest task's update region. ! ENDIF ! ENDIF nw_north ! !---------------------------------------------- !*** Is there a parent task east of the first !*** that provides update data? !---------------------------------------------- ! nw_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I for east parent in 2nd update region. SEND_TASK(KP)%IEND (2)=I_END_X !<-- Ending I for east parent in 2nd update region. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J for east parent in 2nd update region. SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J for east parent in 2nd update region. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ENDIF ! ENDIF ! IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(2) & !<-- 2nd scenario of a parent task to the east of .AND. & ! the first parent task. JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN !<-- ! KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment the parent task counter. KP=KOUNT_PARENT_TASKS SEND_TASK(KP)%ID=ID_1+1 !<-- Store the ID of this parent task to the east. ID_E=SEND_TASK(KP)%ID SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I where parent task ID_E updates nest task. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_E updates nest task. SEND_TASK(KP)%JSTART(1)=J_UPDATE(3) !<-- Starting J where parent task ID_E updates nest task. SEND_TASK(KP)%JEND (1)=MIN(J_END_X & !<-- Ending J where parent task ID_E updates nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ENDIF ! ENDIF nw_east ! EXIT search_i ! ENDIF nw ! !------------------------------------------------------ !------------------------------------------------------ !*** The nest task on the NE corner of the footprint. !------------------------------------------------------ !------------------------------------------------------ ! ne: IF(CORNER=='NE')THEN !<-- This nest task lies on the NE corner of the footprint. ! !----------------------------------------------------------------------- !*** The northeast corner of the footprint is even more involved !*** than the other three because [I_UPDATE(1),J_UPDATE(1)] on this !*** nest task is within the footprint of the nest's previous location !*** and thus is not updated by parent task 1. In fact parent task 1 !*** might not update any points on this nest task if that region of !*** the nest task covered by parent task 1 lies entirely within the !*** footprint. !----------------------------------------------------------------------- ! KOUNT_PARENT_TASKS=0 !<-- Parent task ID_1 might not send any data. ! IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN ! KOUNT_PARENT_TASKS=1 !<-- Parent task ID_1 does send data. SEND_TASK(1)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task 1 begins updating nest task. SEND_TASK(1)%IEND(1)=MIN(I_END_X & !<-- Nest I where parent task 1 ends updating nest task. ,NINT(ITE_PARENT_ON_CHILD(ID_1))) SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. SEND_TASK(1)%JEND (1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task 1 ends updating nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) ! IF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN SEND_TASK(1)%ISTART(2)=I_START_X !<-- Nest I where parent task 1 begins updating 2nd region. SEND_TASK(1)%IEND (2)=SEND_TASK(1)%IEND(1) !<-- Nest I where parent task 1 ends updating 2nd region. SEND_TASK(1)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task 1 begins updating 2nd region. SEND_TASK(1)%JEND (2)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating 2nd region. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) ENDIF ! ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN ! KOUNT_PARENT_TASKS=1 !<-- Parent task ID_1 does send data. SEND_TASK(1)%ISTART(1)=I_UPDATE(1) !<-- Nest I where parent task 1 begins updating nest task. SEND_TASK(1)%IEND(1)=NINT(ITE_PARENT_ON_CHILD(ID_1)) !<-- Nest I where parent task 1 ends updating nest task. SEND_TASK(1)%JSTART(1)=J_UPDATE(3) !<-- Nest J where parent task 1 begins updating nest task. SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating 2nd region. ,NINT(JTE_PARENT_ON_CHILD(ID_1))) ! ENDIF ! !----------------------------------------------------------------------- !*** The points in this nest task subdomain being updated by the first !*** identified parent task have been demarcated. Now identify any !*** other parent tasks updating this nest task lying on the NE corner !*** of the footprint. !----------------------------------------------------------------------- ! !------------------------------------------------------ !*** Is there a parent task to the north of the first !*** that provides update data? !------------------------------------------------------ ! ne_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN SEND_TASK(KP)%IEND (1)=MIN(I_END_X & !<-- Nest I where parent task ID_N ends updating this region. ,NINT(ITE_PARENT_ON_CHILD(ID_N))) IF(JTS_PARENT_ON_CHILD(ID_N)<=J_UPDATE(2))THEN !<-- 2nd scenario of parent task north of the first. SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_N begins updating this region. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Nest J where parent task ID_N begins updating this region. SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Nest J where parent task ID_N ends updating this region. SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Nest I where parent task ID_N begins updating 2nd region. SEND_TASK(KP)%IEND (2)=SEND_TASK(KP)%IEND(1) !<-- Nest I where parent task ID_N ends updating 2nd region. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_N begins updating 2nd region. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Nest J where parent task ID_N ends updating 2nd region. ELSEIF(JTS_PARENT_ON_CHILD(ID_N)>=J_UPDATE(3))THEN !<-- 3rd scenario of parent task north of the first. SEND_TASK(KP)%ISTART(1)=I_START_X !<-- Nest I where parent task ID_N begins updating this region. SEND_TASK(KP)%JSTART(1)=MAX(J_UPDATE(3) & !<-- Nest J where parent task ID_N begins updating this region. ,NINT(JTS_PARENT_ON_CHILD(ID_N))) SEND_TASK(KP)%JEND (1)=J_END_X !<-- Nest J where parent task ID_N begins updating this region. ENDIF ENDIF ! !----------------------------------------------- !*** Does a parent task northeast of the first !*** provide any update data? This can only !*** happen if there was a parent task to !*** the north of the first therefore we !*** remain in the ne_north IF block. !----------------------------------------------- ! ne_ne: IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3) & !<-- 1st scenario of parent task to the NE of the first. .OR. & ! ITS_PARENT_ON_CHILD(ID_NE)+EPS>=I_UPDATE(3) & ! .AND. & ! JTS_PARENT_ON_CHILD(ID_NE)-EPS<=J_UPDATE(2))THEN !<-- ! SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Nest I where parent task ID_NE begins updating this region. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_NE ends updating this region. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Nest J where parent task ID_NE begins updating this region. SEND_TASK(KP)%JEND (1)=J_END_X !<-- Nest J where parent task ID_NE ends updating this region. ENDIF ! IF(ITS_PARENT_ON_CHILD(ID_NE)-EPS<=I_UPDATE(2) & !<-- 2nd scenario of parent task to the NE of the first. .AND. & ! JTS_PARENT_ON_CHILD(ID_NE)-EPS<=J_UPDATE(2))THEN !<-- ! SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_NE begins updating this region SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_NE ends updating this region. SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Nest J where parent task ID_NE begins updating this region SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Nest J where parent task ID_NE ends updating this region. SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Nest I where parent task ID_NE begins updating 2nd region. SEND_TASK(KP)%IEND (2)=I_END_X !<-- Nest I where parent task ID_NE ends updating 2nd region. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_NE begins updating 2nd region. SEND_TASK(KP)%JEND (2)=J_END_X !<-- Nest J where parent task ID_NE ends updating 2nd region. ENDIF ! ENDIF ne_ne ! ENDIF ne_north ! !---------------------------------------------- !*** Is there a parent task east of the first !*** that provides update data? !---------------------------------------------- ! ne_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- 1st scenario of parent task east of the first. SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I where parent task ID_E updates nest task. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_E updates nest task. SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Starting J where parent task ID_E updates nest task. SEND_TASK(KP)%JEND (1)=MIN(J_END_X & !<-- Ending J where parent task ID_E updates nest task. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ENDIF ! IF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2))THEN SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_E begins updating 1st region. SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_E ends updating 1st region. SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Nest J where parent task ID_E begins updating 1st region. SEND_TASK(KP)%JEND (1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task ID_E ends updating 1st region. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ! IF(JTE_PARENT_ON_CHILD(ID_E)+EPS>=J_UPDATE(3))THEN SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Nest I where parent task ID_E begins updating 2nd region. SEND_TASK(KP)%IEND (2)=I_END_X !<-- Nest I where parent task ID_E ends updating 2nd region. SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_E begins updating 2nd region. SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Nest I where parent task ID_E ends updating 2nd region. ,NINT(JTE_PARENT_ON_CHILD(ID_E))) ENDIF ENDIF ! ENDIF ne_east ! EXIT search_i ! ENDIF ne ! !----------------------------------------------------------------------- ! ENDIF update_j ! ENDDO search_j ! ENDIF update_i ! ENDDO search_i ! !----------------------------------------------------------------------- !*** Add up the number of points being updated by each parent task. !----------------------------------------------------------------------- ! DO KP=1,KOUNT_PARENT_TASKS ! SEND_TASK(KP)%NPTS=(SEND_TASK(KP)%IEND(1) & -SEND_TASK(KP)%ISTART(1)+1)* & (SEND_TASK(KP)%JEND(1) & -SEND_TASK(KP)%JSTART(1)+1) ! IF(SEND_TASK(KP)%ISTART(2)>=IMS)THEN !<-- Add points for 2nd regions on corners if present. SEND_TASK(KP)%NPTS=SEND_TASK(KP)%NPTS & +(SEND_TASK(KP)%IEND(2) & -SEND_TASK(KP)%ISTART(2)+1)* & (SEND_TASK(KP)%JEND(2) & -SEND_TASK(KP)%JSTART(2)+1) ENDIF ! ENDDO ! !----------------------------------------------------------------------- ! DEALLOCATE(ITS_PARENT_ON_CHILD) DEALLOCATE(ITE_PARENT_ON_CHILD) DEALLOCATE(JTS_PARENT_ON_CHILD) DEALLOCATE(JTE_PARENT_ON_CHILD) ! !----------------------------------------------------------------------- ! END SUBROUTINE MOVING_NEST_BOOKKEEPING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE 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 & ,EXPORT_STATE & ) ! !----------------------------------------------------------------------- !*** After having determined which of their internal gridpoints !*** need to be updated by which parent tasks following a nest's !*** move, the nest's forecast tasks now receive the update data !*** from the parent. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent ,NTIMESTEP & !<-- Nest's current timestep ,NUM_FIELDS_MOVE_2D_H_I & !<-- # of 2-D internal state integer H variables to be updated ,NUM_FIELDS_MOVE_2D_X_I & !<-- # of 2-D integer H variables updated from external files ,NUM_FIELDS_MOVE_2D_H_R & !<-- # of 2-D internal state real H variables to be updated ,NUM_FIELDS_MOVE_2D_X_R & !<-- # of 2-D real H variables updated from external files ,NUM_LEVELS_MOVE_3D_H & !<-- # of 2-D levels in all 3-D H update variables ,NUM_FIELDS_MOVE_2D_V & !<-- # of 2-D internal state V variables to be updated ,NUM_LEVELS_MOVE_3D_V !<-- # of 2-D levels in all 3-D V update variables ! TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4),INTENT(IN) :: & SEND_TASK !<-- Specifics about interior data from sending parent tasks ! TYPE(ESMF_State),INTENT(INOUT) :: EXPORT_STATE !<-- The Parent-Child coupler export state ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ITAG,N,NUM_PTASK_UPDATE,NUM_WORDS ! INTEGER(kind=KINT) :: IERR,RC,RC_RECV ! INTEGER(kind=KINT),DIMENSION(1:8) :: INDICES_H,INDICES_V ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: UPDATE_INTEGER_DATA ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: UPDATE_REAL_DATA ! CHARACTER(len=1) :: N_PTASK CHARACTER(len=12) :: NAME CHARACTER(len=17) :: NAME_REAL CHARACTER(len=20) :: NAME_INTEGER ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RC =ESMF_SUCCESS RC_RECV=ESMF_SUCCESS ! !----------------------------------------------------------------------- !*** First load into the Parent-Child coupler export state the !*** number of parent tasks that send update data to this nest task. !*** We insist that parent tasks will update the same H and V points !*** with respect to their I,J indices. !----------------------------------------------------------------------- ! NUM_PTASK_UPDATE=0 ! DO N=1,4 !<-- No more than 4 parent tasks will send data. IF(SEND_TASK(N)%ID<0)THEN EXIT ELSE NUM_PTASK_UPDATE=NUM_PTASK_UPDATE+1 ENDIF ENDDO ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="MOVING_NEST_RECV_DATA: Load # of Parent Tasks Sending Interior Updates" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state ,name ='Num Parent Tasks Update' & !<-- Name of the variable ,value=NUM_PTASK_UPDATE & !<-- # of parent tasks that update this nest task ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** If no parent tasks are sending update data to this nest task !*** then there is nothing more to do so RETURN. !----------------------------------------------------------------------- ! IF(NUM_PTASK_UPDATE==0)RETURN ! !----------------------------------------------------------------------- ! parent_tasks: DO N=1,NUM_PTASK_UPDATE ! !----------------------------------------------------------------------- ! NUM_WORDS=(NUM_FIELDS_MOVE_2D_H_R-NUM_FIELDS_MOVE_2D_X_R & !<-- Total # of real words coming from Nth parent task +NUM_LEVELS_MOVE_3D_H)*SEND_TASK(N)%NPTS & +(NUM_FIELDS_MOVE_2D_V+NUM_LEVELS_MOVE_3D_V) & *SEND_TASK(N)%NPTS ! ALLOCATE(UPDATE_REAL_DATA(1:NUM_WORDS)) !<-- Allocate the Recv buffer ! ITAG=NUM_WORDS+NTIMESTEP !<-- Tag that changes for both data size and time ! !----------------------------------------------------------------------- !*** Receive the interior H and V real update data sent by !*** parent task N. !----------------------------------------------------------------------- ! CALL MPI_RECV(UPDATE_REAL_DATA & !<-- Real update data from Nth parent task ,NUM_WORDS & !<-- # of real words received ,MPI_REAL & !<-- The data is Real ,SEND_TASK(N)%ID & !<-- Receive from parent task with this rank ,ITAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent ,JSTAT & !<-- MPI status object ,IERR ) ! !----------------------------------------------------------------------- !*** Load the update data and associated index limits into the !*** Parent-Child coupler export state so it can be sent back into !*** the DOMAIN component for incorporation. !----------------------------------------------------------------------- ! WRITE(N_PTASK,'(I1)')N NAME_REAL='PTASK_REAL_DATA_'//N_PTASK ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load # of Words in Real Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME_REAL//' Words' & !<-- Name of the variable ,value=NUM_WORDS & !<-- Put # of real words here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Real Update Data from Parent into P-C Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME_REAL & !<-- Name of the variable ,itemCount=NUM_WORDS & !<-- # of words in real update data from parent task N ,valueList=UPDATE_REAL_DATA & !<-- The real update data from parent task N ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(UPDATE_REAL_DATA) ! !----------------------------------------------------------------------- !*** There may or may not be integer variable updates at this time. !----------------------------------------------------------------------- ! NUM_WORDS=(NUM_FIELDS_MOVE_2D_H_I-NUM_FIELDS_MOVE_2D_X_I) & !<-- Total # of integer words coming from *SEND_TASK(N)%NPTS ! the Nth parent task ! !----------------------------------------------------------------------- !*** Load into the Parent-Child coupler export state the number !*** of integer words to be updated so the value can be sent to !*** the DOMAIN component for incorporation of the integer data. !----------------------------------------------------------------------- ! WRITE(N_PTASK,'(I1)')N NAME_INTEGER='PTASK_INTEGER_DATA_'//N_PTASK ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load # of Words in Integer Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME_INTEGER//' Words' & !<-- Name of the variable ,value=NUM_WORDS & !<-- Put # of integer words here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! recv_int: IF(NUM_WORDS>0)THEN ! !----------------------------------------------------------------------- ! ALLOCATE(UPDATE_INTEGER_DATA(1:NUM_WORDS)) !<-- Allocate the Recv buffer ! ITAG=NUM_WORDS+NTIMESTEP !<-- Tag that changes for both data size and time ! !----------------------------------------------------------------------- !*** Receive the interior integer update data for H and V points !*** sent by parent task N. !----------------------------------------------------------------------- ! CALL MPI_RECV(UPDATE_INTEGER_DATA & !<-- Integer update data from Nth parent task ,NUM_WORDS & !<-- # of integer words received ,MPI_INTEGER & !<-- The data is Integer ,SEND_TASK(N)%ID & !<-- Receive from parent task with this rank ,ITAG & !<-- Unique MPI tag ,COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent ,JSTAT & !<-- MPI status object ,IERR ) ! !----------------------------------------------------------------------- !*** Load the update data and associated index limits into the !*** Parent-Child coupler export state so it can be sent back into !*** the DOMAIN component for incorporation. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Integer Update Data from Parent into P-C Cpl Export State" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME_INTEGER & !<-- Name of the variable ,itemCount=NUM_WORDS & !<-- # of words in integer update data from parent task N ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from parent task N ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! DEALLOCATE(UPDATE_INTEGER_DATA) ! !----------------------------------------------------------------------- ! ENDIF recv_int ! !----------------------------------------------------------------------- ! INDICES_H(1)=SEND_TASK(N)%ISTART(1) INDICES_H(2)=SEND_TASK(N)%ISTART(2) INDICES_H(3)=SEND_TASK(N)%IEND(1) INDICES_H(4)=SEND_TASK(N)%IEND(2) INDICES_H(5)=SEND_TASK(N)%JSTART(1) INDICES_H(6)=SEND_TASK(N)%JSTART(2) INDICES_H(7)=SEND_TASK(N)%JEND(1) INDICES_H(8)=SEND_TASK(N)%JEND(2) ! INDICES_V(1)=SEND_TASK(N)%ISTART(1) INDICES_V(2)=SEND_TASK(N)%ISTART(2) INDICES_V(3)=SEND_TASK(N)%IEND(1) INDICES_V(4)=SEND_TASK(N)%IEND(2) INDICES_V(5)=SEND_TASK(N)%JSTART(1) INDICES_V(6)=SEND_TASK(N)%JSTART(2) INDICES_V(7)=SEND_TASK(N)%JEND(1) INDICES_V(8)=SEND_TASK(N)%JEND(2) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Load Index Limits for Update Data from Parent" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! WRITE(N_PTASK,'(I1)')N NAME='PTASK_DATA_'//N_PTASK ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME//' Indices H' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_H & !<-- The update data index specifications for H ,rc =RC) ! CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state ,name =NAME//' Indices V' & !<-- Name of the variable ,itemCount=N8 & !<-- # of words in index limits of update data ,valueList=INDICES_V & !<-- The update data index specifications for V ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- ! ENDDO parent_tasks ! !----------------------------------------------------------------------- ! END SUBROUTINE MOVING_NEST_RECV_DATA ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_UPDATES_HALOS(FLAG_H_OR_V & ,MOVE_BUNDLE & ,NFLDS_3DR & ,NFLDS_2DR & ,NFLDS_2DI & ) ! !----------------------------------------------------------------------- !*** Before a parent can update locations on its moving nests' domains !*** it must perform halo exchanges for all those variables specified !*** for use in updates but which do not have their halos exchanged !*** during the normal integration. Use of the parent tasks halo !*** regions cannot be avoided during the nest point updates. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! CHARACTER(len=1),INTENT(IN) :: FLAG_H_OR_V ! TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE !<-- ESMF Bundle of 2-D and 3-D arrays specified for updating ! INTEGER(kind=KINT),INTENT(IN) :: NFLDS_2DR & !<-- # of 2-D real arrays specified for updating ,NFLDS_3DR !<-- # of 3-D real arrays specified for updating ! INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: NFLDS_2DI !<-- # of 2-D integer arrays specified for updating ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: N_FIELD,N_REMOVE,NUM_DIMS & ,NUM_FIELDS_MOVE,NUM_LEVELS & ,RC,RC_FINAL ! INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & ,LIMITS_LO ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D ! CHARACTER(len=30) :: FIELD_NAME ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! LOGICAL(kind=KLOG) :: EXCH_NEEDED ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** What is the total number of Fields in the update data BUNDLE? !----------------------------------------------------------------------- ! IF(FLAG_H_OR_V=='H')THEN NUM_FIELDS_MOVE=NFLDS_2DI+NFLDS_2DR+NFLDS_3DR ! ELSEIF(FLAG_H_OR_V=='V')THEN NUM_FIELDS_MOVE=NFLDS_2DR+NFLDS_3DR ENDIF ! !----------------------------------------------------------------------- !*** Check each Field to see if its array has its halo exchanged !*** during the integration. !----------------------------------------------------------------------- ! field_loop: DO N_FIELD=1,NUM_FIELDS_MOVE ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Each Field From Move_Bundle" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the 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_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Type, Dimensions, Name of the 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? ,typeKind=DATATYPE & !<-- Is this Field integer or real? ,name =FIELD_NAME & !<-- This Field's name ,rc =RC ) ! N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** None of the variables needed by the parent for updating its !*** moving nests are type integer so we can skip those outright. !----------------------------------------------------------------------- ! IF(DATATYPE==ESMF_TYPEKIND_I4)THEN CYCLE field_loop ENDIF ! !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Halo Exchange Flag" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Take Attribute from this Field ,name ='EXCH_NEEDED' & !<-- The Attribute's name ,value=EXCH_NEEDED & !<-- The Attribute's value ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** Move to the next Field if a halo exchange is not needed. !----------------------------------------------------------------------- ! IF(.NOT.EXCH_NEEDED)THEN CYCLE field_loop ENDIF ! !----------------------------------------------------------------------- !*** 2-D Fields !----------------------------------------------------------------------- ! dims_2_or_3: IF(NUM_DIMS==2)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the 2-D Array from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,localDe =0 & ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D real array with Field's data ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL HALO_EXCH(ARRAY_2D,1,1,1) ! !----------------------------------------------------------------------- !*** 3-D Fields !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==3)THEN ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the 3-D Array from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle ,localDe =0 & ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D real 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_FINAL) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! NUM_LEVELS=LIMITS_HI(3)-LIMITS_LO(3)+1 ! CALL HALO_EXCH(ARRAY_3D,NUM_LEVELS,1,1) ! !----------------------------------------------------------------------- ! ENDIF dims_2_or_3 ! !----------------------------------------------------------------------- ! ENDDO field_loop ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_UPDATES_HALOS ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_BOOKKEEPING_MOVING(I_PARENT_SW_NEW & ,J_PARENT_SW_NEW & ,I_PARENT_SW_OLD & ,J_PARENT_SW_OLD & ,ITS,ITE,JTS,JTE & ,NUM_CHILD_TASKS & ,CHILD_TASK_LIMITS & ,PARENT_CHILD_SPACE_RATIO & ,NHALO & ,NROWS_P_UPD_W & ,NROWS_P_UPD_E & ,NROWS_P_UPD_S & ,NROWS_P_UPD_N & ,N_UPDATE_CHILD_TASKS & ,TASK_UPDATE_SPECS & ,HANDLE_UPDATE & ,CHILD_UPDATE_DATA & ) ! !----------------------------------------------------------------------- !*** This parent has learned that one of its children wants to move !*** to a new location therefore the parent must determine which !*** points on which child tasks need to be updated by which of its !*** own tasks. Update points on nests are those that lie outside !*** of the nest's pre-move footprint following the move. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_PARENT_SW_NEW & !<-- SW corner of nest on this parent I after move ,I_PARENT_SW_OLD & !<-- SW corner of nest on this parent I before move ,J_PARENT_SW_NEW & !<-- SW corner of nest on this parent J after move ,J_PARENT_SW_OLD & !<-- SW corner of nest on this parent J before move ! ,ITS,ITE,JTS,JTE & !<-- Subdomain integration limits of parent task ! ,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 ,NUM_CHILD_TASKS & !<-- # of child forecast tasks ,PARENT_CHILD_SPACE_RATIO !<-- # of child grid increments in one of parent's ! INTEGER(kind=KINT),DIMENSION(1:4,NUM_CHILD_TASKS),INTENT(IN) :: & CHILD_TASK_LIMITS !<-- ITS,ITE,JTS,JTE for each child forecast task ! INTEGER(kind=KINT),INTENT(INOUT) :: N_UPDATE_CHILD_TASKS !<-- # of moving nest tasks to be updated by this parent task ! INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS),INTENT(IN) :: & HANDLE_UPDATE !<-- MPI Handles for ISends to the child tasks ! TYPE(CHILD_UPDATE_LINK),TARGET,INTENT(INOUT) :: TASK_UPDATE_SPECS !<-- Linked list with nest task update region specifications ! TYPE(MIXED_DATA_TASKS),INTENT(INOUT) :: CHILD_UPDATE_DATA !<-- Composite of all update data from parent for nest tasks ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: I_SHIFT,I1,I2 & ,IDE_CHILD,IDS_CHILD & ,IMS_CHILD,IME_CHILD & ,IDE_FOOTPRINT,IDS_FOOTPRINT & ,ITE_PARENT_ON_CHILD,ITS_PARENT_ON_CHILD & ,J_SHIFT,J1,J2 & ,JDE_CHILD,JDS_CHILD & ,JMS_CHILD,JME_CHILD & ,JDE_FOOTPRINT,JDS_FOOTPRINT & ,JTE_PARENT_ON_CHILD,JTS_PARENT_ON_CHILD & ,KOUNT_TASKS,N,NN ! INTEGER(kind=KINT) :: IERR,ISTAT ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT ! REAL(kind=KFPT) :: I1R,I2R & ,ITE_PARENT_ON_CHILD_R,ITS_PARENT_ON_CHILD_R & ,J1R,J2R & ,JTE_PARENT_ON_CHILD_R,JTS_PARENT_ON_CHILD_R ! TYPE(CHILD_UPDATE_LINK),POINTER :: PTR,PTR_X ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Prior to doing anything related to updating nest tasks !*** following the latest move, be sure that all update data !*** that this parent task might have sent to any nest tasks !*** following the preceding move has indeed been received !*** by all of those tasks whether or not this parent task !*** will send to any of the same nest tasks this time. !----------------------------------------------------------------------- ! PTR=>TASK_UPDATE_SPECS !<-- Start at the top of the list of updated nest tasks ! DO WHILE(ASSOCIATED(PTR%TASK_ID)) !<-- A link exists if TASK_ID is associated. CALL MPI_WAIT(HANDLE_UPDATE(PTR%TASK_ID) & !<-- Handle for ISend from parent task to child task ,JSTAT & !<-- MPI status ,IERR ) IF(ASSOCIATED(PTR%NEXT_LINK))THEN PTR=>PTR%NEXT_LINK ELSE EXIT ENDIF ENDDO ! !----------------------------------------------------------------------- !*** All nest tasks have received data from the previous move !*** so proceed with deleting those data objects. !----------------------------------------------------------------------- ! PTR_X=>TASK_UPDATE_SPECS !<-- Go back to the top of the list of updated nest tasks KOUNT_TASKS=0 ! DO WHILE(ASSOCIATED(PTR_X%TASK_ID)) !<-- An old link exists if TASK_ID is associated. KOUNT_TASKS=KOUNT_TASKS+1 DEALLOCATE(PTR_X%TASK_ID,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,*)' Failed to deallocate TASK_UPDATE_SPECS%TASK_ID for nest task #',KOUNT_TASKS,' stat=',istat ENDIF DEALLOCATE(PTR_X%NUM_PTS_UPDATE_HZ,stat=ISTAT) DEALLOCATE(PTR_X%IL,stat=ISTAT) DEALLOCATE(PTR_X%JL,stat=ISTAT) ! TAIL=>NULL() IF(ASSOCIATED(PTR_X%NEXT_LINK))THEN !<-- If another links exists, point to it. TAIL=>PTR_X%NEXT_LINK ENDIF ! IF(KOUNT_TASKS>1)THEN !<-- The top of TASK_UPDATE_SPECS is allocatable array element N DEALLOCATE(PTR_X,stat=ISTAT) ! (for the Nth moving child) and is not a pointer. IF(ISTAT/=0)THEN WRITE(0,*)' Failed to deallocate TASK_UPDATE_SPECS for nest task #',KOUNT_TASKS,' stat=',istat ENDIF ENDIF ! !--------------------------------------------------------------- !*** Precisely the same nest tasks are updated for both !*** H and V points therefore the deallocation of working !*** pointers for nest tasks in the following block is !*** removing all data for both types of points and not !*** leaving some behind of one type or the other. !--------------------------------------------------------------- ! IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER))THEN DEALLOCATE(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER,stat=ISTAT) IF(ISTAT/=0)then WRITE(0,*)' Failed to deallocate CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER' & ,' for KOUNT_TASKS=',kount_tasks,' stat=',istat ENDIF ENDIF ! IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL))THEN DEALLOCATE(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL,stat=ISTAT) IF(ISTAT/=0)then WRITE(0,*)' Failed to deallocate CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL' & ,' for KOUNT_TASKS=',kount_tasks,' stat=',istat ENDIF ENDIF ! IF(ASSOCIATED(TAIL))THEN PTR_X=>TAIL !<-- There is still another old link ELSE EXIT !<-- The last link in this list has been deallocated ENDIF ! ENDDO ! IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS))THEN DEALLOCATE(CHILD_UPDATE_DATA%TASKS) ENDIF ! !----------------------------------------------------------------------- !*** How far did the nest move on the parent grid? !----------------------------------------------------------------------- ! I_SHIFT=I_PARENT_SW_NEW-I_PARENT_SW_OLD J_SHIFT=J_PARENT_SW_NEW-J_PARENT_SW_OLD ! !----------------------------------------------------------------------- !*** What are this parent task's integration limits !*** in terms of the moving nest's grid indices? !*** To figure that out begin with the values of the !*** index limits of the entire moving nest domain. !----------------------------------------------------------------------- ! IDS_CHILD=CHILD_TASK_LIMITS(1,1) !<-- Index limits of the moving nest on IDE_CHILD=CHILD_TASK_LIMITS(2,NUM_CHILD_TASKS) ! its own grid. JDS_CHILD=CHILD_TASK_LIMITS(3,1) ! JDE_CHILD=CHILD_TASK_LIMITS(4,NUM_CHILD_TASKS) !<-- ! !----------------------------------------------------------------------- !*** In the following diagram 'H' represents mass points on the !*** parent grid while 'h' represents mass points on the nest grid. !*** Gridpoint values on the top are with respect to the nest. !*** Gridpoint values on the bottom are with respect to the parent. !*** The Parent-Child space ratio is 3. The given parent task must !*** cover the gap between its ITE and the next parent task's ITS. !*** 'Hh' indicates that parent and nest points coincide. !----------------------------------------------------------------------- ! ! ! ITS_PARENT_ON_CHILD=-5 I=1 ITE_PARENT_ON_CHILD=9 ! | | | ! | | | ! Hh h h Hh h h Hh h h Hh h h Hh h h Hh ! | | | ! | | |<--gap--> ! ITS_PARENT=1 I_PARENT_SW=3 ITE_PARENT=5 ! ! !----------------------------------------------------------------------- ! ITS_PARENT_ON_CHILD=IDS_CHILD-(I_PARENT_SW_NEW-ITS) & !<-- ITS of parent task in child's coordinate space *PARENT_CHILD_SPACE_RATIO ! for H points ! ITE_PARENT_ON_CHILD=IDS_CHILD-(I_PARENT_SW_NEW-ITE) & !<-- ITE of parent task in child's coordinate space *PARENT_CHILD_SPACE_RATIO & ! for H points +PARENT_CHILD_SPACE_RATIO-1 !<-- Filling in gap beyond last parent point on nest grid ! JTS_PARENT_ON_CHILD=JDS_CHILD-(J_PARENT_SW_NEW-JTS) & !<-- JTS of parent task in child's coordinate space *PARENT_CHILD_SPACE_RATIO ! for H points ! JTE_PARENT_ON_CHILD=JDS_CHILD-(J_PARENT_SW_NEW-JTE) & !<-- JTE of parent task in child's coordinate space *PARENT_CHILD_SPACE_RATIO & ! for H points +PARENT_CHILD_SPACE_RATIO-1 !<-- Filling in gap beyond last parent point on nest grid ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** The situation for V points is necessarily more complex. !*** In the following diagram 'H' represents mass points on the !*** parent grid and 'h' represents mass points on the nest grid !*** while 'V' and 'v' represent the velocity points on the respective !*** grids. Gridpoint values on the top are with respect to the !*** nest's v points. The Parent-Child space ratio is 3. !*** 'Hh' and 'Vv' indicate that parent and nest points coincide. !*** Note the correspondence of the V diagram below with the H diagram !*** above. The nest's v points for which a parent task is responsible !*** have exactly the same indices as the nest h points for which that !*** parent task is responsible. Although doing this means that !*** ITS_PARENT_ON_CHILD is not at the same location as ITS_PARENT, !*** it is required for exactly the same nest tasks to be updated by !*** a parent task for both the h and v points. Likewise for !*** ITE_PARENT_ON_CHILD, etc. !*** The reason the relationships on velocity points are much more !*** complicated than on mass points is that the SW corner point !*** which serves as the anchor of the nest is always an H/h point. !----------------------------------------------------------------------- ! ! ! ITS_PARENT_ON_CHILD_R=-5. I=1 ITE_PARENT_ON_CHILD_R=9. ! | | | ! | | | ! Hh | h h Hh h h Hh | h h Hh h h Hh h h | Hh ! | | v v v |<-gap->| | ! | | | ! | v Vv v v Vv v v Vv v v Vv v v Vv v v Vv ! | | | | ! | | v | v | ! Hh h | h Hh h h Hh h | h Hh h h Hh h | h Hh ! | | | | | | ! | | | | | | ! | ITS_PARENT=1 | I_PARENT_SW=3 | ITE_PARENT=5 ! | on V | on V | on V ! | | | ! | | | ! ITS_PARENT=1 I_PARENT_SW=3 ITE_PARENT=5 ! on H on H on H ! ! !----------------------------------------------------------------------- !*** However the logic has been constructed such that the index limits !*** on each moving nest task subdomain for which each parent task !*** must provide update data are identical for H and V points so we !*** need only use the simpler perspective of H points to find those !*** limits. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Boundary of the nest's pre-move footprint in terms of the !*** nest's new position. !----------------------------------------------------------------------- ! IDS_FOOTPRINT=IDS_CHILD-I_SHIFT*PARENT_CHILD_SPACE_RATIO IDE_FOOTPRINT=IDE_CHILD-I_SHIFT*PARENT_CHILD_SPACE_RATIO JDS_FOOTPRINT=JDS_CHILD-J_SHIFT*PARENT_CHILD_SPACE_RATIO JDE_FOOTPRINT=JDE_CHILD-J_SHIFT*PARENT_CHILD_SPACE_RATIO ! !----------------------------------------------------------------------- !*** Loop through the nest's task subdomains. !----------------------------------------------------------------------- ! child_tasks: DO N=1,NUM_CHILD_TASKS ! !----------------------------------------------------------------------- !*** What are child task N's memory limits? We use those limits !*** since the parent task updates both integration and halo points !*** on the child's subdomains in order to avoid all of the !*** communication involved in doing halo exchanges following the !*** updates. The parent uses only its integration points (no halo !*** points) to do the updating. !----------------------------------------------------------------------- ! IMS_CHILD=MAX(CHILD_TASK_LIMITS(1,N)-NHALO,IDS_CHILD) IME_CHILD=MIN(CHILD_TASK_LIMITS(2,N)+NHALO,IDE_CHILD) JMS_CHILD=MAX(CHILD_TASK_LIMITS(3,N)-NHALO,JDS_CHILD) JME_CHILD=MIN(CHILD_TASK_LIMITS(4,N)+NHALO,JDE_CHILD) ! !----------------------------------------------------------------------- !*** Do any of child task N's H points lie within this parent task's !*** subdomain for the new nest position? !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! limits: IF((IMS_CHILD>=ITS_PARENT_ON_CHILD & .AND. & IMS_CHILD<=ITE_PARENT_ON_CHILD & .OR. & IME_CHILD>=ITS_PARENT_ON_CHILD & .AND. & IME_CHILD<=ITE_PARENT_ON_CHILD) & .AND. & (JMS_CHILD>=JTS_PARENT_ON_CHILD & .AND. & JMS_CHILD<=JTE_PARENT_ON_CHILD & .OR. & JME_CHILD>=JTS_PARENT_ON_CHILD & .AND. & JME_CHILD<=JTE_PARENT_ON_CHILD))THEN !<-- If so, some of child task N's points are within ! ! this parent task's region of responsibility for ! updating post-move nest points. !----------------------------------------------------------------------- !*** The intersection of child task N's subdomain with this parent !*** task's region. !----------------------------------------------------------------------- ! I1=MAX(IMS_CHILD,ITS_PARENT_ON_CHILD) !<-- I limits of child task N's subdomain that lies I2=MIN(IME_CHILD,ITE_PARENT_ON_CHILD) ! within this parent task's subdomain. ! J1=MAX(JMS_CHILD,JTS_PARENT_ON_CHILD) !<-- J limits of child task N's subdomain that lies J2=MIN(JME_CHILD,JTE_PARENT_ON_CHILD) ! within this parent task's subdomain. ! !----------------------------------------------------------------------- !*** The parent task will update only those nest H points that lie !*** outside of the footprint of the nest domain's pre-move position. !*** If all the nest points in child task N's subdomain lie within !*** the footprint then the parent task has nothing to do so move on !*** to the next child task. ! !*** NOTE: The north and east limits of the nest domain's pre-move !*** footprint cannot be used as a source for post-move updates !*** in the intra-task and inter-task shifts of data. That is !*** because the V-pt variables there are not part of the nest !*** integration therefore their values are not valid. So we !*** also must not use the H-pt variables at those same limits !*** or else occasions would arise when nest tasks receiving !*** H-pt updates would not be exactly the same as the nest !*** tasks receiving V-pt updates. That situation is avoided !*** or else the bookkeeping would be even more complicated. !*** The parent will update H-pt and V-pt variables along the !*** nest domain's pre-move footprint's north and east limits. !*** But the intra- and inter-task shifts also cannot do the !*** updating of the nest domain's southern and western boundary !*** because many of the nest variables do not have valid !*** integration values there so the parent must also update !*** those nest boundaries following a shift. Moreover the !*** dynamical tendencies for T, U, and V are not computed in !*** the next to the outermost row of the domain which means the !*** parent will have to update all nest points that move to !*** IDE and IDE-1 and JDE and JDE-1 on the pre-move footprint. !*** Use variables for the depth to which the parent will !*** provide update data to nest points within the footprint !*** in case that depth needs to change in the future. !----------------------------------------------------------------------- ! IF(I1>=IDS_FOOTPRINT+NROWS_P_UPD_W & .AND. & I2<=IDE_FOOTPRINT-NROWS_P_UPD_E & .AND. & J1>=JDS_FOOTPRINT+NROWS_P_UPD_S & .AND. & J2<=JDE_FOOTPRINT-NROWS_P_UPD_N )THEN !<-- If so, these nest points lie entirely within the footprint. ! CYCLE child_tasks !<-- So this child task receives no updating from this ! ! parent task. ENDIF ! !----------------------------------------------------------------------- !*** Now we know this parent task is updating at least some H points !*** within child task N's subdomain so allocate a link in the !*** linked list that holds update information about task N. !*** We use a linked list because we do not know a priori how many !*** child tasks need updates from each parent task and that number !*** will change with each shift of the nest. !----------------------------------------------------------------------- ! N_UPDATE_CHILD_TASKS=N_UPDATE_CHILD_TASKS+1 ! CALL PARENT_FINDS_UPDATE_LIMITS ! !----------------------------------------------------------------------- ! ENDIF limits ! !----------------------------------------------------------------------- !*** The parent task now knows which H points on child task N's !*** subdomain that it must update following the nest's move. !*** Those same index limits will apply to V point updates even !*** though the physical locations differ. !----------------------------------------------------------------------- ! ENDDO child_tasks ! !----------------------------------------------------------------------- ! CONTAINS ! !----------------------------------------------------------------------- ! SUBROUTINE PARENT_FINDS_UPDATE_LIMITS ! !----------------------------------------------------------------------- ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT) :: ISTAT,NLOC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Add a link to this parent task's linked list of moving nest !*** specifications. Each new link is associated with another !*** nest task that needs updating by this parent task on the !*** current moving nest. !----------------------------------------------------------------------- ! IF(N_UPDATE_CHILD_TASKS==1)THEN TAIL=>TASK_UPDATE_SPECS !<-- For the 1st link, point at the top of the list. NULLIFY(TAIL%NEXT_LINK) ELSE ALLOCATE(TAIL%NEXT_LINK,stat=ISTAT) !<-- Add a new link for each additional child task TAIL=>TAIL%NEXT_LINK !<-- Point at the new link so it is ready to use NULLIFY(TAIL%NEXT_LINK) ENDIF ! ALLOCATE(TAIL%TASK_ID) !<-- Allocate the pieces of data in this link ALLOCATE(TAIL%NUM_PTS_UPDATE_HZ) ! ALLOCATE(TAIL%IL(1:4)) ! ALLOCATE(TAIL%JL(1:4)) !<-- ! TAIL%TASK_ID=N !<-- Task is Nth among all tasks on this child ! DO NLOC=1,4 TAIL%IL(NLOC)=-999 TAIL%JL(NLOC)=-999 ENDDO ! !----------------------------------------------------------------------- !*** The simplest case occurs when all of child task N's subdomain !*** that intersects this parent task's subdomain lies outside of !*** the pre-move footprint. The parent task then just updates !*** all those nest points. !----------------------------------------------------------------------- ! parent_updates: IF(I2<=IDS_FOOTPRINT+NROWS_P_UPD_W-1 & .OR. & I1>=IDE_FOOTPRINT-NROWS_P_UPD_E+1 & .OR. & J2<=JDS_FOOTPRINT+NROWS_P_UPD_S-1 & .OR. & J1>=JDE_FOOTPRINT-NROWS_P_UPD_N+1 )THEN ! !----------------------------------------------------------------------- ! TAIL%IL(1)=I1 !<-- I limits of nest task N's update region by parent task TAIL%IL(2)=I2 ! in terms of the nest's grid. ! TAIL%JL(1)=J1 !<-- J limits of nest task N's update region by parent task TAIL%JL(2)=J2 ! in terms of the nest's grid. ! !----------------------------------------------------------------------- !*** What remains are intersections between child task N's subdomain !*** and this parent task's subdomain that lie along the edge of the !*** pre-move footprint. Usually these regions will be a rectangle. !*** However if both child task N and this parent task cover a corner !*** of the footprint then the update region of the child task's !*** subdomain is not a simple rectangle; essentially it is two !*** rectangles. !*** See diagrams in subroutine RECV_INTERIOR_DATA_FROM_PARENT !*** in this module. !----------------------------------------------------------------------- ! ELSE parent_updates ! IF(I1>=IDS_FOOTPRINT+NROWS_P_UPD_W & .AND. & I2<=IDE_FOOTPRINT-NROWS_P_UPD_E )THEN !<-- Rectangular update region on S/N edge of footprint. ! TAIL%IL(1)=I1 TAIL%IL(2)=I2 ! IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Rectangular update region on south edge of footprint. TAIL%JL(1)=J1 TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 ! ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Rectangular update region on north edge of footprint. TAIL%JL(1)=JDE_FOOTPRINT-NROWS_P_UPD_N+1 TAIL%JL(2)=J2 ENDIF ! ELSEIF(J1>=JDS_FOOTPRINT+NROWS_P_UPD_S & .AND. & J2<=JDE_FOOTPRINT-NROWS_P_UPD_N )THEN !<-- Rectangular update region on W/E edge of footprint. ! TAIL%JL(1)=J1 TAIL%JL(2)=J2 ! IF(I1<=IDS_FOOTPRINT+NROWS_P_UPD_W-1)THEN !<-- Rectangular update region on west edge of footprint. TAIL%IL(1)=I1 TAIL%IL(2)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 ! ELSEIF(I2>=IDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Rectangular update region on east edge of footprint. TAIL%IL(1)=IDE_FOOTPRINT-NROWS_P_UPD_N+1 TAIL%IL(2)=I2 ENDIF ! ELSEIF(I1<=IDS_FOOTPRINT+NROWS_P_UPD_W-1 & .AND. & I2>=IDS_FOOTPRINT+NROWS_P_UPD_W )THEN !<-- Child task update region on SW/NW corner of footprint. ! IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Child task update region on SW corner of footprint. TAIL%IL(1)=I1 TAIL%IL(2)=I2 TAIL%IL(3)=I1 TAIL%IL(4)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 TAIL%JL(1)=J1 TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 TAIL%JL(3)=TAIL%JL(2)+1 TAIL%JL(4)=J2 ! ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N-1)THEN !<-- Child task update region on NW corner of footprint. TAIL%IL(1)=I1 TAIL%IL(2)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 TAIL%IL(3)=I1 TAIL%IL(4)=I2 TAIL%JL(1)=J1 TAIL%JL(2)=JDE_FOOTPRINT-NROWS_P_UPD_N TAIL%JL(3)=TAIL%JL(2)+1 TAIL%JL(4)=J2 ENDIF ! ELSEIF(I1<=IDE_FOOTPRINT-NROWS_P_UPD_E & .AND. & I2>=IDE_FOOTPRINT-NROWS_P_UPD_E+1 )THEN !<-- Child task update region on SE/NE corner of footprint ! IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Child task update region on SE corner of footprint. TAIL%IL(1)=I1 TAIL%IL(2)=I2 TAIL%IL(3)=IDE_FOOTPRINT-NROWS_P_UPD_E+1 TAIL%IL(4)=I2 TAIL%JL(1)=J1 TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 TAIL%JL(3)=TAIL%JL(2)+1 TAIL%JL(4)=J2 ! ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Child task update region on NE corner of footprint. TAIL%IL(1)=IDE_FOOTPRINT-NROWS_P_UPD_E+1 TAIL%IL(2)=I2 TAIL%IL(3)=I1 TAIL%IL(4)=I2 TAIL%JL(1)=J1 TAIL%JL(2)=JDE_FOOTPRINT-NROWS_P_UPD_N TAIL%JL(3)=TAIL%JL(2)+1 TAIL%JL(4)=J2 ENDIF ! ENDIF ! !----------------------------------------------------------------------- ! ENDIF parent_updates ! !----------------------------------------------------------------------- ! TAIL%NUM_PTS_UPDATE_HZ=(TAIL%IL(2)-TAIL%IL(1)+1) & *(TAIL%JL(2)-TAIL%JL(1)+1) ! IF(TAIL%IL(3)>0)THEN TAIL%NUM_PTS_UPDATE_HZ=(TAIL%IL(4)-TAIL%IL(3)+1) & *(TAIL%JL(4)-TAIL%JL(3)+1) & +TAIL%NUM_PTS_UPDATE_HZ ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_FINDS_UPDATE_LIMITS ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_BOOKKEEPING_MOVING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_UPDATES_MOVING(FLAG_H_OR_V & ,N_UPDATE_CHILD_TASKS & ,PARENT_CHILD_SPACE_RATIO & ,PARENT_CHILD_TIME_RATIO & ,NTIMESTEP_CHILD & ,I_PARENT_SW & ,J_PARENT_SW & ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & ,DSG2,PDSG1 & ,FIS,PD & ,T,Q,CW & ,NUM_PARENT_TASKS & ,NUM_CHILD_TASKS & ,CHILD_TASK_RANKS & ,CHILD_TASK_LIMITS & ,HYPER_A & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE & ,NUM_LYRS & ,LBND1,UBND1,LBND2,UBND2 & ,FIS_CHILD & ,COMM_TO_MY_CHILD & ,HANDLE_UPDATE & ,MOVE_BUNDLE & ,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 & ,CHILD_UPDATE_DATA & ) ! !----------------------------------------------------------------------- !*** Each parent task knows which moving nest tasks if any that it !*** must update and which points on those tasks. Now the bilinear !*** interpolation weights can be computed and then all specified !*** 2-D and 3-D variables are interpolated from the parent grid !*** to the nest's. Finally the parent tasks send the data to the !*** appropriate nest tasks. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_CHILD & !<-- MPI communicator to the current nest/child ,I_PARENT_SW,J_PARENT_SW & !<-- SW corner of nest on this parent I,J after move ,IDS,IDE,JDS,JDE & !<-- Parent domain index limits ,IMS,IME,JMS,JME & !<-- Parent task memory index limits ,N_UPDATE_CHILD_TASKS & !<-- # of moving nest tasks updated by this parent task ,NTIMESTEP_CHILD & !<-- Child's timestep at which it recvs parent data ,NUM_LYRS & !<-- # of model layers ,NUM_CHILD_TASKS & !<-- # of forecast tasks on all of this parent's children ,NUM_FIELDS_MOVE_2D_H_I & !<-- # of 2-D integer H arrays specified for updating ,NUM_FIELDS_MOVE_2D_X_I & !<-- # of 2-D integer H arrays updated from external files ,NUM_FIELDS_MOVE_2D_H_R & !<-- # of 2-D real H arrays specified for updating ,NUM_FIELDS_MOVE_2D_X_R & !<-- # of 2-D real H arrays updated from external files ,NUM_FIELDS_MOVE_3D_H & !<-- # of 3-D H arrays specified for updating ,NUM_LEVELS_MOVE_3D_H & !<-- # of 2-D levels in all 3-D H update arrays ,NUM_FIELDS_MOVE_2D_V & !<-- # of 2-D V arrays specified for updating ,NUM_FIELDS_MOVE_3D_V & !<-- # of 3-D V arrays specified for updating ,NUM_LEVELS_MOVE_3D_V & !<-- # of 2-D levels in all 3-D V update arrays ,NUM_PARENT_TASKS & !<-- # of forecast tasks on this parent ,PARENT_CHILD_SPACE_RATIO & !<-- Ratio of parent's grid increment to its child's ,PARENT_CHILD_TIME_RATIO & !<-- Ratio of parent's time step to its child's ,LBND1,UBND1,LBND2,UBND2 !<-- Array bounds of nest-resolution FIS on parent ! INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & HANDLE_UPDATE !<-- MPI Handles for ISends to the child tasks ! INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS),INTENT(IN) :: & CHILD_TASK_RANKS !<-- Child task local ranks in p-c intracomm ! INTEGER(kind=KINT),DIMENSION(1:4,NUM_CHILD_TASKS),INTENT(IN) :: & CHILD_TASK_LIMITS !<-- ITS,ITE,JTS,JTE for each child forecast task ! REAL(kind=KFPT),INTENT(IN) :: PDTOP & !<-- Pressure at top of sigma domain (Pa) ,PT !<-- Top pressure of model domain (Pa) ! REAL(kind=KDBL),INTENT(IN) :: HYPER_A !<-- Underground extrapolation quantity ! REAL(kind=KFPT),DIMENSION(1:NUM_LYRS),INTENT(IN) :: DSG2 & !<-- Vertical structure coefficients for midlayers ,PDSG1 & ! ,PSGML1 & ! ,SGML2 !<-- ! REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+1),INTENT(IN) :: SG1,SG2 !<-- Vertical structure coefficients for interfaces ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Sfc geopotential on parent mass points ,PD !<-- Parent PD ! REAL(kind=KFPT),DIMENSION(LBND1:UBND1,LBND2:UBND2),INTENT(IN) :: & FIS_CHILD !<-- Moving nest's full res FIS distributed on the parent ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NUM_LYRS) & ,INTENT(IN) :: T & !<-- Parent sensible temperature (K) ,Q & !<-- Parent specific humidity (kg/kg) ,CW !<-- Parent cloud condensate (kg/kg) ! CHARACTER(len=1),INTENT(IN) :: FLAG_H_OR_V !<-- Are we updating H or V points? ! TYPE(MIXED_DATA_TASKS),INTENT(INOUT) :: CHILD_UPDATE_DATA !<-- Composite of all update data from parent for each nest task ! TYPE(CHILD_UPDATE_LINK),TARGET,INTENT(INOUT) :: & TASK_UPDATE_SPECS !<-- Linked list with nest task update specifications ! TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE !<-- ESMF Bundle of 2-D and 3-D arrays specified for updating ! !--------------------- !*** Local Variables !--------------------- ! INTEGER(kind=KINT),SAVE :: I,I1,I2 & ,I_EAST,I_OFFSET,I_WEST & ,IDS_CHILD,ISTART,ITAG,ITER & ,J,J1,J2 & ,J_NORTH,J_OFFSET,J_SOUTH & ,JDS_CHILD,JSTART & ,KHI,KLO & ,L,LOC_1,LOC_2 & ,N,N_ADD,N_FIELD,N_REMOVE,N_STRIDE & ,NPOINTS_HORIZ & ,NPOINTS_HORIZ_H & ,NPOINTS_HORIZ_V & ,NUM_DIMS & ,NUM_FIELDS_MOVE & ,NUM_LEVS_IN & ,NUM_LEVS_SEC & ,NUM_LEVELS & ,NUM_INTEGER_WORDS_SEND & ,NUM_REAL_WORDS_SEND & ,UPDATE_TYPE_INT ! INTEGER(kind=KINT) :: CHILDTASK,I_TRANS,IERR,ISTAT,IVAL,J_TRANS & ,KNT_DUMMY,RC,RC_UPDATE ! INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & ,LIMITS_LO ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,TARGET :: & I_PARENT_EAST & ,I_PARENT_WEST & ,J_PARENT_NORTH & ,J_PARENT_SOUTH ! INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PARENT_EAST_H & ,I_PARENT_WEST_H & ,J_PARENT_NORTH_H & ,J_PARENT_SOUTH_H ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: & KNT_INTEGER_PTS & ,KNT_REAL_PTS & ,NUM_ITER ! INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D ! REAL(kind=KFPT) :: CHILD_PARENT_SPACE_RATIO & ,COEFF_1,COEFF_2,CW_INTERP & ,D_LNP_DFI,DELP_EXTRAP,DP,FACTOR & ,IDIFF_EAST,IDIFF_WEST & ,JDIFF_NORTH,JDIFF_SOUTH & ,LOG_P1_PARENT & ,MAX_WGHT & ,PDTOP_PT,PHI_DIFF & ,PSFC_CHILD & ,PSFC_PARENT_NE,PSFC_PARENT_NW & ,PSFC_PARENT_SE,PSFC_PARENT_SW & ,PX_NE,PX_NW,PX_SE,PX_SW & ,Q_INTERP,R_DELP,R_INC & ,RECIP_SUM_WGT,SUM_PROD,SUM_WGT & ,T_INTERP,TMP & ,X_NE,X_NW,X_SE,X_SW ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: P_OUTPUT ! REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+2) :: P_INPUT & ,VBL_INPUT ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: I_PARENT & ,J_PARENT & ,SEC_DERIV ! REAL(kind=KFPT),DIMENSION(:),POINTER :: I_CHILD_ON_PARENT_H & ,J_CHILD_ON_PARENT_H ! REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL_CHILD & ,VBL_COL_X ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) :: LMASK ! REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+2,1:4) :: C_TMP !<-- Working array for ESSL spline call ! REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: LOG_PBOT & ,LOG_PTOP & ,PD_CHILD & ,PD_INTERP & ,PROD_LWGT_NE & ,PROD_LWGT_NW & ,PROD_LWGT_SE & ,PROD_LWGT_SW & ,PROD_SWGT_NE & ,PROD_SWGT_NW & ,PROD_SWGT_SE & ,PROD_SWGT_SW ! REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE,TARGET :: WGHT_NE & ,WGHT_NW & ,WGHT_SE & ,WGHT_SW ! REAL(kind=KFPT),DIMENSION(:,:),POINTER,SAVE :: PDO & ,SMASK ! REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D & ,WGHT_NE_H & ,WGHT_NW_H & ,WGHT_SE_H & ,WGHT_SW_H ! REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE,TARGET :: PINT_CHILD & ,PINT_INTERP & ,PMID_CHILD & ,PMID_INTERP ! REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PHI_INTERP & ,VBL_INTERP ! REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D & ,P3D_INPUT & ,P3D_OUTPUT ! LOGICAL(kind=KLOG) :: INTERFACES & ,MIDLAYERS ! CHARACTER(len=1) :: UPDATE_TYPE_CHAR ! CHARACTER(len=4) :: FNAME ! CHARACTER(len=30) :: FIELD_NAME ! TYPE(CHILD_UPDATE_LINK),POINTER,SAVE :: PTR_H,PTR_V ! TYPE(CHILD_UPDATE_LINK),POINTER :: PTR_X ! TYPE(ESMF_Field) :: HOLD_FIELD ! TYPE(ESMF_TypeKind_Flag) :: DATATYPE ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! btim=timef() ! RC =ESMF_SUCCESS RC_UPDATE=ESMF_SUCCESS ! CHILD_PARENT_SPACE_RATIO=1./PARENT_CHILD_SPACE_RATIO ! !----------------------------------------------------------------------- !*** This update routine is called first for H points and then !*** a second time for V points. To save time on communication !*** all H and V point data will be sent together at the end of !*** the 2nd (V-point) call. First do some prep work that only !*** needs to be done once for both H and V at this move. !----------------------------------------------------------------------- ! prep_block: IF(FLAG_H_OR_V=='H')THEN ! !----------------------------------------------------------------------- ! ALLOCATE(KNT_REAL_PTS(1:N_UPDATE_CHILD_TASKS) & ,stat=ISTAT) ALLOCATE(KNT_INTEGER_PTS(1:N_UPDATE_CHILD_TASKS) & ,stat=ISTAT) ALLOCATE(CHILD_UPDATE_DATA%TASKS(1:N_UPDATE_CHILD_TASKS) & ,stat=ISTAT) ALLOCATE(NUM_ITER(1:N_UPDATE_CHILD_TASKS) & ,stat=ISTAT) ! LM=NUM_LYRS ! !----------------------------------------------------------------------- !*** Start at the top of the linked lists that hold the task ID !*** and index limits for all update H and V points on each nest !*** task for the current nest. Remember that each link in the !*** lists corresponds to a nest task that this parent task must !*** update. !----------------------------------------------------------------------- ! PTR_H=>TASK_UPDATE_SPECS PTR_V=>TASK_UPDATE_SPECS ! !----------------------------------------------------------------------- !*** Find the total number of words to be updated on each nest task !*** for both H and V points. !----------------------------------------------------------------------- ! prep_loop: DO N=1,N_UPDATE_CHILD_TASKS ! !----------------------------------------------------------------------- ! IF(N>1)THEN !<-- Point to the next link (the next task to be updated). PTR_H=>PTR_H%NEXT_LINK PTR_V=>PTR_V%NEXT_LINK ENDIF ! NPOINTS_HORIZ_H=(PTR_H%IL(2)-PTR_H%IL(1)+1) & *(PTR_H%JL(2)-PTR_H%JL(1)+1) ! NPOINTS_HORIZ_V=(PTR_V%IL(2)-PTR_V%IL(1)+1) & *(PTR_V%JL(2)-PTR_V%JL(1)+1) ! NUM_INTEGER_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_I & -NUM_FIELDS_MOVE_2D_X_I) & *NPOINTS_HORIZ_H ! NUM_REAL_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_R & -NUM_FIELDS_MOVE_2D_X_R & +NUM_LEVELS_MOVE_3D_H) & *NPOINTS_HORIZ_H & +(NUM_FIELDS_MOVE_2D_V & +NUM_LEVELS_MOVE_3D_V) & *NPOINTS_HORIZ_V ! !----------------------------------------------------------------------- !*** If there is a 2nd region on nest task N updated by the current !*** parent task then we need to iterate twice through the updating !*** process. These 2nd regions exist only when the parent task !*** and the nest task it is updating both lie on the corner of the !*** nest's pre-move footprint. !----------------------------------------------------------------------- ! NUM_ITER(N)=1 ! IF(PTR_H%IL(3)>0)THEN !<-- If true then there must be a 2nd update region. IF(PTR_V%IL(3)<0)THEN WRITE(0,*)' A 2nd update region exists for H points but not V!! ABORT!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF NUM_ITER(N)=2 NPOINTS_HORIZ_H=(PTR_H%IL(4)-PTR_H%IL(3)+1) & *(PTR_H%JL(4)-PTR_H%JL(3)+1) ! NPOINTS_HORIZ_V=(PTR_V%IL(4)-PTR_V%IL(3)+1) & *(PTR_V%JL(4)-PTR_V%JL(3)+1) ! NUM_INTEGER_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_I & !<-- Total # of integer words in parent's update -NUM_FIELDS_MOVE_2D_X_I) & ! of nest task N. *NPOINTS_HORIZ_H & +NUM_INTEGER_WORDS_SEND ! NUM_REAL_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_R & !<-- Total # of real words in parent's update -NUM_FIELDS_MOVE_2D_X_R & ! of nest task N. +NUM_LEVELS_MOVE_3D_H) & *NPOINTS_HORIZ_H & +(NUM_FIELDS_MOVE_2D_V & +NUM_LEVELS_MOVE_3D_V) & *NPOINTS_HORIZ_V & +NUM_REAL_WORDS_SEND ENDIF ! !----------------------------------------------------------------------- !*** Now we know how many words will be sent from the current parent !*** task to nest task N so allocate the objects that will hold this !*** data. There may or may not be any integer variables updated at !*** this time. !----------------------------------------------------------------------- ! ALLOCATE(CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(1:NUM_REAL_WORDS_SEND)) ! IF(NUM_INTEGER_WORDS_SEND>0)THEN ALLOCATE(CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER(1:NUM_INTEGER_WORDS_SEND)) ELSE CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER=>NULL() ENDIF ! !----------------------------------------------------------------------- ! KNT_REAL_PTS(N)=0 !<-- Initialize the counter of real update data words. KNT_INTEGER_PTS(N)=0 !<-- Initialize the counter of integer update data words. ! ISTART=MAX(IMS,IDS) JSTART=MAX(JMS,JDS) ! I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO & !<-- I offset of child SW corner in full topo array on parent +LBND1-1 J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO & !<-- J offset of child SW corner in full topo array on parent +LBND2-1 ! !----------------------------------------------------------------------- ! ENDDO prep_loop ! !----------------------------------------------------------------------- !*** We need PD and PDO on the parent for building the !*** pressure structure from which to interpolate to the nest !*** update points. PD was already sent into this routine via !*** the argument list since it was needed earlier in the coupler. !*** Unload PDO now. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PDO Field From H Move_Bundle" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates ,fieldName ='PDO'//SUFFIX_MOVE & !<-- Get the Field with this name ,field =HOLD_FIELD & !<-- Put the Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract PDO Array from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field holding PDO ,localDe =0 & ,farrayPtr=PDO & !<-- Put array here ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** We need the parent's Sea Mask for generating surface variable !*** updates in order to exclude either sea or land point values !*** in the bilinear interpolation. !----------------------------------------------------------------------- ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract the Sea Mask from the H Move_Bundle" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates ,fieldName ='SM'//SUFFIX_MOVE & !<-- The parent's sea mask ,field =HOLD_FIELD & !<-- Put the Field here ,rc =RC) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ MESSAGE_CHECK="Extract Sea Mask Array from Field" ! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field holding PDO ,localDe =0 & ,farrayPtr=SMASK & !<-- Put the sea mask array here ,rc =RC ) ! ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! !----------------------------------------------------------------------- !*** 'Flip' the seamask values (1=>sea) for use as a landmask (0=>sea). !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME IF(SMASK(I,J)>0.5)THEN LMASK(I,J)=0. ELSE LMASK(I,J)=1. ENDIF ENDDO ENDDO ! !----------------------------------------------------------------------- ! ENDIF prep_block ! !----------------------------------------------------------------------- !*** As we prepare to interpolate from the parent to the child, !*** we need to be aware of another distinction between the H !*** and the V point locations on those domains' grids regarding !*** I=1 on the nest relative to I_PARENT_SW. For H points !*** I=1 on the nest coincides with I_PARENT_SW on the parent. !*** However for V points I=1 is to the west of I_PARENT_SW. !*** See the diagram at the beginning of the FLAG_H_OR_V==V !*** section of PARENT_BOOKKEEPING_MOVING. Specifically !*** v(1) on the nest is !*** (0.5*PARENT_CHILD_SPACE_RATIO-0.5)/PARENT_CHILD_SPACE_RATIO !*** to the west of V(I_PARENT_SW) on the parent grid. Compute !*** that increment here then use it below when we need the !*** Real values for parent I's and J's on the parent grid !*** that coincide with the update locations on the nest grid. !----------------------------------------------------------------------- ! PTR_X=>TASK_UPDATE_SPECS ! IF(FLAG_H_OR_V=='H')THEN NUM_FIELDS_MOVE=NUM_FIELDS_MOVE_2D_H_I & +NUM_FIELDS_MOVE_2D_H_R & +NUM_FIELDS_MOVE_3D_H R_INC=0. ! ELSEIF(FLAG_H_OR_V=='V')THEN NUM_FIELDS_MOVE=NUM_FIELDS_MOVE_2D_V & +NUM_FIELDS_MOVE_3D_V R_INC=-(0.5*PARENT_CHILD_SPACE_RATIO-0.5) & *CHILD_PARENT_SPACE_RATIO ENDIF ! !----------------------------------------------------------------------- ! DO L=1,NUM_LYRS+2 P_INPUT(L)=0. VBL_INPUT(L)=0. ENDDO ! !----------------------------------------------------------------------- !*** Loop through each of the moving nest tasks whose subdomains !*** contain points that must be updated by this parent task !*** after the nest moved. !----------------------------------------------------------------------- ! ctask_loop: DO N=1,N_UPDATE_CHILD_TASKS ! !----------------------------------------------------------------------- ! iter_loop: DO ITER=1,NUM_ITER(N) !<-- Either one or two regions on the nest task must be updated. ! !----------------------------------------------------------------------- ! IF(ITER==1)THEN I1=PTR_X%IL(1) !<-- I limits of nest task's update region by parent task I2=PTR_X%IL(2) ! in terms of the nest's grid. J1=PTR_X%JL(1) !<-- J limits of nest task's update region by parent task J2=PTR_X%JL(2) ! in terms of the nest's grid. ELSE I1=PTR_X%IL(3) !<-- I limits of nest task's update region by parent task I2=PTR_X%IL(4) ! in terms of the nest's grid for 2nd update region. J1=PTR_X%JL(3) !<-- J limits of nest task's update region by parent task J2=PTR_X%JL(4) ! in terms of the nest's grid for 2nd update region. ENDIF ! ALLOCATE(I_PARENT(I1:I2)) ALLOCATE(I_PARENT_EAST(I1:I2)) ALLOCATE(I_PARENT_WEST(I1:I2)) ! ALLOCATE(J_PARENT(J1:J2)) ALLOCATE(J_PARENT_NORTH(J1:J2)) ALLOCATE(J_PARENT_SOUTH(J1:J2)) ! ALLOCATE(WGHT_SW(I1:I2,J1:J2)) ALLOCATE(WGHT_NW(I1:I2,J1:J2)) ALLOCATE(WGHT_NE(I1:I2,J1:J2)) ALLOCATE(WGHT_SE(I1:I2,J1:J2)) ! ALLOCATE(PINT_INTERP(I1:I2,J1:J2,1:NUM_LYRS+1)) ALLOCATE( PHI_INTERP(I1:I2,J1:J2,1:NUM_LYRS+1)) ALLOCATE( PD_CHILD(I1:I2,J1:J2)) ALLOCATE( PD_INTERP(I1:I2,J1:J2)) ALLOCATE( LOG_PBOT(I1:I2,J1:J2)) ALLOCATE( LOG_PTOP(I1:I2,J1:J2)) ! NPOINTS_HORIZ=(I2-I1+1)*(J2-J1+1) ALLOCATE(PMID_INTERP(I1:I2,J1:J2,1:NUM_LYRS)) ALLOCATE( PMID_CHILD(I1:I2,J1:J2,1:NUM_LYRS)) ALLOCATE( PINT_CHILD(I1:I2,J1:J2,1:NUM_LYRS+1)) ! IDS_CHILD=CHILD_TASK_LIMITS(1,1) !<-- Child task's starting I on grid of moving nest JDS_CHILD=CHILD_TASK_LIMITS(3,1) !<-- Child task's starting J on grid of moving nest ! DO I=I1,I2 I_PARENT(I)=I_PARENT_SW+R_INC & !<-- Real Parent I's on parent grid for these nest I's +(I-IDS_CHILD)*CHILD_PARENT_SPACE_RATIO ! in the nest grid's Update region. ENDDO ! DO J=J1,J2 J_PARENT(J)=J_PARENT_SW+R_INC & !<-- Real Parent J's on parent grid for these nest J's +(J-JDS_CHILD)*CHILD_PARENT_SPACE_RATIO ! in the nest grid's update region. ENDDO ! !----------------------------------------------------------------------- !*** Loop through this nest's update points and determine the four !*** parent points that surround each nest point as well and the !*** bilinear interpolation weight associated with each of those !*** four parent points for the given nest point. !----------------------------------------------------------------------- ! DO J=J1,J2 J_PARENT_SOUTH(J)=INT(J_PARENT(J)+EPS) !<-- Parent J at or immediately south of nest point J_PARENT_NORTH(J)=J_PARENT_SOUTH(J)+1 !<-- Parent J immediately north of nest point ! DO I=I1,I2 I_PARENT_WEST(I)=INT(I_PARENT(I)+EPS) !<-- Parent I at or immediately west of nest point I_PARENT_EAST(I)=I_PARENT_WEST(I)+1 !<-- Parent I immediately east of nest point ! IDIFF_EAST=I_PARENT_EAST(I)-I_PARENT(I) IDIFF_WEST=I_PARENT(I)-I_PARENT_WEST(I) JDIFF_NORTH=J_PARENT_NORTH(J)-J_PARENT(J) JDIFF_SOUTH=J_PARENT(J)-J_PARENT_SOUTH(J) ! WGHT_SW(I,J)=IDIFF_EAST*JDIFF_NORTH !<-- Bilinear weight for parent's point SW of child's point WGHT_NW(I,J)=IDIFF_EAST*JDIFF_SOUTH !<-- Bilinear weight for parent's point NW of child's point WGHT_NE(I,J)=IDIFF_WEST*JDIFF_SOUTH !<-- Bilinear weight for parent's point NE of child's point WGHT_SE(I,J)=IDIFF_WEST*JDIFF_NORTH !<-- Bilinear weight for parent's point SE of child's point ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** The parent computes its layer interface pressures at the !*** locations of the moving nest update points. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** If we are updating mass point variables then those variables !*** obviously coincide with the pressure information. In other !*** words we are interpolating from parent H points to nest h points. !----------------------------------------------------------------------- ! h_v_block: IF(FLAG_H_OR_V=='H')THEN ! I_PARENT_EAST_H=>I_PARENT_EAST I_PARENT_WEST_H=>I_PARENT_WEST J_PARENT_NORTH_H=>J_PARENT_NORTH J_PARENT_SOUTH_H=>J_PARENT_SOUTH ! WGHT_NE_H=>WGHT_NE WGHT_NW_H=>WGHT_NW WGHT_SE_H=>WGHT_SE WGHT_SW_H=>WGHT_SW ! !----------------------------------------------------------------------- !*** If we are updating wind components then we need to know !*** T, Q, and FIS at V points in order to compute sfc pressure !*** and ultimately midlayer pressure at the V points. !*** Base the bilinear interpolation to nest v points on the !*** values at parent H points (where T, Q, and FIS are defined) !*** in order to minimize horizontal interpolation. !----------------------------------------------------------------------- ! ELSEIF(FLAG_H_OR_V=='V')THEN ! ALLOCATE(I_PARENT_EAST_H(I1:I2)) ALLOCATE(I_PARENT_WEST_H(I1:I2)) ALLOCATE(J_PARENT_NORTH_H(J1:J2)) ALLOCATE(J_PARENT_SOUTH_H(J1:J2)) ! ALLOCATE(I_CHILD_ON_PARENT_H(I1:I2)) ALLOCATE(J_CHILD_ON_PARENT_H(J1:J2)) ! ALLOCATE(WGHT_NE_H(I1:I2,J1:J2)) ALLOCATE(WGHT_NW_H(I1:I2,J1:J2)) ALLOCATE(WGHT_SE_H(I1:I2,J1:J2)) ALLOCATE(WGHT_SW_H(I1:I2,J1:J2)) ! DO I=I1,I2 ! I_CHILD_ON_PARENT_H(I)=I_PARENT_SW & +(I-IDS_CHILD+0.5) & *CHILD_PARENT_SPACE_RATIO ! I_PARENT_WEST_H(I)=INT(I_CHILD_ON_PARENT_H(I)) !<-- Parent I on H immediately west of nest V point I_PARENT_EAST_H(I)=I_PARENT_WEST_H(I)+1 !<-- Parent I on H immediately east of nest V point ! ENDDO ! DO J=J1,J2 ! J_CHILD_ON_PARENT_H(J)=J_PARENT_SW & +(J-JDS_CHILD+0.5) & *CHILD_PARENT_SPACE_RATIO ! J_PARENT_SOUTH_H(J)=INT(J_CHILD_ON_PARENT_H(J)) !<-- Parent J on H immediately south of nest V point J_PARENT_NORTH_H(J)=J_PARENT_SOUTH_H(J)+1 !<-- Parent J on H immediately north of nest V point ! ENDDO ! DO J=J1,J2 DO I=I1,I2 WGHT_SW_H(I,J)=(I_PARENT_EAST_H(I)-I_CHILD_ON_PARENT_H(I)) & *(J_PARENT_NORTH_H(J)-J_CHILD_ON_PARENT_H(J)) WGHT_SE_H(I,J)=(I_CHILD_ON_PARENT_H(I)-I_PARENT_WEST_H(I)) & *(J_PARENT_NORTH_H(J)-J_CHILD_ON_PARENT_H(J)) WGHT_NW_H(I,J)=(I_PARENT_EAST_H(I)-I_CHILD_ON_PARENT_H(I)) & *(J_CHILD_ON_PARENT_H(J)-J_PARENT_SOUTH_H(J)) WGHT_NE_H(I,J)=(I_CHILD_ON_PARENT_H(I)-I_PARENT_WEST_H(I)) & *(J_CHILD_ON_PARENT_H(J)-J_PARENT_SOUTH_H(J)) ENDDO ENDDO ! ENDIF h_v_block ! !----------------------------------------------------------------------- !*** When the parent generates Real soil variable updates for its !*** moving nests it uses bilinear interpolation but also must use !*** the sea/land mask in order to avoid including sea values in !*** land variables and vice versa. This means the bilinear !*** interpolation weighting needs to be adjusted to account for !*** the exclusion of sea or land points in the 4-pt summation. !----------------------------------------------------------------------- ! soil_wgts: IF(FLAG_H_OR_V=='H')THEN ! ALLOCATE(PROD_LWGT_SW(I1:I2,J1:J2)) ALLOCATE(PROD_LWGT_SE(I1:I2,J1:J2)) ALLOCATE(PROD_LWGT_NW(I1:I2,J1:J2)) ALLOCATE(PROD_LWGT_NE(I1:I2,J1:J2)) ALLOCATE(PROD_SWGT_SW(I1:I2,J1:J2)) ALLOCATE(PROD_SWGT_SE(I1:I2,J1:J2)) ALLOCATE(PROD_SWGT_NW(I1:I2,J1:J2)) ALLOCATE(PROD_SWGT_NE(I1:I2,J1:J2)) ! DO J=J1,J2 J_SOUTH=J_PARENT_SOUTH(J) J_NORTH=J_PARENT_NORTH(J) ! DO I=I1,I2 I_WEST=I_PARENT_WEST(I) I_EAST=I_PARENT_EAST(I) ! X_SW=WGHT_SW(I,J)*LMASK(I_WEST,J_SOUTH) X_SE=WGHT_SE(I,J)*LMASK(I_EAST,J_SOUTH) X_NW=WGHT_NW(I,J)*LMASK(I_WEST,J_NORTH) X_NE=WGHT_NE(I,J)*LMASK(I_EAST,J_NORTH) ! SUM_WGT=X_SW+X_SE+X_NW+X_NE ! IF(ABS(SUM_WGT)>1.E-6)THEN RECIP_SUM_WGT=1./(X_SW+X_SE+X_NW+X_NE) ELSE RECIP_SUM_WGT=0. ENDIF ! PROD_LWGT_SW(I,J)=X_SW*RECIP_SUM_WGT !<-- These are the adjusted bilinear interpolation PROD_LWGT_SE(I,J)=X_SE*RECIP_SUM_WGT ! weights that take into account the presence PROD_LWGT_NW(I,J)=X_NW*RECIP_SUM_WGT ! of sea points that must be excluded in the PROD_LWGT_NE(I,J)=X_NE*RECIP_SUM_WGT ! summation. ! X_SW=WGHT_SW(I,J)*SMASK(I_WEST,J_SOUTH) X_SE=WGHT_SE(I,J)*SMASK(I_EAST,J_SOUTH) X_NW=WGHT_NW(I,J)*SMASK(I_WEST,J_NORTH) X_NE=WGHT_NE(I,J)*SMASK(I_EAST,J_NORTH) ! SUM_WGT=X_SW+X_SE+X_NW+X_NE ! IF(ABS(SUM_WGT)>1.E-6)THEN RECIP_SUM_WGT=1./(X_SW+X_SE+X_NW+X_NE) ELSE RECIP_SUM_WGT=0. ENDIF ! PROD_SWGT_SW(I,J)=X_SW*RECIP_SUM_WGT !<-- These are the adjusted bilinear interpolation PROD_SWGT_SE(I,J)=X_SE*RECIP_SUM_WGT ! weights that take into account the presence PROD_SWGT_NW(I,J)=X_NW*RECIP_SUM_WGT ! of land points that must be excluded in the PROD_SWGT_NE(I,J)=X_NE*RECIP_SUM_WGT ! summation. ENDDO ENDDO ! ENDIF soil_wgts ! !----------------------------------------------------------------------- !*** Some of the primary dynamics integration variables are valid !*** at the previous time step (PDO,TP,UP,VP). Update those at !*** the appropriate nest gridpoints as well. Since the parent's !*** time step is larger than the child's, approximate the child's !*** previous time step value as !*** (PARENT_CHILD_TIME_RATIO-1.)/PARENT_CHILD_TIME_RATIO !*** between the old and current parent values. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Compute the parent's Psfc at the nest H or V update points. !----------------------------------------------------------------------- ! DO J=J1,J2 DO I=I1,I2 ! PSFC_PARENT_SW=PD(I_PARENT_WEST_H(I),J_PARENT_SOUTH_H(J))+PT PSFC_PARENT_SE=PD(I_PARENT_EAST_H(I),J_PARENT_SOUTH_H(J))+PT PSFC_PARENT_NW=PD(I_PARENT_WEST_H(I),J_PARENT_NORTH_H(J))+PT PSFC_PARENT_NE=PD(I_PARENT_EAST_H(I),J_PARENT_NORTH_H(J))+PT ! PINT_INTERP(I,J,LM+1)=WGHT_SW_H(I,J)*PSFC_PARENT_SW & !<-- Parent's Psfc at nest point at parent's sfc elevation +WGHT_SE_H(I,J)*PSFC_PARENT_SE & ! +WGHT_NW_H(I,J)*PSFC_PARENT_NW & ! +WGHT_NE_H(I,J)*PSFC_PARENT_NE !<-- ! LOG_PBOT(I,J)=LOG(PINT_INTERP(I,J,LM+1)) ! PHI_INTERP(I,J,LM+1)=WGHT_SW_H(I,J)*FIS(I_PARENT_WEST_H(I) & !<-- Parent's sfc geopotential at nest point ,J_PARENT_SOUTH_H(J)) & ! +WGHT_SE_H(I,J)*FIS(I_PARENT_EAST_H(I) & ! ,J_PARENT_SOUTH_H(J)) & ! +WGHT_NW_H(I,J)*FIS(I_PARENT_WEST_H(I) & ! ,J_PARENT_NORTH_H(J)) & ! +WGHT_NE_H(I,J)*FIS(I_PARENT_EAST_H(I) & ! ,J_PARENT_NORTH_H(J)) !<-- ! ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Parent computes its layer interface pressures and geopotentials !*** at the locations of the moving nest update points. The input !*** and target values of pressure locations for the vertical !*** interpolations from parent to nest are the hydrostatic midlayer !*** and interface pressures. !----------------------------------------------------------------------- ! DO J=J1,J2 !<-- J limits of child task update region on parent task J_SOUTH=J_PARENT_SOUTH_H(J) J_NORTH=J_PARENT_NORTH_H(J) ! DO I=I1,I2 !<-- I limits of child task update region on parent task I_WEST=I_PARENT_WEST_H(I) I_EAST=I_PARENT_EAST_H(I) ! PD_INTERP(I,J)=WGHT_SW_H(I,J)*PD(I_WEST,J_SOUTH) & !<-- Parent's PD interp'd to child task update points +WGHT_SE_H(I,J)*PD(I_EAST,J_SOUTH) & +WGHT_NW_H(I,J)*PD(I_WEST,J_NORTH) & +WGHT_NE_H(I,J)*PD(I_EAST,J_NORTH) ! ENDDO ENDDO ! DO L=NUM_LYRS,1,-1 ! PDTOP_PT=SG1(L+1)*PDTOP+PT ! DO J=J1,J2 !<-- J limits of child task update region on parent task J_SOUTH=J_PARENT_SOUTH_H(J) J_NORTH=J_PARENT_NORTH_H(J) ! DO I=I1,I2 !<-- I limits of child task update region on parent task I_WEST=I_PARENT_WEST_H(I) I_EAST=I_PARENT_EAST_H(I) ! 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 ! PINT_INTERP(I,J,L)=WGHT_SW_H(I,J)*PX_SW & !<-- Top interface hydrostatic pressure interpolated to +WGHT_SE_H(I,J)*PX_SE & ! update point for child task N. These are the source +WGHT_NW_H(I,J)*PX_NW & ! pressures for interface variables. +WGHT_NE_H(I,J)*PX_NE !<-- ! PMID_INTERP(I,J,L)=0.5*(PINT_INTERP(I,J,L) & !<-- Parent's midlayer hydrostatic pressure at nest update +PINT_INTERP(I,J,L+1)) ! points. Source pressures for midlayer variables. ! T_INTERP=WGHT_SW_H(I,J)*T(I_WEST,J_SOUTH,L) & !<-- T interp'd to update point for child task N +WGHT_SE_H(I,J)*T(I_EAST,J_SOUTH,L) & ! +WGHT_NW_H(I,J)*T(I_WEST,J_NORTH,L) & ! +WGHT_NE_H(I,J)*T(I_EAST,J_NORTH,L) !<-- ! Q_INTERP=WGHT_SW_H(I,J)*Q(I_WEST,J_SOUTH,L) & !<-- Q interp'd to update point for child task N +WGHT_SE_H(I,J)*Q(I_EAST,J_SOUTH,L) & ! +WGHT_NW_H(I,J)*Q(I_WEST,J_NORTH,L) & ! +WGHT_NE_H(I,J)*Q(I_EAST,J_NORTH,L) !<-- ! CW_INTERP=WGHT_SW_H(I,J)*CW(I_WEST,J_SOUTH,L) & !<-- CW interp'd to update point for child task N +WGHT_SE_H(I,J)*CW(I_EAST,J_SOUTH,L) & ! +WGHT_NW_H(I,J)*CW(I_WEST,J_NORTH,L) & ! +WGHT_NE_H(I,J)*CW(I_EAST,J_NORTH,L) !<-- ! DP=DSG2(L)*PD_INTERP(I,J)+PDSG1(L) ! TMP=R_D*T_INTERP*((1.-CW_INTERP)+P608*Q_INTERP) LOG_PTOP(I,J)=LOG(PINT_INTERP(I,J,L)) ! PHI_INTERP(I,J,L)=PHI_INTERP(I,J,L+1) & !<-- Top interface geopotl of parent at child update point I,J +TMP*(LOG_PBOT(I,J)-LOG_PTOP(I,J)) ! LOG_PBOT(I,J)=LOG_PTOP(I,J) ! ENDDO ENDDO ! ENDDO ! !----------------------------------------------------------------------- !*** Use the sfc geopotential at the nest points to derive the !*** value of PD at the nest points based on the parent's heights !*** and pressures on the parent's layer interfaces over the !*** child's 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. !----------------------------------------------------------------------- ! DO J=J1,J2 J_TRANS=J+J_OFFSET !<-- J on full nest resolution of parent at given nest J ! DO I=I1,I2 I_TRANS=I+I_OFFSET !<-- I on full nest resolution of parent at given nest I ! IF(FIS_CHILD(I_TRANS,J_TRANS) Bilinear interpolation !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ELSEIF(NUM_DIMS==3)THEN dims_2_or_3 ! !----------------------------------------------------------------------- ! CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle ,localDe =0 & ,farrayPtr =ARRAY_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 ) ! KLO=LIMITS_LO(3) KHI=LIMITS_HI(3) NUM_LEVELS=KHI-KLO+1 !<-- # of levels in this 3-D Real variable ! !----------------------------------------------------------------------- !*** The nature of the unique Q2 array complicates how the parent !*** must interpolate its values to the nest gridpoints. Q2 is a !*** 3-D array that lie on the layer interfaces BUT its level K=1 !*** is the BOTTOM of the uppermost model layer and not the top of !*** the uppermost layer. Thus while there are NUM_LYRS+1 layer !*** interfaces there are only NUM_LYRS levels in Q2 that correspond !*** with interfaces 2->NUM_LYRS+1. Rather than insert an assortment !*** of confusing IF tests to make a single set of code be generic, !*** separate Q2 from the rest of the variables and deal with it !*** inside its own block. !----------------------------------------------------------------------- ! q2: IF(FIELD_NAME=='Q2')THEN ! !----------------------------------------------------------------------- !*** We must add a new level to the top of the Q2 or E2 data in case !*** their pressures at the bottom of the uppermost layer are less !*** than on the bottom of the uppermost layer in the parent. !----------------------------------------------------------------------- ! IF(ALLOCATED(P_OUTPUT))DEALLOCATE(P_OUTPUT) ALLOCATE(P_OUTPUT(KLO:KHI+1)) ! IF(ALLOCATED(VBL_INTERP))DEALLOCATE(VBL_INTERP) ALLOCATE(VBL_INTERP(I1:I2,J1:J2,KLO:KHI+1+1)) ALLOCATE(VBL_COL_X(KLO:KHI+1)) ! DO L=KLO,KHI+2 P_INPUT(L)=0. VBL_INPUT(L)=0. ENDDO ! DO J=J1,J2 DO I=I1,I2 VBL_INTERP(I,J,KHI+1+1)=0. ENDDO ENDDO ! DO L=KLO,KHI DO J=J1,J2 J_SOUTH=J_PARENT_SOUTH(J) J_NORTH=J_PARENT_NORTH(J) ! DO I=I1,I2 I_WEST=I_PARENT_WEST(I) I_EAST=I_PARENT_EAST(I) ! VBL_INTERP(I,J,L+1)= & !<-- Parent's 3-D variable interpolated WGHT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! horizontally to the moving nest's +WGHT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! update location. +WGHT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! +WGHT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- ENDDO ENDDO ENDDO ! DO J=J1,J2 DO I=I1,I2 VBL_INTERP(I,J,1)=VBL_INTERP(I,J,2) !<-- Fill in the artificial top level. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** Use cubic spline interpolation to move variables to child update !*** point levels from their original vertical locations in the column !*** following horizontal interpolation from the surrounding parent !*** points. The target locations are the new interface pressures !*** in the nest update point columns based on the new surface !*** pressure for the nest's terrain. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** If the target location lies below the lowest parent pressure !*** level in the newly created child column then extrapolate linearly !*** in pressure to obtain a value at the lowest child level and !*** fill in the remaining 'underground' levels using the call to !*** 'SPLINE' just as with all the other levels above it. !----------------------------------------------------------------------- ! N_STRIDE=NPOINTS_HORIZ N_ADD =NPOINTS_HORIZ*(NUM_LEVELS-1) ! NUM_LEVS_SEC=NUM_LEVELS+1+1 !<-- Use this many levels in the 2nd derivative array ALLOCATE(SEC_DERIV(1:NUM_LEVS_SEC)) !<-- Allocate 1 longer in case we increase the ! ! # of input levels below. LOC_1=KNT_REAL_PTS(N) ! P3D_INPUT=>PINT_INTERP P3D_OUTPUT=>PINT_CHILD ! DO J=J1,J2 DO I=I1,I2 ! DO L=1,NUM_LEVELS+1 !<-- We are adding a temporary top level to Q2 and E2 P_INPUT (L)=P3D_INPUT(I,J,L) !<-- Parent input pressures over nest update point P_OUTPUT (L)=P3D_OUTPUT(I,J,L) !<-- Nest target pressures over nest update point VBL_INPUT(L)=VBL_INTERP(I,J,L) !<-- Values of parent variable values over nest update point ENDDO ! NUM_LEVS_IN=NUM_LEVELS+1 LOC_1=LOC_1+1 LOC_2=LOC_1+N_ADD VBL_COL_CHILD=>CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into ! the 1-D rendering of this 3-D real ! update variable in the composite output. ! IF(P_OUTPUT(NUM_LEVELS+1)>P_INPUT(NUM_LEVELS+1))THEN !<-- The nest's bottom level is below the parent's NUM_LEVS_IN=NUM_LEVELS+1+1 ! so add another input level that is the same P_INPUT(NUM_LEVELS+1+1)=P_OUTPUT(NUM_LEVELS+1) ! as the nest's lowest level. R_DELP=1./(P_INPUT(NUM_LEVELS+1)-P_INPUT(NUM_LEVELS)) DELP_EXTRAP=P_OUTPUT(NUM_LEVELS+1) & -P_INPUT(NUM_LEVELS+1) ! COEFF_1=(VBL_INPUT(NUM_LEVELS+1) & -VBL_INPUT(NUM_LEVELS))*R_DELP FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) VBL_INPUT(NUM_LEVELS+1+1)=VBL_INPUT(NUM_LEVELS+1) & !<-- Create extrapolated value at parent's new lowest +COEFF_1*DELP_EXTRAP*FACTOR ! level for input to the spline. ENDIF ! DO L=1,NUM_LEVS_SEC SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. ENDDO ! CALL SPLINE(NUM_LEVS_IN & !<-- # of input levels ,P_INPUT & !<-- Input variable is at these input pressure values ,VBL_INPUT & !<-- The column of input variable values ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent levels ,NUM_LEVS_SEC & !<-- Vertical dimension of SEC_DERIV ,NUM_LEVELS+1 & !<-- # of child target levels to interpolate to ,P_OUTPUT & !<-- Child target pressure values to interpolate to ,VBL_COL_X) !<-- Child values of variable returned on P_OUTPUT levels ! DO L=KLO,KHI VBL_COL_CHILD(L)=VBL_COL_X(L+1) !<-- Eliminate the artificial level on top of layer 1. ENDDO ! ENDDO ENDDO ! KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+NPOINTS_HORIZ*NUM_LEVELS !<-- Total points updated in composite output after ! ! this 3-D real variable was done. DEALLOCATE(VBL_COL_X) DEALLOCATE(SEC_DERIV) ! !----------------------------------------------------------------------- ! ELSE q2 !<-- All 3-D variables that are not Q2 ! !----------------------------------------------------------------------- ! MIDLAYERS=.FALSE. INTERFACES=.FALSE. ! IF(NUM_LEVELS==NUM_LYRS)THEN MIDLAYERS=.TRUE. ELSEIF(NUM_LEVELS==NUM_LYRS+1)THEN INTERFACES=.TRUE. ENDIF ! IF(ALLOCATED(P_OUTPUT))DEALLOCATE(P_OUTPUT) ALLOCATE(P_OUTPUT(KLO:KHI)) ! IF(ALLOCATED(VBL_INTERP))DEALLOCATE(VBL_INTERP) ALLOCATE(VBL_INTERP(I1:I2,J1:J2,KLO:KHI+1)) ! !----------------------------------------------------------------------- !*** Use cubic spline interpolation to move variables to child update !*** point levels from their original vertical locations in the column !*** following horizontal interpolation from the surrounding parent !*** points. The target locations are the new pressures values !*** in the nest update point columns based on the new surface !*** pressure for the nest's terrain. However this is obviously !*** done only for atmospheric variables. Of course it is not !*** done for 3-D land surface variables. !----------------------------------------------------------------------- ! soil_or_not: IF(UPDATE_TYPE_CHAR/='L')THEN !<-- 3-D H-pt variable that is not soil. ! !----------------------------------------------------------------------- ! DO L=1,NUM_LYRS+2 !<-- Maximum # of levels to be used. P_INPUT(L)=0. VBL_INPUT(L)=0. ENDDO ! DO J=J1,J2 DO I=I1,I2 VBL_INTERP(I,J,KHI+1)=0. ENDDO ENDDO ! DO L=KLO,KHI DO J=J1,J2 J_SOUTH=J_PARENT_SOUTH(J) J_NORTH=J_PARENT_NORTH(J) ! DO I=I1,I2 I_WEST=I_PARENT_WEST(I) I_EAST=I_PARENT_EAST(I) ! VBL_INTERP(I,J,L)= & !<-- Parent's 3-D variable interpolated WGHT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! horizontally to the moving nest's +WGHT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! update location. +WGHT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! +WGHT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- ENDDO ENDDO ENDDO ! !----------------------------------------------------------------------- !*** If the target location lies below the lowest parent pressure !*** level in the newly created child column then extrapolate linearly !*** in pressure to obtain a value at the lowest child level and !*** fill in the remaining 'underground' levels using the call to !*** 'SPLINE' just as with all the other levels above it. !----------------------------------------------------------------------- ! N_STRIDE=NPOINTS_HORIZ N_ADD =NPOINTS_HORIZ*(NUM_LEVELS-1) ! NUM_LEVS_SEC=NUM_LEVELS+1 !<-- Use this many levels in the 2nd derivative array ALLOCATE(SEC_DERIV(1:NUM_LEVS_SEC)) !<-- Allocate 1 longer in case we increase the ! ! # of input levels below. LOC_1=KNT_REAL_PTS(N) ! IF(MIDLAYERS)THEN !<-- Input/output pressures are at midlayers P3D_INPUT=>PMID_INTERP P3D_OUTPUT=>PMID_CHILD ! ELSEIF(INTERFACES)THEN !<-- Input/output pressures are at interfaces P3D_INPUT=>PINT_INTERP P3D_OUTPUT=>PINT_CHILD ! ELSE WRITE(0,*)' # of levels in 3-D variable is ',NUM_LEVELS WRITE(0,*)' That is not midlayer, interface, or soil.' WRITE(0,*)' ABORT!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ! ENDIF ! DO J=J1,J2 DO I=I1,I2 ! DO L=1,NUM_LEVELS !<-- Variable has NUM_LEVELS levels in parent and nest P_INPUT (L)=P3D_INPUT(I,J,L) !<-- Parent input pressures over nest update point P_OUTPUT (L)=P3D_OUTPUT(I,J,L) !<-- Nest target pressures over nest update point VBL_INPUT(L)=VBL_INTERP(I,J,L) !<-- Values of parent variable values over nest update point ENDDO ! NUM_LEVS_IN=NUM_LEVELS LOC_1=LOC_1+1 LOC_2=LOC_1+N_ADD VBL_COL_CHILD=>CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into ! the 1-D rendering of this 3-D real ! update variable in the composite output. ! IF(P_OUTPUT(NUM_LEVELS)>P_INPUT(NUM_LEVELS))THEN !<-- The nest's bottom level is below the parent's NUM_LEVS_IN=NUM_LEVELS+1 ! so add another input level that is the same P_INPUT(NUM_LEVELS+1)=P_OUTPUT(NUM_LEVELS) ! as the nest's lowest level. R_DELP=1./(P_INPUT(NUM_LEVELS)-P_INPUT(NUM_LEVELS-1)) DELP_EXTRAP=P_OUTPUT(NUM_LEVELS) & -P_INPUT(NUM_LEVELS) ! COEFF_1=(VBL_INPUT(NUM_LEVELS) & -VBL_INPUT(NUM_LEVELS-1))*R_DELP FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) VBL_INPUT(NUM_LEVELS+1)=VBL_INPUT(NUM_LEVELS) & !<-- Create extrapolated value at parent's new lowest +COEFF_1*DELP_EXTRAP*FACTOR ! level for input to the spline. ENDIF ! DO L=1,NUM_LEVS_SEC SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. ENDDO ! CALL SPLINE(NUM_LEVS_IN & !<-- # of input levels ,P_INPUT & !<-- Input variable is at these input pressure values ,VBL_INPUT & !<-- The column of input variable values ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent levels ,NUM_LEVS_SEC & !<-- Vertical dimension of SEC_DERIV ,NUM_LEVELS & !<-- # of child target levels to interpolate to ,P_OUTPUT & !<-- Child target pressure values to interpolate to ,VBL_COL_CHILD) !<-- Child values of variable returned on P_OUTPUT levels ! !----------------------------------------------------------------------- !*** Do not let the F_* moisture variables become negative. !----------------------------------------------------------------------- ! IF(FIELD_NAME=='F_ICE' .OR. FIELD_NAME=='F_RAIN' ) THEN DO L=LBOUND(VBL_COL_CHILD,1),UBOUND(VBL_COL_CHILD,1) VBL_COL_CHILD(L)=MAX(VBL_COL_CHILD(L),0.0) VBL_COL_CHILD(L)=MIN(VBL_COL_CHILD(L),1.0) ENDDO ENDIF ! ENDDO ENDDO ! KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+NPOINTS_HORIZ*NUM_LEVELS !<-- Total points updated in composite output after ! ! this 3-D real variable was done. DEALLOCATE(SEC_DERIV) ! !----------------------------------------------------------------------- !*** For 3-D soil variables the parent uses bilinear interpolation !*** but must also use the land mask. The bilinear interpolation !*** weighting needs to be adjusted to account for water points that !*** are excluded from the summation. The code assumes there are !*** no 3-D water point variables to update (UPDATE_TYPE_CHAR=='S'). !----------------------------------------------------------------------- ! ELSEIF(UPDATE_TYPE_CHAR=='L')THEN !<-- 3-D H-pt variable that is soil ! !----------------------------------------------------------------------- ! !!! FNAME=TRIM(FIELD_NAME) FNAME=FIELD_NAME ! DO L=KLO,KHI !<-- Loop through the soil layers ! DO J=J1,J2 J_SOUTH=J_PARENT_SOUTH(J) J_NORTH=J_PARENT_NORTH(J) ! DO I=I1,I2 I_WEST=I_PARENT_WEST(I) I_EAST=I_PARENT_EAST(I) ! KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+1 !<-- Total real points updated in composite output. ! !!! CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))= & !<-- Parent's 3-D soil variable interpolated SUM_PROD=PROD_LWGT_SW(I,J)+PROD_LWGT_SE(I,J) & +PROD_LWGT_NW(I,J)+PROD_LWGT_NE(I,J) ! IF(ABS(SUM_PROD)<1.E-5)THEN IF(FNAME=='SMC'.OR.FNAME=='SH2O')THEN CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))=1.0 ELSEIF(FNAME=='STC')THEN CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))=273.16 ENDIF ELSE CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))= & !<--- PROD_LWGT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! Parent's 3-D soil variable interpolated +PROD_LWGT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! horizontally to the moving nest's +PROD_LWGT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! update location using the land mask. +PROD_LWGT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- ENDIF ! ENDDO ENDDO ENDDO ! !----------------------------------------------------------------------- ! ENDIF soil_or_not ! !----------------------------------------------------------------------- ! ENDIF q2 ! !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- ! ENDIF dims_2_or_3 ! !----------------------------------------------------------------------- ! ENDDO field_loop ! !----------------------------------------------------------------------- ! DEALLOCATE(I_PARENT) DEALLOCATE(I_PARENT_EAST) DEALLOCATE(I_PARENT_WEST) ! DEALLOCATE(J_PARENT) DEALLOCATE(J_PARENT_NORTH) DEALLOCATE(J_PARENT_SOUTH) ! DEALLOCATE(WGHT_SW) DEALLOCATE(WGHT_NW) DEALLOCATE(WGHT_NE) DEALLOCATE(WGHT_SE) ! DEALLOCATE(LOG_PBOT ) DEALLOCATE(LOG_PTOP ) DEALLOCATE(PINT_INTERP) DEALLOCATE( PHI_INTERP) DEALLOCATE(PMID_INTERP) DEALLOCATE(PMID_CHILD ) DEALLOCATE(PINT_CHILD ) DEALLOCATE(PD_CHILD ) DEALLOCATE(PD_INTERP ) DEALLOCATE(VBL_INTERP ) ! NULLIFY(P3D_INPUT) NULLIFY(P3D_OUTPUT) ! IF(FLAG_H_OR_V=='H')THEN DEALLOCATE(PROD_LWGT_NE) DEALLOCATE(PROD_LWGT_NW) DEALLOCATE(PROD_LWGT_SE) DEALLOCATE(PROD_LWGT_SW) DEALLOCATE(PROD_SWGT_NE) DEALLOCATE(PROD_SWGT_NW) DEALLOCATE(PROD_SWGT_SE) DEALLOCATE(PROD_SWGT_SW) ENDIF ! IF(FLAG_H_OR_V=='V')THEN ! DEALLOCATE(I_PARENT_EAST_H) DEALLOCATE(I_PARENT_WEST_H) DEALLOCATE(J_PARENT_NORTH_H) DEALLOCATE(J_PARENT_SOUTH_H) ! DEALLOCATE(I_CHILD_ON_PARENT_H) DEALLOCATE(J_CHILD_ON_PARENT_H) ! DEALLOCATE(WGHT_NE_H) DEALLOCATE(WGHT_NW_H) DEALLOCATE(WGHT_SE_H) DEALLOCATE(WGHT_SW_H) ! ENDIF ! ENDDO iter_loop ! !----------------------------------------------------------------------- !*** The parent task sends its update data to this moving nest task. !*** The parent only sends to a moving nest after updating both H !*** and V points so that all data can be sent to each nest task !*** in a single message. !----------------------------------------------------------------------- ! IF(FLAG_H_OR_V=='V')THEN ! CHILDTASK=CHILD_TASK_RANKS(PTR_X%TASK_ID) ITAG=KNT_REAL_PTS(N)+NTIMESTEP_CHILD !<-- Tag that changes for data size and time ! CALL MPI_ISSEND(CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL & !<-- Internal real update data for moving nest task N ,KNT_REAL_PTS(N) & !<-- # of real words in the data string ,MPI_REAL & !<-- Datatype ,CHILDTASK & !<-- Local intracom rank of nest task to recv data ,ITAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILD & !<-- MPI intracommunicator ,HANDLE_UPDATE(PTR_X%TASK_ID) & !<-- Handle for ISend to child task ,IERR ) ! IF(KNT_INTEGER_PTS(N)>0)THEN ITAG=KNT_INTEGER_PTS(N)+NTIMESTEP_CHILD !<-- Tag that changes for data size and time ! CALL MPI_ISSEND(CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER & !<-- Internal integer update data for moving nest task N ,KNT_INTEGER_PTS(N) & !<-- # of integer words in the data string ,MPI_INTEGER & !<-- Datatype ,CHILDTASK & !<-- Local intracom rank of nest task to recv data ,ITAG & !<-- Unique MPI tag ,COMM_TO_MY_CHILD & !<-- MPI intracommunicator ,HANDLE_UPDATE(PTR_X%TASK_ID) & !<-- Handle for ISend to child task ,IERR ) ENDIF ! ENDIF ! !----------------------------------------------------------------------- !*** Point at the next link of the linked list holding the !*** update task ID and index limits on the next task. !----------------------------------------------------------------------- ! PTR_X=>PTR_X%NEXT_LINK ! !----------------------------------------------------------------------- ! ENDDO ctask_loop ! !----------------------------------------------------------------------- !*** All of the combined H and V update data has been sent by this !*** parent task to each appropriate task on this nest so deallocate !*** the array holding the number of update points on each nest task. !----------------------------------------------------------------------- ! IF(FLAG_H_OR_V=='V')THEN DEALLOCATE(KNT_REAL_PTS) DEALLOCATE(KNT_INTEGER_PTS) DEALLOCATE(NUM_ITER) ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_UPDATES_MOVING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & ,NUM_MOVING_CHILDREN & ,LINK_MRANK_RATIO & ,LIST_OF_RATIOS & ,M_NEST_RATIO & ,KOUNT_RATIOS_MN & ,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) ! !----------------------------------------------------------------------- !*** Parents of moving nests must fill their own domains with the !*** full resolution topography of those children. That data spans !*** the entire domain of the uppermost parent. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IM_1,JM_1 & !<-- Dimensions of the uppermost parent domain ,IDS,IDE,JDS,JDE & !<-- This parent domain's index limits ,IMS,IME,JMS,JME & !<-- This parent tasks's memory limits ,ITS,ITE,JTS,JTE & !<-- This parent tasks's integration limits ,KOUNT_RATIOS_MN & !<-- # of space ratios of children to upper parent ,MY_DOMAIN_ID & !<-- This parent domain's ID ,NUM_MOVING_CHILDREN !<-- # of moving children on this parent domain ! INTEGER(kind=KINT),DIMENSION(1:NUM_MOVING_CHILDREN),INTENT(IN) :: & LINK_MRANK_RATIO & !<-- Each child asociated with rank of space ratio in list ,LIST_OF_RATIOS & !<-- The list of different space ratios ,M_NEST_RATIO !<-- Associate each child with its upper parent space ratio ! REAL(kind=KFPT),INTENT(IN) :: RECIP_DPH_1,RECIP_DLM_1 & !<-- Reciprocal of uppermost domain grid increments (radians) ,TLM0_1,TPH0_1 & !<-- Central geo lat/lon of uppermost domain (radians; east/north) ,SB_1,WB_1 !<-- Rotated lat/lon of south/west boundary (radians; north/east) ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: GLAT,GLON !<-- Geographic lat/lon (radians) on parent grid ! LOGICAL(kind=KLOG),INTENT(IN) :: GLOBAL_TOP_PARENT !<-- Is the uppermost parent domain global? ! TYPE(BNDS_2D),DIMENSION(1:KOUNT_RATIOS_MN),INTENT(OUT) :: & NEST_FIS_ON_PARENT_BNDS !<-- Parent subdomain index limits of nest-res topo data ! TYPE(REAL_DATA_2D),DIMENSION(1:KOUNT_RATIOS_MN),INTENT(INOUT) :: & NEST_FIS_ON_PARENT & !<-- Nest-res topo data on the parent task subdomain ,NEST_FIS_V_ON_PARENT !<-- Nest-res topo data at V on the parent task subdomain ! !-------------------- !*** Local Variables !-------------------- ! INTEGER(kind=KINT) :: I,ICORNER,IDIM,IEND,ISTART,IUNIT_FIS_NEST & ,J,JCORNER,JDIM,JEND,JSTART,JSTOP,LOR,N,NN ! INTEGER(kind=KINT) :: I_COUNT_DATA,J_COUNT_DATA & ,I_EXTRA_DATA,J_EXTRA_DATA & ,NCID,NCTYPE,NDIMS,VAR_ID ! INTEGER(kind=KINT) :: IERR,ISTAT ! INTEGER(kind=KINT),DIMENSION(1:2) :: DIM_IDS ! REAL(kind=KFPT) :: GBL,REAL_I_NE,REAL_I_SW,REAL_J_NE,REAL_J_SW & ,VAL_NE ! REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: COL,ROW ! CHARACTER(len=2) :: ID_TOPO_FILE CHARACTER(len=9) :: FILENAME CHARACTER(len=15) :: VNAME ! LOGICAL(kind=KLOG) :: OPENED ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** 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. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Each parent task obtains the real I,J on the uppermost parent !*** of the SW and NE corners of each of their subdomains. Given !*** the known resolution of the nest topography data the parent !*** tasks can then extract and save only that data which covers !*** their own subdomain. !----------------------------------------------------------------------- ! !---------------------------------------- !*** SW corner of parent task subdomain !---------------------------------------- ! ICORNER=MAX(IMS,IDS) !<-- Parent task covers its halos with data too since JCORNER=MAX(JMS,JDS) ! the moving nest boundaries can extend into them. ! IF(MY_DOMAIN_ID==1.AND.GLOBAL_TOP_PARENT)THEN !<-- The current parent domain is global. IF(ITS==IDS)THEN ICORNER=ICORNER+1. !<-- Past buffer row to Intl Dateline ENDIF IF(JTS==JDS)THEN JCORNER=JCORNER+1. ENDIF ENDIF ! CALL LATLON_TO_IJ(GLAT(ICORNER,JCORNER) & !<-- Geographic lat (radians) of parent task's SW corner ,GLON(ICORNER,JCORNER) & !<-- Geographic lon (radians) of parent task's SW corner ,TPH0_1,TLM0_1 & !<-- Geographic lat,lon of upper parent's central point ,SB_1,WB_1 & !<-- Rotated lat/lon of upper parent's SW corner ,RECIP_DPH_1,RECIP_DLM_1 & ,GLOBAL_TOP_PARENT & !<-- Is the uppermost parent domain global? ,REAL_I_SW & !<-- Uppermost parent I of this task's SW corner ,REAL_J_SW) !<-- Uppermost parent J of this task's SW corner ! !---------------------------------------- !*** NE corner of parent task subdomain !---------------------------------------- ! ICORNER=MIN(IME,IDE) !<-- Parent task covers its halos with data too since JCORNER=MIN(JME,JDE) ! the moving nest boundaries can extend into them. ! IF(MY_DOMAIN_ID==1.AND.GLOBAL_TOP_PARENT)THEN !<-- The current parent domain is global. IF(ITE==IDE)THEN ICORNER=ICORNER-1. !<-- Past buffer row to Intl Dateline ENDIF IF(JTE==JDE)THEN JCORNER=JCORNER-1. ENDIF ENDIF ! CALL LATLON_TO_IJ(GLAT(ICORNER,JCORNER) & ,GLON(ICORNER,JCORNER) & ,TPH0_1,TLM0_1 & ,SB_1,WB_1 & ,RECIP_DPH_1,RECIP_DLM_1 & ,GLOBAL_TOP_PARENT & ,REAL_I_NE & ,REAL_J_NE) ! !----------------------------------------------------------------------- nr_loop: DO N=1,KOUNT_RATIOS_MN !<-- Loop through the different parent-child space ratios !----------------------------------------------------------------------- ! LOR=LIST_OF_RATIOS(N) ! IF(GLOBAL_TOP_PARENT)THEN GBL=1. !<-- Account for the extra row that surrounds global domains. ELSE GBL=0. ENDIF ! ISTART=NINT((REAL_I_SW-1.-GBL)*LOR+1.) !<-- I index in sfc data at W bndry of this parent task JSTART=NINT((REAL_J_SW-1.-GBL)*LOR+1.) !<-- J index in sfc data at S bndry of this parent task ! IEND=NINT((REAL_I_NE-1.-GBL)*LOR+1.) !<-- I index in nest sfc data at E bndry (H) of this parent task JEND=NINT((REAL_J_NE-1.-GBL)*LOR+1.) !<-- J index in nest sfc data at N bndry (H) of this parent task ! I_COUNT_DATA=IEND-ISTART+1 J_COUNT_DATA=JEND-JSTART+1 ! !----------------------------------------------------------------------- ! NEST_FIS_ON_PARENT_BNDS(N)%LBND1=ISTART !<-- Array limits in nest-resolution topography data NEST_FIS_ON_PARENT_BNDS(N)%UBND1=IEND ! for region covering this parent task's subdomain. NEST_FIS_ON_PARENT_BNDS(N)%LBND2=JSTART ! NEST_FIS_ON_PARENT_BNDS(N)%UBND2=JEND !<-- ! !----------------------------------------------------------------------- !*** Each parent task opens and reads the topography file. !----------------------------------------------------------------------- ! IF(N<=9)THEN NN=LOR IF(NN<=9)THEN WRITE(ID_TOPO_FILE,'(I1.1)')NN ELSEIF(NN>=10)THEN WRITE(ID_TOPO_FILE,'(I2.2)')NN ENDIF ELSE WRITE(0,*)' User specified more than 9 different' & ,' moving nest resolutions!!!' WRITE(0,*)' ABORTING' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! FILENAME='FIS_'//TRIM(ID_TOPO_FILE)//'.nc' ! CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) !<-- Open the FIS external netCDF file for Nth space ratio. ! !----------------------------------------------------------------------- !*** Each task allocates its space for holding its moving children's !*** topography at their resolution. !----------------------------------------------------------------------- ! IF(ASSOCIATED(NEST_FIS_ON_PARENT(N)%DATA))THEN DEALLOCATE(NEST_FIS_ON_PARENT(N)%DATA,stat=ISTAT) ENDIF IF(ASSOCIATED(NEST_FIS_V_ON_PARENT(N)%DATA))THEN DEALLOCATE(NEST_FIS_V_ON_PARENT(N)%DATA,stat=ISTAT) ENDIF ! ALLOCATE(NEST_FIS_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND)) ALLOCATE(NEST_FIS_V_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND)) ! !----------------------------------------------------------------------- !*** Save only those points in the topography data for resolution N !*** that cover this parent task's subdomain. !*** Begin with the nest-resolution topography at H points. !----------------------------------------------------------------------- ! CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & !<-- Topography is the 3rd variable in the file. ,NDIMS,DIM_IDS)) CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) ! CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the values ,NEST_FIS_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND) & ! of nest-resolution ,start=(/ISTART,JSTART/) & ! topography from the ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! external file. ! !----------------------------------------------------------------------- !*** For the nest topography values at V points we can begin by !*** averaging the values at H points. !----------------------------------------------------------------------- ! DO J=JSTART,JEND-1 DO I=ISTART,IEND-1 NEST_FIS_V_ON_PARENT(N)%DATA(I,J)=(NEST_FIS_ON_PARENT(N)%DATA(I,J) & +NEST_FIS_ON_PARENT(N)%DATA(I+1,J) & +NEST_FIS_ON_PARENT(N)%DATA(I,J+1) & +NEST_FIS_ON_PARENT(N)%DATA(I+1,J+1) & )*0.25 ENDDO ENDDO ! !----------------------------------------------------------------------- !*** The V row at J=J_END is north of the H row at J=J_END. !*** The V column at I=I_END is east of the H column at I=I_END. !*** This means we need to read in extra values to get those !*** V points on the north and east edges of the parent tasks. !----------------------------------------------------------------------- ! ALLOCATE(ROW(ISTART:IEND)) ALLOCATE(COL(JSTART:JEND)) ! I_EXTRA_DATA=ISTART+I_COUNT_DATA !<-- 1 column east of task's saved H data J_EXTRA_DATA=JSTART+J_COUNT_DATA !<-- 1 row north of task's saved H data ! !----------------------------------------------------------------------- !*** Fill in values of nest topography on V points one row north !*** of the northern limit of the H-point topography saved on !*** this parent task. !----------------------------------------------------------------------- ! IF(JTEH, !*** v-->V, pd-->H, and pd-->V. Determine the set of parent !*** target I's and J's common to all the stencils and use !*** that to ensure that the same parent I,J indices are used !*** for both H and V variables. !----------------------------------------------------------------------- ! N_STENCIL_X(1)=N_STENCIL_H_CHILD N_STENCIL_X(2)=N_STENCIL_V_CHILD N_STENCIL_X(3)=N_STENCIL_SFC_H_CHILD N_STENCIL_X(4)=N_STENCIL_SFC_V_CHILD ! !----------------------------------------------------------------------- !*** Deallocate the linked list of child update tasks if it already !*** exists. This is relevant only for moving nests. This routine !*** is called only once for static nests when the linked list does !*** not yet exist. !----------------------------------------------------------------------- ! KOUNT=0 HEAD=>CHILD_TASKS_2WAY_UPDATE !<-- Point at the top of the linked list ! dealloc: DO ! KOUNT=KOUNT+1 TAIL=>NULL() IF(ASSOCIATED(HEAD%NEXT_LINK))THEN TAIL=>HEAD%NEXT_LINK !<-- If another link exists, point at it. ENDIF ! IF(KOUNT>1)THEN !<-- Do not deallocate the topmost object's memory DEALLOCATE(HEAD%TASK_ID) DEALLOCATE(HEAD%IL) DEALLOCATE(HEAD%JL) DEALLOCATE(HEAD%NUM_PTS_UPDATE_HZ) DEALLOCATE(HEAD,stat=ISTAT) !<-- Deallocate the current link. IF(ISTAT/=0)THEN WRITE(0,*)' Failed to deallocate link #',KOUNT,' in 2-way linked list!' WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! IF(ASSOCIATED(TAIL))THEN !<-- If true, another link exists. HEAD=>TAIL !<-- Reset so that the head is at the new link. ELSE EXIT dealloc !<-- No further links exist. ENDIF ! ENDDO dealloc ! !----------------------------------------------------------------------- !*** Only the top of the list remains. Point at it. !----------------------------------------------------------------------- ! HEAD=>CHILD_TASKS_2WAY_UPDATE HEAD%NEXT_LINK=>NULL() !<-- There is no 'next link' in the list yet. ! !----------------------------------------------------------------------- !*** Which if any child tasks will be updating this parent task? !*** Begin by finding the subdomain limits of each child task on !*** the parent domain. !----------------------------------------------------------------------- ! child_tasks: DO NT=1,NUM_CHILD_TASKS ! !----------------------------------------------------------------------- ! ITS_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(1,NT)-CHILD_TASK_LIMITS(1,1))*RECIP_RATIO & !<-- Child task NT's starting I on parent grid +REAL(I_PARENT_SW) ITE_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(2,NT)-CHILD_TASK_LIMITS(1,1))*RECIP_RATIO & !<-- Child task NT's ending I on parent grid +REAL(I_PARENT_SW) ! JTS_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(3,NT)-CHILD_TASK_LIMITS(3,1))*RECIP_RATIO & !<-- Child task NT's starting J on parent grid +REAL(J_PARENT_SW) JTE_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(4,NT)-CHILD_TASK_LIMITS(3,1))*RECIP_RATIO & !<-- Child task NT's ending J on parent grid +REAL(J_PARENT_SW) ! CHILD_ISTART_ON_PARENT=ITS_CHILD_ON_PARENT CHILD_IEND_ON_PARENT =ITE_CHILD_ON_PARENT CHILD_JSTART_ON_PARENT=JTS_CHILD_ON_PARENT CHILD_JEND_ON_PARENT =JTE_CHILD_ON_PARENT ! !----------------------------------------------------------------------- !*** Find the common parent target points for all averaging stencils. !----------------------------------------------------------------------- ! DO N=1,4 !<-- There are 4 averaging stencils; see above. ! N_STENCIL_0=N_STENCIL_X(N)/2 !<-- Child's delta I,J from parent update pt to edge of ! ! stencil region that will update the parent point. LIMIT_WEST_H=REAL(I_PARENT_SW) & +(N_BLEND_CHILD+N_STENCIL_0)*RECIP_RATIO ! CHILD_ISTART_ON_PARENT=MAX(CHILD_ISTART_ON_PARENT & !<-- ,ITS_CHILD_ON_PARENT & ,LIMIT_WEST_H ) ! LIMIT_EAST_H=REAL(I_PARENT_SW) & +(IM_CHILD-1-N_BLEND_CHILD-N_STENCIL_0)*RECIP_RATIO ! CHILD_IEND_ON_PARENT=MIN(CHILD_IEND_ON_PARENT & !<-- ,ITE_CHILD_ON_PARENT & ,LIMIT_EAST_H ) ! LIMIT_SOUTH_H=REAL(J_PARENT_SW) & +(N_BLEND_CHILD+N_STENCIL_0)*RECIP_RATIO ! CHILD_JSTART_ON_PARENT=MAX(CHILD_JSTART_ON_PARENT & !<-- ,JTS_CHILD_ON_PARENT & ,LIMIT_SOUTH_H ) ! LIMIT_NORTH_H=REAL(J_PARENT_SW) & +(JM_CHILD-1-N_BLEND_CHILD-N_STENCIL_0)*RECIP_RATIO ! CHILD_JEND_ON_PARENT=MIN(CHILD_JEND_ON_PARENT & !<-- ,JTE_CHILD_ON_PARENT & ,LIMIT_NORTH_H ) ! ENDDO ! !----------------------------------------------------------------------- !*** Which if any of this parent task's points are updated by !*** this child's task NT? !----------------------------------------------------------------------- ! IF(REAL(ITS)CHILD_ISTART_ON_PARENT-EPS & .AND. & REAL(JTS)CHILD_JSTART_ON_PARENT-EPS )THEN ! !----------------------------------------------------------------------- !*** Which points on this parent task will be updated by this !*** child task? See examples of the logic used here in !*** subroutine CHILD_2WAY_BOOKKEEPING. !----------------------------------------------------------------------- ! I1=MAX(ITS,INT(CHILD_ISTART_ON_PARENT+1.-EPS)) !<-- Lower I limit on parent update region by child task NT. I2=MIN(ITE,INT(CHILD_IEND_ON_PARENT+EPS)) !<-- Upper I limit on parent update region by child task NT. J1=MAX(JTS,INT(CHILD_JSTART_ON_PARENT+1.-EPS)) !<-- Lower J limit on parent update region by child task NT. J2=MIN(JTE,INT(CHILD_JEND_ON_PARENT+EPS)) !<-- Upper J limit on parent update region by child task NT. ! NPTS_PARENT_UPDATE=(I2-I1+1)*(J2-J1+1) ! IF(NPTS_PARENT_UPDATE<=0)THEN CYCLE child_tasks !<-- No usable 2-way exchange region on this child task. ENDIF ! NTASKS_UPDATE_CHILD=NTASKS_UPDATE_CHILD+1 !<-- Save # of child tasks that send 2-way update ! IF(NTASKS_UPDATE_CHILD>1)THEN !<-- We need another link in the list. ALLOCATE(HEAD%NEXT_LINK) !<-- Create the new link HEAD=>HEAD%NEXT_LINK !<-- Point at the new link. HEAD%NEXT_LINK=>NULL() !<-- Nullify the link that would follow the new link. ! ALLOCATE(HEAD%TASK_ID) !<-- ALLOCATE(HEAD%IL(1:2)) ! Create the components ALLOCATE(HEAD%JL(1:2)) ! of the new link. ALLOCATE(HEAD%NUM_PTS_UPDATE_HZ) !<-- ENDIF ! !----------------------------------------------------------------------- !*** In this link of the list save the updating child task's local !*** rank on its domain as well as the index limits on this parent !*** task that this child task will update along with the total !*** number of updated parent task points. !----------------------------------------------------------------------- ! HEAD%TASK_ID=NT-1 !<-- Local rank of child task sending 2-way update ! HEAD%IL(1)=I1 HEAD%IL(2)=I2 HEAD%JL(1)=J1 HEAD%JL(2)=J2 ! HEAD%NUM_PTS_UPDATE_HZ=NPTS_PARENT_UPDATE ! !----------------------------------------------------------------------- ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO child_tasks ! !----------------------------------------------------------------------- ! END SUBROUTINE PARENT_2WAY_BOOKKEEPING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHILD_2WAY_BOOKKEEPING(I_SW_PARENT_CURRENT & ,J_SW_PARENT_CURRENT & ,SPACE_RATIO_MY_PARENT & ,NUM_FCST_TASKS_PARENT & ,ITS_PARENT_TASKS & ,ITE_PARENT_TASKS & ,JTS_PARENT_TASKS & ,JTE_PARENT_TASKS & ,N_BLEND_H & ,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 & ! ,NTASKS_UPDATE_PARENT & ,ID_PARENT_UPDATE_TASKS & ,NPTS_UPDATE_PARENT & ,I_2WAY_UPDATE & ,J_2WAY_UPDATE & ) ! !----------------------------------------------------------------------- !*** In 2-way mode each child domain must determine to which parent !*** tasks and to which points on those tasks update data must be !*** sent. The method used here is taking the mean of the points !*** on a stencil of child points that surround a given parent !*** point. !*** This routine is called from CHILDREN_SEND_PARENTS_2WAY_DATA. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: I_SW_PARENT_CURRENT & !<-- Child domain SW corner on this parent I ,J_SW_PARENT_CURRENT & !<-- Child domain SW corner on this parent J ,N_BLEND_H & !<-- # of nest blending rows for H pts ,N_BLEND_V & !<-- # of nest blending rows for V pts ,N_STENCIL_H & !<-- Width of stencil for averaging h to parent H ,N_STENCIL_V & !<-- Width of stencil for averaging v to parent V ,N_STENCIL_SFC_H & !<-- Width of stencil for averaging fis,pd to parent H ,N_STENCIL_SFC_V & !<-- Width of stencil for averaging fis,pd to parent V ,NUM_FCST_TASKS_PARENT & !<-- # of fcst tasks on this nest's parent ,SPACE_RATIO_MY_PARENT !<-- Parent-to-child gridspace ratio ! INTEGER(kind=KINT),DIMENSION(0:NUM_FCST_TASKS_PARENT-1),INTENT(IN) :: & ITS_PARENT_TASKS & !<-- Starting I on all parent tasks in parent space ,ITE_PARENT_TASKS & !<-- Ending I on all parent tasks in parent space ,JTS_PARENT_TASKS & !<-- Starting J on all parent tasks in parent space ,JTE_PARENT_TASKS !<-- Ending J on all parent tasks in parent space ! INTEGER(kind=KINT),INTENT(IN) :: IDE,IDS,ITE,ITS & ,JDE,JDS,JTE,JTS ! INTEGER(kind=KINT),INTENT(INOUT) :: NTASKS_UPDATE_PARENT !<-- How many parent tasks does this child task update? ! INTEGER(kind=KINT),DIMENSION(1:4),INTENT(OUT) :: NPTS_UPDATE_PARENT !<-- # of points to update on each parent task subdomain ! INTEGER(kind=KINT),DIMENSION(1:4),INTENT(OUT) :: & ID_PARENT_UPDATE_TASKS !<-- Local ID in P-C intracom of parent tasks to update ! TYPE(INTEGER_DATA),DIMENSION(1:4),INTENT(OUT) :: I_2WAY_UPDATE & !<-- I indices of parent points to update ,J_2WAY_UPDATE !<-- J indices of parent points to update ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: I,ISTAT,J,KOUNT,N,N_BLEND,N_STENCIL_0 & ,NPTS_PARENT_UPDATE ! INTEGER(kind=KINT) :: I1,I2,J1,J2 ! INTEGER(kind=KINT),DIMENSION(1:4) :: N_STENCIL_X ! REAL(kind=KFPT) :: LIMIT_EAST,LIMIT_NORTH & ,LIMIT_SOUTH,LIMIT_WEST ! REAL(kind=KFPT) :: MY_IDE_ON_PARENT,MY_IDS_ON_PARENT & ,MY_JDE_ON_PARENT,MY_JDS_ON_PARENT & ,MY_ITE_ON_PARENT,MY_ITS_ON_PARENT & ,MY_JTE_ON_PARENT,MY_JTS_ON_PARENT ! REAL(kind=KFPT) :: MY_ISTART_ON_PARENT,MY_IEND_ON_PARENT & ,MY_JSTART_ON_PARENT,MY_JEND_ON_PARENT ! REAL(kind=KFPT) :: RECIP_RATIO ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! RECIP_RATIO=1./REAL(SPACE_RATIO_MY_PARENT) !<-- Reciprocal of parent-to-child gridspace ratio ! NTASKS_UPDATE_PARENT=0 !<-- Initialize the # of parent tasks this child task ! ! will update. !----------------------------------------------------------------------- !*** The domain blending region must be the same for H and V points !*** at the current time. !----------------------------------------------------------------------- ! N_BLEND=N_BLEND_H ! !----------------------------------------------------------------------- !*** What are this child's domain limits in terms of its parent's !*** grid? !----------------------------------------------------------------------- ! MY_IDS_ON_PARENT=REAL(I_SW_PARENT_CURRENT) MY_IDE_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(IDE-1)*RECIP_RATIO MY_JDS_ON_PARENT=REAL(J_SW_PARENT_CURRENT) MY_JDE_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JDE-1)*RECIP_RATIO ! !----------------------------------------------------------------------- !*** What are this child task's subdomain integration limits in !*** terms of its parent's grid? !----------------------------------------------------------------------- ! MY_ITS_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(ITS-IDS)*RECIP_RATIO !<-- Child task starting I in parent grid space MY_ITE_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(ITE-IDS)*RECIP_RATIO !<-- Child task ending I in parent grid space MY_JTS_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JTS-JDS)*RECIP_RATIO !<-- Child task starting J in parent grid space MY_JTE_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JTE-JDS)*RECIP_RATIO !<-- Child task ending J in parent grid space ! !----------------------------------------------------------------------- !*** We want to limit the child points that can be used for !*** computing the 2-way data. For now do not use any child !*** points in the averaging stencil that lie in the child's !*** boundary blending region. Stencils can vary for h-->H, !*** v-->V, fis,pd-->H, and fis,pd-->V. Determine the set of !*** parent target I's and J's common to all the stencils and !*** use that to ensure that the same parent I,J indices are !*** used for both H and V variables. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- !*** Loop through the four stencils. They will be considered in !*** this order: h-->H, v-->V, fis,pd-->H, fis,pd-->V where small !*** letters refer to the child and capitals refer to the parent. !----------------------------------------------------------------------- ! N_STENCIL_X(1)=N_STENCIL_H N_STENCIL_X(2)=N_STENCIL_V N_STENCIL_X(3)=N_STENCIL_SFC_H N_STENCIL_X(4)=N_STENCIL_SFC_V ! MY_ISTART_ON_PARENT=MY_IDS_ON_PARENT !<-- MY_IEND_ON_PARENT =MY_IDE_ON_PARENT ! | Child domain limits in terms of MY_JSTART_ON_PARENT=MY_JDS_ON_PARENT ! | the parent I,J. MY_JEND_ON_PARENT =MY_JDE_ON_PARENT !<-- ! !----------------------------------------------------------------------- ! DO N=1,4 !<-- Loop through the four stencils. ! !----------------------------------------------------------------------- ! N_STENCIL_0=N_STENCIL_X(N)/2 !<-- Child's delta I,J from parent update pt to ! west/south edge of stencil. LIMIT_WEST=REAL(MY_IDS_ON_PARENT) & +(N_BLEND+N_STENCIL_0)*RECIP_RATIO MY_ISTART_ON_PARENT=MAX(MY_ISTART_ON_PARENT & !<-- Westernmost parent I that this child task ,MY_ITS_ON_PARENT & ! will update on the parent domain. ,LIMIT_WEST) ! LIMIT_EAST=REAL(MY_IDE_ON_PARENT) & -(N_BLEND+N_STENCIL_0)*RECIP_RATIO MY_IEND_ON_PARENT=MIN(MY_IEND_ON_PARENT & !<-- Easternmost parent I that this child task ,MY_ITE_ON_PARENT & ! will update on the parent domain. ,LIMIT_EAST) ! LIMIT_SOUTH=REAL(MY_JDS_ON_PARENT) & +(N_BLEND+N_STENCIL_0)*RECIP_RATIO MY_JSTART_ON_PARENT=MAX(MY_JSTART_ON_PARENT & !<-- Southernmost parent J that this child task ,MY_JTS_ON_PARENT & ! will update on the parent domain. ,LIMIT_SOUTH) ! LIMIT_NORTH=REAL(MY_JDE_ON_PARENT) & -(N_BLEND+N_STENCIL_0)*RECIP_RATIO MY_JEND_ON_PARENT=MIN(MY_JEND_ON_PARENT & !<-- Northernmost parent J that this child task ,MY_JTE_ON_PARENT & ! will update on the parent domain. ,LIMIT_NORTH) ! ENDDO ! !----------------------------------------------------------------------- !*** Find how many parent tasks will be updated by this child task !*** and save their local IDs from the P-C intracommunicator. !----------------------------------------------------------------------- ! find: DO N=0,NUM_FCST_TASKS_PARENT-1 ! !----------------------------------------------------------------------- ! IF(REAL(ITS_PARENT_TASKS(N))MY_ISTART_ON_PARENT-EPS & .AND. & REAL(JTS_PARENT_TASKS(N))MY_JSTART_ON_PARENT-EPS )THEN ! !----------------------------------------------------------------------- !*** Now determine which points on each parent task will be updated. ! ! Example 1: The child task's MY_ISTART_ON_PARENT is 10.666667 and ! the parent task's ITS is 10. Then the first parent I ! to be updated by the child task is ! INT(10.66667+1.-EPS)=INT(11.66667-EPS)=11. ! Example 2: The child task's MY_ISTART_ON_PARENT is 10.999999 and ! the parent task's ITS is 10. Then the first parent I ! to be updated by the child task is ! INT(10.999999+1.-EPS)=INT(11.999999-EPS)=11. ! Example 3: The child task's MY_ISTART_ON_PARENT is 11.000001 and ! the parent task's ITS is 10. Then the first parent I ! to be updated by the child task is ! INT(11.000001+1.-EPS)=INT(12.000001-EPS)=11. ! Example 4: The child task's MY_IEND_ON_PARENT is 18.999999 and ! the parent task's ITE is 20. Then the last parent I ! to be updated by the child task is ! INT(18.999999+EPS)=19. !----------------------------------------------------------------------- ! I1=MAX(ITS_PARENT_TASKS(N),INT(MY_ISTART_ON_PARENT+1.-EPS)) !<-- Starting parent I to update on parent task N I2=MIN(ITE_PARENT_TASKS(N),INT(MY_IEND_ON_PARENT+EPS)) !<-- Ending parent I to update on parent task N J1=MAX(JTS_PARENT_TASKS(N),INT(MY_JSTART_ON_PARENT+1.-EPS)) !<-- Starting parent J to update on parent task N J2=MIN(JTE_PARENT_TASKS(N),INT(MY_JEND_ON_PARENT+EPS)) !<-- Ending parent J to update on parent task N ! NPTS_PARENT_UPDATE=(I2-I1+1)*(J2-J1+1) !<-- # of points to update on parent task N ! IF(NPTS_PARENT_UPDATE<=0)THEN CYCLE find !<-- No usable 2-way exchange region on this child task. ENDIF ! NTASKS_UPDATE_PARENT=NTASKS_UPDATE_PARENT+1 !<-- Count the # of parent tasks to update. ! IF(NTASKS_UPDATE_PARENT>4)THEN WRITE(0,11101)NTASKS_UPDATE_PARENT 11101 FORMAT(' Child task is updating ',I3,' parent tasks which is > 4') WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! ID_PARENT_UPDATE_TASKS(NTASKS_UPDATE_PARENT)=N !<-- Local rank of the parent task. ! NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)=NPTS_PARENT_UPDATE !<-- # of points to update on parent task N ! IF(ASSOCIATED(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA))THEN DEALLOCATE(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,11102)NTASKS_UPDATE_PARENT 11102 FORMAT(' Failed to deallocate I_2WAY_UPDATE(',I1,')%DATA') WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! ALLOCATE(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(1:NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,11103)NTASKS_UPDATE_PARENT 11103 FORMAT(' Failed to allocate I_2WAY_UPDATE(',I1,')%DATA') WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! IF(ASSOCIATED(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA))THEN DEALLOCATE(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,11104)NTASKS_UPDATE_PARENT 11104 FORMAT(' Failed to deallocate J_2WAY_UPDATE(',I1,')%DATA') WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ENDIF ! ALLOCATE(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(1:NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)) & ,stat=ISTAT) IF(ISTAT/=0)THEN WRITE(0,11105)NTASKS_UPDATE_PARENT 11105 FORMAT(' Failed to allocate J_2WAY_UPDATE(',I1,')%DATA') WRITE(0,*)' Aborting!!' CALL ESMF_Finalize(endflag=ESMF_END_ABORT) ENDIF ! !----------------------------------------------------------------------- !*** This child task saves the parent I's and J's it will update !*** on parent task N which is update task #NTASKS_UPDATE_PARENT). !*** Recall that NTASKS_UPDATE_PARENT ranges from 1 to 4. !----------------------------------------------------------------------- ! KOUNT=0 DO J=J1,J2 DO I=I1,I2 KOUNT=KOUNT+1 I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(KOUNT)=I J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(KOUNT)=J ENDDO ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! ENDDO find ! !----------------------------------------------------------------------- ! END SUBROUTINE CHILD_2WAY_BOOKKEEPING ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE GENERATE_2WAY_DATA(VAR_CHILD & ,PD_CHILD & ,FIS_CHILD & ,IMS,IME,JMS,JME,NVERT & ,I_2WAY & ,J_2WAY & ,N_STENCIL & ,N_STENCIL_SFC & ,NPTS_UPDATE_PARENT & ,VAR_2WAY & ,INTERPOLATE_SFC & ,CHILD_SFC_ON_PARENT & ) ! !----------------------------------------------------------------------- !*** When there is 2-way nesting the children interpolate data in !*** their domains to gridpoints in their parents' domains. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME !<-- Child task subdomain horizontal memory dimensions ! INTEGER(kind=KINT),INTENT(IN) :: N_STENCIL & !<-- Use N_STENCILxN_STENCIL child pts for each parent point ,N_STENCIL_SFC & !<-- Stencil width for interpolating child FIS,PD to parent ,NPTS_UPDATE_PARENT & !<-- # of parent points (I,J) updated on given parent task ,NVERT !<-- Vertical dimension of VAR_CHILD ! INTEGER(kind=KINT),DIMENSION(1:NPTS_UPDATE_PARENT),INTENT(IN) :: & I_2WAY & !<-- Child I on each parent update point (H or V) ,J_2WAY !<-- Child J on each parent update point (H or V) ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS_CHILD & !<-- The child's sfc geopotential ,PD_CHILD !<-- The child's PD array ! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NVERT),INTENT(IN) :: & VAR_CHILD !<-- The child array of the 3-D update variable ! REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_PARENT,1:2),INTENT(OUT) :: & CHILD_SFC_ON_PARENT !<-- Child's FIS,PD interpolated to parent update points ! REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_PARENT*NVERT),INTENT(OUT) :: & VAR_2WAY !<-- 2-way variable interp'd from child grid to parent's ! LOGICAL(kind=KLOG),INTENT(IN) :: INTERPOLATE_SFC !<-- Should FIS,PD be interpolated this call? ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT),SAVE :: KNT_PTS ! INTEGER(kind=KINT) :: I,IC,J,JC,KNT_PTS_HORZ,L & ,N_STENCIL_0,N_STENCIL_TOT,NP ! INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: I_START,I_END & ,J_START,J_END ! REAL(kind=KFPT) :: FIS_SUM,PD_SUM,RECIP_N_STENCIL_TOT,VSUM ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! N_STENCIL_0=N_STENCIL/2 !<-- 2->1; 3->1; 4->2; 5->2, etc. N_STENCIL_TOT=N_STENCIL*N_STENCIL !<-- # of points in the stencil RECIP_N_STENCIL_TOT=1./REAL(N_STENCIL_TOT) !<-- Reciprocal of # of points in the stencil ! !----------------------------------------------------------------------- !*** Parent-child gridspace ratios can be any positive integer (>1 of !*** course). On the B-grid a child H point will lie on a parent H !*** point no matter what the ratio is. A child V point will lie on !*** a parent V point only for odd values of the parent-child gridspace !*** ratio. If the ratio is even then child H points will lie on !*** parent V points. The I,J of the child H point on the parent !*** V point in that case will be the same as the child V point's !*** immediately to the NE on the B grid. This implies that the !*** stencil will always be even (2x2, 4x4, etc) for interpolating !*** to parent V points when the gridspace ratio is even while it !*** will be odd (3x3, 5x5, etc.) for all other cases. The previous !*** statement is true for stencils that are oriented north-south. !*** New code will need to be added if stencils rotated 45 degrees !*** are desired. ! !*** The diagram below exemplifies odd and even ratios. The capital !*** letters are parent gridpoints and the small letters are child !*** gridpoints. !----------------------------------------------------------------------- ! ! Parent-child Parent-child ! gridspace ratio gridspace ratio ! is odd (3) is even (2) ! ! ! Hh h h Hh Hh h Hh ! ! v v v ! v v ! h h h h ! ! v Vv v h Vh h ! ! h h h h ! v v ! v v v ! ! Hh h h Hh Hh h Hh ! ! ! ! Child h points lie on parent H Child h points lie on parent H ! points and child v points lie points but child h points also ! on parent V points. lie on parent V points. ! ! !----------------------------------------------------------------------- !*** Recall that the I,J of a V point on the B grid is the same as !*** that of the neighboring H point to the southwest. Therefore !*** from the diagrams above one can see that if a child point I,J !*** coincides with a parent point to be interpolated to then !*** the SW corner of the interpolation stencil will always be !*** at I-N_STENCIL_0, J-N_STENCIL_0 where N_STENCIL_0 is equal to !*** N_STENCIL/2 (integer division). !----------------------------------------------------------------------- ! ALLOCATE(I_START(1:NPTS_UPDATE_PARENT)) ALLOCATE(I_END (1:NPTS_UPDATE_PARENT)) ALLOCATE(J_START(1:NPTS_UPDATE_PARENT)) ALLOCATE(J_END (1:NPTS_UPDATE_PARENT)) ! DO NP=1,NPTS_UPDATE_PARENT !<-- Loop through this parent task subdomain's update points ! IC=I_2WAY(NP) !<-- Child I at parent's NP'th update point I_START(NP)=IC-N_STENCIL_0 !<-- Child I on west side of averaging stencil I_END(NP) =I_START(NP)+N_STENCIL-1 !<-- Child I on east side of averaging stencil ! JC=J_2WAY(NP) !<-- Child J at parent's NP'th update point J_START(NP)=JC-N_STENCIL_0 !<-- Child J on south side of averaging stencil J_END(NP) =J_START(NP)+N_STENCIL-1 !<-- Child J on north side of averaging stencil ! ENDDO ! !----------------------------------------------------------------------- !*** This child task loops through the parent points for which it is !*** responsible on the given parent task. !----------------------------------------------------------------------- ! KNT_PTS=0 DO L=1,NVERT ! DO NP=1,NPTS_UPDATE_PARENT !<-- Loop over update points on the given parent task ! VSUM=0. ! DO J=J_START(NP),J_END(NP) DO I=I_START(NP),I_END(NP) VSUM=VSUM+VAR_CHILD(I,J,L) !<-- Sum the variable over the averaging stencil for ENDDO ! parent point NP. ENDDO ! KNT_PTS=KNT_PTS+1 VAR_2WAY(KNT_PTS)=VSUM*RECIP_N_STENCIL_TOT !<-- Child's update value at parent point stored as 1-D ! ENDDO ! ENDDO ! !----------------------------------------------------------------------- !*** The child interpolates its sfc geopotential and sfc pressure !*** to the parent points to be updated as it did for the primary !*** prognostic variables. If either the parent's sfc geopotential !*** or the child's interpolated sfc geopotential is above sea level !*** then the parent will interpolate vertically the update values !*** received from the child to account for differences in the !*** domains' topographies. !*** Note that the value of N_STENCIL_0 (the distance in I or J !*** from the child I,J lying on the target parent H or V point to !*** the west/south edge of the stencil) is different than above !*** since now child H-pt values (FIS,PD) are always being averaged !*** onto both H and V parent points. !----------------------------------------------------------------------- ! IF(INTERPOLATE_SFC)THEN ! N_STENCIL_0=(N_STENCIL_SFC+1)/2-1 !<-- 2-->0; 3-->1; 4-->1; 5-->2, etc. N_STENCIL_TOT=N_STENCIL_SFC*N_STENCIL_SFC !<-- # of points in the sfc stencil RECIP_N_STENCIL_TOT=1./REAL(N_STENCIL_TOT) !<-- Reciprocal of # of points in the sfc stencil ! KNT_PTS_HORZ=0 ! DO NP=1,NPTS_UPDATE_PARENT !<-- Loop over update points on the given parent task ! PD_SUM=0. FIS_SUM=0. ! IC=I_2WAY(NP) !<-- Child I at parent's NP'th update point I_START(NP)=IC-N_STENCIL_0 !<-- Child I on west side of sfc averaging stencil I_END(NP) =I_START(NP)+N_STENCIL_SFC-1 !<-- Child I on east side of sfc averaging stencil ! JC=J_2WAY(NP) !<-- Child J at parent's NP'th update point J_START(NP)=JC-N_STENCIL_0 !<-- Child J on south side of sfc averaging stencil J_END(NP) =J_START(NP)+N_STENCIL_SFC-1 !<-- Child J on north side of sfc averaging stencil ! DO J=J_START(NP),J_END(NP) DO I=I_START(NP),I_END(NP) PD_SUM=PD_SUM+PD_CHILD(I,J) FIS_SUM=FIS_SUM+FIS_CHILD(I,J) ENDDO ENDDO ! KNT_PTS_HORZ=KNT_PTS_HORZ+1 CHILD_SFC_ON_PARENT(KNT_PTS_HORZ,1)=FIS_SUM*RECIP_N_STENCIL_TOT !<-- Child's mean sfc geopotential within stencil CHILD_SFC_ON_PARENT(KNT_PTS_HORZ,2)=PD_SUM*RECIP_N_STENCIL_TOT !<-- Child's mean PD within stencil ! ENDDO ! ENDIF ! !----------------------------------------------------------------------- ! DEALLOCATE(I_START) DEALLOCATE(I_END) DEALLOCATE(J_START) DEALLOCATE(J_END) ! !----------------------------------------------------------------------- ! END SUBROUTINE GENERATE_2WAY_DATA ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE READ_NETCDF_LATLON(GRID_NAME & ,IM_1,JM_1,I_SW,J_SW,SPACE_RATIO & ,GLAT,GLON,VLAT,VLON & ,ITS,ITE,JTS,JTE & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE) ! !----------------------------------------------------------------------- !*** Read the domain's geographic latitudes/longitudes (radians) !*** from external NetCDF files. Include the MPI task subdomains' !*** haloes to avoid doing a halo exchange afterward. !----------------------------------------------------------------------- ! !------------------------ !*** Argument variables !------------------------ ! INTEGER(kind=KINT),INTENT(IN) :: IM_1,JM_1 & !<-- Index limits of upper parent grid ,I_SW,J_SW & !<-- Parent I,J of this domain's SW corner ,SPACE_RATIO !<-- Ratio of parent's grid increment to this domain's ! INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & ,IMS,IME,JMS,JME & ,IDS,IDE,JDS,JDE ! CHARACTER(len=*),INTENT(IN) :: GRID_NAME ! REAL(kind=KDBL),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GLAT & ,GLON & ,VLAT & ,VLON ! !--------------------- !*** Local variables !--------------------- ! INTEGER(kind=KINT) :: I1,I2,J1,J2 & ,I_COUNT_DATA & ,I_START,I_END & ,I_WEST_NEST,I_EAST_NEST & ,J_COUNT_DATA & ,J_START,J_END & ,J_NORTH_NEST,J_SOUTH_NEST & ,NCID,NCTYPE,NDIMS,VAR_ID ! INTEGER(kind=KINT),DIMENSION(1:2) :: DIM_IDS ! CHARACTER(len=15) :: VNAME CHARACTER(len=21) :: FILENAME ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! IF(GRID_NAME=='Upper_Parent')THEN I_START=MAX(IMS,IDS) I_END=MIN(IME,IDE) I1=I_START !<-- Parent task I of west halo start I2=I_END !<-- Parent task I of east halo end ! J_START=MAX(JMS,JDS) J_END=MIN(JME,JDE) J1=J_START !<-- Parent task J of south halo start J2=J_END !<-- Parent task J of north halo end i_west_nest=-999 i_east_nest=-999 j_south_nest=-999 j_north_nest=-999 ! ELSEIF(GRID_NAME=='Outer_Nest')THEN I_WEST_NEST=(I_SW-1)*SPACE_RATIO+1 !<-- Nest-res I on full parent domain of nest west bndry I_EAST_NEST=I_WEST_NEST+IDE-1 !<-- Nest-res I on full parent domain of nest east bndry I_START=MAX(I_WEST_NEST,I_WEST_NEST+IMS-1) !<-- Nest-res I on full parent domain of nest task west halo start I_END=MIN(I_EAST_NEST,I_WEST_NEST+IME-1) !<-- Nest-res I on full parent domain of nest task east halo end I1=MAX(IMS,IDS) !<-- Nest I of nest task west halo start I2=MIN(IME,IDE) !<-- Nest I of nest task east halo end ! J_SOUTH_NEST=(J_SW-1)*SPACE_RATIO+1 !<-- Nest-res J on full parent domain of nest south bndry J_NORTH_NEST=J_SOUTH_NEST+JDE-1 !<-- Nest-res J on full parent domain of nest north bndry J_START=MAX(J_SOUTH_NEST,J_SOUTH_NEST+JMS-1) !<-- Nest-res J on full parent domain of nest task south halo start J_END=MIN(J_NORTH_NEST,J_SOUTH_NEST+JME-1) !<-- Nest-res I on full parent domain of nest task north halo end J1=MAX(JMS,JDS) !<-- Nest J of nest task south halo start J2=MIN(JME,JDE) !<-- Nest J of nest task north halo end ENDIF ! I_COUNT_DATA=I_END-I_START+1 !<-- I extent of data to be read J_COUNT_DATA=J_END-J_START+1 !<-- J extent of data to be read ! !----------------------------------------------------------------------- !*** Open and read the file with H-point latitudes for !*** this task's subdomain. !----------------------------------------------------------------------- ! FILENAME=TRIM(GRID_NAME)//'_lat_H.nc' CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) ! CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,1,VNAME,NCTYPE & ,NDIMS,DIM_IDS)) CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) ! CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & ,GLAT(I1:I2,J1:J2) & ,start=(/I_START,J_START/) & ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! CALL CHECK(NF90_CLOSE(NCID)) ! !----------------------------------------------------------------------- !*** Open and read the file with H-point longitudes for !*** this task's subdomain. !----------------------------------------------------------------------- ! FILENAME=TRIM(GRID_NAME)//'_lon_H.nc' CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) ! CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,1,VNAME,NCTYPE & ,NDIMS,DIM_IDS)) CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) ! CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & ,GLON(I1:I2,J1:J2) & ,start=(/I_START,J_START/) & ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! CALL CHECK(NF90_CLOSE(NCID)) ! !----------------------------------------------------------------------- !*** Open and read the file with V-point latitudes for !*** this task's subdomain. !----------------------------------------------------------------------- ! FILENAME=TRIM(GRID_NAME)//'_lat_V.nc' CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) ! CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,1,VNAME,NCTYPE & ,NDIMS,DIM_IDS)) CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) ! CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & ,VLAT(I1:I2,J1:J2) & ,start=(/I_START,J_START/) & ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! CALL CHECK(NF90_CLOSE(NCID)) ! !----------------------------------------------------------------------- !*** Open and read the file with V-point longitudes for !*** this task's subdomain. !----------------------------------------------------------------------- ! FILENAME=TRIM(GRID_NAME)//'_lon_V.nc' CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) ! CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,1,VNAME,NCTYPE & ,NDIMS,DIM_IDS)) CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) ! CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & ,VLON(I1:I2,J1:J2) & ,start=(/I_START,J_START/) & ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! CALL CHECK(NF90_CLOSE(NCID)) ! !----------------------------------------------------------------------- ! END SUBROUTINE READ_NETCDF_LATLON ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- 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. * ! * * ! ****************************************************************** ! !----------------------------------------------------------------------- !*** Arguments !----------------------------------------------------------------------- ! INTEGER,INTENT(IN) :: NNEW,NOLD,Y2_K ! REAL,DIMENSION(1:NOLD),INTENT(IN) :: XOLD,YOLD REAL,DIMENSION(1:NNEW),INTENT(IN) :: XNEW ! REAL,DIMENSION(1:Y2_K),INTENT(INOUT) :: Y2 ! REAL,DIMENSION(1:NNEW),INTENT(OUT) :: YNEW ! !----------------------------------------------------------------------- !*** Local Variables !----------------------------------------------------------------------- ! INTEGER :: K,K1,K2,KOLD,NOLDM1 ! REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR,RDX,RTDXC & ,X,XK,XSQ,Y2K,Y2KP1 ! REAL,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 HYPERBOLA(A) ! !----------------------------------------------------------------------- !*** Generate a hyperbola that will reduce the magnitude of the !*** source domain's underground extrapolation in those instances !*** when the target domain's ground surface lies below the source !*** domain's. The hyperbola has the formula: ! ! Y=A/(X+A) ! !*** The value of Y is the fraction between 1 and 0 that provides !*** the reduction in the amount added to the source domain's lowest !*** layer value to account for the extrapolation underground. !*** The value of X is the difference in pressure (Pa) between the !*** source domain's lowest pressure level and the target pressure !*** of the extrapolation. When the pressure difference is zero then !*** there is no reduction in the source domain's extrapolation and !*** so the value of Y is 1.0. For very large extrapolations then !*** the amount added to the source domain's lowest layer value to !*** account for the extrapolation is reduced by a factor approaching !*** zero. !*** The formula gives the user 1 degree of freedom. Specify one !*** extrapolated underground pressure depth and the amount desired !*** for the reduction in the linear extrapolation of the source !*** domain's lowest layer value through that depth. !*** For example, if X1=10000.0 and Y1=0.05 then when the lowest !*** layer value in the source domain is linearly extrapolated !*** through an underground depth of 10000 Pa then the amount added !*** to that lowest layer value to account for the extrapolation is !*** first multiplied by 0.05. !----------------------------------------------------------------------- ! REAL(kind=KDBL),PARAMETER :: X1=10000.0, Y1=0.05 ! !------------------------ !*** Argument Variables !------------------------ ! REAL(kind=KDBL),INTENT(OUT) :: A !<-- Constant in the hyperbola Y=A/(X+A) ! !--------------------- !*** Local Variables !--------------------- ! REAL(kind=KDBL) :: F,G,H,DISCRIM,PROD1,PROD2 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! A=(X1*Y1)/(1.-Y1) ! !----------------------------------------------------------------------- ! END SUBROUTINE HYPERBOLA ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHECK_REAL(P_IN,NAME) ! !----------------------------------------------------------------------- !*** Check the status of pointer P_IN and deallocate or nullify. !----------------------------------------------------------------------- ! !------------------------ !*** Argument Variables !------------------------ ! REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(INOUT) :: P_IN ! CHARACTER(len=*),INTENT(IN) :: NAME ! !-------------------- !*** Local Variables !-------------------- ! INTEGER(kind=KINT) :: ISTAT ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! IF(ASSOCIATED(P_IN))THEN DEALLOCATE(P_IN,stat=ISTAT) IF(ISTAT/=0)THEN NULLIFY(P_IN) WRITE(0,*)NAME,' was associated but not allocated. ' & ,' It has now been nullified.' ELSE WRITE(0,*)' Forced to deallocate ',NAME ENDIF ENDIF ! !----------------------------------------------------------------------- ! END SUBROUTINE CHECK_REAL ! !----------------------------------------------------------------------- !####################################################################### !----------------------------------------------------------------------- ! SUBROUTINE CHECK(RC) ! IMPLICIT NONE ! INTEGER,INTENT(IN) :: RC ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! IF(RC/=NF90_NOERR)THEN WRITE(*,*)TRIM(ADJUSTL(NF90_STRERROR(RC))) ! WRITE(0,11101)RC 11101 FORMAT(' ERROR: RC=',I5) ENDIF ! END SUBROUTINE CHECK ! !----------------------------------------------------------------------- ! END MODULE MODULE_NESTING ! !-----------------------------------------------------------------------