MODFLOW 6  version 6.7.0.dev0
USGS Modular Hydrologic Model
VirtualExchange.f90
Go to the documentation of this file.
5  use kindmodule, only: i4b, lgp
6  use listmodule, only: listtype
10  implicit none
11  private
12 
13  public :: get_virtual_exchange
15  private :: cast_as_virtual_exchange
16 
17  !> The Virtual Exchange is based on two Virtual Models
18  !! and is therefore not always strictly local or remote.
19  !! We have to consider three different cases:
20  !!
21  !! 1) both virtual models are local
22  !!
23  !! RECV: In this case this virtual data container will have
24  !! no data items to receive from other processes.
25  !! SEND: Whenever it is called to send its virtual data items
26  !! to other processes, it simply sends everything.
27  !!
28  !! 2) one model is local, one model is remote
29  !!
30  !! Consequently, there is another exchange which
31  !! has the reverse, we call this our _dual_ exchange.
32  !!
33  !! RECV: The sender is our dual exchange, and we have all data
34  !! except its list of reduced model node numbers, either
35  !! this%nodem1 or this%nodem2. We receive the missing
36  !! array. Receiving from a sender that is not the dual
37  !! exchange cannot occur.
38  !!
39  !! SEND: here we have to consider two cases
40  !! a) The receiver is our dual exchange, we return the favor
41  !! and send the list of model node numbers that is present
42  !! on this process, this
43  !! would be either this%nodem1 or this%nodem2
44  !! b) The receiver is not the dual exchange. And here we will
45  !! send everything.
46  !!
47  !! 3) both models are remote
48  !!
49  !! RECV: we will receive everything. In case the source
50  !! exchange is fully local, i.e. type 1) above, we get
51  !! all the data at the first attempt. Otherwise, it will
52  !! take a second attempt before all the data is in.
53  !! (To allow for two attempts, the nodem1 and nodem2
54  !! arrays are registered to be synchronized at two
55  !! consecutive stages)
56  !!
57  !! SEND: nothing to be sent.
58  !!
59  !!
60  !! This behavior is different from the general VirtualDataContainer,
61  !! so the get_send_items and get_recv_items subroutines are
62  !! overridden accordingly.
63  !! Additionally, for case 2) the container will have a mix of
64  !< local and remote virtual data items.
66  class(virtualmodeltype), pointer :: v_model1 => null()
67  class(virtualmodeltype), pointer :: v_model2 => null()
68  ! scalars
69  type(virtualinttype), pointer :: nexg => null()
70  type(virtualinttype), pointer :: naux => null()
71  type(virtualinttype), pointer :: ianglex => null()
72  ! arrays
73  type(virtualint1dtype), pointer :: nodem1 => null()
74  type(virtualint1dtype), pointer :: nodem2 => null()
75  type(virtualint1dtype), pointer :: ihc => null()
76  type(virtualdbl1dtype), pointer :: cl1 => null()
77  type(virtualdbl1dtype), pointer :: cl2 => null()
78  type(virtualdbl1dtype), pointer :: hwva => null()
79  type(virtualdbl2dtype), pointer :: auxvar => null()
80  contains
81  procedure :: create => vx_create
82  procedure :: prepare_stage => vx_prepare_stage
83  procedure :: get_send_items => vx_get_send_items
84  procedure :: get_recv_items => vx_get_recv_items
85  procedure :: has_mover => vx_has_mover
86  procedure :: destroy => vx_destroy
87  ! private
88  procedure, private :: init_virtual_data
89  procedure, private :: allocate_data
90  procedure, private :: deallocate_data
91  end type virtualexchangetype
92 
93 contains
94 
95  !> @brief Create the virtual exchange base
96  !<
97  subroutine vx_create(this, name, exg_id, m1_id, m2_id)
98  class(virtualexchangetype) :: this
99  character(len=*) :: name
100  integer(I4B) :: exg_id
101  integer(I4B) :: m1_id
102  integer(I4B) :: m2_id
103  ! local
104  logical(LGP) :: is_local
105 
106  this%v_model1 => get_virtual_model(m1_id)
107  this%v_model2 => get_virtual_model(m2_id)
108 
109  ! 1) both models local: is_local = true
110  ! 2) only one of them: is_local = true
111  ! 3) both models remote: is_local = false
112  is_local = this%v_model1%is_local .or. this%v_model2%is_local
113  call this%VirtualDataContainerType%vdc_create(name, exg_id, is_local)
114 
115  call this%allocate_data()
116  call this%init_virtual_data()
117 
118  end subroutine vx_create
119 
120  subroutine init_virtual_data(this)
121  class(virtualexchangetype) :: this
122  ! local
123  logical(LGP) :: is_nodem1_local
124  logical(LGP) :: is_nodem2_local
125 
126  ! exchanges can be hybrid with both local and remote
127  ! fields, nodem1/2 array only local when corresponding
128  ! model sits on the same process
129  is_nodem1_local = this%v_model1%is_local
130  is_nodem2_local = this%v_model2%is_local
131  call this%set(this%nexg%base(), 'NEXG', '', map_all_type)
132  call this%set(this%naux%base(), 'NAUX', '', map_all_type)
133  call this%set(this%ianglex%base(), 'IANGLEX', '', map_all_type)
134  call this%set(this%nodem1%base(), 'NODEM1', '', &
135  map_all_type, is_nodem1_local)
136  call this%set(this%nodem2%base(), 'NODEM2', '', &
137  map_all_type, is_nodem2_local)
138  call this%set(this%ihc%base(), 'IHC', '', map_all_type)
139  call this%set(this%cl1%base(), 'CL1', '', map_all_type)
140  call this%set(this%cl2%base(), 'CL2', '', map_all_type)
141  call this%set(this%hwva%base(), 'HWVA', '', map_all_type)
142  call this%set(this%auxvar%base(), 'AUXVAR', '', map_all_type)
143 
144  end subroutine init_virtual_data
145 
146  subroutine vx_prepare_stage(this, stage)
147  class(virtualexchangetype) :: this
148  integer(I4B) :: stage
149  ! local
150  integer(I4B) :: nexg, naux
151 
152  if (stage == stg_aft_exg_df) then
153 
154  call this%map(this%nexg%base(), (/stg_aft_exg_df/))
155  call this%map(this%naux%base(), (/stg_aft_exg_df/))
156  call this%map(this%ianglex%base(), (/stg_aft_exg_df/))
157 
158  else if (stage == stg_aft_con_cr) then
159 
160  nexg = this%nexg%get()
161  naux = this%naux%get()
162  call this%map(this%nodem1%base(), nexg, (/stg_aft_con_cr, &
163  stg_bfr_con_df/))
164  call this%map(this%nodem2%base(), nexg, (/stg_aft_con_cr, &
165  stg_bfr_con_df/))
166  call this%map(this%ihc%base(), nexg, (/stg_aft_con_cr/))
167  call this%map(this%cl1%base(), nexg, (/stg_aft_con_cr/))
168  call this%map(this%cl2%base(), nexg, (/stg_aft_con_cr/))
169  call this%map(this%hwva%base(), nexg, (/stg_aft_con_cr/))
170  call this%map(this%auxvar%base(), naux, nexg, (/stg_aft_con_cr/))
171 
172  end if
173 
174  end subroutine vx_prepare_stage
175 
176  subroutine vx_get_recv_items(this, stage, rank, virtual_items)
177  class(virtualexchangetype) :: this
178  integer(I4B) :: stage
179  integer(I4B) :: rank
180  type(stlvecint) :: virtual_items
181  ! local
182  integer(I4B) :: nodem1_idx, nodem2_idx
183  class(*), pointer :: vdi
184 
185  vdi => this%nodem1
186  nodem1_idx = this%virtual_data_list%GetIndex(vdi)
187  vdi => this%nodem2
188  nodem2_idx = this%virtual_data_list%GetIndex(vdi)
189 
190  if (this%v_model1%is_local .and. &
191  this%v_model2%orig_rank == rank) then
192  ! this is our dual exchange on the other rank,
193  ! only receive nodem2
194  if (this%nodem2%check_stage(stage)) then
195  call virtual_items%push_back(nodem2_idx)
196  end if
197  else if (this%v_model2%is_local .and. &
198  this%v_model1%orig_rank == rank) then
199  ! the reverse case...
200  if (this%nodem1%check_stage(stage)) then
201  call virtual_items%push_back(nodem1_idx)
202  end if
203  else
204  ! receive all using base
205  call this%VirtualDataContainerType%get_recv_items(stage, rank, &
206  virtual_items)
207  end if
208 
209  end subroutine vx_get_recv_items
210 
211  subroutine vx_get_send_items(this, stage, rank, virtual_items)
212  class(virtualexchangetype) :: this
213  integer(I4B) :: stage
214  integer(I4B) :: rank
215  type(stlvecint) :: virtual_items
216  ! local
217  integer(I4B) :: nodem1_idx, nodem2_idx
218  class(*), pointer :: vdi
219 
220  vdi => this%nodem1
221  nodem1_idx = this%virtual_data_list%GetIndex(vdi)
222  vdi => this%nodem2
223  nodem2_idx = this%virtual_data_list%GetIndex(vdi)
224  if (this%v_model1%is_local .and. &
225  this%v_model2%orig_rank == rank) then
226  ! this is our dual exchange on the other rank,
227  ! only send nodem1
228  if (this%nodem1%check_stage(stage)) then
229  call virtual_items%push_back(nodem1_idx)
230  end if
231  else if (this%v_model2%is_local .and. &
232  this%v_model1%orig_rank == rank) then
233  ! the reverse case...
234  if (this%nodem2%check_stage(stage)) then
235  call virtual_items%push_back(nodem2_idx)
236  end if
237  else
238  ! send all of it
239  call this%VirtualDataContainerType%get_send_items(stage, rank, &
240  virtual_items)
241  end if
242 
243  end subroutine vx_get_send_items
244 
245  !> @brief Checks if there is an active mover in the exchange
246  !<
247  function vx_has_mover(this) result(has_mover)
248  class(virtualexchangetype) :: this
249  logical(LGP) :: has_mover
250 
251  has_mover = .false.
252 
253  end function vx_has_mover
254 
255  subroutine vx_destroy(this)
256  class(virtualexchangetype) :: this
257 
258  call this%VirtualDataContainerType%destroy()
259  call this%deallocate_data()
260 
261  end subroutine vx_destroy
262 
263  subroutine allocate_data(this)
264  class(virtualexchangetype) :: this
265 
266  allocate (this%nexg)
267  allocate (this%naux)
268  allocate (this%ianglex)
269  allocate (this%nodem1)
270  allocate (this%nodem2)
271  allocate (this%ihc)
272  allocate (this%cl1)
273  allocate (this%cl2)
274  allocate (this%hwva)
275  allocate (this%auxvar)
276 
277  end subroutine allocate_data
278 
279  subroutine deallocate_data(this)
280  class(virtualexchangetype) :: this
281 
282  deallocate (this%nexg)
283  deallocate (this%naux)
284  deallocate (this%ianglex)
285  deallocate (this%nodem1)
286  deallocate (this%nodem2)
287  deallocate (this%ihc)
288  deallocate (this%cl1)
289  deallocate (this%cl2)
290  deallocate (this%hwva)
291  deallocate (this%auxvar)
292 
293  end subroutine deallocate_data
294 
295  !> @brief Returns a virtual exchange with the specified id
296  !< from the global list
297  function get_virtual_exchange(exg_id) result(virtual_exg)
299  integer(I4B) :: exg_id
300  class(virtualexchangetype), pointer :: virtual_exg
301  ! local
302  integer(I4B) :: i
303  class(*), pointer :: ve
304 
305  virtual_exg => null()
306  do i = 1, virtual_exchange_list%Count()
307  ve => virtual_exchange_list%GetItem(i)
308  select type (ve)
309  class is (virtualexchangetype)
310  if (ve%id == exg_id) then
311  virtual_exg => ve
312  return
313  end if
314  end select
315  end do
316 
317  end function get_virtual_exchange
318 
319  function get_virtual_exchange_from_list(list, idx) result(virtual_exg)
320  type(listtype) :: list
321  integer(I4B) :: idx
322  class(virtualexchangetype), pointer :: virtual_exg
323  ! local
324  class(*), pointer :: obj_ptr
325 
326  obj_ptr => list%GetItem(idx)
327  virtual_exg => cast_as_virtual_exchange(obj_ptr)
328 
329  end function get_virtual_exchange_from_list
330 
331  function cast_as_virtual_exchange(obj_ptr) result(virtual_exg)
332  class(*), pointer :: obj_ptr
333  class(virtualexchangetype), pointer :: virtual_exg
334 
335  virtual_exg => null()
336  select type (obj_ptr)
337  class is (virtualexchangetype)
338  virtual_exg => obj_ptr
339  end select
340 
341  end function cast_as_virtual_exchange
342 
343 end module virtualexchangemodule
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter lenexchangename
maximum length of the exchange name
Definition: Constants.f90:24
This module defines variable data types.
Definition: kind.f90:8
integer(i4b), parameter, public stg_aft_exg_df
after exchange define
Definition: SimStages.f90:12
integer(i4b), parameter, public stg_aft_con_cr
after connection create
Definition: SimStages.f90:13
integer(i4b), parameter, public stg_bfr_con_df
before connection define
Definition: SimStages.f90:14
subroutine destroy(this)
Definition: STLVecInt.f90:170
integer(i4b), parameter, public map_all_type
Definition: VirtualBase.f90:13
type(listtype), public virtual_exchange_list
subroutine deallocate_data(this)
subroutine init_virtual_data(this)
logical(lgp) function vx_has_mover(this)
Checks if there is an active mover in the exchange.
subroutine allocate_data(this)
class(virtualexchangetype) function, pointer, private cast_as_virtual_exchange(obj_ptr)
class(virtualexchangetype) function, pointer, public get_virtual_exchange_from_list(list, idx)
subroutine vx_get_send_items(this, stage, rank, virtual_items)
subroutine vx_get_recv_items(this, stage, rank, virtual_items)
subroutine vx_create(this, name, exg_id, m1_id, m2_id)
Create the virtual exchange base.
class(virtualexchangetype) function, pointer, public get_virtual_exchange(exg_id)
Returns a virtual exchange with the specified id.
subroutine vx_prepare_stage(this, stage)
subroutine vx_destroy(this)
A generic heterogeneous doubly-linked list.
Definition: List.f90:14
The Virtual Exchange is based on two Virtual Models and is therefore not always strictly local or rem...