|
| 1 | +#if ( EM_CORE == 1 && DA_CORE != 1 ) |
| 2 | + |
| 3 | +!------------------------------------------------------------------ |
| 4 | + |
| 5 | + SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags & |
| 6 | +! |
| 7 | +#include "dummy_new_args.inc" |
| 8 | +! |
| 9 | + ) |
| 10 | + USE module_state_description |
| 11 | + USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid |
| 12 | + USE module_configure, ONLY : grid_config_rec_type, model_config_rec |
| 13 | + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & |
| 14 | + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & |
| 15 | + nest_pes_x, nest_pes_y, & |
| 16 | + intercomm_active, nest_task_offsets, & |
| 17 | + mpi_comm_to_mom, mpi_comm_to_kid, which_kid !, & |
| 18 | + !push_communicators_for_domain, pop_communicators_for_domain |
| 19 | + |
| 20 | + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub |
| 21 | + USE module_utility |
| 22 | + IMPLICIT NONE |
| 23 | + |
| 24 | +! |
| 25 | + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") |
| 26 | + TYPE(domain), POINTER :: intermediate_grid |
| 27 | + TYPE(domain), POINTER :: ngrid |
| 28 | + TYPE(domain), POINTER :: parent_grid |
| 29 | + |
| 30 | +#include "dummy_new_decl.inc" |
| 31 | + INTEGER nlev, msize |
| 32 | + INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k |
| 33 | + TYPE (grid_config_rec_type) :: config_flags |
| 34 | + REAL xv(2000) |
| 35 | + INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & |
| 36 | + cims, cime, cjms, cjme, ckms, ckme, & |
| 37 | + cips, cipe, cjps, cjpe, ckps, ckpe |
| 38 | + INTEGER :: nids, nide, njds, njde, nkds, nkde, & |
| 39 | + nims, nime, njms, njme, nkms, nkme, & |
| 40 | + nips, nipe, njps, njpe, nkps, nkpe |
| 41 | + INTEGER :: xids, xide, xjds, xjde, xkds, xkde, & |
| 42 | + xims, xime, xjms, xjme, xkms, xkme, & |
| 43 | + xips, xipe, xjps, xjpe, xkps, xkpe |
| 44 | + INTEGER :: ids, ide, jds, jde, kds, kde, & |
| 45 | + ims, ime, jms, jme, kms, kme, & |
| 46 | + ips, ipe, jps, jpe, kps, kpe |
| 47 | + |
| 48 | + INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 |
| 49 | + |
| 50 | + INTEGER icoord, jcoord, idim_cd, jdim_cd |
| 51 | + INTEGER local_comm, myproc, nproc, ioffset |
| 52 | + INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width |
| 53 | + REAL nest_influence |
| 54 | + |
| 55 | + character*256 :: timestr |
| 56 | + integer ierr |
| 57 | + |
| 58 | + LOGICAL, EXTERNAL :: cd_feedback_mask |
| 59 | + |
| 60 | +!cyl: add variables for trajectory |
| 61 | + integer tjk |
| 62 | + |
| 63 | +! On entry to this routine, |
| 64 | +! "grid" refers to the parent domain |
| 65 | +! "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest |
| 66 | +! "ngrid" refers to the nest, which is only needed for smoothing on the parent because |
| 67 | +! the nest feedback data has already been transferred during em_nest_feedbackup_interp |
| 68 | +! in part1, above. |
| 69 | +! The way these settings c and n dimensions are set, below, looks backwards but from the point |
| 70 | +! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by |
| 71 | +! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain |
| 72 | +! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c |
| 73 | +! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road |
| 74 | +! sign that says "DIP" than fix the dip, at this point it was easier just to write this comment. JM |
| 75 | +! |
| 76 | + nest_influence = 1. |
| 77 | +
|
| 78 | + CALL domain_clock_get( grid, current_timestr=timestr ) |
| 79 | +
|
| 80 | + CALL get_ijk_from_grid ( intermediate_grid , & |
| 81 | + cids, cide, cjds, cjde, ckds, ckde, & |
| 82 | + cims, cime, cjms, cjme, ckms, ckme, & |
| 83 | + cips, cipe, cjps, cjpe, ckps, ckpe ) |
| 84 | + CALL get_ijk_from_grid ( grid , & |
| 85 | + nids, nide, njds, njde, nkds, nkde, & |
| 86 | + nims, nime, njms, njme, nkms, nkme, & |
| 87 | + nips, nipe, njps, njpe, nkps, nkpe ) |
| 88 | + CALL get_ijk_from_grid ( ngrid , & |
| 89 | + xids, xide, xjds, xjde, xkds, xkde, & |
| 90 | + xims, xime, xjms, xjme, xkms, xkme, & |
| 91 | + xips, xipe, xjps, xjpe, xkps, xkpe ) |
| 92 | +
|
| 93 | + ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below |
| 94 | + jps_save = ngrid%j_parent_start |
| 95 | + ipe_save = ngrid%i_parent_start + (xide-xids+1) / ngrid%parent_grid_ratio - 1 |
| 96 | + jpe_save = ngrid%j_parent_start + (xjde-xjds+1) / ngrid%parent_grid_ratio - 1 |
| 97 | +
|
| 98 | +
|
| 99 | +
|
| 100 | +
|
| 101 | +IF ( ngrid%active_this_task ) THEN |
| 102 | +!cyl add this for trajectory |
| 103 | + CALL push_communicators_for_domain( ngrid%id ) |
| 104 | +
|
| 105 | + do tjk = 1,config_flags%num_traj |
| 106 | + if (ngrid%traj_long(tjk) .eq. -9999.0) then |
| 107 | +! print*,'n=-9999',tjk |
| 108 | + ngrid%traj_long(tjk)=grid%traj_long(tjk) |
| 109 | + ngrid%traj_k(tjk)=grid%traj_k(tjk) |
| 110 | + else |
| 111 | +! print*,'p!=-9999',tjk |
| 112 | + grid%traj_long(tjk)=ngrid%traj_long(tjk) |
| 113 | + grid%traj_k(tjk)=ngrid%traj_k(tjk) |
| 114 | + endif |
| 115 | + if (ngrid%traj_lat(tjk) .eq. -9999.0) then |
| 116 | + ngrid%traj_lat(tjk)=grid%traj_lat(tjk) |
| 117 | + ngrid%traj_k(tjk)=grid%traj_k(tjk) |
| 118 | + else |
| 119 | + grid%traj_lat(tjk)=ngrid%traj_lat(tjk) |
| 120 | + grid%traj_k(tjk)=ngrid%traj_k(tjk) |
| 121 | + endif |
| 122 | + enddo |
| 123 | +!endcyl |
| 124 | +
|
| 125 | + CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt ) |
| 126 | + CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt ) |
| 127 | + CALL nl_get_shw ( intermediate_grid%id, sw ) |
| 128 | + icoord = iparstrt - sw |
| 129 | + jcoord = jparstrt - sw |
| 130 | + idim_cd = cide - cids + 1 |
| 131 | + jdim_cd = cjde - cjds + 1 |
| 132 | +
|
| 133 | + nlev = ckde - ckds + 1 |
| 134 | +
|
| 135 | + CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width ) |
| 136 | +
|
| 137 | + parent_grid => grid |
| 138 | + grid => ngrid |
| 139 | +#include "nest_feedbackup_pack.inc" |
| 140 | + grid => parent_grid |
| 141 | + CALL pop_communicators_for_domain |
| 142 | +
|
| 143 | +END IF |
| 144 | +
|
| 145 | +! CALL wrf_get_dm_communicator ( local_comm ) |
| 146 | +! CALL wrf_get_myproc( myproc ) |
| 147 | +! CALL wrf_get_nproc( nproc ) |
| 148 | +
|
| 149 | + ! determine which communicator and offset to use |
| 150 | + IF ( intercomm_active( grid%id ) ) THEN ! I am parent |
| 151 | + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) |
| 152 | + ioffset = nest_task_offsets(ngrid%id) |
| 153 | + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest |
| 154 | + local_comm = mpi_comm_to_mom( ngrid%id ) |
| 155 | + ioffset = nest_task_offsets(ngrid%id) |
| 156 | + END IF |
| 157 | +
|
| 158 | + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN |
| 159 | +#ifndef STUBMPI |
| 160 | + CALL mpi_comm_rank(local_comm,myproc,ierr) |
| 161 | + CALL mpi_comm_size(local_comm,nproc,ierr) |
| 162 | +#endif |
| 163 | +!call tracebackqq() |
| 164 | + CALL rsl_lite_merge_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & |
| 165 | + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & |
| 166 | + ioffset, local_comm ) |
| 167 | + END IF |
| 168 | +
|
| 169 | +IF ( grid%active_this_task ) THEN |
| 170 | + CALL push_communicators_for_domain( grid%id ) |
| 171 | +
|
| 172 | +
|
| 173 | +#define NEST_INFLUENCE(A,B) A = B |
| 174 | +#include "nest_feedbackup_unpack.inc" |
| 175 | +
|
| 176 | + ! smooth coarse grid |
| 177 | + CALL get_ijk_from_grid ( ngrid, & |
| 178 | + nids, nide, njds, njde, nkds, nkde, & |
| 179 | + nims, nime, njms, njme, nkms, nkme, & |
| 180 | + nips, nipe, njps, njpe, nkps, nkpe ) |
| 181 | + CALL get_ijk_from_grid ( grid , & |
| 182 | + ids, ide, jds, jde, kds, kde, & |
| 183 | + ims, ime, jms, jme, kms, kme, & |
| 184 | + ips, ipe, jps, jpe, kps, kpe ) |
| 185 | +
|
| 186 | +#include "HALO_INTERP_UP.inc" |
| 187 | +
|
| 188 | + CALL get_ijk_from_grid ( grid , & |
| 189 | + cids, cide, cjds, cjde, ckds, ckde, & |
| 190 | + cims, cime, cjms, cjme, ckms, ckme, & |
| 191 | + cips, cipe, cjps, cjpe, ckps, ckpe ) |
| 192 | +
|
| 193 | +#include "nest_feedbackup_smooth.inc" |
| 194 | +
|
| 195 | + CALL pop_communicators_for_domain |
| 196 | +END IF |
| 197 | +
|
| 198 | + RETURN |
| 199 | + END SUBROUTINE feedback_domain_em_part2 |
| 200 | +#endif |
0 commit comments