20 character(len=12),
dimension(4) ::
mvrtypes = &
21 &[character(len=12) ::
'FACTOR',
'EXCESS',
'THRESHOLD',
'UPTO']
30 character(len=LENMEMPATH) :: mem_path_src =
''
31 character(len=LENMEMPATH) :: mem_path_tgt =
''
32 integer(I4B),
pointer :: irchnrsrc => null()
33 integer(I4B) :: irchnrsrcmapped
34 integer(I4B),
pointer :: irchnrtgt => null()
35 integer(I4B),
pointer :: imvrtype => null()
36 real(dp),
pointer ::
value => null()
37 logical(LGP) :: is_provider_active = .true.
38 logical(LGP) :: is_receiver_active = .true.
41 real(dp),
pointer :: qtformvr_ptr => null()
42 real(dp),
pointer :: qformvr_ptr => null()
43 real(dp),
pointer :: qtomvr_ptr => null()
44 real(dp),
pointer :: qfrommvr_ptr => null()
63 subroutine set_values(this, mname1, pname1, id1, mname2, pname2, &
67 character(len=*),
intent(in) :: mname1
68 character(len=*),
intent(in) :: pname1
69 integer(I4B),
intent(in),
target :: id1
70 character(len=*),
intent(in) :: mname2
71 character(len=*),
intent(in) :: pname2
72 integer(I4B),
intent(in),
target :: id2
73 integer(I4B),
intent(in),
target :: imvrtype
74 real(DP),
intent(in),
target :: value
80 this%imvrtype => imvrtype
84 this%iRchNrSrcMapped = -1
96 subroutine prepare(this, inunit, pckMemPaths, pakmovers)
101 integer(I4B),
intent(in) :: inunit
102 character(len=LENMEMPATH), &
103 dimension(:),
pointer,
contiguous :: pckMemPaths
106 real(DP),
dimension(:),
pointer,
contiguous :: temp_ptr => null()
109 integer(I4B) :: ipakloc1, ipakloc2
112 if (this%mem_path_src == this%mem_path_tgt .and. &
113 this%iRchNrSrc == this%iRchNrTgt)
then
114 call store_error(
'Provider and receiver are the same: '// &
115 trim(this%mem_path_src)//
' : '//trim(this%mem_path_tgt))
123 do i = 1,
size(pckmempaths)
124 if (this%mem_path_src == pckmempaths(i))
then
130 if (.not. found)
then
131 call store_error(
'Mover capability not activated in '//this%mem_path_src)
132 call store_error(
'Add "MOVER" keyword to package options block.')
136 do i = 1,
size(pckmempaths)
137 if (this%mem_path_tgt == pckmempaths(i))
then
143 if (.not. found)
then
144 call store_error(
'Mover capability not activated in '//this%mem_path_tgt)
145 call store_error(
'Add "MOVER" keyword to package options block.')
151 if (this%is_provider_active)
then
154 temp_ptr => pakmovers(ipakloc1)%qtomvr
155 if (this%iRchNrSrc < 1 .or. this%iRchNrSrc >
size(temp_ptr))
then
156 call store_error(
'Provider ID < 1 or greater than package size ')
157 write (
errmsg,
'(a,i0,a,i0)')
'Provider ID = ', this%iRchNrSrc, &
158 '; Package size = ',
size(temp_ptr)
162 this%qtomvr_ptr => temp_ptr(this%iRchNrSrc)
165 temp_ptr => pakmovers(ipakloc1)%qformvr
166 this%qformvr_ptr => temp_ptr(this%iRchNrSrc)
169 temp_ptr => pakmovers(ipakloc1)%qtformvr
170 this%qtformvr_ptr => temp_ptr(this%iRchNrSrc)
173 if (this%is_receiver_active)
then
176 temp_ptr => pakmovers(ipakloc2)%qfrommvr
177 if (this%iRchNrTgt < 1 .or. this%iRchNrTgt >
size(temp_ptr))
then
178 call store_error(
'Receiver ID < 1 or greater than package size ')
179 write (
errmsg,
'(a,i0,a,i0)')
'Receiver ID = ', this%iRchNrTgt, &
180 '; package size = ',
size(temp_ptr)
184 this%qfrommvr_ptr => temp_ptr(this%iRchNrTgt)
200 integer(I4B),
intent(in) :: iout
203 write (iout,
'(4x, a, a, a, i0)')
'FROM PACKAGE: ', trim(this%mem_path_src), &
204 ' FROM ID: ', this%iRchNrSrc
205 write (iout,
'(4x, a, a, a, i0)')
'TO PACKAGE: ', trim(this%mem_path_tgt), &
206 ' TO ID: ', this%iRchNrTgt
207 write (iout,
'(4x, a, a, a, 1pg15.6,/)')
'MOVER TYPE: ', &
208 trim(
mvrtypes(this%imvrtype)),
' ', this%value
239 real(DP) :: qavailable, qtanew, qpactual
242 qavailable = this%qformvr_ptr
243 qtanew = this%qtformvr_ptr
244 this%qavailable = qavailable
248 qpactual = this%qrcalc(qavailable, qtanew)
251 this%qpactual = qpactual
255 this%qtomvr_ptr = this%qtomvr_ptr + qpactual
259 this%qformvr_ptr = this%qformvr_ptr - qpactual
274 this%qfrommvr_ptr = this%qfrommvr_ptr + this%qpactual
285 function qrcalc(this, qa, qta)
result(qr)
291 real(dp),
intent(in) :: qa
292 real(dp),
intent(in) :: qta
298 select case (this%imvrtype)
302 if (qta >
dzero) qr = qta * this%value
306 if (qa > this%value)
then
313 if (this%value > qa)
then
320 if (qa > this%value)
then
340 integer(I4B),
intent(in) :: iout
342 character(len=*),
parameter :: fmt = &
343 "(1x, a, ' ID ', i0, ' AVAILABLE ', 1(1pg15.6), &
344 &' PROVIDED ', 1(1pg15.6), ' TO ', a, ' ID ', i0)"
346 write (iout, fmt) trim(this%mem_path_src), this%iRchNrSrc, this%qavailable, &
347 this%qpactual, trim(this%mem_path_tgt), this%iRchNrTgt
This module contains simulation constants.
integer(i4b), parameter linelength
maximum length of a standard line
integer(i4b), parameter lenmodelname
maximum length of the model name
integer(i4b), parameter lenauxname
maximum length of a aux variable
integer(i4b), parameter lenboundname
maximum length of a bound name
real(dp), parameter dzero
real constant zero
integer(i4b), parameter lenbudtxt
maximum length of a budget component names
integer(i4b), parameter lenmempath
maximum length of the memory path
real(dp), parameter done
real constant 1
This module defines variable data types.
character(len=lenmempath) function create_mem_path(component, subcomponent, context)
returns the path to the memory object
This module contains the MvrModule Module.
subroutine prepare(this, inunit, pckMemPaths, pakmovers)
@ brief Prepare object
subroutine echo(this, iout)
@ brief Echo data to list file
character(len=12), dimension(4) mvrtypes
subroutine update_receiver(this)
@ brief Formulate coefficients
real(dp) function qrcalc(this, qa, qta)
@ brief Flow to receiver
subroutine set_values(this, mname1, pname1, id1, mname2, pname2, id2, imvrtype, value)
@ brief Set values from input data
subroutine writeflow(this, iout)
@ brief Write flow
subroutine update_provider(this)
@ brief Formulate coefficients
subroutine advance(this)
@ brief Advance
This module contains simulation methods.
subroutine, public store_error(msg, terminate)
Store an error message.
integer(i4b) function, public count_errors()
Return number of errors.
subroutine, public store_error_unit(iunit, terminate)
Store the file unit number.
This module contains simulation variables.
character(len=maxcharlen) errmsg
error message string
Derived type for MvrType.