!----- AGPL --------------------------------------------------------------------
!
! Copyright (C) Stichting Deltares, 2015.
!
! This file is part of Delft3D (D-Flow Flexible Mesh component).
!
! Delft3D is free software: you can redistribute it and/or modify
! it under the terms of the GNU Affero General Public License as
! published by the Free Software Foundation version 3.
!
! Delft3D is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU Affero General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License
! along with Delft3D. If not, see .
!
! contact: delft3d.support@deltares.nl
! Stichting Deltares
! P.O. Box 177
! 2600 MH Delft, The Netherlands
!
! All indications and logos of, and references to, "Delft3D",
! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting
! Deltares, and remain the property of Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
! $Id: unstruc.F90 43424 2015-12-04 17:30:45Z kernkam $
! $HeadURL: https://repos.deltares.nl/repos/ds/trunk/additional/unstruc/src/unstruc.F90 $
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
! todo: na u1 substitutie checken of hu van de correcte kant kwam. Zo niet, setback en opnieuw
! todo: check if 1 loop may be saved in tridiag u1q1
! todo: turkin, tureps en vicwwu naar boven toe doorzetten bij weer nat maken
! todo, wcxyl op randen is niet goed doordat acl op randen niet goed is doordat meteomodule niet werkt met xz,yz in gespiegelde
! binnencelpunten. graag goed zetten
subroutine inctime_user()
use m_flowtimes
use m_flowexternalforcings, only: nbndz, zbndz
implicit none
if (time1 >= time_user) then
! If not, current time_user was not yet reached (user interrupt in interface)
time_user = time_user + dt_user !
! time_user = max(time_user, time1) ! safety for now only, until sobektimestepping is introduced
time_user = min(time_user,tstop_user)
dnt_user = dnt_user + 1 ! todo from, to
end if
end subroutine inctime_user
!> Increase the time_user with a delta t
!! Called from API.
subroutine inctime_user_dt(dt)
use m_flowtimes
implicit none
double precision, intent(in) :: dt !< increase time_user with delta t (dt)
! If not, current time_user was not yet reached (user interrupt in interface)
time_user = time_user + dt !
! time_user = max(time_user, time1) ! safety for now only, until sobektimestepping is introduced
dnt_user = dnt_user + 1 ! todo from, to
end subroutine inctime_user_dt
subroutine flow_spatietimestep() ! do 1 flowstep
use m_flowtimes
use m_flowgeom, only: ndx
use m_flowexternalforcings, only: nbndz, zbndz
implicit none
integer :: key, ierr
integer :: i
integer, external :: flow_modelinit
if (ndx == 0) then
ierr = flow_modelinit()
end if
if (ndx == 0) return ! No valid flow network was initialized
call inctime_user()
if (time0 >= time_user) then
Tstop_user = tstop_user + dt_user
time_user = time_user + dt_user
endif
! ipv time0
call flow_setexternalforcings(time_user,.false., ierr) ! set field oriented forcings. boundary oriented forcings are in
call flow_externalinput(time_user) ! receive RTC signals etc
call flow_single_timestep(key, ierr)
call updateValuesOnObervationStations()
call flow_externaloutput(time1) ! receive signals etc, write map, his etc
! these two functions are explicit. therefore, they are in the usertimestep
end subroutine flow_spatietimestep
!> Runs flow steps for a certain period (do computational flowsteps for as long as timeinterval dtrange).
subroutine flow_run_sometimesteps(dtrange, iresult) ! do computational flowsteps for as long as timeinterval dtrange
use m_flowtimes
use unstruc_messages
use m_partitioninfo
use unstruc_display, only: jaGUI
use dfm_error
implicit none
double precision, intent(in) :: dtrange
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
integer :: key
double precision :: timetarget
iresult = DFM_GENERICERROR
if (dtrange < 0) then
timetarget = time1 + epsilon(1d0) ! dtrange < 0 means: auto pick a *single* timestep. Enforce this with a target time *just* larger than current time.
else
timetarget = time1 + dtrange
end if
timetarget = min(timetarget, tstop_user)
do while (time1 < timetarget) ! nb, outside flow_singletimestep, time0=time1 !
!! INIT only in case of new user timestep
if (time1 >= time_user) then
call flow_init_usertimestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
end if
!! RUN actual SINGLE computational timestep
call flow_single_timestep(key, iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
!! FINALIZE only when a time_user is finished
if (time1 >= time_user) then
call flow_finalize_usertimestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
end if
enddo
iresult = DFM_NOERR
return ! Return with success.
888 continue
end subroutine flow_run_sometimesteps
!> A complete single user time step (init-run-finalize).
subroutine flow_usertimestep(key, iresult) ! do computational flowsteps until timeuser
use m_flowtimes
use unstruc_messages
use m_partitioninfo
use unstruc_display, only: jaGUI
use m_timer
use dfm_error
implicit none
integer, intent(out) :: key !< Key number if any key was pressed in GUI.
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
iresult = DFM_GENERICERROR
key = 0
call flow_init_usertimestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
call flow_run_usertimestep(key, iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
call flow_finalize_usertimestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
iresult = DFM_NOERR
return ! Return with success.
888 continue
end subroutine flow_usertimestep
!> Initializes a new user-timestep (advances user time, sets new meteo forcing)
!!
!! Should be followed by a flow_run_usertimestep and a flow_finalize_usertimestep.
subroutine flow_init_usertimestep(iresult)
use m_flowtimes
use dfm_error
implicit none
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
iresult = DFM_GENERICERROR
call inctime_user()
call flow_setexternalforcings(time_user,.false., iresult) ! set field oriented forcings. boundary oriented forcings are in
if (iresult /= DFM_NOERR) then
goto 888
end if
call flow_externalinput (time_user) ! receive signals etc
iresult = DFM_NOERR
return ! Return with success.
888 continue
end subroutine flow_init_usertimestep
!> Runs a user-timestep (do computational flowsteps until timeuser), but not the init and finalize.
!!
!! Should be preceded by a flow_run_usertimestep and followed by a flow_finalize_usertimestep.
subroutine flow_run_usertimestep(key, iresult) ! do computational flowsteps until timeuser
use m_flowtimes
use unstruc_messages
use m_partitioninfo
use unstruc_display, only: jaGUI
use dfm_error
implicit none
integer, intent(out) :: key
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
key = 0
iresult = DFM_GENERICERROR
do while (time0 < time_user) ! nb, outside flow_singletimestep, time0=time1 !
call flow_single_timestep(key, iresult)
if (iresult /= DFM_NOERR .and. iresult /= DFM_TIMESETBACK) then
goto 888
end if
if ( jaGUI.eq.1 ) then
call get_s_key(key)
if ( jampi.eq.1 ) then
call reduce_key(key)
end if
if (key == 1 ) then
call mess(LEVEL_INFO, 'User interrupt')
iresult = DFM_NOERR
return
end if
end if
enddo
iresult = DFM_NOERR
return ! Return with success.
888 continue
end subroutine flow_run_usertimestep
!> Finalizes the current user-timestep (monitoring and I/O).
!!
!! Should be called directly after a flow_run_usertimestep.
subroutine flow_finalize_usertimestep(iresult)
use m_flowtimes
use m_timer
use m_flow
use m_flowgeom
use m_transport, only: constituents, numconst, const_names
use m_fourier_analysis
use dfm_error
use unstruc_files, only: defaultFilename, getoutputdir
implicit none
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
double precision, pointer, dimension(:,:) :: s1_ptr, u1_ptr,ucx_ptr, ucy_ptr,taus_ptr,bl_ptr
double precision, pointer, dimension(:,:) :: xs_ptr, ys_ptr, xu_ptr, yu_ptr
integer, pointer, dimension(:,:) :: kfs_ptr,kfst0_ptr
double precision, pointer, dimension(:,:,:) :: const_ptr
character(len=255) :: filename_fou_out
iresult = DFM_GENERICERROR
if (time1 >= time_user-1d-5) then
if (time1 <= time_user+1d-5) then
time1 = time_user
time0 = time1
endif
if ( jatimer.eq.1 ) call starttimer(IOUTPUT)
! only update values at the observation stations when necessary
! alternative: move this to flow_externaloutput
if (ti_his > 0) then
if (time1 >= time_his) then
call updateValuesOnObervationStations()
end if
end if
call flow_externaloutput(time1)
if ( jatimer.eq.1 ) call stoptimer(IOUTPUT)
end if
filename_fou_out = defaultFilename('fou')
if (gdfourier%nofouvar>0) then
s1_ptr(1:ndx,1:1) => s1
u1_ptr(1:lnkx,1:1) => u1
ucx_ptr(1:ndkx,1:1) => ucx
ucy_ptr(1:ndkx,1:1) => ucy
const_ptr(1:NUMCONST,1:ndkx,1:1) => constituents
taus_ptr(1:ndxi,1:1) => taus
bl_ptr(1:ndx,1:1) => bl
kfs_ptr(1:ndx,1:1) => kfs
kfst0_ptr(1:ndx,1:1) => kfst0
gdfourier_ptr => gdfourier
gddimens_ptr => gddimens
call postpr_fourier(s1_ptr,u1_ptr,ucx_ptr,ucy_ptr,const_ptr,taus_ptr,kfs_ptr,kfst0_ptr,bl_ptr, &
& nint(time0/dt_user), &
& trim(getoutputdir())//trim(filename_fou_out),dt_user,filename_fou_out,const_names, &
& refdat,0.5d0*dt_user, &
& Tzone, xz, yz, xu, yu, gdfourier_ptr, gddimens_ptr)
endif
iresult = DFM_NOERR
return ! Return with success.
888 continue
end subroutine flow_finalize_usertimestep
!> A complete single computational time step (init-perform-finalize).
subroutine flow_single_timestep(key, iresult) ! do only 1 flow timestep
use m_flow
use m_flowgeom
use m_flowtimes
use unstruc_model, only : jawritebalancefile
use unstruc_netcdf
use m_timer
use unstruc_display, only : jaGUI
use dfm_error
implicit none
integer :: key
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
integer :: N, L
iresult = DFM_GENERICERROR
! double precision :: t
! call checkspeed(t)
call flow_init_single_timestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
call flow_run_single_timestep(key, iresult)
if (iresult /= DFM_NOERR .and. iresult /= DFM_TIMESETBACK) then
goto 888
end if
call flow_finalize_single_timestep(iresult)
if (iresult /= DFM_NOERR) then
goto 888
end if
iresult = DFM_NOERR
return ! Return with success
888 continue
! Error
end subroutine flow_single_timestep
!> Initializes a single computational timestep, call this prior to flow_perform_single_timestep.
subroutine flow_init_single_timestep(iresult)
use m_flow
use m_flowgeom
use m_flowtimes
use m_timer
use dfm_error
implicit none
integer :: key
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful.
integer :: N, L
iresult = DFM_GENERICERROR
if (lnx == 0) then
iresult = DFM_MODELNOTINITIALIZED
goto 888
end if
call klok(cpusteps(1))
if ( jatimer.eq.1 ) call starttimer(ITIMESTEP)
call flow_initimestep(0, iresult) ! initialise timestep
if (iresult /= DFM_NOERR) then
goto 888
end if
iresult = DFM_NOERR
return ! Return with success
888 continue
! Error
end subroutine flow_init_single_timestep
!> Performs a single computational timestep, but not the init and finalize of the timestep.
subroutine flow_run_single_timestep(key, iresult) ! do only 1 flow timestep
use m_flow
use m_flowgeom
use m_flowtimes
use unstruc_model, only : jawritebalancefile
use unstruc_netcdf
use m_timer
use unstruc_display, only : jaGUI
use dfm_error
implicit none
integer :: key
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if successful. DFM_TIMESETBACK if succesful, but with timestep setbacks.
integer :: N, L
iresult = DFM_GENERICERROR
if (itstep >= 2) then
call step_reduce(key) ! set a computational timestep implicit, reduce, elim conj grad substi
if (dsetb > 0) then
iresult = DFM_TIMESETBACK ! Warning about setbacks, but don't return directly, continue function normally
end if
else
call velocities_explicit() ! progress without pressure coupling
call transport() ! progress without pressure coupling
time1 = time0 + dts ! progress without pressure coupling
endif
! Finalize timestep code used to be here, now flow_finalize_single_timestep()
call klok(cpusteps(2)) ; cpusteps(3) = cpusteps(3) + cpusteps(2) - cpusteps(1)
! Finalize timestep code used to be here, now flow_finalize_single_timestep()
if (iresult /= DFM_TIMESETBACK) then
iresult = DFM_NOERR
end if
return ! Return with success
888 continue
! Error
end subroutine flow_run_single_timestep
!> Finalizes a single time step, should be called directly after flow_run_single_timestep
subroutine flow_finalize_single_timestep(iresult)
use m_flow
use m_flowgeom
use m_flowtimes
use unstruc_model, only : jawritebalancefile
use unstruc_netcdf
use m_timer
use unstruc_display, only : jaGUI
use dfm_error
use dfm_signals
implicit none
integer, intent(out) :: iresult
! Timestep has been performed, now finalize it.
call flow_f0isf1() ! mass balance and vol0 = vol1
call structure_parameters
dnt = dnt + 1
time0 = time1 ! idem
dtprev = dts ! save previous timestep
if ( jatimer.eq.1 ) then ! TODO: AvD: consider moving timers to flow_perform_*
call stoptimer(ITIMESTEP)
numtsteps = numtsteps + 1
end if
! call wriinc(time1)
call updateValuesOnCrossSections(time1) ! Compute sum values across cross sections.
! note updateValuesOnObervationStations() in flow_usertimestep
if (jawritebalancefile == 1) then
call wribal()
endif
if ( jaGUI.eq.1 ) then
call TEXTFLOW()
end if
iresult = dfm_check_signals() ! Abort when Ctrl-C was pressed
if (iresult /= DFM_NOERR) goto 888
if (validateon) then
call flow_validatestate(iresult) ! abort when the solution becomes unphysical
endif
validateon = .true.
if (iresult /= DFM_NOERR) goto 888
888 continue
end subroutine flow_finalize_single_timestep
subroutine velocities_explicit()
use m_flowgeom
use m_flow
use m_flowtimes
implicit none
integer :: n, L, LL, k1, k2
if (itstep == 1) then
u1 = (u0 - dts*adve)/(1d0 + dts*advi)
do n = 1, nbndu ! boundaries at u points
L = kbndu(3,n)
u1(L) = zbndu(n)
end do
endif
q1 = u1*au
squ = 0d0 ; sqi = 0d0
if ( kmx.eq.0 ) then
do L = 1,lnx
if (q1(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k1) = squ(k1) + q1(L)
sqi(k2) = sqi(k2) + q1(L)
else if (q1(L) < 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k2) = squ(k2) - q1(L)
sqi(k1) = sqi(k1) - q1(L)
endif
enddo
else
do LL = 1,lnx
do L=Lbot(LL),Ltop(LL)
if (q1(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k1) = squ(k1) + q1(L)
sqi(k2) = sqi(k2) + q1(L)
else if (q1(L) < 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k2) = squ(k2) - q1(L)
sqi(k1) = sqi(k1) - q1(L)
endif
end do
enddo
end if
end subroutine velocities_explicit
subroutine flow_initimestep(jazws0, iresult) ! intialise flow timestep, also called once after flowinit
use m_flowtimes
use m_flow
use m_flowgeom
use unstruc_model, only: md_ident
use m_xbeach_data, only: swave, Lwave, uin, vin, cgwav
use dfm_error
implicit none
integer :: jazws0
integer, intent(out) :: iresult !< Error status, DFM_NOERR==0 if succesful.
integer :: k, n, LL
iresult = DFM_GENERICERROR
call klok(cpuinistep(1))
if (jazws0.eq.0) s0 = s1 ! progress water levels
call bathyupdate() ! only if jamorf == 1
hs = s1 - bl ! total water height
call setsigmabnds() ! our side of preparation for 3D ec module
call flow_setexternalforcingsonboundaries( max(tim1bnd, time0+dts ), iresult) ! boundary forcings
if (iresult /= DFM_NOERR) then
goto 888
end if
tim1bnd = time0+dts
if (tlfsmo > 0d0 ) then
alfsmo = (tim1bnd - tstart_user) / tlfsmo
endif
! apply XBeach wave boundary conditions
if (jawave .eq. 4) then
if ( swave.eq.1 ) then
call xbeach_wave_bc()
call xbeach_apply_wave_bc()
call xbeach_wave_compute_celerities()
else
uin = 0d0
vin = 0d0
endif
call xbeach_flow_bc()
end if
if (jazws0.eq.0) u0 = u1 ! progress velocities
advi = 0d0
adve = 0d0
if (jaorgsethu == 0) call setumod() ! set cell center velocities, falsely here from 2012 orso to 2014
call sethu(jazws0)
call setau() ! set au after limited h upwind at u points
if (jaorgsethu == 1) call setumod() ! set cell center velocities, should be here as prior to 2012 orso
call setcfuhi() ! set friction- and other time varying coefficients
! TIDAL TURBINES: Insert equivalent calls to updturbine and applyturbines here
if (jazws0.eq.0) then
call setdt() ! set computational timestep dt based on active hu's,
end if
call advecdriver() ! advec limiting for depths below chkadvdp, so should be called after all source terms such as spiralforce
if (jazws0.eq.1) then
call makeq1qaAtStart() ! compute q1 and qa to ensure exact restart
call setkfs()
endif
call klok(cpuinistep(2)) ; cpuinistep(3) = cpuinistep(3) + cpuinistep(2) - cpuinistep(1)
iresult = DFM_NOERR
return ! Return with success
888 continue
! Error
end subroutine flow_initimestep
!> Validates the current flow state and returns whether simulation should be aborted.
!! Moreover, a final snapshot is written into the output files before aborting.
!!
!! Validity is determined by s01max, u01max and dtminbreak.
subroutine flow_validatestate(iresult)
use unstruc_messages
use m_flow
use m_flowgeom
use m_flowparameters
use m_flowtimes
use dfm_error
implicit none
integer, intent(out) :: iresult ! validation result status
double precision :: dtavgwindow
integer :: i, q
iresult = DFM_NOERR
q = 0
if (s01max > 0) then ! water level validation
do i = 1,ndx
if(abs(s1(i) - s0(i)) > s01max) then
call mess(LEVEL_WARN,'water level change above threshold: (cell index, delta s[m]) = ', i, abs(s1(i) - s0(i)))
! TODO: UNST-725, once done, change the above back to LEVEL_ERROR
q = 1
exit
end if
end do
end if
if (u01max > 0) then ! velocity validation
do i = 1,lnx
if(abs(u1(i) - u0(i)) > u01max) then
call mess(LEVEL_ERROR,'velocity change above threshold: (flowlink index, delta u[m/s]) = ', i, abs(u1(i) - u0(i)))
! TODO: UNST-725, once done, change the above back to LEVEL_ERROR
q = 1
exit
end if
end do
end if
if (dtminbreak > 0) then ! smallest allowed timestep (in s), checked on a sliding average of several timesteps
! NOTE: this code below assumes that this routine is called once and exactly once every time step (i.e. in `dnt` rythm)
dtavgwindow = (time1 - tvalswindow(idtwindow_start)) / max(1d0, min(dble(NUMDTWINDOWSIZE), dnt))
if (dnt < dble(NUMDTWINDOWSIZE)) then
! First few time steps: just store all time1's until array is full
tvalswindow(int(dnt+1)) = time1
else
! Array is full already, overwrite the oldest element (i.e. at current idtwindow_start)
! and increment start index, cycling back to 1 if necessary.
tvalswindow(idtwindow_start) = time1
idtwindow_start = mod(idtwindow_start, NUMDTWINDOWSIZE) + 1
end if
! Now ready for the actual dtminbreak check, but only do that once we have
! at least done dnt > NUMDTWINDOWSIZE time steps, to prevent the initial
! spin-up period to cause unwanted simulation breaks.
if (dnt >= dble(NUMDTWINDOWSIZE) .and. dtavgwindow < dtminbreak) then
write (msgbuf, '(a,e11.4,a,e11.4,a)') 'Comp. time step average below treshold: ', dtavgwindow, ' < ', dtminbreak, '.'
call warn_flush() ! PENDING UNST-725, make this a warning instead of an error, because stopping will take place elsewhere in a clean way.
q = 1
end if
end if
if(q /= 0) then
call flow_externaloutput_direct() ! Last-minute save of emergency snapshot in map/his/rst
iresult = DFM_INVALIDSTATE
end if
end subroutine flow_validatestate
subroutine advecdriver()
use m_flowtimes
use m_flow
use m_flowgeom
implicit none
double precision :: dta, das, ds
integer :: L, k1, k2, k
double precision, allocatable :: adve0(:)
if (itstep == 3) then
if (.not. allocated(adve0) ) then
allocate(adve0(lnkx))
endif
dta = 0.7D0*dts/cflmx
das = dta/dts
do k = 1,2
adve = 0d0
call advec()
if (k == 1) then
adve0 = adve
endif
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
ds = ag*dxi(L)*(s0(k2) - s0(k1))
u1(L) = ( u1(L)*(1d0 - das) + u0(L)*das - dta*(adve(L) + ds) ) / (1d0 + dta*advi(L))
enddo
call setucxucyucxuucyu()
enddo
! adve = teta0*adve + (1d0-teta0)*adve0
! u1 = u0
else
call advec() ! advection term, must be called after set-umod and cell velocity updates
endif
call setextforcechkadvec() ! set external forcings and check explicit part adve
end subroutine advecdriver
subroutine makeq1qaAtStart()
use m_flow
use m_flowgeom
implicit none
integer :: L
do L = 1,lnx
if (hu(L) > 0) then
q1(L) = au(L)*( teta(L)*u1(L) + (1d0-teta(L))*u0(L) )
qa(L) = au(L)*u1(L)
else
q1(L) = 0
qa(L) = 0
endif
enddo
end subroutine makeq1qaAtStart
subroutine step_reduce(key) ! do a flow timestep dts guus, reduce once, then elimin conjugate grad substi
use m_flow ! when entering this subroutine, s1=s0, u1=u0, etc
use m_flowgeom
use m_sediment, only: stm_included
use m_flowtimes
use m_sferic
use m_wind
use m_reduce
use m_ship
use m_partitioninfo
use m_timer
use m_xbeach_data
use m_xbeach_netcdf
use MessageHandling
use m_timer
use m_sobekdfm
implicit none
integer :: key, LL
integer :: ja, k, ierror, n, kt, num
character (len=40) :: tex
double precision :: wave_tnow, wave_tstop, t0, t1
character(len=128) :: msg
!-----------------------------------------------------------------------------------------------
numnodneg = 0
111 continue
time1 = time0 + dts ! try to reach time1
dti = 1d0/dts
nums1it = 0
!call flow_setexternalforcingsonboundaries(time1) ! set boundary conditions for time that you attempt to reach, every step
! should formally be at this position if setbacks occur
! this may howver cause a problem for some boundary routines that do not
! allow for subsequent calls at decreasing time
! In that case put this in initimestep and accept non smooth bndc's
!-----------------------------------------------------------------------------------------------
if (nshiptxy > 0) then
call setship() ; ithull = 0
222 call setpressurehull()
endif
call furu() ! staat in s0
if ( itstep.ne.4 ) then ! non-explicit time-step
333 call s1ini() !
call pack_matrix()
!-----------------------------------------------------------------------------------------------
444 call s1nod() ! entry point for non-linear continuity
call solve_matrix(s1,ndx,itsol) ! solve s1
! synchronise all water-levels
if ( jampi.eq.1 ) then
if ( jaoverlap.eq.0 ) then
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
call update_ghosts(ITYPE_SALL, 1, Ndx, s1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
else
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
call update_ghosts(ITYPE_Snonoverlap, 1, Ndx, s1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
end if
end if
call poshcheck(key) ! s1 above local bottom? (return through key only for easier interactive)
if (key == 1) then
return ! go to user control, timestep too small
else if (key == 2 ) then
call setkfs()
if (jposhchk == 2 .or. jposhchk == 4) then ! redo without timestep reduction, setting hu=0 => 333 s1ini
goto 333
else
goto 111 ! redo with timestep reduction => 111 furu
endif
endif
else
s1 = s0
end if
!s1=s0
call volsur()
if (nonlin == 1) then
difmaxlev = 0d0 ; noddifmaxlev = 0
do k = 1,ndx
if ( abs(s1(k)-s00(k)) > difmaxlev ) then
difmaxlev = abs(s1(k)-s00(k))
noddifmaxlev = k
endif
s00(k) = s1(k)
enddo
nums1it = nums1it + 1
if (nums1it > 40) then
write(tex,*) difmaxlev
call gtext(tex,xz(noddifmaxlev), yz(noddifmaxlev), 40+nums1it)
difmaxlev = 0
call toemaar()
endif
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_double_max(difmaxlev)
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
if ( difmaxlev > epsmaxlev) then
ccr = ccrsav ! avoid redo s1ini, ccr is altered by solve
goto 444 ! standard non-lin iteration => 444 s1nod
endif
dnums1it = dnums1it + nums1it
endif
!-----------------------------------------------------------------------------------------------
! TODO: AvD: consider moving everything below to flow_finalize single_timestep?
call setkbotktop(0) ! bottom and top layer indices and new sigma distribution
call u1q1() ! the vertical flux qw depends on new sigma => after setkbotktop
call compute_q_total_1d2d()
if ( itstep.eq.4 ) then ! explicit time-step
call update_s_explicit()
end if
if (stm_included) then
call fm_erosed()
call fm_bott3d()
call setbobs()
end if
! secondary flow
if ( jasecf > 0 ) then
call get_curvature()
end if
!SPvdP: timestep is now based on u0, q0
! transport is with u1,q1 with timestep based on u0,q0
if ( jatimer.eq.1 ) call starttimer(ITRANSPORT)
call transport()
if ( jatimer.eq.1 ) call stoptimer (ITRANSPORT)
if (jawave == 4 .and. swave.eq.1 ) then
call klok(t0)
call xbeach_wave_compute_celerities()
! call xbeach_wave_maxtimestep() ! not here, in setdt
wave_tnow = time0
wave_tstop = time1
num = 0
do while (wave_tnow < wave_tstop)
num = num+1
call xbeach_wave_update_energy()
if (jaavgwavquant .eq. 1) then
call xbeach_makeaverages(dtmaxwav) ! time-averaged stats
end if
wave_tnow = wave_tnow + dtmaxwav
end do
call klok(t1)
msg = ''
write(msg, "('XBeach: elapsed time=', F7.4, ' s, number of substeps=', I5, ', my_rank=', I5)") t1-t0, num, my_rank
call mess(LEVEL_INFO, trim(msg))
endif
! Moved to flow_finalize_single_timestep: call flow_f0isf1() ! mass balance and vol0 = vol1
if (layertype > 1 .and. kmx.gt.0 ) then
ln = ln0 ! was ok.
endif
end subroutine step_reduce
subroutine update_s_explicit()
use m_flow
use m_flowgeom
use m_flowtimes
use m_partitioninfo
use m_timer
use m_sobekdfm
implicit none
double precision :: qwave
integer :: k, k1, k2, L
integer :: numchanged
integer :: iter, ierror
double precision, parameter :: dtol = 1d-16
!! check if upwinddirection has changed
! numchanged = 0
! do L=1,Lnx
! if ( u0(L)*u1(L).lt.-dtol ) then
! numchanged = numchanged+1
! end if
! end do
! if ( numchanged.gt.0 ) then
!! write(6,*) numchanged
! continue
! end if
! do iter=1,1
!
!! recompute hu
! call sethu(0)
!
!! recompute Au
! call setau()
!
!! recompute q1, qa (as in u1q1)
!!$OMP PARALLEL DO &
!!$OMP PRIVATE(L,k1,k2)
! do L=1,Lnx
! if ( hu(L).gt.0 ) then
! k1 = ln(1,L)
! k2 = ln(2,L)
! q1(L) = au(L)*u1(L)
! qa(L) = au(L)*u1(L)
! else
! q1(L) = 0d0
! qa(L) = 0
! end if
! end do
!!$OMP END PARALLEL DO
!
! do L = 1,lnx
!
! if (q1(L) > 0) then
! k1 = ln(1,L) ; k2 = ln(2,L)
! squ(k1) = squ(k1) + q1(L)
! sqi(k2) = sqi(k2) + q1(L)
! else if (q1(L) < 0) then
! k1 = ln(1,L) ; k2 = ln(2,L)
! squ(k2) = squ(k2) - q1(L)
! sqi(k1) = sqi(k1) - q1(L)
! endif
!
! enddo
!
! sq = sqi-squ
!
!
! sqwave = 0d0
! do L=1,Lnx
! k1 = ln(1,L); k2 = ln(2,L)
! qwave = 2d0*sqrt(hu(L)*ag)*Au(L) ! 2d0: safety
! sqwave(k1) = sqwave(k1) + max(q1(L)+qwave,0d0)
! sqwave(k2) = sqwave(k2) - min(q1(L)-qwave,0d0)
! end do
do k=1,Ndx
s1(k) = s0(k) + sq(k)*bai(k)*dts
end do
call sets01zbnd(1) ! expl
! synchronise all water-levels
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
call update_ghosts(ITYPE_SALL, 1, Ndx, s1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
end if
! end do
return
end subroutine update_s_explicit
subroutine poshcheck(key)
use m_flow ! when entering this subroutine, s1=s0, u1=u0, etc
use m_flowgeom
use m_flowtimes
use m_partitioninfo
use m_timer
use unstruc_display, only: jaGUI
implicit none
integer :: key
integer :: n, L, LL, LLL
integer, dimension(2) :: idum
Nodneg = 0 ; key = 0
if (jposhchk == 0) return
do n = 1,ndxi ! check result
if ( jampi.eq.1 ) then
! exclude ghost cells
if ( idomain(n).ne.my_rank ) cycle
end if
if (kfs(n) > 0) then
if ( s1(n) < bl(n) ) then
if ( s1(n) < bl(n) - 1d-10 ) then ! if ( s1(n) < bl(n) ) then
nodneg = n ; numnodneg = numnodneg + 1
if ( jaGUI.eq.1 ) then
call rcirc( xz(n), yz(n) )
end if
if (jposhchk == 1) then ! only timestep reduction
exit
else if (jposhchk == 2 .or. jposhchk == 3) then ! set dry all attached links
key = 2 ! flag redo setkfs
do LL = 1, nd(n)%lnx
L = iabs(nd(n)%ln(LL))
hu(L) = 0d0
enddo
else if (jposhchk == 4 .or. jposhchk == 5) then ! reduce links au
do LL = 1, nd(n)%lnx
LLL = nd(n)%ln(LL); L = iabs(LLL)
if (hu(L) > 0) then
au(L) = 0.2d0*au(L)
if (au(L) < eps6) then
hu(L) = 0d0 ; key = 2 ! flag redo setkfs
endif
endif
enddo
else if (jposhchk == 6 .or. jposhchk == 7) then ! only set dry outflowing links
do LL = 1, nd(n)%lnx
LLL = nd(n)%ln(LL); L = iabs(LLL)
if (LLL < 0 .and. u1(L) > 0 .or. &
LLL > 0 .and. u1(L) < 0 ) then
hu(L) = 0d0 ; key = 2 ! flag redo setkfs
endif
enddo
endif
endif
! s1(n) = bl(n)
endif
endif
enddo
if ( jampi.eq.1 ) then
! reduce nodneg and key
idum = (/ key, nodneg /)
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
! call reduce_key(key)
call reduce_int_max(2,idum)
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
key = idum(1)
nodneg = idum(2)
end if
if (nodneg /= 0) then
if (jposhchk == 1 .or. jposhchk == 3 .or. jposhchk == 5 .or. jposhchk == 7) then
dts = 0.7d0*dts
endif
dsetb = dsetb + 1 ! total nr of setbacks
s1 = s0
if (dts .lt. dtmin) then
s1 = max(s1,bl) ! above bottom
call okay(0)
key = 1 ! for easier mouse interrupt
endif
endif
end subroutine poshcheck
subroutine volsur() ! volsur entirely in s1 because of s1 iteration
use m_flowgeom
use m_flow
implicit none
! locals
integer :: japerim
integer :: L, n, k1, k2, k
double precision :: ha, hh
japerim = 0
!call sets01zbnd(1) ! set s1 on z-boundaries SPvdP: not necessary, values at the boundaries were already properly filled in solve_matrix, as the boundary nodes are included in the solution vector
if (nonlin2d == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(n,hh)
do n = 1,ndx2d
hh = max(0d0, s1(n)-bl(n) )
vol1(n) = ba(n)*hh
a1(n) = ba(n)
enddo
!$OMP END PARALLEL DO ! TODO OMP
else
nonlin = 1
vol1(1:ndx2d) = 0d0
a1 (1:ndx2d) = 0d0
endif
if (nonlin == 0) then
do n = ndx2d+1, ndxi
hh = max(0d0, s1(n)-bl(n) )
vol1(n) = ba(n)*hh
a1(n) = ba(n)
enddo
else
vol1(ndx2D+1:ndxi) = 0d0
a1 (ndx2D+1:ndxi) = 0d0
endif
call VOL12D(japerim) ! and add area's and volumes of 1D links
do L = lnxi+1,Lnx
a1 (ln(1,L)) = a1 (ln(2,L)) ! set bnd a1 to that of inside point
vol1(ln(1,L)) = vol1(ln(2,L))
enddo
end subroutine volsur
subroutine addlink1D(L,japerim) ! and add area's and volumes of 1D links
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: japerim, L, ja
integer :: k1, k2, K
double precision :: ar1, wid1, cf1, ar2, wid2, cf2, dx1, dx2, widu
double precision :: hpr
k1 = ln(1,L) ; k2 = ln(2,L)
if (japerim == 0) then
if (nonlin == 1 ) then ! this statement is called most nr of times through waterlevel iteration
hpr = max(0d0,s1(k1)-bob(1,L))
if (hpr > 0) then !
call getprof_1D(L, hpr, ar1, wid1, japerim)
dx1 = dx(L)*acl(L)
a1(k1) = a1(k1) + dx1*wid1
vol1(k1) = vol1(k1) + dx1*ar1
endif
hpr = max(0d0,s1(k2)-bob(2,L))
if (hpr > 0) then !
call getprof_1D(L, hpr, ar2, wid2, japerim)
dx2 = dx(L)*(1d0-acl(L))
a1(k2) = a1(k2) + dx2*wid2
vol1(k2) = vol1(k2) + dx2*ar2
endif
endif
else if (hu(L) > 0) then
call getprof_1D(L, hu(L), au(L), widu, japerim) ! memory closeness of profiles causes this statement here instead of in setau
! getprof1D sets cfu
endif
end subroutine addlink1D
subroutine addlink1D2D(L,japerim) ! and add area's and volumes of 1D2D links
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: japerim, L
integer :: k1, k2, k3, k4, K, jaconv, jaconvu,ifrctyp
double precision :: hpr1, ar1, wid1, aconv1, hpr2, ar2, wid2, aconv2, aru, widu, aconvu
double precision :: dx1, dx2, frcn, BL1, BL2, b21, wu2, ai
double precision :: beta, bt2, deltaa,hyr, uucn, ucna
k1 = ln(1,L) ; k2 = ln(2,L)
if (bob(1,L) < bob(2,L)) then
BL1 = bob(1,L); BL2 = bob(2,L)
else
BL1 = bob(2,L); BL2 = bob(1,L)
endif
wu2 = wu(L)
b21 = BL2 - BL1
ai = b21/wu2
if (japerim == 0) then
if (nonlin == 1) then
jaconv = 0
hpr1 = s1(k1)-BL1 ! == 1,2: (ibedlevtyp=3), hrad = A/P , link or node
if (hpr1 > 0) then
CALL getprof2d(hpr1,wu2,b21,ai,frcn,ifrctyp, wid1,ar1,aconv1,jaconv, beta, deltaa,hyr) ! == 3,4: (ibedlevtyp=3), 1D conveyance, link or node
dx1 = 0.5d0*dx(L)*acl(L)
if (k1 > ndx2D) dx1 = 2*dx1
a1(k1) = a1(k1) + dx1*wid1
vol1(k1) = vol1(k1) + dx1*ar1
endif
hpr2 = s1(k2)-BL1 ! == 5,6: (ibedlevtyp=3), 2D conveyance, link or node
if (hpr2 > 0) then
CALL getprof2d(hpr2,wu2,b21,ai,frcn,ifrctyp, wid2,ar2,aconv2,jaconv, beta, deltaa,hyr)
dx2 = 0.5d0*dx(L)*(1d0-acl(L))
if (k2 > ndx2D) dx2 = 2*dx2
a1(k2) = a1(k2) + dx2*wid2
vol1(k2) = vol1(k2) + dx2*ar2
endif
endif
else if (hu(L) > 0d0) then
hpr1 = hu(L)
if (jaconveyance2D > 0) then
jaconv = min(2,jaconveyance2D)
frcn = frcu(L) ; ifrctyp = ifrcutp(L)
CALL getprof2d(hpr1,wu2,b21,ai,frcn,ifrctyp, widu,aru,aconvu,jaconv, beta, deltaa,hyr)
if (frcn > 0) then
cfuhi(L) = aifu(L)*ag*aconvu
else
cfuhi(L) = 0d0
endif
au(L) = aru
else
au(L) = hpr1*wu(L)
endif
endif
end subroutine addlink1D2D
subroutine addlink2D(L,japerim) ! and add area's and volumes of 1D links
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: japerim, L
integer :: k1, k2, k3, k4, K, jaconv, jaconvu, ifrctyp
double precision :: hpr1, ar1, wid1, aconv1, hpr2, ar2, wid2, aconv2, aru, widu, aconvu
double precision :: dx1, dx2, frcn, BL1, BL2, b21, wu2, ai
double precision :: beta, bt2, deltaa, hyr, uucn, ucna, bob1, bob2, bb1, hsmall
double precision :: ditcharea, ditchw, ditchconv, Cz, convu
if (japerim == 0) then
if (nonlin2D > 0) then
bob1 = bob(1,L) ; bob2 = bob(2,L)
if (bob1 < bob2) then
BL1 = bob1 ; BL2 = bob2
else
BL1 = bob2 ; BL2 = bob1
endif
wu2 = wu(L) ; b21 = BL2 - BL1 ; ai = b21/wu2
k1 = ln(1,L) ; k2 = ln(2,L)
jaconv = 0
if (nonlin2D == 1) then ! default
hpr1 = s1(k1)-BL1
if (hpr1 > 0) then
call getlinkareawid2D(L,wu2,b21,ai,hpr1,ar1,wid1)
dx1 = 0.5d0*dx(L)*acl(L)
a1(k1) = a1(k1) + dx1*wid1
vol1(k1) = vol1(k1) + dx1*ar1
endif
hpr2 = s1(k2)-BL1 ! == 5,6: (ibedlevtyp=3), 2D conveyance, link or node
if (hpr2 > 0) then
call getlinkareawid2D(L,wu2,b21,ai,hpr2,ar2,wid2)
dx2 = 0.5d0*dx(L)*(1d0-acl(L))
a1(k2) = a1(k2) + dx2*wid2
vol1(k2) = vol1(k2) + dx2*ar2
endif
else if (nonlin2D == 2) then
if (u1(L) > 0d0) then
hpr1 = s1(k1) - BL1
else if (u1(L) < 0d0) then
hpr1 = s1(k2) - BL1
else if (s1(k1) > s1(k2) ) then
hpr1 = s1(k1) - BL1
else
hpr1 = s1(k2) - BL1
endif
if (hpr1 > 0) then
call getlinkareawid2D(L,wu2,b21,ai,hpr1,ar1,wid1)
dx1 = 0.5d0*dx(L)*acl(L)
a1(k1) = a1(k1) + dx1*wid1
vol1(k1) = vol1(k1) + dx1*ar1
dx2 = 0.5d0*dx(L)*(1d0-acl(L))
a1(k2) = a1(k2) + dx2*wid1
vol1(k2) = vol1(k2) + dx2*ar1
endif
else if (nonlin2D == 3) then
hpr1 = acl(L)*s1(k1) + (1d0-acl(L))*s1(k2)
if (hpr1 > 0) then
call getlinkareawid2D(L,wu2,b21,ai,hpr1,ar1,wid1)
dx1 = 0.5d0*dx(L)*acl(L)
a1(k1) = a1(k1) + dx1*wid1
vol1(k1) = vol1(k1) + dx1*ar1
dx2 = 0.5d0*dx(L)*(1d0-acl(L))
a1(k2) = a1(k2) + dx2*wid1
vol1(k2) = vol1(k2) + dx2*ar1
endif
endif
endif
else if (hu(L) > 0d0) then
bob1 = bob(1,L) ; bob2 = bob(2,L)
if (bob1 < bob2) then
BL1 = bob1 ; BL2 = bob2
else
BL1 = bob2 ; BL2 = bob1
endif
wu2 = wu(L)
b21 = BL2 - BL1 ; ai = b21/wu2
k1 = ln(1,L) ; k2 = ln(2,L)
hpr1 = hu(L)
if (jaconveyance2D > 0) then
frcn = frcu(L) ; ifrctyp = ifrcutp(L)
jaconv = jaconveyance2D
if (jaconv >= 3) then !> see sysdoc5, 2D conveyance approach I , II
if (bob(1,L) < bob(2,L)) then
k3 = lncn(1,L) ; k4 = lncn(2,L)
else
k3 = lncn(2,L) ; k4 = lncn(1,L)
endif
!bb1 = sign(1d0, bob(2,L) - bob(1,L) ) ! faster coding?
!k3 = lncn(1,L)*bb1 + lncn(2,L)*(1d0-bb1)
!k4 = lncn(2,L)*bb1 + lncn(1,L)*(1d0-bb1)
if (jaconv == 4) then
hsmall = BL1 + hpr1 - BL2 ! depth at shallow side
if ( hsmall/hpr1 > 0.9d0) then
jaconv = 1 ! Hydr rad
endif
endif
if (jaconv >= 3) then
uucn = abs ( ucnx(k3)*csu(L) + ucny(k3)*snu(L))
ucna = ( ucnx(k3)**2 + ucny(k3)**2 )
if (ucna > 0d0 .and. uucn > 0d0) then
ucna = sqrt( ucna )
beta = sqrt( uucn / ucna )
if (beta > 0.97d0) then
beta = 1d0
endif
else
beta = 1d0 ! do simple hydraulic radius approach
endif
uucn = abs ( ucnx(k4)*csu(L) + ucny(k4)*snu(L))
ucna = ( ucnx(k4)**2 + ucny(k4)**2 )
if (ucna > 0d0 .and. uucn > 0d0) then
ucna = sqrt( ucna)
bt2 = sqrt( uucn / ucna )
if (bt2 > 0.97d0) then
bt2 = 1d0
endif
else
bt2 = 1d0
endif
deltaa = (beta - bt2) / wu2
if (jaconv == 4) then
if (beta == 1d0 .and. bt2 == 1d0) then
jaconv = 2
endif
endif
endif
endif
CALL getprof2d(hpr1,wu2,b21,ai,frcn,ifrctyp, widu,aru,aconvu,jaconv, beta, deltaa,hyr)
if (frcn > 0) then
cfuhi(L) = aifu(L)*ag*aconvu
else
cfuhi(L) = 0d0
endif
au(L) = aru
else
au(L) = hpr1*wu(L)
endif
endif
end subroutine addlink2D
subroutine getlinkareawid2D(L,wu2,dz,ai,hpr,ar,wid)
use m_flow, only : slotw2D
implicit none
integer , intent(in ) :: L
double precision, intent(in ) :: wu2,dz,ai,hpr
double precision, intent(out) :: ar,wid
double precision :: hp2
if (ai < 1d-3) then
wid = wu2 ; wid = wid + slotw2D
ar = wid * hpr
else if (hpr < dz) then
wid = wu2 * hpr / dz ; wid = wid + slotw2D
ar = 0.5d0*wid*hpr
else
wid = wu2 ; wid = wid + slotw2D
hp2 = hpr - dz
ar = wid*0.5d0*(hpr + hp2)
endif
end subroutine getlinkareawid2D
subroutine getprof2D( hpr,wu2,dz,ai,frcn,ifrctyp, wid,ar,aconv,jaconv,beta,deltaa,hyr)
use m_flow, only : slotw2D
implicit none
double precision, intent (in) :: hpr,wu2,dz,ai,frcn
double precision, intent (out) :: wid,ar,aconv ! aconv = (a/conv)**2
integer, intent (in) :: ifrctyp, jaconv
double precision :: d83 = 2.666666d0, d16 = 0.166666d0 , d23 = 0.666666d0, d43= 1.333333d0
double precision :: tt, hp2, hrad, Cz, cman, per, hyr, hav, conv, beta, deltaa
double precision :: d38 = 0.375d0 , d113 = 3.666666d0 , d311 = 0.27272727d0, hpr83, hp283
integer :: jac
! for jaconv >= 1, this routine gets conveyance, but without friction surface to horizontal plane surface ratio influence on conveyance
! this constant value, (1+(dz/dy)**2)**0.25 is computed once and is volume cell based instead of link based
! Aconv = (A/K)**2 = 1/(C.C.R), K=Conv=sum(ACsqrt(R))
if (ai < 1d-3) then
wid = wu2 ; wid = wid + slotw2D ! wid = max(wid, slotw2d)
ar = wid * hpr
hyr = hpr
else if (hpr < dz) then
wid = wu2 * hpr / dz ; wid = wid + slotw2D ! wid = max(wid, slotw2d)
ar = 0.5d0*wid*hpr
if (jaconv == 1) then
per = sqrt(hpr*hpr + wid*wid)
hyr = ar/per
endif
else
wid = wu2 ; wid = wid + slotw2D ! wid = max(wid, slotw2d)
hp2 = hpr - dz
ar = wid*0.5d0*(hpr + hp2)
if (jaconv == 1) then
per = sqrt(dz*dz + wid*wid)
hyr = ar/per
endif
endif
if (jaconv == 0) then
return
else if (frcn == 0d0) then
aconv = 0d0 ; return
else if (jaconv == 1) then ! hydraulic radius type
call getcz(hyr, frcn, ifrctyp, Cz)
aconv = 1d0/ (Cz*Cz*hyr)
else if (jaconv >= 2) then ! 1D analytic conveyance type
if (ifrctyp == 1) then
cman = frcn
else
if (ai < 1d-3) then
hav = hpr
else if (hpr < dz) then
hav = 0.5d0*hpr
else
hav = hpr -0.5d0*dz
endif
call getcz(hav, frcn, ifrctyp, Cz)
cman = hav**d16/Cz
endif
jac = jaconv
if (jaconv == 3 .and. beta == 0d0) jac = 2
if (jac == 2) then
if (ai < 1d-3 ) then ! see sysdoc 5 1D conveyance
aconv = (cman/hpr**d23)**2
else if (hpr < dz) then
aconv = (d43*cman/hpr**d23)**2
else
aconv = (d43*cman*(hpr*hpr - hp2*hp2)/(hpr**d83-hp2**d83) )**2
endif
else
if (ai < 1d-3 ) then ! see sysdoc 5 2D conveyance
aconv = (cman / (beta*hpr**d23) )**2
else if (hpr < dz) then
hpr83 = hpr**d83
conv = ( beta - hpr*deltaa/ai ) * d38 * hpr83 + (deltaa*d311/ai)*hpr*hpr83
conv = conv / ai
aconv = (cman*ar/conv)**2
else
hpr83 = hpr**d83; hp283 = hp2**d83
conv = ( beta - hpr*deltaa/ai ) * d38 * (hpr83 - hp283) + (deltaa*d311/ai)*(hpr*hpr83 - hp2*hp283)
conv = conv / ai
aconv = (cman*ar/conv)**2
endif
endif
endif
end subroutine getprof2D
subroutine fixedweirfriction2D(L,k1,k2,frL) ! frL of fixed weir
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: L
double precision :: frL
integer :: k1, k2
double precision :: umod, uin, frLk1, frLk2, ucxk, ucyk, Cz, weirheight, weirlength, flatlength, a, b, ff
if (frcu(L) == 0 .or. hu(L) < epshu) then
frL = 0d0 ; return
endif
if (fixedweirtopfrictcoef .ne. dmiss) then ! standard friction on weirtop only
call getcz(hu(L), fixedweirtopfrictcoef, ifrcutp(L), Cz)
else
call getcz(hu(L), frcu(L), ifrcutp(L), Cz)
endif
umod = sqrt( u1(L)*u1(L) + v(L)*v(L) )
frL = umod*ag / (Cz*Cz*hu(L)) ! on top of weir
frLk1 = frL ! on side 1
frLk2 = frL ! on side 2
weirheight = max(0d0, 0.5d0*(bob(1,L) + bob(2,L)) - 0.5d0*(bl(k1) + bl(k2)) )
weirlength = fixedweirtopwidth
flatlength = max(weirlength , dx(L) - (weirlength + 2d0*weirheight/fixedweirtalud) )
a = weirlength / (weirlength + flatlength) ; b = 1d0 - a
if (ifxedweirfrictscheme == 1) then ! simple bedlevel&velocity
! assumption + direct linearisation
if (hs(k1) > 0d0) then
ff = min(1d0, hu(L)/hs(k1) )
umod = sqrt( u1(L)*u1(L)*ff*ff + v(L)*v(L) )
call getcz(hs(k1), frcu(L), ifrcutp(L), Cz)
frLk1 = umod*ff*ag / (Cz*Cz*hs(k1))
endif
if (hs(k2) > 0d0) then
ff = min(1d0, hu(L)/hs(k2) )
umod = sqrt( u1(L)*u1(L)*ff*ff + v(L)*v(L) )
call getcz(hs(k2), frcu(L), ifrcutp(L), Cz)
frLk2 = umod*ff*ag / (Cz*Cz*hs(k2))
endif
frL = a*frL + b*( (frLk1+frLk2)*0.5d0 )
else if (ifxedweirfrictscheme == 2) then ! Without weir like WAQUA
if (hs(k1) > 0d0) then
ff = min(1d0, hu(L)/hs(k1) )
umod = sqrt( u1(L)*u1(L)*ff*ff + v(L)*v(L) )
call getcz(hs(k1), frcu(L), ifrcutp(L), Cz)
frLk1 = umod*ff*ag / (Cz*Cz*hs(k1))
endif
if (hs(k2) > 0d0) then
ff = min(1d0, hu(L)/hs(k2) )
umod = sqrt( u1(L)*u1(L)*ff*ff + v(L)*v(L) )
call getcz(hs(k2), frcu(L), ifrcutp(L), Cz)
frLk2 = umod*ff*ag / (Cz*Cz*hs(k2))
endif
frL = (frLk1+frLk2)*0.5d0
else if (ifxedweirfrictscheme == 3) then ! full undisturbed velocity reconstruction
if (abs(u1(L)) > 0.1d0) then
if (hs(k1) > 0d0) then
call getucxucynoweirs(k1, ucxk, ucyk, ifixedweirscheme )
umod = sqrt(ucxk*ucxk + ucyk*ucyk)
uin = abs( ucxk*csu(L) + ucyk*snu(L) )
call getcz(hs(k1), frcu(L), ifrcutp(L), Cz)
frLk1 = umod*uin*ag / (Cz*Cz*hs(k1)*u1(L))
endif
if (hs(k2) > 0d0) then
call getucxucynoweirs(k2, ucxk, ucyk, ifixedweirscheme )
umod = sqrt(ucxk*ucxk + ucyk*ucyk)
uin = abs( ucxk*csu(L) + ucyk*snu(L) )
call getcz(hs(k2), frcu(L), ifrcutp(L), Cz)
frLk2 = umod*uin*ag / (Cz*Cz*hs(k2)*u1(L))
endif
endif
frL = a*frL + b*( (frLk1+frLk2)*0.5d0 )
endif
end subroutine fixedweirfriction2D
subroutine widar(hpr,dz,wu2,wid,ar)
use m_flow, only : slotw2D
implicit none
double precision :: hpr,dz,wu2,wid,ar,hyr
double precision :: per, hp2
if (dz/wu2 < 1d-3) then
wid = wu2 ; wid = wid + slotw2D
ar = wid * hpr
else if (hpr < dz) then
wid = wu2 * hpr / dz ; wid = wid + slotw2D
ar = 0.5d0*wid*hpr
else
wid = wu2 ; wid = wid + slotw2D
hp2 = hpr - dz
ar = wid*0.5d0*(hpr + hp2)
endif
end subroutine widar
subroutine widarhyr(hpr,dz,wu2,wid,ar,hyr)
use m_flow, only : slotw2D
implicit none
double precision :: hpr,dz,wu2,wid,ar,hyr
double precision :: per, hp2
if (dz/wu2 < 1d-3) then
wid = wu2 ; wid = wid + slotw2D
ar = wid * hpr
hyr = hpr
else if (hpr < dz) then
wid = wu2 * hpr / dz ; wid = wid + slotw2D
ar = 0.5d0*wid*hpr
per = sqrt(hpr*hpr + wid*wid)
hyr = ar/per
else
wid = wu2 ; wid = wid + slotw2D ! wid = max(wid, slotw2d)
hp2 = hpr - dz
ar = wid*0.5d0*(hpr + hp2)
per = sqrt(dz*dz + wid*wid)
hyr = ar/per
endif
end subroutine widarhyr
subroutine getseg1D(hpr,wu2,dz,ai,frcn,ifrctyp, wid,ar,conv,perim,jaconv) ! copy of above routine dressed out for 1D
implicit none
double precision, intent (in) :: hpr,wu2,dz,ai,frcn
double precision, intent (out) :: wid,ar,conv,perim !
integer, intent (in) :: ifrctyp ,jaconv
double precision :: d83 = 2.666666d0, d16 = 0.166666d0 , d23 = 0.666666d0, d43= 1.333333d0
double precision :: tt, hp2, hrad, Cz, cman, per, hav
double precision :: d38 = 0.375d0 , d113 = 3.666666d0 , d311 = 0.27272727d0, hpr83, hp283, d14 = 0.25d0
integer :: jac
! for jaconv >= 1, this routine gets 1D conveyance
! this constant value, (1+(dz/dy)**2)**0.25 is computed once and is volume cell based instead of link based
if (ai < 1d-3) then
wid = wu2
ar = wid * hpr
else if (hpr < dz) then
wid = wu2 * hpr / dz
ar = 0.5d0*wid*hpr
else
wid = wu2
hp2 = hpr - dz
ar = wid*0.5d0*(hpr + hp2)
endif
if (jaconv == 0) then
return
else if (frcn == 0d0) then
conv = 0d0 ; return
else if (jaconv == 1) then ! hydraulic radius type
if (ai < 1d-3) then
perim = wid
else if (hpr < dz) then
perim = sqrt(wid*wid + hpr*hpr)
else
perim = sqrt(wid*wid + (hpr-hp2)*(hpr-hp2) )
endif
else if (jaconv >= 2) then ! 1D analytic conveyance type
if (ifrctyp == 1) then
cman = frcn
else
if (ai < 1d-3) then
hav = hpr
else if (hpr < dz) then
hav = 0.5d0*hpr
else
hav = hpr -0.5d0*dz
endif
call getcz(hav, frcn, ifrctyp, Cz)
cman = hav**d16/Cz
endif
if (ai < 1d-3 ) then ! see sysdoc 5 1D conveyance
conv = ( ar *hpr**d23 ) / ( cman )
else if (hpr < dz) then
conv = ( d38*hpr**d83 ) / ( cman*ai*(1d0+ai*ai)**d14 )
else
conv = ( d38*(hpr**d83-hp2**d83) ) / ( cman*ai*(1d0+ai*ai)**d14 )
endif
endif
end subroutine getseg1D
subroutine VOL12D(japerim) ! and add area's and volumes of 1D and 2D links, japerim=1: also set conveyance
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: japerim
integer :: L, k1, k2, K, n, kk, kb, kt
double precision :: hh
if (nonlin2D > 0) then
slotw2D = slotw1D
else
slotw2D = 0d0
endif
do L = 1,lnx1D ! regular 1D links
if (kcu(L) == 4) then
call addlink1D2D(L,japerim) ! 1D2D inherits 2D
else
call addlink1D(L,japerim) ! regular 1D link
endif
enddo
do L = lnx1D + 1, lnxi
call addlink2D(L,japerim) ! regular 2D links
enddo
do L = lnxi+1,lnx
if (kcu(L) == -1) then
call addlink1D(L,japerim) ! 1D boundary links
else
call addlink2D(L,japerim) ! 2D boundary links
endif
enddo
if (japerim == 0) then
if (nonlin2D > 0) then
call addclosed_2D_walls() ! 2D Dichte wanden
endif
if (nonlin > 0) then
do k = 1, mx1Dend ! 1D Dichte branch uiteinden
k1 = n1Dend(k)
a1(k1) = 2D0*a1(k1)
if (kmx == 0) then
vol1(k1) = 2D0*vol1(k1)
else
call getkbotktop(k1,kb,kt)
do kk = kb,kt
vol1(kk) = 2D0*vol1(kk)
enddo
endif
enddo
endif
if (jaembed1D == 2) then ! nonlin2D = 0, nonlin1D = 1 , on embedded 2D cells correct vol1, a1
do n = 1,numembed
k = kembed(n)
hh = min(hs(k), dbl21(n) )
vol1(k) = vol1(k) - ba(k) * hh
if (s1(k) < bl(k) + dbl21(n)) then
a1(k) = a1(k) - ba(k)
endif
enddo
endif
endif
end subroutine VOL12D
subroutine addclosed_2D_walls()
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: n, k1
double precision :: bl1, aa1, hh1
do n = 1, mxwalls
k1 = walls(1,n)
bl1 = walls(13,n)
aa1 = walls(17,n)
hh1 = s1(k1) - bl1
a1(k1) = a1(k1) + aa1
if (hh1 > 0d0) then
vol1(k1) = vol1(k1) + aa1*hh1
endif
enddo
end subroutine addclosed_2D_walls
!> adjust bobs and iadvec for dams and structs
subroutine adjust_bobs_for_dams_and_structs()
use m_flowgeom
use m_flow
use m_netw
use m_fixedweirs
implicit none
double precision :: zcdamn, blmx
integer :: ng, k1, k2, L, n
do ng = 1,ncdamsg ! loop over cdam signals, sethu
zcdamn = zcdam(ng)
do n = L1cdamsg(ng), L2cdamsg(ng)
k1 = kcdam(1,n)
k2 = kcdam(2,n)
L = kcdam(3,n)
blmx = max(bl(k1), bl(k2))
bob(1,L) = max(zcdamn,blmx)
bob(2,L) = max(zcdamn,blmx)
enddo
enddo
do ng = 1,ncgensg ! loop over general structures signals, sethu
zcdamn = zcgen(3*(ng-1)+1) ! TODO: actually, the crest/sill_width should be included here: not all flow links may be open
do n = L1cgensg(ng), L2cgensg(ng)
k1 = kcgen(1,n)
k2 = kcgen(2,n)
L = kcgen(3,n)
blmx = max(bl(k1), bl(k2))
bob(1,L) = max(zcdamn,blmx)
bob(2,L) = max(zcdamn,blmx)
call switchiadvnearlink(L)
enddo
enddo
return
end subroutine adjust_bobs_for_dams_and_structs
subroutine sethu(jazws0) ! Set upwind waterdepth hu
use m_flowgeom ! Todo: higher order + limiter, see transport
use m_flow
use m_flowtimes
use m_sediment
use m_fixedweirs
use m_sobekdfm
use m_netw, only: xk, yk
implicit none
! locals
integer :: L, k1, k2, ku, kd, isg, LL, k, Ld, iup, nq, kk, ifrctyp, jazws0
integer :: n, kb, kb0, kt, itpbn, ng, jawet, Lb, nfw
double precision :: zb, hh, dtgh
double precision :: sup, bup, sk1, sk2, hs1, hs2, epsh, qdak
double precision :: hsav, hul, utp, hup
double precision :: huk1, huk2, hsku, sigm
double precision :: onet = 1d0/3d0
double precision :: twot = 2d0/3d0
double precision :: tgi = 1d0/(2d0*9.81d0)
double precision :: ds, ds1, ds2, ds0, xx, hdl, zgaten, bupmin, he, zcdamn, hcrest, uin, blmx
double precision :: h0, dzb, cz, sixth = 1d0/6d0, frcn, z00, sqcf, uuL, vhei, eup, ucxku, ucyku
double precision :: Qweir_super, Qweir_sub, wu_orig
double precision :: weirrelax = 0.75d0
double precision :: Qrat, re, Edown, ucxkd, ucykd
double precision :: dp, d2, aa, hucrest, hunoweir, qweirsimple, ufac, efac
double precision :: avolk, hkruin, wsbov, wsben, d1, ewbov, ewben, eweir, qvolk, qunit, hov, vov, vbov, hvolk, dte0, dtefri, qov, tol
character (len=4) :: toest
integer :: k3, k4, itel
double precision, external :: dbdistance
! SPvdP: s0 at the old time level already satisfies the boundary conditions at the old time level (see s1nod)
! Nevertheless, s0 at the boundary (at the old time-level) will now be filled with boundary conditions at the new time level
call sets01zbnd(0) ! set s0 on z-boundaries
if (uniformhu > 0d0) then
hu = uniformhu ; return
endif
!
! SPvdP: water-levels at the velocity boundaries do already satisfy the Neumann condition (see s1nod)
!
!do n = 1, nbndu ! velocity boundaries
! kb = kbndu(1,n)
! k2 = kbndu(2,n)
! s0(kb) = s0(k2)
!enddo
! adjust bobs for controllable dams
if ( ncdamsg.gt.0 .or. ncgensg.gt.0 ) then
call adjust_bobs_for_dams_and_structs()
end if
avolk = twot*sqrt(twot*ag)
nfw = 0
do L = 1,lnx
! for cut-cells
if (wu(L).eq.0d0 ) then
hu(L) = 0d0 ; cycle
end if
k1 = ln(1,L) ; k2 = ln(2,L)
if (jazws0 == 0) then
uuL = u1(L)
else
uuL = u0(L)
endif
if ( uuL > 0) then ! was q1 (halfway the timestep), jazws0 assigns if start of loop or loop itself is considered
iup = 1 ; ku = k1 ; kd = k2 ; isg = 1
else if (uuL < 0) then
iup = 2 ; ku = k2 ; kd = k1 ; isg = -1
else if ( s0(k1) > s0(k2) ) then
iup = 1 ; ku = k1 ; kd = k2 ; isg = 1
else
iup = 2 ; ku = k2 ; kd = k1 ; isg = -1
endif
sup = s0(ku)
bup = bob(iup,L)
if (jaconveyance2D >= 1) then
if (L > lnx1D) then
bup = min(bob(1,L), bob(2,L) )
else if (kcu(L) == 4) then
bup = min(bob(1,L), bob(2,L) )
endif
endif
huL = sup-bup
if (huL > epshu) then
if (ncdamsg > 0 .or. ifixedweirscheme > 0) then ! sethu
if (iadv(L) == 21 .or. iadv(L) >= 23 .and. iadv(L) <= 25) then ! weir velocity point
nfw = nfw + 1
if (iadv(L) >= 23 .and. iadv(L) <= 25) then ! undisturbed velocity as if no weir present, WAQUA like
hunoweir = sup - blu(L) ! bob(1,L) ! 23 = Rajaratnam, 24 = Tabellenboek, 25 = Villemonte
ucxku = ucx(ku) ; ucyku = ucy(ku)
else
call getucxucynoweirs(ku, ucxku, ucyku, ifixedweirscheme )
endif
if (iadv(L) >= 23 .and. iadv(L) <= 25) then ! 23 = Rajaratnam, 24 = Tabellenboek, 25 = Villemonte
! uin = ucxku*csfxw(nfw) + ucyku*snfxw(nfw)
uin = abs(u1(L))
else
uin = ucxku*csu(L) + ucyku*snu(L) ! semi subgrid
endif
vhei = 0.5d0*uin*uin / ag
eup = hul + vhei
if (iadv(L) == 21 .or. iadv(L) == 23) then
hcrest= s0(kd) - bup
! aa = vhei*hs(ku)*hs(ku) ! compute hucrest based upon bernoulli using Eup,
! call comp_rootshu(Eup,aa,hucrest) ! assuming ucrest=uin*hs(ku)/hucrest
! hcrest = hucrest ! Eup = hucrest + 0.5*ucrest**2/ag
if ( hcrest < hul ) then
huL = hcrest
if (hul < twot*eup) then ! supercritical
! Jan's weirs: not for supercritical conditions
if ( javillemonte.eq.1 ) then
wu(L) = wu_orig * weir_CD0
end if
hul = twot*eup
hup = hcrest - hul
if (hup < 0) then
adve(L) = adve(L) - isg*hup*ag*dxi(L)
endif
endif
endif ! hcrest< hul
endif
if (iadv(L) == 23) then ! simple Rajaratnam
ufac = hunoweir / huL ! compensates for undisturbed field velocity
efac = 1d0 - (1d0/ufac**2)
advi(L) = advi(L) + 0.5d0*dxi(L)*abs(u1(L))*ufac*ufac*efac
huL = hunoweir
else if (iadv(L) == 24) then ! Waqua tabellenboek
wsbov = sup
wsben = s0(kd)
hkruin = -bup
d1 = bup - blu(L)
ewbov = wsbov + hkruin
ewben = wsben + hkruin
! vbov = abs(u1(L))
! vbov = sqrt(ucxku*ucxku + ucyku*ucyku)
vbov = abs(uin)
vhei = 0.5d0*vbov*vbov / ag
eweir = ewbov + vhei
qvolk = avolk*eweir**1.5d0
qunit = vbov*hunoweir
! Qunit = abs(q1(L)) / wu(L)
hov = ewbov
vov = qunit/hov
if (vov < 0.5d0 ) then
itel = 0
hvolk = twot*eweir
tol = 0.001d0 *max(0.0001d0, qunit)
qov = 0d0
do while (itel < 100 .and. (abs(qunit - qov)) > tol )
itel = itel + 1
vov = qunit / hov
hov = max(hvolk, eweir - (vov**2)/(2d0*ag) )
qov = vov*hov
enddo
endif
dte0 = weirdte(L)
dtefri = 0d0
call enloss(ag, d1, eweir, hkruin, hov, &
qunit, qvolk, toest, vov, &
ewbov, ewben, wsben, weirdte(L), dtefri)
weirdte(L) = (1d0 - waquaweirthetaw)*weirdte(L) + waquaweirthetaw*dte0
! attention total waterdepth instead of water above crest
if ( toest == 'volk' ) then
vbov = qvolk/max(hunoweir, 1d-6 )
endif
if (vbov > 1d-4) then
advi(L) = advi(L) + ag*weirdte(L)*dxi(L)/vbov ! 1/s
endif
huL = hunoweir
else if (iadv(L) == 25) then ! Villemonte
endif
endif ! kadepunt
endif
hu(L) = huL
else
hu(L) = 0d0
endif
if (kmx > 0) then
Lb = Lbot(L)
if(hu(L) > 0d0) then
kt = ktop(ku)
kb = min ( ln( iup,Lb ) , kt )
kb0 = kb - 1 ! kbot(ku) - 1
Ltop(L) = Lb + kt - kb
hsku = zws(kt) - zws(kb0)
au(L) = 0d0
do LL = Lb, Ltop(L)
sigm = (zws(kb+LL-Lb)-zws(kb0)) / hsku
hu(LL) = sigm *hu(L)
au(LL) = wu(L)*hu(LL) ! this is only for now here, later move to addlink etc
if (LL > Lb) then
au(LL) = wu(L)*(hu(LL)-hu(LL-1))
endif
au(L) = au(L) + au(LL) ! add to integrated 2Dh layer
enddo
else
Ltop(L) = 1 ! lb - 1 ! 1 ! flag dry
endif
endif
enddo
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
hsav = max(epshs, acl(L)*hs(k1) + (1d0-acl(L))*hs(k2) )
huvli(L) = 1d0 / hsav
enddo
if (lincontin == 1) then
do L = 1,lnx
hu(L) = -0.5d0*( bob(1,L) + bob(2,L) )
enddo
endif
do ng = 1,ngatesg ! loop over gate signals, sethu
zgaten = zgate(ng) ; bupmin = 9d9
do n = L1gatesg(ng), L2gatesg(ng)
L = kgate(3,n)
if (hu(L) > 0d0) then
bup = min(bob(1,L), bob(2,L) )
bupmin = min(bupmin, bup)
sup = bup + hu(L)
if (sup > zgaten) then
hu(L) = hu(L) - (sup - zgaten)
endif
if (hu(L) < epshu) then
hu(L) = 0d0
endif
endif
enddo
if (bupmin /= 9d9) then
zgate(ng) = max( zgate(ng), bupmin )
end if
enddo
do ng = 1,ncgensg ! loop over generalstruc signals, sethu
zgaten = zcgen(3*(ng-1)+2) ; bupmin = 9d9
do n = L1cgensg(ng), L2cgensg(ng)
L = kcgen(3,n)
if (hu(L) > 0d0) then
bup = min(bob(1,L), bob(2,L) )
bupmin = min(bupmin, bup)
sup = bup + hu(L)
! if (sup > zgaten) then
! hu(L) = hu(L) - (sup - zgaten)
! endif
if (hu(L) < epshu) then
hu(L) = 0d0
endif
endif
enddo
if (bupmin /= 9d9) then
zcgen(3*(ng-1)+2) = max( zcgen(3*(ng-1)+2), bupmin )
end if
enddo
if (nbnd1d2d > 0) then ! 1d2d boundary check for closed boundaries
call sethu_1d2d()
endif
end subroutine sethu
subroutine bathyupdate()
use m_flowgeom
use m_flow
use m_netw, only : zk, zk0, zk1, numk
use m_sediment !, only : jamorf
implicit none
integer :: L, k, kk, kkk, k1, k2, n, nn, ierr, ja, k3, k4
double precision :: znn, bobm, zki
if (jamorf == 0) return
if (.not. (ibedlevtyp == 1 .or. ibedlevtyp == 6) .and. jaceneqtr == 1 .and. .not. allocated(zn2rn) ) then ! netnode depth + netcell fluxes !
if (allocated (zk1) ) deallocate( zk1)
allocate ( zk1(numk) , stat=ierr)
call aerr ('zk1(numk)', ierr , numk) ; zk1 = 0d0
ja = 0
if (.not. allocated(zn2rn)) then
ja = 1
else if (size(zn2rn) < numk) then
deallocate(zn2rn) ; ja = 1
endif
if (ja == 1) then
allocate ( zn2rn(numk) , stat = ierr)
call aerr('zn2rn(numk)', ierr , numk); zn2rn = 0d0
do n = 1, ndx2d
nn = size(nd(n)%x)
do kk = 1, nn
kkk = nd(n)%nod(kk)
zn2rn(kkk) = zn2rn(kkk) + ba(n)
enddo
enddo
endif
endif
if (ibedlevtyp == 1 .or. ibedlevtyp == 6) then ! tiledepth types
bl = bl + blinc
do L = lnx1D+1, lnx
bob(1,L) = max( bl(ln(1,L)), bl(ln(2,L)) )
bob(2,L) = bob(1,L)
enddo
else ! netnode types
if ( jaceneqtr == 1) then
zk1 = 0d0
do n = 1, ndx2d
znn = blinc(n)
if (znn .ne. 0d0) then
nn = size(nd(n)%x)
do kk = 1, nn
kkk = nd(n)%nod(kk)
zk1(kkk) = zk1(kkk) + znn*ba(n)
enddo
endif
enddo
do k = 1,numk
if (zk1(k) .ne. 0d0) then
if (zn2rn(k) > 0) then
zki = zk1(k)/zn2rn(k) ! increment
zk (k) = zk(k) + zki ! new bathy
endif
endif
enddo
else ! update already done in subroutine transport
endif
! TODO: Herman: should we skip the step below if optional ibedlevmode==BLMODE_D3D?
bl(1:ndxi) = 1d9
do L = lnx1D+1, lnxi
k3 = lncn(1,L)
k4 = lncn(2,L)
bob(1,L) = zk(k3)
bob(2,L) = zk(k4)
bobm = min( bob(1,L), bob(2,L) )
k1 = ln(1,L) ; k2 = ln(2,L)
! TODO: Herman: should we skip the step below if optional ibedlevmode==BLMODE_D3D?
bl(k1) = min( bl(k1), bobm) ! here minimise based on connected lowest linklevels
bl(k2) = min( bl(k2), bobm)
enddo
endif
call setaifu() ! or, do this every so many steps
do k = 1,ndxi
if (s1(k) < bl(k) )then
s0(k) = bl(k) + 1d-9
s1(k) = bl(k) + 1d-9
endif
enddo
end subroutine bathyupdate
subroutine setau() ! get wet cross-sections at u points, after limiters, setau = vol12D with japerim == 1
use m_flowgeom
use m_flow
use unstruc_model
use m_partitioninfo
use m_timer
implicit none
integer :: n, nq, L, k1, k2
integer :: ierror
double precision :: at, ssav, wwav
double precision, parameter :: FAC = 0.6666666666667d0
if (kmx == 0) then
call vol12D(1)
endif
if ( nqbnd.eq.0 ) return
huqbnd=0d0
if (jbasqbnddownwindhs == 0) then
do nq = 1,nqbnd ! discharge normalising Manning conveyance
at = 0d0
ssav = 0d0 ; wwav = 0d0
do n = L1qbnd(nq), L2qbnd(nq)
L = kbndu(3,n)
k2 = kbndu(2,n)
if ( jampi.eq.1 ) then
! exclude ghost nodes
if ( idomain(k2).ne.my_rank ) then
cycle
end if
end if
if ( hu(L) > 0d0 ) then
ssav = ssav + s1(k2)*wu(L)
wwav = wwav + wu(L)
endif
enddo
wwssav_all(1,nq) = wwav
wwssav_all(2,nq) = ssav
end do
if ( jampi.eq.1 .and. japartqbnd.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_wwssav_all()
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
end if
do nq = 1,nqbnd ! discharge normalising Manning conveyance
at = 0d0
if (jbasqbnddownwindhs == 0) then
wwav = wwssav_all(1,nq)
ssav = wwssav_all(2,nq)
if (wwav > 0) then
ssav = ssav/wwav
do n = L1qbnd(nq), L2qbnd(nq)
L = kbndu(3,n)
if ( hu(L) > 0d0 ) then
! hu(L) = max(0d0, ssav - min( bob(1,L), bob(2,L) ) )
huqbnd(n) = max(0d0, ssav - min( bob(1,L), bob(2,L) ) )
endif
enddo
endif
endif
do n = L1qbnd(nq), L2qbnd(nq)
L = kbndu(3,n)
k2 = kbndu(2,n)
if (jbasqbnddownwindhs == 1) then
hu(L) = s1(k2) - bl(k2) ! Qbnd_downwind_hs
call addlink2D(L,1)
huqbnd(n) = hu(L)
endif
if (zbndu(n) < 0d0 .and. hu(L) < qbndhutrs) then
hu(L) = 0d0 ; au(L) = 0d0
else
if ( jampi.eq.0 ) then
! at = at + au(L)*hu(L)**FAC
at = at + au(L)*huqbnd(n)**FAC
else
! exclude ghost nodes
if ( idomain(k2).eq.my_rank ) then
! at = at + au(L)*hu(L)**FAC
at = at + au(L)*huqbnd(n)**FAC
end if
end if
endif
enddo
at_all(nq) = at
end do
if ( jampi.eq.1 .and. japartqbnd.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_at_all()
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
do nq = 1,nqbnd
at = at_all(nq)
if (at .ne. 0) then
do n = L1qbnd(nq), L2qbnd(nq)
L = kbndu(3,n)
! zbndu(n) = (zbndu(n)*hu(L)**FAC)/at
zbndu(n) = (zbndu(n)*huqbnd(n)**FAC)/at
enddo
endif
enddo
end subroutine setau
subroutine sets01zbnd(n01)
use m_flowgeom
use m_flow
use m_flowtimes
use m_missing
use m_sobekdfm
implicit none
integer :: n, kb, k2, itpbn, L, n01
double precision :: zb, hh, dtgh, alf
do n = 1, nbndz ! overrides for waterlevel boundaries
kb = kbndz(1,n)
k2 = kbndz(2,n)
L = kbndz(3,n)
itpbn = kbndz(4,n)
if (itpbn == 1) then ! waterlevelbnd
zb = zbndz(n)
if (alfsmo < 1d0) then
zb = alfsmo*zb + (1d0-alfsmo)*zbndz0(n)
endif
else if (itpbn == 2) then ! neumannbnd, positive specified slope leads to inflow
!zb = s0(k2) + zbndz(n)*dx(L)
zb = s1(kb)
else if (itpbn == 5) then ! Riemannbnd
hh = max(epshs, 0.5d0*( hs(kb) + hs(k2) ) )
zb = 2d0*zbndz(n) - zbndz0(n) - sqrt(hh/ag)*u1(L)
else if (itpbn == 6) then ! outflowbnd
if (u0(L) > 0) then ! on inflow, copy inside
zb = s0(k2)
if (n01 == 0) then
s0(kb) = max(zb, bl(kb)) ! TODO: AvD: if single time step is being restarted, then this line will have overwritten some of the old s0 values.
else
s1(kb) = max(zb, bl(kb))
endif
endif
else if (itpbn == 7) then ! qhbnd
zb = zbndz(n)
if (alfsmo < 1d0) then
zb = alfsmo*zb + (1d0-alfsmo)*zbndz0(n)
endif
endif
if (japatm > 0 .and. PavBnd > 0) then
zb = zb - ( patm(kb) - PavBnd )/(ag*rhomean)
endif
! zb = max( zb, bl(kb) + 1d-3 )
if (itpbn < 6 .or. itpbn == 7) then
if (n01 == 0) then
s0(kb) = max(zb, bl(kb)) ! TODO: AvD: if single time step is being restarted, then this line will have overwritten some of the old s0 values.
else
s1(kb) = max(zb, bl(kb))
endif
endif
enddo
call set_1d2d_01()
end subroutine sets01zbnd
subroutine setdt()
use m_partitioninfo
use m_flowparameters, only: jawave
use m_xbeach_data, only: swave
use m_flowtimes, only: dts, dti
use m_timer
implicit none
integer :: jareduced
call setdtorg(jareduced) ! 7.1 2031
!call tekcflmax()
if ( jampi.eq.1 .and. jareduced.eq.0 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_double_min(dts)
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
dti = 1d0/dts
if ( jawave.eq.4 .and. swave.eq.1 ) then
call xbeach_wave_maxtimestep()
end if
end subroutine setdt
subroutine setdtorg(jareduced) ! set computational timestep dts
use m_flowgeom
use m_flow
use m_flowtimes
use m_partitioninfo
use m_missing
use m_transport, only: time_dtmax, dtmax, dtmin_transp, kk_dtmin
implicit none
integer, intent(out) :: jareduced ! maximum time-step is already globally reduced (1) or not (0)
! locals
integer :: L, LL, k, n1, n2, nsteps, kk, kb, kt, k1,k2, Lb, Lt
double precision :: a1m, rhomin, rhomax, cbaroc, drho
double precision :: hsx
double precision :: cuu ! flow velocity
double precision :: cuw ! wave velocity
double precision :: cudxi ! relevant courant velocity per length, mx
double precision :: cfltot, dtsc, dtsw, dtsc2D
double precision, allocatable :: squbaroc(:)
INTEGER :: NDRAW
COMMON /DRAWTHIS/ NDRAW(40)
jareduced = 0
if (ja_timestep_auto >= 1) then
IF (NDRAW(28) == 30 .or. NDRAW(29) == 38) THEN
plotlin = dt_max
endif
dts = 1d9 ; kkcflmx = 0
if (ja_timestep_auto == 1 ) then ! depth averaged timestep
if ( itstep.ne.4 ) then ! non-explicit time-step
if ( jatransportmodule.eq.1 .and. time_dtmax.eq.time1 ) then
dts = dtmin_transp
kkcflmx = kk_dtmin
jareduced = 1
else
do k = 1,ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(k).ne.my_rank ) cycle
end if
if (squ(k) > eps10) then ! outflow only
if (hs(k) > epshu) then
dtsc = cflmx*vol1(k)/squ(k)
if (dtsc < dts) then
dts = dtsc ; kkcflmx = k
endif
endif
endif
enddo
end if
else ! explicit time-step
do k = 1,ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(k).ne.my_rank ) cycle
end if
if (sqwave(k) > eps10) then ! outflow only
if (hs(k) > epshu) then
dtsc = cflmx*vol1(k)/sqwave(k)
if (dtsc < dts) then
dts = dtsc ; kkcflmx = k
endif
endif
endif
enddo
end if
else if (ja_timestep_auto == 2 ) then ! depth averaged timestep
do k = 1,ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(k).ne.my_rank ) cycle
end if
if (squ(k) + sqi(k) > eps10) then ! outflow+inflow
if (hs(k) > epshu) then
dtsc = cflmx*vol1(k)/ (squ(k) + sqi(k))
if (dtsc < dts) then
dts = dtsc ; kkcflmx = k
endif
endif
endif
enddo
else if (ja_timestep_auto == 3 .or. ja_timestep_auto == 4) then ! 3 = 2D out over layers, 4=2D in+out all layers
do kk = 1,ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(kk).ne.my_rank ) cycle
end if
if (squ2D(kk) > eps10 .and. hs(kk) > epshu) then
call getkbotktop(kk,kb,kt)
do k = kb,kt
if (squ2d(k) > eps10) then
dtsc = cflmx*vol1(k)/squ2d(k) ! outflow or outflow+inflow
if (dtsc < dts) then
dts = dtsc ; kkcflmx = kk
endif
endif
enddo
endif
enddo
else if ( ja_timestep_auto.eq.5 ) then ! full 3D
if ( jatransportmodule.eq.1 .and. time_dtmax.eq.time1 ) then
dts = dtmin_transp
kkcflmx = kk_dtmin
jareduced = 1
else
do kk=1,Ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(kk).ne.my_rank ) cycle
end if
if ( hs(kk).gt.epshu ) then
call getkbotktop(kk,kb,kt)
do k=kb,kt
if ( squ(k).gt.eps10 .or. sqi(k).gt.eps10 ) then
! dtsc = cflmx*vol1(k)/squ(k)
dtsc = cflmx*vol1(k)/max(squ(k),sqi(k))
if ( dtsc.lt.dts ) then
dts = dtsc ; kkcflmx = kk
endif
end if
end do
end if
end do
end if
else if ( ja_timestep_auto.eq.6) then
do kk=1,Ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(kk).ne.my_rank ) cycle
end if
if ( hs(kk).gt.epshu ) then
dtsc2D = dt_max
if ( squ(kk).gt.eps10 ) then
dtsc2D = cflmx*vol1(kk)/squ(kk)
endif
call getkbotktop(kk,kb,kt)
do k=kb,kt
if ( sqi(k).gt.eps10 ) then
dtsc = cflmx*vol1(k)/sqi(k)
dtsc = min(dtsc, dtsc2D)
if ( dtsc.lt.dts ) then
dts = dtsc ; kkcflmx = kk
endif
end if
end do
end if
end do
else if ( ja_timestep_auto .eq. 7 ) then ! full 3D plus barocline
do LL = 1, Lnxi
n1 = ln(1,LL) ; n2 = ln(2,LL)
call getLbotLtop(LL, Lb, Lt)
rhomin = 2d3; rhomax = -1d0
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
rhomin = min(rhomin, rho(k1), rho(k2) )
rhomax = max(rhomax, rho(k1), rho(k2) )
enddo
drho = rhomax - rhomin
cbaroc = sqrt( 0.25d0*ag*hu(LL)*drho*0.001d0) ! rhomax-rhomin
do L = Lb, Lt
squ(n1) = squ(n1) + au(L)*cbaroc
squ(n2) = squ(n2) + au(L)*cbaroc
sqi(n1) = sqi(n1) + au(L)*cbaroc
sqi(n2) = sqi(n2) + au(L)*cbaroc
enddo
enddo
do kk=1,Ndxi
if ( jampi.eq.1 ) then
if ( idomain(kk).ne.my_rank ) cycle ! do not include ghost cells
endif
if ( hs(kk).gt.epshu ) then
call getkbotktop(kk,kb,kt)
do k = kb,kt
if ( squ(k).gt.eps10 ) then
dtsc = cflmx*vol1(k)/ ( squ(k) + sqi(k) )
if ( dtsc.lt.dts ) then
dts = dtsc ; kkcflmx = kk
endif
endif
enddo
endif
enddo
else if ( ja_timestep_auto .eq. 8 ) then ! full 3D
do kk=1,Ndxi
if ( jampi.eq.1 ) then
! do not include ghost cells
if ( idomain(kk).ne.my_rank ) cycle
end if
if ( hs(kk).gt.epshu ) then
call getkbotktop(kk,kb,kt)
do k=kb,max(kb, kt-1)
if ( squ(k).gt.eps10 ) then
dtsc = cflmx*vol1(k)/squ(k)
if ( dtsc.lt.dts ) then
dts = dtsc ; kkcflmx = kk
endif
endif
enddo
endif
enddo
endif
if (kkcflmx > 0) then
numlimdt(kkcflmx) = numlimdt(kkcflmx) + 1
endif
dts = min (dts, dt_max)
dtsc = dts ! Courant-driven timestep
if (dts > 1.1d0*dtprev) then
dts = 1.1d0*dtprev
nsteps = ceiling((time_user-time0) / dts)
! New timestep dts would be rounded down to same dtprev (undesired, so use nsteps-1)
if (nsteps == ceiling((time_user-time0) / dtprev)) then
nsteps = max(1,nsteps - 1)
end if
dts = (time_user-time0) / dble(nsteps)
! dtmax is always leading.
if (dts > dt_max .or. dts > dtsc) then ! Fall back to smaller step anyway.
dts = (time_user-time0) / dble(nsteps+1)
end if
else
dts = min (dts, dt_max)
! Fit timestep dts so that we will exactly reach time_user in future steps.
nsteps = max(1,ceiling((time_user-time0) / dts ) )
dts = ( time_user-time0 ) / dble(nsteps)
endif
else
dts = dt_max
endif
if (ivariableteta == 2) then ! only for variableteta
do L = 1,lnx
if (hu(L) > 0) then ! only check links that can flow
cuu = abs(u0(L)) ! todo, for restricted au later, rework to vol1/sq
n1 = ln(1,L) ; n2 = ln(2,L)
a1m = min (a1(n1) , a1(n2) )
if (a1m .gt. 0) then
cuw = 1d0*sqrt(ag*au(L)*dx(L)/a1m)
cuu = cuu + cuw
endif
cfltot = cuu*dts*dxi(L) ! cfltot = cfl(velocity + wave)
! if (cfltot > 0.9d0) then
! teta(L) = 1d0
! else
! teta(L) = 0d0
! endif
cfltot = max(0.01d0,cfltot)
teta(L) = max(0d0, (cfltot - 1d0) / cfltot)
endif
enddo
endif
! write(*,*) 'setdt'
! dts = 1d0
end subroutine setdtorg
subroutine advec() ! advection, based on u0, q0 24
use m_flowtimes
use m_flowgeom
use m_flow
use m_partitioninfo
use m_fixedweirs
implicit none
! locals
double precision :: unormal ! function unormal
double precision :: dif ! averaged waterdepth at flow link (m)
integer :: L, k1, k2 ! link, nd1, nd2
integer :: k12 ! nd1 or nd2
integer :: k34 ! nod1 or nod2
double precision :: ul1, ul2 ! just testing
double precision :: uup ! cell centered upwind u(L)
double precision :: vup ! cell centered upwind v(L) determines whether to use corner up or dwn in vdudy
double precision :: ucnup ! corner based upwind u(L)
double precision :: vcn3, vcn4, vcnu, qx
double precision :: v12 ! Wenneker control volume (m3)
double precision :: v12t, v1t, v2t ! time derivative of control volume (m3/s)
double precision :: advil ! local advi
double precision :: advel ! local adve
double precision :: qu1 ! Flux times advection velocity node 1 (m4/s2)
double precision :: qu2 ! idem node 2
double precision :: qu1a ! Flux times advection velocity node 1 (m4/s2)
double precision :: qu2a ! idem node 2
double precision :: qu12a ! both a
double precision :: uqcxl !
double precision :: uqcyl !
double precision :: qu12, aa ! both
double precision :: cs, sn
double precision :: QucWen ! Sum over links of Flux times upwind cell centre velocity (m4/s2), do not include own link
double precision :: QucPer ! idem, include own link
double precision :: QucPer3D ! idem, include own link
double precision :: QucWeni ! idem, only incoming
double precision :: QucPeri ! idem, inly incoming nb: QucPeripiaczek is a subroutine
double precision :: QunPeri
double precision :: QucPerq1 ! ..
double precision :: QucPercu ! testing center differences
double precision :: QufPer ! testing adv of face velocities instead of centre upwind velocities
double precision :: Qucnu ! = original of QucPer
double precision :: visc ! eddy viscosity term
integer :: isg, jcheck, iadvL, ierr
integer :: m, mu, md, mdd, iad, n, kk, kb
double precision :: qxm, qxmu, uam, uamu, uamd, qxmd, du
double precision :: vv1, vv2, dv1, dv2, quk, que
double precision :: ucxku, ucyku, ai, ae, abh, vu1Di, volu, volui, hh, huvL, baik1, baik2
double precision :: ucin, fdx, ql, qucx, qucy, ac1, ac2, uqn
integer :: LL,LLL,LLLL, Lb, Lt, Lay
integer :: ierror, ku, kd, k, nfw
double precision :: quk1(3,kmxx), quk2(3,kmxx), volukk(kmxx) ! 3D for 1=u, 2=turkin, 3=tureps
integer :: kt1, kt2, n1, n2, kb1, kb2, Ltx0, ktx01, ktx02 , ktx1 , ktx2, Ltx, L1
double precision :: sigu, alf, bet1, bet2, hs1, hs2, vo1, vo2, zz1, zz2, econsfac
double precision :: quuk1(kmxx), quuk2(kmxx), volk1(kmxx), volk2(kmxx), sqak1(kmxx), sqak2(kmxx)
double precision :: quuL1(kmxx), quuL2(kmxx), volL1(kmxx), volL2(kmxx), sqaL1(kmxx), sqaL2(kmxx)
double precision :: sigk1(kmxx), sigk2(kmxx), siguL(kmxx)
if (ifixedweirscheme >= 3 .and. ifixedweirscheme <= 5) then
do L = 1,lnxi
if (iadv(L) == 21) then
if (u0(L) > 0) then
kd = ln(2,L) ; ku = ln(1,L)
else
kd = ln(1,L) ; ku = ln(2,l)
endif
call getucxucyweironly ( kd, ucx(kd), ucy(kd), ifixedweirscheme )
call getucxucyweironly ( ku, ucx(ku), ucy(ku), ifixedweirscheme )
endif
enddo
endif
call sethigherorderadvectionvelocities()
uqcx = 0d0 ; uqcy = 0d0
if (kmx == 0) then
do L = Lnx,1,-1
k1 = ln(1,L) ; k2 = ln(2,L)
qL = qa(L)
uqcx(k1) = uqcx(k1) + qL*ucxu(L)
uqcx(k2) = uqcx(k2) - qL*ucxu(L)
uqcy(k1) = uqcy(k1) + qL*ucyu(L)
uqcy(k2) = uqcy(k2) - qL*ucyu(L)
enddo
else
do LL = Lnx,1,-1
Lb = lbot(LL) ; Lt = ltop(LL)
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
qL = qa(L)
uqcx(k1) = uqcx(k1) + qL*ucxu(L)
uqcx(k2) = uqcx(k2) - qL*ucxu(L)
uqcy(k1) = uqcy(k1) + qL*ucyu(L)
uqcy(k2) = uqcy(k2) - qL*ucyu(L)
enddo
enddo
endif
do n = 1,numsrc
if (arsrc(n) > 0) then ! if momentum desired
if (qsrc(n) > 0) then
kk = ksrc(4,n) ! 2D pressure cell nr TO
k = ksrc(5,n) ! cell nr
else
kk = ksrc(1,n) ! 2D pressure cell nr FROM
k = ksrc(2,n) ! cell nr
endif
if (kk > 0) then
if (kmx == 0) then
k = kk ! in 2D, volume cell nr = pressure cell nr
endif
uqn = qin(k)*qin(k) / arsrc(n)
if (qsrc(n) > 0) then ! from 1 to 2
uqcx(k) = uqcx(k) - uqn*cssrc(2,n)
uqcy(k) = uqcy(k) - uqn*snsrc(2,n)
else ! from 2 to 1
uqcx(k) = uqcx(k) + uqn*cssrc(1,n)
uqcy(k) = uqcy(k) + uqn*snsrc(1,n)
endif
if (jarhoxu == 0) then
sqa(k) = sqa(k) - qin(k) ! sqa : out - in
else
sqa(k) = sqa(k) - qin(k)*rho(k)
endif
endif
endif
enddo
nfw = 0
if (kmx == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L, advel,k1,k2,iadvL,qu1,qu2,volu,ai,ae,iad,volui,abh,hh,v12t,ku, isg, ucxku, ucyku, ucin, fdx)
do L = 1,lnx
advel = 0 ! advi (1/s), adve (m/s2)
if ( hu(L) > 0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
iadvL = iadv(L)
if (L > lnxi) then
if (iadvL == 77) then
if (u0(L) < 0) iadvL = 0
else if (u0(L) > 0) then
iadvL = 0 ! switch off advection for inflowing waterlevel bnd's, if not normalvelocitybnds
endif
!vol1(k1) = 0d0
endif
if (iadvL == 33) then !
qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1) - u1(L)*sqa(k1)
qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2) - u1(L)*sqa(k2)
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
advel = (acl(L)*qu1 + (1d0-acl(L))*qu2) / volu
endif
else if (iadvL == 43) then !
qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1) - u1(L)*sqa(k1)
qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2) - u1(L)*sqa(k2)
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
advel = (acl(L)*qu2 + (1d0-acl(L))*qu1) / volu
endif
else if (iadvL == 44) then !
if (vol1(k1) > 0) then
qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1) - u1(L)*sqa(k1)
advel = advel + acl(L)*qu1/vol1(k1)
endif
if (vol1(k2) > 0) then
qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2) - u1(L)*sqa(k2)
advel = advel + (1d0-acl(L))*qu2 / vol1(k2)
endif
else if (iadvL == 3) then ! explicit first order mom conservative
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QucPer(1,L) ! excess momentum in/out u(L) dir. from k1
qu1 = qu1*acl(L) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPer(2,L) ! excess momentum in/out u(L) dir. from k2
qu2 = qu2*(1d0-acl(L)) ! Perot weigthing
endif
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
advel = (qu1 + qu2)/volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 333) then ! explicit first order mom conservative
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (volau(k1) > 0) then
qu1 = QucPer(1,L) ! excess momentum in/out u(L) dir. from k1
qu1 = qu1*acl(L)/ volau(k1) ! Perot weigthing
endif
qu2 = 0
if (volau(k2) > 0) then
qu2 = QucPer(2,L) ! excess momentum in/out u(L) dir. from k2
qu2 = qu2*(1d0-acl(L))/ volau(k2) ! Perot weigthing
endif
advel = qu1 + qu2 ! dimension: ((m4/s2) / m3) = (m/s2)
else if (iadvL == 30) then ! Same as 3, now with alfa = 0.5 in volumes and advection
! based upon cell center excess advection velocity
qu1 = 0
if (vol1(k1) > 0) then
qu1 = QucPer(1,L) ! excess momentum in/out u(L) dir. from k1
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPer(2,L) ! excess momentum in/out u(L) dir. from k2
endif
volu = vol1(k1) + vol1(k2)
if (volu > 0) then
advel = (qu1 + qu2)/volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 31) then ! Thesis Olga 4.8
! based upon cell center excess advection velocity
qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1)
qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2)
advel = acl(L)*qu1 + (1d0-acl(L))*qu2
else if (iadvL == 40) then !
qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1) - u1(L)*sqa(k1)
qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2) - u1(L)*sqa(k2)
volu = acl(L)*voldhu(k1) + (1d0-acl(L))*voldhu(k2)
if (volu > 0) then
advel = (acl(L)*qu1 + (1d0-acl(L))*qu2) / volu
endif
else if (iadvL == 1) then ! explicit first order mom conservative
! based upon cell center advection velocity
! and Wenneker control volume, now with
! uqcx and uqcy arrays instead of function call, (much faster than excess form)
volu = vol1(k1) + vol1(k2) ! Wennekers control volume
! qu1 = ( uqcx(k1)*cs + uqcy(k1)*sn )
! qu2 = ( uqcx(k2)*cs + uqcy(k2)*sn )
if (volu > 0) then
qu1 = csu(L)*( uqcx(k1) + uqcx(k2) )
qu2 = snu(L)*( uqcy(k1) + uqcy(k2) )
v12t = sq(k1) + sq(k2) ! time der. of v12
advel = (qu1 + qu2 + u1(L)*v12t) / volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 2) then ! explicit first order mom conservative
! based upon cell center excess advection velocity
volu = vol1(k1) + vol1(k2) ! Wennekers control volume
if (volu > 0) then
qu1 = QucWen(1,L) ! excess momentum in u(L) dir. out of k1
qu2 = QucWen(2,L) ! out of k2
advel = (qu1 + qu2) / volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 4) then ! explicit first order mom conservative
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QucPeri(1,L) ! excess momentum in u(L) dir. from of k1
qu1 = qu1*acl(L) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPeri(2,L) ! excess momentum in u(L) dir. from of k2
qu2 = qu2*(1d0-acl(L)) ! Perot weigthing
endif
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
advel = (qu1 + qu2)/volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 5 .or. iadvL ==6) then ! 5,6 = advection like 3,4, now Piaczek teta
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
volui = 1d0/volu
if (vol1(k1) > 0) then
call QucPeripiaczekteta(1,L,ai,ae,volu,iadvL-2) ! excess momentum in u(L) dir. out of k1, include own
abh = acl(L)*volui
adveL = adveL + abh*ae
advi(L) = advi(L) + abh*ai
endif
if (vol1(k2) > 0) then
call QucPeripiaczekteta(2,L,ai,ae,volu,iadvL-2) ! excess momentum in u(L) dir. out of k2
abh = (1d0-acl(L))*volui
adveL = adveL + abh*ae
advi(L) = advi(L) + abh*ai
endif
endif
else if (iadvL >= 7 .and. iadvL <= 12) then ! Piaczek fully implicit
iad = 3
if (iadvL == 8 .or. iadvL == 10 .or. iadvL == 12) then
iad = 4
endif
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
volui = 1d0/volu
if (hs(k1) > 0) then
call QucPeripiaczek(1,L,ai,ae,iad) ! excess momentum in u(L) dir. out of k1, include own
abh = acl(L)*volui
adveL = adveL + abh*ae
advi(L) = advi(L) + abh*ai
endif
if (hs(k2) > 0) then
call QucPeripiaczek(2,L,ai,ae,iad) ! excess momentum in u(L) dir. out of k2
abh = (1d0-acl(L))*volui
adveL = adveL + abh*ae
advi(L) = advi(L) + abh*ai
endif
endif
else if (iadvL == 21) then ! subgrid weir small stencil, ifixedweirscheme = 3
! upwind center velocity does not feel crest link
!advel = 0.5d0*( u0(L)*u0(L) - u0(L-1)*u0(L-1) ) / dx(L)
if (u0(L) > 0d0) then
ku = k1 ; kd = k2 ; isg = 1
else
ku = k2 ; kd = k1 ; isg = -1
endif
call getucxucynoweirs(ku, ucxku, ucyku, ifixedweirscheme )
if (ifixedweirscheme == 4) then
ucin = ucxku*csfxw(nfxwL(L)) + ucyku*snfxw(nfxwL(L))
else
ucin = ucxku*csu(L) + ucyku*snu(L)
endif
fdx = 0.5d0*dxi(L)*isg
advi(L) = advi(L) + fdx*u0(L)
advel = advel - fdx*ucin*ucin
! advel = fdx*(u0(L)*u0(L) - ucin*ucin)
else if (iadvL == 77) then ! supercritical inflow boundary
abh = bai(k1)*huvli(L)*acl(L)
adveL = adveL - abh*q1(L)*ucx(k1)
advi(L) = advi(L) + abh*q1(L)
else if (iadvL == 38) then ! explicit first order mom conservative olga (17)
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QucPercu(1,L) ! excess momentum in/out uc(k1) dir. from k1
qu1 = qu1*acl(L)/volau(k1) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPercu(2,L) ! excess momentum in/out uc(k2) dir. from k2
qu2 = qu2*(1d0-acl(L))/volau(k2) ! Perot weigthing
endif
advel = qu1 + qu2 ! dimension: ((m4/s2) / m3) = (m/s2)
else if (iadvL == 34) then ! explicit first order mom conservative (stelling kramer)
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QucPer(1,L) ! excess momentum in/out u(L) dir. from k1
qu1 = qu1*acl(L)*bai(k1) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPer(2,L) ! excess momentum in/out u(L) dir. from k2
qu2 = qu2*(1d0-acl(L))*bai(k2) ! Perot weigthing
endif
advel = (qu1 + qu2)*huvli(L) ! dimension: ((m4/s2) / m3) = (m/s2)
else if (iadvL == 35) then ! explicit first order mom conservative (stelling kramer)
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QufPer(1,L) ! excess momentum in/out u(L) dir. from k1
qu1 = qu1*acl(L) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QufPer(2,L) ! excess momentum in/out u(L) dir. from k2
qu2 = qu2*(1d0-acl(L)) ! Perot weigthing
endif
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
if (volu > 0) then
advel = (qu1 + qu2)/volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
else if (iadvL == 36) then ! explicit first order mom conservative
! based upon cell center excess advection velocity
qu1 = 0 ! and Perot control volume
if (vol1(k1) > 0) then
qu1 = QucPerq1(1,L) ! excess momentum in/out uc(k1) dir. from k1
qu1 = qu1*acl(L)/vol1(k1) ! Perot weigthing
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = QucPerq1(2,L) ! excess momentum in/out uc(k2) dir. from k2
qu2 = qu2*(1d0-acl(L))/vol1(k2) ! Perot weigthing
endif
advel = qu1 + qu2 ! dimension: ((m4/s2) / m3) = (m/s2)
else if (iadvL == 37) then ! Kramer Stelling
qu1 = 0d0
if (vol1(k1) > 0) then
qu1 = acl(L)*QucPerq1(1,L)/ba(k1) ! excess momentum in/out u(L) dir. from k1
endif
qu2 = 0d0
if (vol1(k2) > 0) then
qu2 = (1d0-acl(L))*QucPerq1(2,L)/ba(k2) ! excess momentum in/out u(L) dir. from k1
endif
advel = huvli(L)*(qu1 + qu2)
endif
adve(L) = adve(L) + advel
endif
enddo
!$OMP END PARALLEL DO
else ! Plus vertical
do LL = 1,lnx
if ( hu(LL) > 0 ) then
iadvL = iadv(LL)
if (LL > lnxi) then
if (iadvL == 77) then
if (u0(LL) < 0) cycle
else if (u0(LL) > 0) then
cycle ! switch off advection for inflowing waterlevel bnd's, if not normalvelocitybnds
endif
endif
cs = csu(LL) ; sn = snu(LL)
Lb = Lbot(LL) ; Lt = Ltop(LL)
ac1 = acl(LL) ; ac2 = 1d0 - ac1
if (iadv(LL) == 3) then
call QucPer3Dsigma(1,LL,Lb,Lt,cs,sn,quk1) ! sum of (Q*uc cell centre upwind normal) at side 1 of basis link LL
call QucPer3Dsigma(2,LL,Lb,Lt,cs,sn,quk2) ! sum of (Q*uc cell centre upwind normal) at side 2 of basis link LL
do L = Lb, Lt
advel = 0d0 ! advi (1/s), adve (m/s2)
k1 = ln(1,L) ; k2 = ln(2,L)
qu1 = 0d0
if (vol1(k1) > 0) then
qu1 = quk1(1,L-Lb+1)*ac1 ! Perot weigthing
endif
qu2 = 0d0
if (vol1(k2) > 0) then
qu2 = quk2(1,L-Lb+1)*ac2 ! Perot weigthing
endif
if (jarhoxu > 0) then
volu = ac1*vol1(k1)*rho(k1) + ac2*vol1(k2)*rho(k2)
else
volu = ac1*vol1(k1) + ac2*vol1(k2)
endif
if (volu > 0) then
advel = (qu1 + qu2)/volu ! dimension: ((m4/s2) / m3) = (m/s2)
endif
adve(L) = adve(L) + advel
enddo
else if ( iadv(LL) == 33 .or. iadv(LL) == 40 .or. iadv(LL) == 6 ) then !
! qu1 = csu(L)*uqcx(k1) + snu(L)*uqcy(k1) - u1(L)*sqa(k1)
! qu2 = csu(L)*uqcx(k2) + snu(L)*uqcy(k2) - u1(L)*sqa(k2)
! volu = ac1*vol1(k1) + ac2*vol1(k2)
! if (volu > 0) then
! advel = (acl(L)*qu1 + (1d0-acl(L))*qu2) / volu
! endif
if (layertype == 1) then
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
qu1 = cs*uqcx(k1) + sn*uqcy(k1) - u1(L)*sqa(k1)
qu2 = cs*uqcx(k2) + sn*uqcy(k2) - u1(L)*sqa(k2)
if (jarhoxu > 0) then
volu = ac1*vol1(k1)*rho(k1) + ac2*vol1(k2)*rho(k2)
else
volu = ac1*vol1(k1) + ac2*vol1(k2)
endif
if (volu > 0) then
adve(L) = adve(L) + (ac1*qu1 + ac2*qu2) / volu
endif
enddo
else if (layertype == 2 .and. jahazlayer == 1) then
n1 = ln(1,LL) ; n2 = ln(2,LL)
call getkbotktop(n1,kb1,kt1) ; ktx1 = kt1-kb1+1
call getkbotktop(n2,kb2,kt2) ; ktx2 = kt2-kb2+1
Ltx = Lt-Lb+1
volukk(1:Ltx) = 0d0
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L) ; L1 = L-Lb+1
volukk(L1) = volukk(L1) + ac1*vol1(k1) + ac2*vol1(k2)
enddo
do k = k1+1, kt1
volukk(Ltx) = volukk(Ltx) + ac1*vol1(k)
enddo
do k = k2+1, kt2
volukk(Ltx) = volukk(Ltx) + ac2*vol1(k)
enddo
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L) ; L1 = L-Lb+1
if (volukk(L1) > 0) then
qu1 = cs*uqcx(k1) + sn*uqcy(k1) - u1(L)*sqa(k1)
qu2 = cs*uqcx(k2) + sn*uqcy(k2) - u1(L)*sqa(k2)
adve(L) = adve(L) + (ac1*qu1 + ac2*qu2) / volukk(L-Lb+1)
endif
enddo
else if (layertype == 2 .and. (jahazlayer == 2 .or. jahazlayer == 3) ) then
n1 = ln(1,LL) ; n2 = ln(2,LL)
call getkbotktop(n1,kb1,kt1)
call getkbotktop(n2,kb2,kt2)
hs1 = zws(kt1) - zws(kb1-1)
hs2 = zws(kt2) - zws(kb2-1)
ktx01 = kt1 - kb1 + 2
ktx02 = kt2 - kb2 + 2
volk1(1:ktx01) = 0d0 ; quuk1(1:ktx01) = 0d0 ; sqak1(1:ktx01) = 0d0 ; sigk1(1:ktx01) = 0d0
do k = kb1, kt1
volk1(k-kb1+2) = volk1(k-kb1+1) + vol1(k)
quuk1(k-kb1+2) = quuk1(k-kb1+1) + cs*uqcx(k) + sn*uqcy(k) ! - u1(L)*sqa(k)
sqak1(k-kb1+2) = sqak1(k-kb1+1) + sqa(k)
sigk1(k-kb1+2) = ( zws(k) - zws(kb1-1) ) / hs1
enddo
volk2(1:ktx02) = 0d0 ; quuk2(1:ktx02) = 0d0 ; sqak2(1:ktx02) = 0d0 ; sigk2(1:ktx02) = 0d0
do k = kb2, kt2
volk2(k-kb2+2) = volk2(k-kb2+1) + vol1(k)
quuk2(k-kb2+2) = quuk2(k-kb2+1) + cs*uqcx(k) + sn*uqcy(k) ! - u1(L)*sqa(k)
sqak2(k-kb2+2) = sqak2(k-kb2+1) + sqa(k)
sigk2(k-kb2+2) = ( zws(k) - zws(kb2-1) ) / hs2
enddo
do L = Lb, Lt ; Ltx0 = Lt - Lb + 2 ; siguL(1) = 0d0
siguL(L-Lb+2) = hu(L) / hu(LL)
enddo
call lineinterp3( siguL, quuL1, volL1, sqaL1, Ltx0, sigk1, quuk1, volk1, sqak1, ktx01)
call lineinterp3( siguL, quuL2, volL2, sqaL2, Ltx0, sigk2, quuk2, volk2, sqak2, ktx02)
if (jahazlayer == 2) then
do L = Lb, Lt
volu = ac1*( volL1(L-Lb+2) - volL1(L-Lb+1) ) + &
ac2*( volL2(L-Lb+2) - volL2(L-Lb+1) )
if (volu > 0) then
qu1 = quuL1(L-Lb+2) - quuL1(L-Lb+1) - u1(L)*( sqaL1(L-Lb+2) - sqaL1(L-Lb+1) )
qu2 = quuL2(L-Lb+2) - quuL2(L-Lb+1) - u1(L)*( sqaL2(L-Lb+2) - sqaL2(L-Lb+1) )
adve(L) = adve(L) + ( ac1*qu1 + ac2*qu2 ) / volu
endif
enddo
else
do L = Lb, Lt
vo1 = volL1(L-Lb+2) - volL1(L-Lb+1)
if (vo1 > 0) then
qu1 = quuL1(L-Lb+2) - quuL1(L-Lb+1) - u1(L)*( sqaL1(L-Lb+2) - sqaL1(L-Lb+1) )
adve(L) = adve(L) + ac1*qu1/vo1
endif
vo2 = volL2(L-Lb+2) - volL2(L-Lb+1)
if (vo2 > 0) then
qu2 = quuL2(L-Lb+2) - quuL2(L-Lb+1) - u1(L)*( sqaL2(L-Lb+2) - sqaL2(L-Lb+1) )
adve(L) = adve(L) + ac2*qu2/vo2
endif
enddo
endif
else if (layertype == 2 .and. jahazlayer == 4) then
n1 = ln(1,LL) ; n2 = ln(2,LL)
call getkbotktop(n1,kb1,kt1) ; ktx1 = kt1-kb1+1
call getkbotktop(n2,kb2,kt2) ; ktx2 = kt2-kb2+1
Ltx = Lt-Lb+1
volukk(1:Ltx) = 0d0 ; quuk1(1:Ltx) = 0d0 ; sqak1(1:Ltx) = 0d0
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L) ; L1 = L-Lb+1
volukk(L1) = volukk(L1) + ac1*vol1(k1) + ac2*vol1(k2)
quuk1 (L1) = quuk1 (L1) + ac1*(cs*uqcx(k1) + sn*uqcy(k1)) + ac2*(cs*uqcx(k1) + sn*uqcy(k1))
sqak1 (L1) = sqak1 (L1) + ac1*sqa(k1) + ac2*sqa(k2)
enddo
do k = k1+1, kt1
volukk(Ltx) = volukk(Ltx) + ac1*vol1(k)
quuk1 (Ltx) = quuk1(Ltx) + ac1*(cs*uqcx(k) + sn*uqcy(k))
sqak1 (Ltx) = sqak1(Ltx) + ac1*sqa(k)
enddo
do k = k2+1, kt2
volukk(Ltx) = volukk(Ltx) + ac2*vol1(k)
quuk1 (Ltx) = quuk1(Ltx) + ac2*(cs*uqcx(k) + sn*uqcy(k))
sqak1 (Ltx) = sqak1(Ltx) + ac2*sqa(k)
enddo
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L) ; L1 = L-Lb+1
if (volukk(L1) > 0) then
adve(L) = adve(L) + quuk1(L1) / volukk(L1)
endif
enddo
else ! Default fixed layers
Ltx = Lt-Lb+1
volukk(1:Ltx) = 0d0
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
volukk(L-Lb+1) = volukk(L-Lb+1) + ac1*vol1(k1) + ac2*vol1(k2)
enddo
do k = k1+1, ktop(ln(1,LL) )
volukk(Lt-Lb+1) = volukk(Lt-Lb+1) + ac1*vol1(k)
enddo
do k = k2+1, ktop(ln(2,LL) )
volukk(Lt-Lb+1) = volukk(Lt-Lb+1) + ac2*vol1(k)
enddo
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
qu1 = cs*uqcx(k1) + sn*uqcy(k1) - u1(L)*sqa(k1)
qu2 = cs*uqcx(k2) + sn*uqcy(k2) - u1(L)*sqa(k2)
if (volukk(L-Lb+1) > 0) then
adve(L) = adve(L) + (ac1*qu1 + ac2*qu2) / volukk(L-Lb+1)
endif
enddo
endif
else if (iadv(LL) == 34) then ! Kramer Stelling, ba per cell weighted
call QucPer3Dsigma(1,LL,Lb,Lt,cs,sn,quk1) ! sum of (Q*uc cell centre upwind normal) at side 1 of basis link LL
call QucPer3Dsigma(2,LL,Lb,Lt,cs,sn,quk2) ! sum of (Q*uc cell centre upwind normal) at side 2 of basis link LL
baik1 = bai( ln(1,LL) )
baik2 = bai( ln(2,LL) )
do L = Lb, Lt
advel = 0 ! advi (1/s), adve (m/s2)
k1 = ln(1,L) ; k2 = ln(2,L)
qu1 = 0d0
if (vol1(k1) > 0) then
qu1 = quk1(1,L-Lb+1)*ac1*baik1
endif
qu2 = 0
if (vol1(k2) > 0) then
qu2 = quk2(1,L-Lb+1)*ac2*baik2 ! Perot weigthing
endif
huvL = ac1*(zws(k1)-zws(k1-1)) + ac2*(zws(k2)-zws(k2-1))
if (huvL > 0d0) then
advel = (qu1 + qu2)/huvL ! dimension: ((m4/s2) / m3) = (m/s2)
adve(L) = adve(L) + advel
endif
enddo
else if (iadv(LL) == 5) then
call QucPer3Dsigmapiaczekteta(LL,Lb,Lt,cs,sn,quk1,quk2)
do L = Lb, Lt
adve(L) = adve(L) + quk1(1,L-Lb+1)
advi(L) = advi(L) + quk2(1,L-Lb+1)
enddo
else if (iadv(LL) == 43) then
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
qu1 = cs*uqcx(k1) + sn*uqcy(k1) - u1(L)*sqa(k1)
qu2 = cs*uqcx(k2) + sn*uqcy(k2) - u1(L)*sqa(k2)
if (jarhoxu > 0) then
volu = ac1*vol1(k1)*rho(k1) + ac2*vol1(k2)*rho(k2)
else
volu = ac1*vol1(k1) + ac2*vol1(k2)
endif
if (volu > 0) then
adve(L) = adve(L) + (ac2*qu1 + ac1*qu2) / volu
endif
enddo
else if (iadv(LL) == 44) then
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (vol1(k1) > 0) then
qu1 = cs*uqcx(k1) + sn*uqcy(k1) - u1(L)*sqa(k1)
adve(L) = adve(L) + ac1*qu1/vol1(k1)
endif
if (vol1(k2) > 0) then
qu2 = cs*uqcx(k2) + sn*uqcy(k2) - u1(L)*sqa(k2)
adve(L) = adve(L) + ac2*qu2/vol1(k2)
endif
enddo
endif ! advectiontypes
endif ! (hu)
enddo ! LL
endif
end subroutine advec
subroutine setextforcechkadvec()
use m_flow
use m_flowgeom
use MessageHandling
use m_wind
use m_sferic
use m_xbeach_data, only: Fx, Fy, swave, Lwave, hminlw
implicit none
integer :: L,LL, Lb, Lt, k1,k2
double precision :: dpatm, tidp, trshcorioi
trshcorioi = 1d0/trshcorio
if (jawind > 0) then
if (kmx == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L)
do L = 1,lnx
if ( hu(L) > 0 ) then
! wdsu/huvli = [(m^2/s^2)*m^-1]
adve(L) = adve(L) - wdsu(L)*huvli(L)
endif
enddo
!$OMP END PARALLEL DO
else
do LL = 1,lnx
if (hu(LL) > 0d0) then
L = Ltop(LL)
adve(L) = adve(L) - wdsu(LL) / max( 1d-2, hu(L) - hu(L-1) )
endif
enddo
endif
endif
if (jawave == 3) then ! if a SWAN computation is performed, add wave forces to adve
! This part is mainly based on the wave forces formulation (wsu) of Delft3D (cucnp.f90)
!if ( kmx.eq.0 ) then ! 2D
!$OMP PARALLEL DO &
!$OMP PRIVATE(L)
do L = 1,lnx
adve(L) = adve(L) - wavfu(L)
enddo
!$OMP END PARALLEL DO
!else
!!$OMP PARALLEL DO &
!!$OMP PRIVATE(L)
! do LL = 1,lnx
! !if ( hu(LL).gt.0 ) then ! need to check
! call LbotLtop(LL,Lb,Lt)
! do L=Lb,Lt
! adve(L) = adve(L) - wavfu(L)/(rhomean*hu(L)) ! Dimensions [m/s^2]
! end do
! !end if
! enddo
!!$OMP END PARALLEL DO
!end if
endif
! JRE
if (jawave .eq. 4 .and. Lwave.eq.1 ) then ! wave forcing from XBeach
call xbeach_wave_compute_flow_forcing()
!$OMP PARALLEL DO &
!$OMP PRIVATE(L)
do L = 1,Lnx !lnx
adve(L) = adve(L) - (Fx(L)*csu(L) + Fy(L)*snu(L))/ (rhomean*max(hu(L), epswavxbeach) ) ! Johan+Dano: lower depth set to 20cm, cf XBeach
enddo
!$OMP END PARALLEL DO
endif
if (japatm > 0 .or. jatidep > 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2,dpatm,tidp)
do L = 1,lnx
if ( hu(L) > 0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (japatm > 0) then
dpatm = ( patm(k2) - patm(k1) )*dxi(L)/rhomean
if ( hu(L) < trshcorio ) then
dpatm = dpatm*hu(L)*trshcorioi
endif
if (kmx == 0) then
adve(L) = adve(L) + dpatm
else
adve( Lbot(L):Ltop(L) ) = adve( Lbot(L):Ltop(L) ) + dpatm
endif
endif
if (jatidep > 0) then
tidp = ( tidep(k2) - tidep(k1) )*dxi(L)
if ( hu(L) < trshcorio) then
tidp = tidp*hu(L)*trshcorioi
endif
if (kmx == 0) then
adve(L) = adve(L) - tidp
else
adve( Lbot(L):Ltop(L) ) = adve( Lbot(L):Ltop(L) ) - tidp
endif
endif
endif
enddo
!$OMP END PARALLEL DO
endif
! Anti-creep
if( kmx < 2 .and. jacreep /= 0) then ! A warning due to kmx<2 and anticreep on
call mess(LEVEL_ERROR, 'Error : Anti-creep must be switched off in a 1d/2d model!')
endif
if ( idensform > 0) then ! Baroclinic pressure
if ( jacreep == 0 ) then
call addbaroclinicpressure()
if (abs(jabaroctimeint) == 2) then
rho0 = rho ! save rho
else if (abs(jabaroctimeint) == 5) then
if (jarhoxu == 1) then
rho = rho0 ! restore rho
endif
endif
jabaroctimeint = abs(jabaroctimeint) ! flag as initialised
else
dsalL = 0d0
dtemL = 0d0
!$OMP PARALLEL DO PRIVATE(L)
do L = 1,lnx
call anticreep( L )
enddo
!$OMP END PARALLEL DO
end if
endif
if ( jasecf > 0 ) then ! Secondary Flow
do LL = 1,lnx
call getcz( hu(LL), frcu(LL), ifrcutp(LL), czusf(LL) ) ! calculating chezy coefficient on the flow links
enddo
call linkstocenterstwodoubles( czssf, czusf ) ! converting chezy cofficient to the flow nodes
call get_spiralangle
call get_spiralforce
end if
if (chkadvd > 0) then ! niet droogtrekken door advectie, stress of wind (allen in adve)
if (kmx == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2)
!$XOMP REDUCTION(+:nochkadv)
do L = 1,lnx
if ( hu(L) > 0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (hs(k1) < 0.5d0*hs(k2) ) then
if (adve(L) < 0 .and. hs(k1) < chkadvd ) then
adve(L) = adve(L)*hs(k1) / chkadvd ! ; nochkadv = nochkadv + 1
endif
else if (hs(k2) < 0.5d0*hs(k1) ) then
if (adve(L) > 0 .and. hs(k2) < chkadvd ) then
adve(L) = adve(L)*hs(k2) / chkadvd ! ; nochkadv = nochkadv + 1
endif
endif
endif
enddo
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2,LL,Lb,Lt)
do LL = 1,lnx
if (hu(LL) > 0d0) then
call getLbotLtop(LL,Lb,Lt)
k1 = ln(1,LL) ; k2 = ln(2,LL)
do L = Lb, Lt
if (hs(k1) < 0.5d0*hs(k2) ) then
if (adve(L) < 0 .and. hs(k1) < chkadvd ) then
adve(L) = adve(L)*hs(k1) / chkadvd ! ; nochkadv = nochkadv + 1
endif
else if (hs(k2) < 0.5d0*hs(k1) ) then
if (adve(L) > 0 .and. hs(k2) < chkadvd) then
adve(L) = adve(L)*hs(k2) / chkadvd ! ; nochkadv = nochkadv + 1
endif
endif
enddo
endif
enddo
!$OMP END PARALLEL DO
endif
endif
end subroutine setextforcechkadvec
subroutine getucxucyweironly ( ku, ucxku, ucyku, ischeme )
use m_flow
use m_flowgeom
implicit none
integer :: ku, LLL, LL, L, Ls, ischeme
double precision :: ucxku, ucyku, ww, ac1, huweir, hunoweir, wl, wlno, at, cs, sn, fac
ucxku = 0d0 ; ucyku = 0d0
huweir = 0d0 ; hunoweir = 0d0; wl = 0d0 ; wlno = 0d0; at = 0d0
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if (iadv(L) >= 21 .and. iadv(L) <= 29) then
huweir = huweir + wu(L)*hu(L)
wl = wl + wu(L)
endif
enddo
huweir = huweir/wl
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if (Ls < 0) then
ac1 = acL(L)
else
ac1 = 1d0 - acL(L)
endif
ww = ac1*dx(L)*wu(L)
cs = ww*csu(L) ; sn = ww*snu(L)
if (iadv(L) >= 21 .and. iadv(L) <= 29) then
ucxku = ucxku + cs*u0(L)
ucyku = ucyku + sn*u0(L)
else
fac = 1d0
if (huweir > 0d0) fac = max(1d0, hu(L) / huweir )
ucxku = ucxku + cs*u0(L)*fac
ucyku = ucyku + sn*u0(L)*fac
endif
enddo
ucxku = ucxku/ba(ku)
ucyku = ucyku/ba(ku)
end subroutine getucxucyweironly
subroutine getucxucynoweirs( ku, ucxku, ucyku, ischeme )
use m_flow
use m_flowgeom
implicit none
integer :: ku, LLL, LL, L, Ls, ischeme
double precision :: ucxku, ucyku, ww, ac1, huweir, hunoweir, wl, wlno, at, cs, sn, fac
ucxku = 0d0 ; ucyku = 0d0
huweir = 0d0 ; hunoweir = 0d0; wl = 0d0 ; wlno = 0d0; at = 0d0
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if (iadv(L) < 21 .or. iadv(L) > 29) then ! .ne. structures
hunoweir = hunoweir + wu(L)*hu(L)
wlno = wlno + wu(L)
endif
enddo
if (wlno > 0d0 ) hunoweir = hunoweir/wlno
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if (Ls < 0) then
ac1 = acL(L)
else
ac1 = 1d0 - acL(L)
endif
ww = ac1*dx(L)*wu(L)
cs = ww*csu(L) ; sn = ww*snu(L)
at = at + ww
if (iadv(L) < 21 .or. iadv(L) > 29) then ! .ne. structures
ucxku = ucxku + cs*u0(L)
ucyku = ucyku + sn*u0(L)
else
fac = 1d0
if (hunoweir > 0d0) fac = min(1d0, hu(L) / hunoweir )
ucxku = ucxku + cs*u0(L)*fac
ucyku = ucyku + sn*u0(L)*fac
endif
enddo
ucxku = ucxku/ba(ku)
ucyku = ucyku/ba(ku)
end subroutine getucxucynoweirs
subroutine getucxucyweironlywrong ( ku, ucxku, ucyku, ischeme )
use m_flow
use m_flowgeom
implicit none
integer :: ku, LLL, LL, L, Ls, ischeme
double precision :: ucxku, ucyku, wwx, wwy, ww, wwt, ac1, wwxt, wwyt, ux, uy
ucxku = 0d0 ; ucyku = 0d0; wwt = 0d0; wwxt = 0d0 ; wwyt = 0d0
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if (iadv(L) == 21) then
if (Ls < 0) then
ac1 = acL(L)
else
ac1 = 1d0 - acL(L)
endif
ww = ac1*dx(L)*wu(L)
if (ischeme == 3) then
wwx = csu(L)*ww
wwy = snu(L)*ww
ucxku = ucxku + wwx*u0(L)
ucyku = ucyku + wwy*u0(L)
else
wwx = abs(csu(L))*ww
wwy = abs(snu(L))*ww
ux = csu(L)*u0(L)
uy = snu(L)*u0(L)
ucxku = ucxku + ux*wwx
ucyku = ucyku + uy*wwy
endif
wwxt = wwxt + abs(wwx)
wwyt = wwyt + abs(wwy)
endif
enddo
if (wwxt > 0d0) ucxku = ucxku / wwxt
if (wwyt > 0d0) ucyku = ucyku / wwyt
end subroutine getucxucyweironlywrong
subroutine getucxucynoweirswrong(ku, ucxku, ucyku, ischeme) !wrong
use m_flow
use m_flowgeom
implicit none
integer :: ku, LL, L, Ls, ischeme
double precision :: ucxku, ucyku, wwx, wwy, ww, wwt, ac1, wwxt, wwyt, ux, uy
ucxku = 0d0 ; ucyku = 0d0; wwt = 0d0; wwxt = 0d0 ; wwyt = 0d0
do LL = 1,nd(ku)%lnx
Ls = nd(ku)%ln(LL); L = iabs(Ls)
if ( iadv(L) < 21 .or. iadv(L) > 25 ) then ! no weir
if (Ls < 0) then
ac1 = acL(L)
else
ac1 = 1d0 - acL(L)
endif
ww = ac1*dx(L)*wu(L)
if (ischeme == 3) then
wwx = csu(L)*ww
wwy = snu(L)*ww
ucxku = ucxku + wwx*u0(L)
ucyku = ucyku + wwy*u0(L)
else
wwx = abs(csu(L))*ww
wwy = abs(snu(L))*ww
ux = csu(L)*u0(L)
uy = snu(L)*u0(L)
ucxku = ucxku + ux*wwx
ucyku = ucyku + uy*wwy
endif
wwxt = wwxt + abs(wwx)
wwyt = wwyt + abs(wwy)
endif
enddo
if (wwxt > 0d0) ucxku = ucxku / wwxt
if (wwyt > 0d0) ucyku = ucyku / wwyt
end subroutine getucxucynoweirswrong
subroutine setumod() ! set cell center Perot velocities at nodes
! set Perot based friction velocities umod at u point
! set tangential velocities at u point
! set velocity gradient at u point
! set corner based Perot velocities
use m_flow
use m_flowgeom
use m_flowtimes
use m_sferic
use m_wind
use m_missing
use m_xbeach_data, only : DR, roller, swave
implicit none
! locals
integer :: L, LL, k, k1, k2, k12, k3, k4, kb, n, n1, n2, nn, ks, ierr
double precision :: ux, uy ! centre or node velocity x- and y components
double precision :: hsi, humx ! inverse centre depth, max depth u points
double precision :: qwd,qwd1,qwd2 !
double precision :: qucx, qucy
double precision :: duxdn, duydn, duxdt, duydt ! normal and tangential global ux,uy gradients
double precision :: vicl, c11, c12, c22, wudx, bai2, sxx, syy, snn
double precision :: sxw, syw, sf, ac1, ac2, csl, snl, wuw, ustar, suxw, suyw, uin, suxL, suyL
double precision :: cs, sn, dxi2, dyi2, sucheck
double precision :: chezy2, hhu, rt, hmin
double precision :: uu,vv,uucx,uucy, ff, ds, hup, fcor
double precision :: dundn, dutdn, dundt, dutdt, shearvar, delty
double precision :: umodLL, volu, hul, dzz, adx, hdx, huv, qL, wcxu, wcyu
integer :: nw, L1, L2, kbk, k2k, Ld, Lu, kt, Lb, Lt, Lb1, Lt1, Lb2, Lt2, kb1, kb2
double precision :: depumin ! external
double precision :: horvic ! external
double precision :: horvic3 ! external
double precision :: DRL, nuhroller
double precision :: dxiAu, vicc
integer :: ini = 0
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
!if (jased > 0) then
! taucx = 0d0; taucy = 0d0
!endif
call klok(cpuumod(1)) ! Perot velocities
call setucxucyucxuucyu()
! set friction velocities umod, tangential velocities v and velocity gradients and windstresses
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,LL,Lb,Lt,k1,k2,cs,sn,hmin,fcor)
do LL = lnx1D+1,lnx
hmin = min( hs(ln(1,LL)),hs(ln(2,LL)) )
call getLbotLtop(LL,Lb,Lt)
cs = csu(LL) ; sn = snu(LL)
do L = Lb,Lt
k1 = ln(1,L) ; k2 = ln(2,L)
! set u tangential
v(L) = acl(LL) *(-sn*ucxq(k1) + cs*ucyq(k1) ) + & ! continuity weighted best sofar plus depth limiting
(1d0-acl(LL))*(-sn*ucxq(k2) + cs*ucyq(k2) )
if (icorio > 0) then
if (jsferic == 1) then
fcor = fcori(LL)
else
fcor = fcorio
endif
if (trshcorio > 0) then
if ( hmin < trshcorio) then
fcor = fcor*hmin/trshcorio
endif
endif
adve(L) = adve(L) - fcor*v(L)
endif
enddo
enddo
!$OMP END PARALLEL DO
!updvertp
ihorvic = 0
if (vicouv > 0 .or. javiusp == 1 .or. Smagorinsky > 0 .or. Elder > 0 .or. kmx > 0) then
ihorvic = 1
endif
if (ihorvic > 0 .or. jaconveyance2D>=3) then
call setcornervelocities() ! must be called after ucx, ucy have been set
endif
if (ihorvic > 0 .or. NDRAW(29) == 37) then
dvxc = 0 ; dvyc = 0; suu = 0
if (kmx == 0) then
if (istresstyp == 2 .or. istresstyp == 3) then ! first set stressvector in cell centers
do L = lnx1D+1,lnx
if (hu(L) > 0) then ! link will flow
cs = csu(L) ; sn = snu(L)
k1 = ln(1,L) ; k2 = ln(2,L)
vicL = 0d0
if (Elder > 0d0) then ! add Elder
vicL = vicL + Elder * 0.0045 * ( hs(k1)+hs(k2) ) * sqrt( u1(L)*u1(L) + v(L)*v(L) ) ! vonkar*sag/(6*Cz) = 0.009
endif
k3 = lncn(1,L) ; k4 = lncn(2,L)
duxdn = ( ucx(k2) - ucx(k1)) * dxi(L)
duydn = ( ucy(k2) - ucy(k1)) * dxi(L)
duxdt = (ucnx(k4) - ucnx(k3)) * wui(L)
duydt = (ucny(k4) - ucny(k3)) * wui(L)
if (Smagorinsky > 0 .or. NDRAW(29) == 37) then ! add Smagorinsky
dundn = cs*duxdn + sn*duydn
dutdn = -sn*duxdn + cs*duydn
dundt = cs*duxdt + sn*duydt
dutdt = -sn*duxdt + cs*duydt
if ( NDRAW(29) == 37 ) then ! plot curl
plotlin(L) = (dutdn - dundt)
endif
if (Smagorinsky > 0) then
shearvar = 2d0*(dundn*dundn + dutdt*dutdt + dundt*dutdn) + dundt*dundt + dutdn*dutdn
vicL = vicL + Smagorinsky*Smagorinsky*sqrt(shearvar)/( dxi(L)*wui(L) )
endif
endif
! JRE: add roller induced viscosity
if ((jawave .eq. 4) .and. (swave .eq. 1) .and. (roller .eq. 1)) then
DRL = acL(L) * DR(k1) + (1-acL(L)) * DR(k2)
nuhroller = hu(L) * (DRL / rhomean) ** 1d0/3d0
vicL = max(nuhroller, vicL)
end if
! if (viuchk < 0.5d0) then
! vicL = min(vicL, viuchk*dti /( dxi(L)*dxi(L) + wui(L)*wui(L) ) )
! endif
! viuchk: safe would be min(vol1(k1)/nd(k1)%N, vol1(k2)/nd(k2)%N) * dti / (dxi(L)*Au(L)),
! hence 0.2d0*min(vol1(k1),vol1(k2))... is safe up to pentagons
if (javiusp == 1) then ! user specified part
vicc = viusp(L)
else
vicc = vicouv
endif
vicL = vicL + vicc
dxiAu = dxi(L)*hu(L)*wu(L)
if ( dxiAu.gt.0d0 ) then
vicL = min(vicL, 0.2d0*dti*min( vol1(k1) , vol1(k2) ) / dxiAu )
endif
viu(L) = max(0d0, vicL - vicc) ! limited turbulent part
c11 = cs*cs ; c12=cs*sn ; c22=sn*sn
suxL = duxdn + c11*duxdn + c12*(duydn - duxdt) - c22*duydt
suyL = duydn + c11*duxdt + c12*(duxdn + duydt) + c22*duydn
suxL = suxL*vicL/wui(L)
suyL = suyL*vicL/wui(L)
if (istresstyp == 3) then
hmin = min(hs(k1), hs(k2))
suxL = hmin*suxL
suyL = hmin*suyL
endif
if (istresstyp >= 2) then
dvxc(k1) = dvxc(k1) + suxL ; dvyc(k1) = dvyc(k1) + suyL
dvxc(k2) = dvxc(k2) - suxL ; dvyc(k2) = dvyc(k2) - suyL
endif
endif
enddo
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2)
do L = lnx1D+1,lnx
if (hu(L) > 0) then ! link will flow
k1 = ln(1,L) ; k2 = ln(2,L)
if (istresstyp == 4 .or. istresstyp == 5) then ! set stresscomponent in links right away
suu(L) = acl(L)*horvic(1,L) + (1d0-acl(L))*horvic(2,L)
else if (istresstyp == 6) then
suu(L) = acl(L)*horvic3(1,L) + (1d0-acl(L))*horvic3(2,L)
endif
endif
enddo
!$OMP END PARALLEL DO
endif
else if (kmx > 0) then
if (istresstyp == 2 .or. istresstyp == 3) then ! first set stressvector in cell centers
do LL = lnx1D+1,lnx
if (abs(kcu(LL)) .ne. 2) cycle
call getLbotLtop(LL,Lb,Lt)
cs = csu(LL) ; sn = snu(LL)
if (javiusp == 1) then ! user specified part
vicc = viusp(LL)
else
vicc = vicouv
endif
do L = Lb, Lt
vicL = 0d0
k1 = ln (1,L) ; k2 = ln (2,L)
k3 = lncn(1,L) ; k4 = lncn(2,L)
duxdn = ( ucx(k2) - ucx(k1)) * dxi(LL)
duydn = ( ucy(k2) - ucy(k1)) * dxi(LL)
duxdt = (ucnx(k4) - ucnx(k3)) * wui(LL)
duydt = (ucny(k4) - ucny(k3)) * wui(LL)
if (Smagorinsky > 0 .or. NDRAW(29) == 37) then ! add Smagorinsky
dundn = cs*duxdn + sn*duydn
dutdn = -sn*duxdn + cs*duydn
dundt = cs*duxdt + sn*duydt
dutdt = -sn*duxdt + cs*duydt
if ( NDRAW(29) == 37 .and. L-Lb+1 == kplot ) then ! plot curl
plotlin(LL) = (dutdn - dundt)
endif
if (Smagorinsky > 0) then
shearvar = 2d0*(dundn*dundn + dutdt*dutdt + dundt*dutdn) + dundt*dundt + dutdn*dutdn
vicL = vicL + Smagorinsky*Smagorinsky*sqrt(shearvar)/( dxi(LL)*wui(LL) )
endif
endif
vicL = vicL + vicc
if (javiuplus3D > 0) then
vicL = vicL + vicwwu(L)
endif
dxiAu = dxi(LL)*Au(L)
if ( dxiAu.gt.0d0 ) then
vicL = min(vicL, 0.2d0*dti*min( vol1(k1) , vol1(k2) ) / dxiAu )
endif
viu(L) = max(0d0, vicL - vicc) ! limited turbulent part
c11 = cs*cs ; c12=cs*sn ; c22=sn*sn
suxL = duxdn + c11*duxdn + c12*(duydn - duxdt) - c22*duydt
suyL = duydn + c11*duxdt + c12*(duxdn + duydt) + c22*duydn
suxL = suxL*vicL/wui(LL)
suyL = suyL*vicL/wui(LL)
if (istresstyp == 3) then
hmin = min( zws(k1)-zws(k1-1), zws(k2)-zws(k2-1) )
suxL = hmin*suxL
suyL = hmin*suyL
endif
if (istresstyp >= 2) then
dvxc(k1) = dvxc(k1) + suxL ; dvyc(k1) = dvyc(k1) + suyL
dvxc(k2) = dvxc(k2) - suxL ; dvyc(k2) = dvyc(k2) - suyL
endif
enddo
enddo
endif
endif
endif
if (ihorvic > 0) then
if (istresstyp == 2 .or. istresstyp == 3 ) then
if (kmx == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2,huv)
do L = lnx1D+1,lnx
if (hu(L) > 0) then ! link will flow
k1 = ln(1,L) ; k2 = ln(2,L)
huv = 0.5d0*( hs(k1) + hs(k2) ) ! *huvli(L)
if (huv > epshu ) then
suu(L) = acl(L) *bai(k1)*( csu(L)*dvxc(k1) + snu(L)*dvyc(k1) ) + &
(1d0-acl(L))*bai(k2)*( csu(L)*dvxc(k2) + snu(L)*dvyc(k2) )
if (istresstyp == 3) then
suu(L) = suu(L) / huv
endif
endif
endif
enddo
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(LL,kb1,kb2,Lb,Lt,L,k1,k2,huv)
do LL = lnx1D+1,lnx
if (hu(LL) > 0d0) then
kb1 = ln(1,LL) ; kb2 = ln(2,LL)
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln(1,L) ; k2 = ln(2,L)
huv = 0.5d0 * ( (zws(k1)-zws(k1-1)) + (zws(k2)-zws(k2-1) ) )
if (huv > epshu) then
suu(L) = acl(LL) *bai(kb1)*( csu(LL)*dvxc(k1) + snu(LL)*dvyc(k1) ) + &
(1d0-acl(LL))*bai(kb2)*( csu(LL)*dvxc(k2) + snu(LL)*dvyc(k2) )
if (istresstyp == 3) then
suu(L) = suu(L)/huv
endif
endif
enddo
endif
enddo
!$OMP END PARALLEL DO
endif
endif
do nw = 1,mxwalls
k1 = walls(1,nw) ! waterlevel point on the inside
k3 = walls(2,nw) ! first corner
k4 = walls(3,nw) ! second corner
L1 = walls(4,nw) ! link attached to first corner
L2 = walls(5,nw) ! link attached to second corner
sf = walls(6,nw) ! ustarfactor, ustar=sf*us
cs = walls(7,nw) ! sux = -cs*ustar
sn = walls(8,nw) ! suy = -sn*ustar
wuw = walls(9,nw) ! width of wall
if (irov == 1) then ! partial slip
if (kmx == 0) then
ustar = (cs*ucx(k1) + sn*ucy(k1))*sf
walls(16,nw) = ustar
suxw = -cs*ustar*abs(ustar)*wuw*bai(k1)
suyw = -sn*ustar*abs(ustar)*wuw*bai(k1)
if (L1 .ne. 0) then
csl = csu(L1) ; snl = snu(L1) ; ac1 = walls(10,nw)
suu(L1) = suu(L1) + (csl*suxw + snl*suyw)*ac1
endif
if (L2 .ne. 0) then
csl = csu(L2) ; snl = snu(L2) ; ac2 = walls(11,nw)
suu(L2) = suu(L2) + (csl*suxw + snl*suyw)*ac2
endif
else
call getkbotktop(k1,kb,kt)
if ( L1.ne.0 ) call getLbotLtop(L1,Lb1,Lt1)
if ( L2.ne.0 ) call getLbotLtop(L2,Lb2,Lt2)
do k = kb, kt
ustar = (cs*ucx(k) + sn*ucy(k))*sf
walls(16,nw) = ustar
suxw = -cs*ustar*abs(ustar)*wuw*bai(k1)
suyw = -sn*ustar*abs(ustar)*wuw*bai(k1)
if (L1 .ne. 0) then
csl = csu(L1) ; snl = snu(L1) ; ac1 = walls(10,nw)
suu(Lb1+k-kb) = suu(Lb1+k-kb) + (csl*suxw + snl*suyw)*ac1
endif
if (L2 .ne. 0) then
csl = csu(L2) ; snl = snu(L2) ; ac2 = walls(11,nw)
suu(Lb2+k-kb) = suu(Lb2+k-kb) + (csl*suxw + snl*suyw)*ac2
endif
enddo
endif
else if (irov == 2) then ! no slip
ustar = (cs*ucx(k1) + sn*ucy(k1)) ! component parallel to wall
walls(16,nw) = 0d0
if (javiusp == 1) then
vicl = viusp(L)
else
vicl = vicouv
endif
delty = ba(k1)/wuw ! cell area / wall width is distance between internal point and mirror point
delty = 0.5d0*delty
suxw = -(cs*ustar*vicl/delty)*wuw*bai(k1)
suyw = -(sn*ustar*vicl/delty)*wuw*bai(k1)
if (L1 .ne. 0) then
csl = csu(L1) ; snl = snu(L1) ; ac1 = walls(10,nw)
suu(L1) = suu(L1) + (csl*suxw + snl*suyw)*ac1
endif
if (L2 .ne. 0) then
csl = csu(L2) ; snl = snu(L2) ; ac2 = walls(11,nw)
suu(L2) = suu(L2) + (csl*suxw + snl*suyw)*ac2
endif
else if (irov == 0) then ! free slip
walls(16,nw) = cs*ucx(k1) + sn*ucy(k1)
endif
enddo
if ( izbndpos.eq.0 ) then
do L = lnxi+1,lnx ! quick fix for open boundaries
suu(L) = 2d0*suu(L)
enddo
end if
adve = adve - suu
endif
call klok(cpuumod(2)) ; cpuumod(3) = cpuumod(3) + cpuumod(2) - cpuumod(1)
end subroutine setumod
subroutine setucxucyucxuucyu()
use m_flowgeom
use m_flow
use m_sobekdfm
implicit none
integer :: L, KK, k1, k2, k, nw, Lb, Lt, LL, nn, n, kt,kb, kbk, k2k
integer :: itpbn
double precision :: uu, vv, uucx, uucy, wcxu, wcyu, cs, sn, adx, ac1, ac2, wuw, hdx, hul, dzz, uin, dudn
ucxq = 0d0 ; ucyq = 0d0 ! zero arrays
ucx = 0d0 ; ucy = 0d0
if (kmx < 1) then ! original 2D coding
do L = 1,lnx1D
if (u1(L) .ne. 0d0 .and. kcu(L) .ne. 3) then ! link flows ; in 2D, the loop is split to save kcu check in 2D
k1 = ln(1,L) ; k2 = ln(2,L)
wcxu = wcx1(L)*u1(L)
ucx (k1) = ucx (k1) + wcxu
ucxq (k1) = ucxq (k1) + wcxu*hu(L)
wcyu = wcy1(L)*u1(L)
ucy (k1) = ucy (k1) + wcyu
ucyq (k1) = ucyq (k1) + wcyu*hu(L)
wcxu = wcx2(L)*u1(L)
ucx (k2) = ucx (k2) + wcxu
ucxq (k2) = ucxq (k2) + wcxu*hu(L)
wcyu = wcy2(L)*u1(L)
ucy (k2) = ucy (k2) + wcyu
ucyq (k2) = ucyq (k2) + wcyu*hu(L)
endif
enddo
do L = lnx1D + 1,lnx
if (u1(L) .ne. 0d0) then ! link flows
k1 = ln(1,L) ; k2 = ln(2,L)
wcxu = wcx1(L)*u1(L)
ucx (k1) = ucx (k1) + wcxu
ucxq (k1) = ucxq (k1) + wcxu*hu(L)
wcyu = wcy1(L)*u1(L)
ucy (k1) = ucy (k1) + wcyu
ucyq (k1) = ucyq (k1) + wcyu*hu(L)
wcxu = wcx2(L)*u1(L)
ucx (k2) = ucx (k2) + wcxu
ucxq (k2) = ucxq (k2) + wcxu*hu(L)
wcyu = wcy2(L)*u1(L)
ucy (k2) = ucy (k2) + wcyu
ucyq (k2) = ucyq (k2) + wcyu*hu(L)
endif
enddo
! if (jased > 0 .or. ti_waq > 0) then !TODO: AvD: are we going to keep all these tau-components, or average at cell center directly?
!taucx(ln(1,L)) = taucx(ln(1,L)) + wcx1(L)*tauu(L)
!taucy(ln(1,L)) = taucy(ln(1,L)) + wcy1(L)*tauu(L)
!taucx(ln(2,L)) = taucx(ln(2,L)) + wcx2(L)*tauu(L)
!taucx(ln(2,L)) = taucx(ln(2,L)) + wcy2(L)*tauu(L)
! endif
else
do LL = 1,lnx
Lb = Lbot(LL) ; Lt = Lb - 1 + kmxL(LL)
do L = Lb, Lt
if (u1(L) .ne. 0d0) then ! link flows
k1 = ln(1,L)
k2 = ln(2,L)
huL = hu(L)
if (L>Lbot(LL)) then
huL = huL - hu(L-1)
endif
ucx (k1) = ucx (k1) + wcx1(LL)*u1(L)
ucxq(k1) = ucxq(k1) + wcx1(LL)*u1(L)*huL
ucy (k1) = ucy (k1) + wcy1(LL)*u1(L)
ucyq(k1) = ucyq(k1) + wcy1(LL)*u1(L)*huL
ucx (k2) = ucx (k2) + wcx2(LL)*u1(L)
ucxq(k2) = ucxq(k2) + wcx2(LL)*u1(L)*huL
ucy (k2) = ucy (k2) + wcy2(LL)*u1(L)
ucyq(k2) = ucyq(k2) + wcy2(LL)*u1(L)*huL
endif
enddo
enddo
endif
if (kmx < 1) then ! original 2D coding
!$OMP PARALLEL DO &
!$OMP PRIVATE(k)
do k = 1,ndxi
if (hs(k) > 0d0) then
ucxq(k) = ucxq(k)/hs(k)
ucyq(k) = ucyq(k)/hs(k)
if (iperot == 2) then
ucx (k) = ucxq(k)
ucy (k) = ucyq(k)
endif
endif
enddo
!$OMP END PARALLEL DO
else
do nn = 1,ndxi
if (hs(nn) > 0d0) then
kb = kbot(nn)
kt = ktop(nn)
ucxq(nn) = sum(ucxq(kb:kt)) / hs(nn) ! Depth-averaged cell center velocity in 3D, based on ucxq
ucyq(nn) = sum(ucyq(kb:kt)) / hs(nn)
do k = kb,kt
dzz = zws(k) - zws(k-1)
if (dzz > 0) then
ucxq(k) = ucxq(k)/dzz
ucyq(k) = ucyq(k)/dzz
endif
if (iperot == 2) then
ucx(k) = ucxq(k)
ucy(k) = ucyq(k)
endif
enddo
endif
enddo
endif
do n = 1, nbndz ! waterlevel boundaries
kb = kbndz(1,n)
k2 = kbndz(2,n)
LL = kbndz(3,n)
itpbn = kbndz(4,n)
cs = csu(LL) ; sn = snu(LL)
if (kmx == 0) then
if ( jacstbnd.eq.0 .and. itpbn.ne.2 ) then ! Neumann: always
uin = ucx(k2)*cs + ucy(k2)*sn
ucx(kb) = uin*cs ; ucy(kb) = uin*sn
else
ucx(kb) = ucx(k2)
ucy(kb) = ucy(k2)
end if
else
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
kbk = ln(1,L) ; k2k = ln(2,L)
if ( jacstbnd.eq.0 .and. itpbn.ne.2 ) then
uin = ucx(k2k)*cs + ucy(k2k)*sn
ucx(kbk) = uin*cs ; ucy(kbk) = uin*sn
else
ucx(kbk) = ucx(k2k)
ucy(kbk) = ucy(k2k)
end if
enddo
endif
enddo
do n = 1,nbndu ! velocity boundaries
kb = kbndu(1,n)
k2 = kbndu(2,n)
LL = kbndu(3,n)
cs = csu(LL) ; sn = snu(LL)
if (kmx == 0) then
if ( jacstbnd.eq.0 ) then
uin = ucx(k2)*cs + ucy(k2)*sn
ucx(kb) = uin*cs ; ucy(kb) = uin*sn
else
ucx(kb) = ucx(k2)
ucy(kb) = ucy(k2)
end if
else
do k = 1, kmxL(LL)
kbk = kbot(kb) - 1 + min(k,kmxn(kb))
k2k = kbot(k2) - 1 + min(k,kmxn(k2))
if ( jacstbnd.eq.0 ) then
uin = ucx(k2k)*cs + ucy(k2k)*sn
ucx(kbk) = uin*cs ; ucy(kbk) = uin*sn
else
ucx(kbk) = ucx(k2k)
ucy(kbk) = ucy(k2k)
end if
enddo
endif
enddo
do n = 1, nbndt ! todo3d ! tangential velocity boundaries, override other types
kb = kbndt(1,n)
k2 = kbndt(2,n)
LL = kbndt(3,n)
cs = csu(LL) ; sn = snu(LL)
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
kbk = ln(1,L)
uu = u0(L) ; vv = zbndt(n) ! v(L)
uucx = uu*cs - vv*sn
uucy = uu*sn + vv*cs
ucx(kbk) = uucx ; ucy(kbk) = uucy
enddo
enddo
do n = 1, nbnduxy ! do3d ! uxuy velocity boundaries, override other types
kb = kbnduxy(1,n)
LL = kbnduxy(3,n)
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
kbk = ln(1,L)
ucx(kbk) = zbnduxy(2*n-1) ; ucy(kbk) = zbnduxy(2*n)
enddo
enddo
do n = 1, nbndn ! normal velocity boundaries, override other types
kb = kbndn(1,n)
k2 = kbndn(2,n)
LL = kbndn(3,n)
cs = csu(LL) ; sn = snu(LL)
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
kbk = ln(1,L)
uu = zbndn(n) ; vv = 0d0
uucx = uu*cs - vv*sn !
uucy = uu*sn + vv*cs
ucx(kbk) = uucx ; ucy(kbk) = uucy
enddo
enddo
do n=1,nbnd1d2d
kb = kbnd1d2d(1,n)
k2 = kbnd1d2d(2,n)
if (kmx == 0) then ! 2D
ucx(kb) = ucx(k2)
ucy(kb) = ucy(k2)
else ! 3D
endif
end do
if (limtypmom == 6) then
ducdx = 0d0; ducdy = 0d0
do LL = 1,lnx
Lb = Lbot(LL) ; Lt = Lb - 1 + kmxL(LL)
do L = Lb, Lt
k1 = ln(1,L)
k2 = ln(2,L)
dudn = dxi(LL)*( csu(LL)*(ucx(k2) - ucx(k1)) + snu(LL)*(ucy(k2) - ucy(k1)) )
ducdx(k1) = ducdx(k1) + wcx1(LL)*dudn
ducdy(k1) = ducdy(k1) + wcy1(LL)*dudn
ducdx(k2) = ducdx(k2) + wcx2(LL)*dudn
ducdy(k2) = ducdy(k2) + wcy2(LL)*dudn
enddo
enddo
endif
if (kmx < 1) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L)
do L = 1,lnx
if (qa(L) > 0) then ! set upwind ucxu, ucyu on links
ucxu(L) = ucx(ln(1,L))
ucyu(L) = ucy(ln(1,L))
else if (qa(L) < 0) then
ucxu(L) = ucx(ln(2,L))
ucyu(L) = ucy(ln(2,L))
else
ucxu(L) = 0d0
ucyu(L) = 0d0
endif
enddo
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(LL,L,Lb,Lt)
do LL = 1,lnx
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
if (qa(L) > 0) then ! set upwind ucxu, ucyu on links
ucxu(L) = ucx(ln(1,L))
ucyu(L) = ucy(ln(1,L))
if (jarhoxu > 0) then
ucxu(L) = ucxu(L)*rho(ln(1,L))
ucyu(L) = ucyu(L)*rho(ln(1,L))
endif
else if (qa(L) < 0) then
ucxu(L) = ucx(ln(2,L))
ucyu(L) = ucy(ln(2,L))
if (jarhoxu > 0) then
ucxu(L) = ucxu(L)*rho(ln(2,L))
ucyu(L) = ucyu(L)*rho(ln(2,L))
endif
else
ucxu(L) = 0d0
ucyu(L) = 0d0
endif
enddo
enddo
!$OMP END PARALLEL DO
endif
end subroutine setucxucyucxuucyu
subroutine setucxucyeuler()
use m_flowgeom
use m_flow
use m_waves, only: Mxwav, Mywav
implicit none
integer :: i
double precision :: u1l
do i = 1,ndx
if (hs(i) > epshu) then
workx(i) = workx(i) - Mxwav(i)/hs(i)
worky(i) = worky(i) - Mywav(i)/hs(i)
endif
enddo
end subroutine setucxucyeuler
!> Update the cumulative waq fluxes for the just set timestep.
!!
!! Should be called at the end of each computational timestep.
!! I.e., at time1, after a step dts with the new fluxes in q1.
!! In the waq-output, the cumulative values should be divided
!! by ti_waq, as the cumulative values are multiplied by each
!! timestep dts (necessary because of non-constant timestep).
subroutine update_waqfluxes()
use waq
use m_flow
use m_flowgeom
use m_flowtimes
implicit none
integer :: L, k, isrc, ip, kmxnxa2
integer :: k1, kk1, kmax1, ktx1, kb1
integer :: k2, kk2, kmax2, ktx2, kb2
if (int(ti_waq) <= 0) then ! No waq output necessary
return
end if
do L = 1,lnkx
q1waq(L) = q1waq(L) + dts*q1(L) ! (teta(L)*q1(L) + (1d0-teta(L))*q0(L))
end do
if(kmx > 1) then
do k = ndx + 1,ndkx
qwwaq(k) = qwwaq(k) + dts*qw(k) ! (teta(k)*qw(k) + (1d0-teta(k))*q0(k))
end do
end if
if (numsrc > 0) then
do isrc = 1, numsrc
if (waqpar%kmxnxa == 1) then
qsrcwaq(isrc) = qsrcwaq(isrc) + dts*qsrc(isrc)
else
kk1 = ksrc(1,isrc)
k1 = ksrc(2,isrc) - kbot(kk1) + 1 ! 2, 3 are now kb,kt resp.
kk2 = ksrc(4,isrc)
k2 = ksrc(5,isrc) - kbot(kk2) + 1
kmxnxa2 = waqpar%kmxnxa
if (kk1 > 0) then
call getkbotktopmax(kk1,kb1,ktx1)
kmax1 = ktx1 - kb1 + 1
else
kmax1 = 1
kmxnxa2 = 1
endif
if (kk2 > 0) then
call getkbotktopmax(kk2,kb2,ktx2)
kmax2 = ktx2 - kb2 + 1
else
kmax2 = 1
endif
if (waqpar%aggrel == 1) then
ip = ksrcwaq(isrc) + (waqpar%ilaggr(kmax1 - k1 + 1)) + kmxnxa2 * (waqpar%ilaggr(kmax2 - k2 + 1) - 1)
else
ip = ksrcwaq(isrc) + (kmax1 - k1 + 1) + kmxnxa2 * (kmax2 - k2 + 1 - 1)
endif
qsrcwaq(ip) = qsrcwaq(ip) + dts*qsrc(isrc)
endif
enddo
end if
end subroutine update_waqfluxes
subroutine setlinktocenterweights() ! set center related linkxy weights
use m_flow
use m_netw
use m_flowgeom
implicit none
double precision :: wud, wuL, wuk, cs, sn
integer :: k, L, ierr
integer :: k1, k2, k3, k4, nn, LL, jaclosedcorner
double precision, allocatable :: wcxy (:,:) ! center weight factors (2,ndx) , only for normalising
double precision, allocatable :: wc (:) ! center weight factors (ndx) , only for normalising
if ( allocated (wcx1) ) deallocate(wcx1,wcy1,wcx2,wcy2)
if ( allocated (wcxy ) ) deallocate(wcxy )
if ( allocated (wcL ) ) deallocate(wcL )
allocate ( wcx1(lnx) , stat = ierr) ; wcx1 = 0
call aerr('wcx1(lnx)', ierr, lnx)
allocate ( wcy1(lnx) , stat = ierr) ; wcy1 = 0
call aerr('wcy1(lnx)', ierr, lnx)
allocate ( wcx2(lnx) , stat = ierr) ; wcx2 = 0
call aerr('wcx2(lnx)', ierr, lnx)
allocate ( wcy2(lnx) , stat = ierr) ; wcy2 = 0
call aerr('wcy2(lnx)', ierr, lnx)
allocate ( wcxy (2,ndx) , stat = ierr) ; wcxy = 0
call aerr('wcxy (2,ndx)', ierr, 2*ndx)
allocate ( wcL (2,Lnx) , stat = ierr) ; wcL = 0
call aerr('wcL (2,Lnx)', ierr, 2*Lnx)
allocate ( wc (ndx) , stat = ierr) ; wc = 0
call aerr('wc (ndx)', ierr, ndx)
do L = 1, lnx
if (kcu(L) == 3) cycle ! no contribution from internal 1D2D links
k1 = ln(1,L) ; k2 = ln(2,L)
wud = wu(L)*dx(L)
cs = csu(L)
sn = snu(L)
wuL = acl(L)*wud
wcL (1,L ) = wuL
wc (k1) = wc(k1) + wuL
wcx1(L) = cs*wuL
wcy1(L) = sn*wuL
wcxy (1,k1) = wcxy (1,k1) + abs(wcx1(L))
wcxy (2,k1) = wcxy (2,k1) + abs(wcy1(L))
wuL = (1d0-acl(L))*wud
wcL (2, L) = wuL
wc (k2) = wc(k2) + wuL
wcx2(L) = cs*wuL
wcy2(L) = sn*wuL
wcxy (1,k2) = wcxy (1,k2) + abs(wcx2(L))
wcxy (2,k2) = wcxy (2,k2) + abs(wcy2(L))
enddo
do L = 1, lnx
k1 = ln(1,L) ; k2 = ln(2,L)
if (iabs(kcu(L)) == 2 .or. iabs(kcu(L)) == 4) then ! 2D links, 1D2D links
IF (kfs(K1) == 0) THEN ! kfs temporarily used as cutcell flag, set in cutcelwu
wcx1(L) = wcx1(L)*bai(k1)
wcy1(L) = wcy1(L)*bai(k1)
ELSE
if (wcxy(1,k1) .ne. 0) wcx1(L) = wcx1(L)/wcxy(1,k1)
if (wcxy(2,k1) .ne. 0) wcy1(L) = wcy1(L)/wcxy(2,k1)
ENDIF
IF (kfs(K2) == 0) THEN
wcx2(L) = wcx2(L)*bai(k2)
wcy2(L) = wcy2(L)*bai(k2)
ELSE
if (wcxy(1,k2) .ne. 0) wcx2(L) = wcx2(L)/wcxy(1,k2)
if (wcxy(2,k2) .ne. 0) wcy2(L) = wcy2(L)/wcxy(2,k2)
ENDIF
else
wcx1(L) = wcx1(L)*bai(k1) !if (wcxy(2,k1) .ne. 0) /wcxy(2,k1)
wcy1(L) = wcy1(L)*bai(k1) !if (wcxy(1,k1) .ne. 0) /wcxy(1,k1)
wcx2(L) = wcx2(L)*bai(k2) !if (wcxy(2,k2) .ne. 0) /wcxy(2,k2)
wcy2(L) = wcy2(L)*bai(k2) !if (wcxy(1,k2) .ne. 0) /wcxy(1,k2)
endif
if (wc(k1) > 0d0) wcL(1,L) = wcL(1,L) / wc(k1)
if (wc(k2) > 0d0) wcL(2,L) = wcL(2,L) / wc(k2)
enddo
deallocate (wcxy, wc)
kfs = 0
end subroutine setlinktocenterweights
subroutine setlinktocornerweights() ! set corner related link x- and y weights
use m_flow
use m_netw
use m_flowgeom
implicit none
double precision :: ax, ay, wuL, wud, csa, sna
integer :: k, L, ierr, nx
integer :: k1, k2, k3, k4
integer :: jacomp=1
double precision :: ff = 5d0
integer :: ka, kb, LL
double precision, allocatable :: wcnxy (:,:) ! corner weight factors (2,numk) , only for normalising
integer, dimension(:), allocatable :: jacorner ! corner node (1) or not (0), dim(numk)
if ( allocated (wcnx3) ) deallocate(wcnx3,wcny3,wcnx4,wcny4)
if ( allocated (wcnxy ) ) deallocate(wcnxy )
allocate ( wcnx3(lnx) , stat = ierr) ; wcnx3 = 0
call aerr('wcnx3(lnx) ', ierr, lnx)
allocate ( wcny3(lnx) , stat = ierr) ; wcny3 = 0
call aerr('wcny3(lnx) ', ierr, lnx)
allocate ( wcnx4(lnx) , stat = ierr) ; wcnx4 = 0
call aerr('wcnx4(lnx) ', ierr, lnx)
allocate ( wcny4(lnx) , stat = ierr) ; wcny4 = 0
call aerr('wcny4(lnx) ', ierr, lnx)
nx = 0
do L = lnx1D+1, lnx
k3 = lncn(1,L) ; k4 = lncn(2,L)
nx = max(nx,k3,k4)
enddo
allocate ( wcnxy (3,numk) , stat = ierr) ; wcnxy = 0
call aerr('wcnxy (3,numk)', ierr, 3*numk)
allocate( jacorner(numk), stat=ierr)
jacorner = 0
call aerr('jacorner(numk)', ierr, numk)
do L = lnx1D+1, lnx
if (abs(kcu(L)) == 1) then
cycle
endif
k3 = lncn(1,L) ; k4 = lncn(2,L)
wcnxy(3,k3)= wcnxy(3,k3) + 1
wcnxy(3,k4)= wcnxy(3,k4) + 1
wud = wu(L)*dx(L)
csa = max( 1d-6,abs(csu(L)) )
sna = max( 1d-6,abs(snu(L)) )
wuL = acn(1,L)*wud
if (jacomp == 1) then
ax = csa*wuL
ay = sna*wuL
else
ax = 0.5d0*wuL
ay = ax
endif
wcnx3(L) = ax
wcny3(L) = ay
wcnxy(1,k3) = wcnxy (1,k3) + ax
wcnxy(2,k3) = wcnxy (2,k3) + ay
wuL = acn(2,L)*wud
if (jacomp == 1) then
ax = csa*wuL
ay = sna*wuL
else
ax = 0.5d0*wuL
ay = ax
endif
wcnx4(L) = ax
wcny4(L) = ay
wcnxy (1,k4) = wcnxy (1,k4) + ax
wcnxy (2,k4) = wcnxy (2,k4) + ay
enddo
! count number of attached and closed boundary links, and store it temporarily in jacorner
jacorner = 0
do L=1,numL
if ( ( kn(3,L).eq.2 .and. lnn(L).eq.1 .and. lne2ln(L).le.0 ) ) then
k1 = kn(1,L)
k2 = kn(2,L)
jacorner(k1) = jacorner(k1) + 1
jacorner(k2) = jacorner(k2) + 1
end if
end do
! post-process corner indicator: use ALL boundary nodes, and project on closed boundary later
! used to be: nmk(k) - int(wcnxy (3,k)) == 2
do k=1,numk
if ( jacorner(k).ge.1 ) then
jacorner(k) = 1
else
jacorner(k) = 0
end if
end do
! exclude all nodes with a disabled netlink attached from the projection
do L=1,numL
if ( kn(3,L).eq.0 ) then
k1 = kn(1,L)
k2 = kn(2,L)
jacorner(k1) = 0
jacorner(k2) = 0
end if
end do
do L = lnx1D+1, lnx
if (abs(kcu(L)) == 1) cycle
k3 = lncn(1,L) ; k4 = lncn(2,L)
if (wcnxy(1,k3) .ne. 0) wcnx3(L) = wcnx3(L)/wcnxy(1,k3)
if (wcnxy(2,k3) .ne. 0) wcny3(L) = wcny3(L)/wcnxy(2,k3)
if (wcnxy(1,k4) .ne. 0) wcnx4(L) = wcnx4(L)/wcnxy(1,k4)
if (wcnxy(2,k4) .ne. 0) wcny4(L) = wcny4(L)/wcnxy(2,k4)
if (irov == 2) then ! zero cornervelocities for no-slip
if (int(wcnxy (3,k3)) .ne. nmk(k3) ) then
wcnx3(L) = 0d0 ; wcny3(L) = 0d0
endif
if (int(wcnxy (3,k4)) .ne. nmk(k4) ) then
wcnx4(L) = 0d0 ; wcny4(L) = 0d0
endif
endif
enddo
nrcnw = 0
do k = 1,numk ! set up admin for corner velocity alignment at closed walls
! if ( nmk(k) - int(wcnxy (3,k)) == 2 ) then ! two more netlinks than flowlinks to this corner
if ( jacorner(k).eq.1 ) then
nrcnw = nrcnw + 1 ! cnw = cornerwall point (netnode)
endif
enddo
if ( allocated (cscnw) ) deallocate(cscnw,sncnw,kcnw,nwalcnw,sfcnw)
allocate ( cscnw(nrcnw) , stat = ierr) ; cscnw = 0
call aerr('cscnw(nrcnw)', ierr, nrcnw )
allocate ( sncnw(nrcnw) , stat = ierr) ; sncnw = 0
call aerr('sncnw(nrcnw)', ierr, nrcnw )
allocate ( kcnw(nrcnw) , stat = ierr) ; kcnw = 0
call aerr(' kcnw(nrcnw)', ierr, nrcnw )
allocate ( nwalcnw(2,nrcnw) , stat = ierr) ; nwalcnw = 0
call aerr(' nwalcnw(2,nrcnw)', ierr, 2*nrcnw )
allocate ( sfcnw(nrcnw) , stat = ierr) ; sfcnw = 0
call aerr(' sfcnw(nrcnw)', ierr, nrcnw)
nrcnw = 0
do k = 1,numk ! set up admin for corner velocity alignment at closed walls
! if ( nmk(k) - int(wcnxy (3,k)) == 2 ) then ! two more netlinks than flowlinks to this corner
if ( jacorner(k).eq.1 ) then
nrcnw = nrcnw + 1 ! cnw = cornerwall point (netnode)
kcnw(nrcnw) = k
ka = 0 ; kb = 0
do LL = 1,nmk(k)
L = nod(k)%lin(LL) ! netstuff
if (lnn(L) == 1) then
if (ka == 0) then
if ( lne2ln(L).le.0 .and. kn(3,L).ne.0 ) then ! SPvdP: closed boundaries used in determination of normal vector only
call othernode(k,L,ka) ! use other node on closed boundary
else
ka = k ! use own node on open boundary
endif
else if (kb == 0 .and. kn(3,L).ne.0 ) then
if ( lne2ln(L).le.0 ) then ! SPvdP: closed boundaries used in determination of normal vector only
call othernode(k,L,kb) ! use other node on closed boundary
else
kb = k ! use own node on closed boundary
endif
endif
endif
enddo
if (ka .ne. 0 .and. kb .ne. 0 .and. ka.ne.kb ) then ! only for 2D netnodes
call normalin(xk(ka), yk(ka), xk(kb), yk(kb), csa, sna )
cscnw(nrcnw) = csa
sncnw(nrcnw) = sna
endif
endif
enddo
deallocate (wcnxy, acn, jacorner)
end subroutine setlinktocornerweights
subroutine setcornervelocities() ! set corner related velocity x- and y components
use m_flow
use m_netw
use m_flowgeom
implicit none
integer :: L, k1, k2, k3, k4, k, kk, LL, Lb, Lt, kw
double precision :: uLx, uLy, csk, snk, sg
ucnx = 0 ; ucny = 0
if (kmx == 0) then
do L = lnx1D+1,lnx
k1 = ln (1,L) ; k2 = ln (2,L)
k3 = lncn(1,L) ; k4 = lncn(2,L)
uLx = 0.5d0*( ucx(k1) + ucx(k2) )
uLy = 0.5d0*( ucy(k1) + ucy(k2) )
ucnx(k3) = ucnx(k3) + uLx*wcnx3(L)
ucny(k3) = ucny(k3) + uLy*wcny3(L)
ucnx(k4) = ucnx(k4) + uLx*wcnx4(L)
ucny(k4) = ucny(k4) + uLy*wcny4(L)
enddo
do kw = 1, nrcnw ! cornervelocities aligned with closed walls
csk = cscnw(kw)
snk = sncnw(kw)
k = kcnw (kw)
sg = csk*ucnx(k) + snk*ucny(k)
ucnx(k) = sg*csk
ucny(k) = sg*snk
enddo
else
do LL = lnx1D+1,lnx
if (abs(kcu(LL)) == 2) then
call getLbotLtop(LL,Lb, Lt)
do L = Lb,Lt
k1 = ln (1,L) ; k2 = ln (2,L)
k3 = lncn(1,L) ; k4 = lncn(2,L)
uLx = 0.5d0*( ucx(k1) + ucx(k2) )
uLy = 0.5d0*( ucy(k1) + ucy(k2) )
ucnx(k3) = ucnx(k3) + uLx*wcnx3(LL)
ucny(k3) = ucny(k3) + uLy*wcny3(LL)
ucnx(k4) = ucnx(k4) + uLx*wcnx4(LL)
ucny(k4) = ucny(k4) + uLy*wcny4(LL)
enddo
endif
enddo
do kw = 1, nrcnw ! cornervelocities aligned with closed walls
kk = kcnw (kw)
csk = cscnw(kw)
snk = sncnw(kw)
do k = kbotc(kk), kbotc(kk) + kmxc(kk) - 1
sg = csk*ucnx(k) + snk*ucny(k)
ucnx(k) = sg*csk
ucny(k) = sg*snk
enddo
enddo
endif
end subroutine setcornervelocities
subroutine linkstocenters(vnod,vlin) ! set flow node value based on flow link values scalar
use m_flow
use m_netw
use m_flowgeom
implicit none
double precision :: vlin(lnkx)
real :: vnod(ndkx)
integer :: L, k1, k2, LL, Lb, Lt, kk, kb, kt, k
vnod = 0d0
if (kmx == 0) then
do L = 1,lnx
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(k1) = vnod(k1) + vlin(L)*wcL(1,L)
vnod(k2) = vnod(k2) + vlin(L)*wcL(2,L)
enddo
else
do LL = 1,lnx
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(k1) = vnod(k1) + vlin(L)*wcL(1,LL)
vnod(k2) = vnod(k2) + vlin(L)*wcL(2,LL)
enddo
enddo
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,kb,kt,k)
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kt+1, kb+kmxn(kk)-1
vnod(k) = vnod(kt)
enddo
enddo
!$OMP END PARALLEL DO
endif
end subroutine linkstocenters
subroutine linkstocenterstwodoubles(vnod,vlin) ! set flow node value based on flow link values scalar
use m_flow
use m_netw
use m_flowgeom
implicit none
double precision :: vlin(lnkx)
double precision :: vnod(ndkx)
integer :: L, k1, k2, LL, Lb, Lt, kk, kb, kt, k
vnod = 0d0
if (kmx == 0) then
do L = 1,lnx
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(k1) = vnod(k1) + vlin(L)*wcL(1,L)
vnod(k2) = vnod(k2) + vlin(L)*wcL(2,L)
enddo
else
do LL = 1,lnx
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(k1) = vnod(k1) + vlin(L)*wcL(1,LL)
vnod(k2) = vnod(k2) + vlin(L)*wcL(2,LL)
enddo
enddo
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,kb,kt,k)
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kt+1, kb+kmxn(kk)-1
vnod(k) = vnod(kt)
enddo
enddo
!$OMP END PARALLEL DO
endif
end subroutine linkstocenterstwodoubles
subroutine linkstocenterstwodoubles2(vnod,vlin,vlin2) ! both vlin and vlin2 to vnod(1,* and vnod(2,*
use m_flow
use m_netw
use m_flowgeom
implicit none
double precision :: vlin(lnkx), vlin2(lnkx)
double precision :: vnod(2,ndkx)
integer :: L, k1, k2, LL, Lb, Lt, kk, kb, kt, k
vnod = 0d0
if (kmx == 0) then
do L = 1,lnx
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(1,k1) = vnod(1,k1) + vlin (L)*wcL(1,L)
vnod(1,k2) = vnod(1,k2) + vlin (L)*wcL(2,L)
vnod(2,k1) = vnod(2,k1) + vlin2(L)*wcL(1,L)
vnod(2,k2) = vnod(2,k2) + vlin2(L)*wcL(2,L)
enddo
else
do LL = 1,lnx
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln (1,L) ; k2 = ln (2,L)
vnod(1,k1) = vnod(1,k1) + vlin (L)*wcL(1,LL)
vnod(1,k2) = vnod(1,k2) + vlin (L)*wcL(2,LL)
vnod(2,k1) = vnod(2,k1) + vlin2(L)*wcL(1,LL)
vnod(2,k2) = vnod(2,k2) + vlin2(L)*wcL(2,LL)
enddo
enddo
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,kb,kt,k)
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kt+1, kb+kmxn(kk)-1
vnod(1,k) = vnod(1,kt)
vnod(2,k) = vnod(2,kt)
enddo
enddo
!$OMP END PARALLEL DO
endif
end subroutine linkstocenterstwodoubles2
double precision function horvic(n12,L) ! horizontal viscosity term
use m_flow
use m_flowgeom
use m_missing
implicit none
integer :: L ! in direction of link L
integer :: n12 ! find hor visc term for cell 1 or 2
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, k1, k2, k3, k4, isig ! relevant node, 1 or 2
double precision :: cs, sn, csL, snL
double precision :: duxdn, duydn, duxdt, duydt, txx, tyy, c11,c12,c22, vicl
horvic = 0d0
csL = csu(L) ; snL = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if (LLLL .ne. L) then
if (LLL < 0) then
cs = csu(LLLL)
sn = snu(LLLL)
k1 = ln (1,LLLL) ; k2 = ln (2,LLLL)
k3 = lncn(1,LLLL) ; k4 = lncn(2,LLLL)
else
cs = -csu(LLLL)
sn = -snu(LLLL)
k1 = ln (2,LLLL) ; k2 = ln (1,LLLL)
k3 = lncn(2,LLLL) ; k4 = lncn(1,LLLL)
endif
duxdn = ( ucx(k2) - ucx(k1)) * dxi(LLLL)
duydn = ( ucy(k2) - ucy(k1)) * dxi(LLLL)
duxdt = (ucnx(k4) - ucnx(k3)) * wui(LLLL)
duydt = (ucny(k4) - ucny(k3)) * wui(LLLL)
c11 = cs*cs ; c12=cs*sn ; c22=sn*sn
txx = duxdn + c11*duxdn + c12*(duydn - duxdt) - c22*duydt
tyy = duydn + c11*duxdt + c12*(duxdn + duydt) + c22*duydn
if (javiusp == 1) then
vicl = viusp(LLLL)
else
vicl = vicouv
endif
if (istresstyp == 4) then
horvic = horvic + ( txx*csl + tyy*snl )*wu(LLLL)*vicL
else if (istresstyp == 5) then ! volume averaged
horvic = horvic + ( txx*csl + tyy*snl )*au(LLLL)*vicL
endif
endif
enddo
horvic = horvic*bai(k12)
if (istresstyp == 5) then ! volume averaged
horvic = horvic / hs(k12)
endif
end function Horvic
double precision function horvic3(n12,L) ! horizontal viscosity term, out of face normal and tang comp's
use m_flow
use m_flowgeom
use m_missing
implicit none
integer :: L ! in direction of link L
integer :: n12 ! find hor visc term for cell 1 or 2
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, k1, k2, k3, k4, isig ! relevant node, 1 or 2
double precision :: cs, sn, csL, snL, vicl
double precision :: duxdn, duydn, duxdt, duydt, txx, tyy, c, s, cs2
double precision :: uuk1, vvk1, uuk2, vvk2, uuk3, uuk4, dux, duy, dvx, tuu, tvv
horvic3 = 0d0
csL = csu(L) ; snL = snu(L)
k12 = ln(n12,L)
vicL = vicouv
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if (LLLL .ne. L) then
if (LLL < 0) then
cs = csu(LLLL)
sn = snu(LLLL)
k1 = ln (1,LLLL) ; k2 = ln (2,LLLL)
k3 = lncn(1,LLLL) ; k4 = lncn(2,LLLL)
else
cs = -csu(LLLL)
sn = -snu(LLLL)
k1 = ln (2,LLLL) ; k2 = ln (1,LLLL)
k3 = lncn(2,LLLL) ; k4 = lncn(1,LLLL)
endif
uuk1 = cs* ucx(k1) + sn* ucy(k1)
vvk1 = -sn* ucx(k1) + cs* ucy(k1)
uuk2 = cs* ucx(k2) + sn* ucy(k2)
vvk2 = -sn* ucx(k2) + cs* ucy(k2)
dux = (uuk2 - uuk1)*dxi(LLLL)
dvx = (vvk2 - vvk1)*dxi(LLLL)
uuk3 = cs*ucnx(k3) + sn*ucny(k3)
uuk4 = cs*ucnx(k4) + sn*ucny(k4)
duy = (uuk4 - uuk3)*wui(LLLL)
tuu = dux + dux
tvv = duy + dvx
txx = tuu*cs - tvv*sn
tyy = tuu*sn + tvv*cs
if (javiusp == 1) then
vicl = viusp(LLLL)
else
vicl = vicouv
endif
horvic3 = horvic3 + ( txx*csl + tyy*snl )*wu(LLLL)*vicL
endif
enddo
horvic3 = horvic3*bai(k12)
end function Horvic3
Subroutine setvelocityfield()
use m_flow
use m_flowgeom
implicit none
integer :: k,k1,k2,L
double precision :: xx,yy,ux,uy,yyy,uuu, ykmx
uy = -0.5d0
ux = 0.5d0*sqrt(3d0)
ykmx = 100d0 ! 0d0
do k = 1,ndx
xx = xz(k)
yy = yz(k) ! ykmx - yz(k)
if (iuvfield == 1) then ! kwadratic horizontal
ucx(k) = yy*yy
ucy(k) = 0
else if (iuvfield == 2) then ! kwadratic 30 degrees
yyy = -uy*xx + ux*yy
uuu = yyy*yyy
ucx(k) = uuu*ux
ucy(k) = uuu*uy
else if (iuvfield == 3) then ! circular
ucx(k) = -yy
ucy(k) = xx
else if (iuvfield == 4) then ! linear horizontal
ucx(k) = yy
ucy(k) = 0
else if (iuvfield == 5) then ! linear 30 degrees
yyy = -uy*xx + ux*yy
uuu = yyy
ucx(k) = uuu*ux
ucy(k) = uuu*uy
else if (iuvfield == 6) then ! random
ucx(k) = 2 + sin(0.1d0*k)
ucy(k) = cos(1.5d0*k)
endif
enddo
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
u1(L) = ( (1d0-acl(L))*ucx(k1) + acl(L)*ucx(k2) )*csu(L) + & ! reversed acl weighting
( (1d0-acl(L))*ucy(k1) + acl(L)*ucy(k2) )*snu(L)
enddo
u0 = u1
s0 = s1
call setcornervelocities()
end subroutine setvelocityfield
double precision function QucWen(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucWen = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0 .or. L == LLLL) then ! skip, this is link L itself
else
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)
if (LLL > 0) then ! incoming link
QucWen = QucWen - qa(LLLL)*ucin
else
QucWen = QucWen + qa(LLLL)*ucin
endif
endif
enddo
end function QucWen
double precision function QucPer(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 , kup ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucPer = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)
if (LLL > 0) then ! incoming link
QucPer = QucPer - qa(LLLL)*ucin
else
QucPer = QucPer + qa(LLLL)*ucin
endif
endif
enddo
end function QucPer
subroutine QucPer3Dsigma(n12,LL,Lb,Lt,cs,sn,quk1) ! sum of (Q*uc cell centre upwind normal) at side n12 of basis link LL
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer, intent(in) :: n12,LL,Lb,Lt ! working for basis link LL
double precision, intent(in) :: cs, sn
double precision, intent(out):: quk1(3,Lt-Lb+1) !
! locals
integer :: La, LLL, LLLL, Lb2, Lt2, Lk ! for links LL,
integer :: k12, Lkin ! relevant node, 1 or 2, L/R
double precision :: ucin, tkein, epsin ! velocity surplus
Quk1 = 0d0
k12 = ln(n12,LL)
do La = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(La)
LLLL = iabs(LLL)
Lb2 = Lbot(LLLL) ; Lt2 = Ltop(LLLL)
do Lk = LB2, LT2
if ( qa(Lk) .ne. 0) then ! include own link
if (jarhoxu > 0) then
ucin = (ucxu(Lk)*cs + ucyu(Lk)*sn)*rhou(Lk) - u1(Lb + Lk - Lb2)*rhou(Lb + Lk - Lb2)
else
ucin = ucxu(Lk)*cs + ucyu(Lk)*sn - u1(Lb + Lk - Lb2)
endif
if (LLL > 0) then ! incoming link
ucin = -1d0*ucin
endif
Lkin = min (Lk-Lb2+1, Lt-Lb+1) ! for fixed layers just add to top index
Quk1(1,Lkin) = Quk1(1,Lkin) + qa(Lk)*ucin
endif
enddo
enddo
end subroutine QucPer3Dsigma
subroutine QucPer3Dsigmapiaczekteta(LL,Lb,Lt,cs,sn,ae,ai) ! Piaczekteta in 3D
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom
use m_flowtimes, only : dts !
implicit none
integer, intent(in) :: LL,Lb,Lt ! working for basis link LL
double precision, intent(in) :: cs, sn
double precision, intent(out):: ae(Lt-Lb+1) ! explicit part
double precision, intent(out):: ai(Lt-Lb+1) ! implicit part
! locals
integer :: La, LLL, LLLL, Lb2, Lt2, Lk ! for links LL,
integer :: k12, n12, k1, k2 ! relevant node, 1 or 2, L/R
double precision :: ucin, cfl, tet, volu, ac, acq ! velocity surplus
ae = 0d0 ; ai = 0d0
do n12 = 1,2
if (n12 ==1) then
ac = acL(LL)
else
ac = 1d0-acL(LL)
endif
k12 = ln(n12,LL)
do La = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(La)
LLLL = iabs(LLL)
Lb2 = Lbot(LLLL) ; Lt2 = Ltop(LLLL)
do Lk = LB2, LT2
if ( qa(Lk) .ne. 0) then ! include own link
k1 = ln(1,Lb+Lk-Lb2) ; k2 = ln(2,Lb+Lk-Lb2)
volu = acL(LL)*vol1(k1) + (1d0-acl(LL))*vol1(k2)
if (volu > 0d0) then
cfl = abs(qa(Lk))*dts/volu
if (nd(k12)%lnx ==3) cfl=1.4d0*cfl
if (cfl > 0d0) then
tet = max(0d0, 1d0 - 1d0/cfl )
ucin = ucxu(Lk)*cs + ucyu(Lk)*sn - (1d0-tet)*u1(Lb + Lk - Lb2)
acq = ac*qa(Lk)/volu
if (LLL > 0) then ! incoming link
ae(Lk-Lb2+1) = ae(Lk-Lb2+1) - acq*ucin
ai(Lk-Lb2+1) = ai(Lk-Lb2+1) + acq*tet
else
ae(Lk-Lb2+1) = ae(Lk-Lb2+1) + acq*ucin
ai(Lk-Lb2+1) = ai(Lk-Lb2+1) - acq*tet
endif
endif
endif
endif
enddo
enddo
enddo
end subroutine QucPer3Dsigmapiaczekteta
double precision function QucPerq1(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 , kup ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucPerq1 = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)
if (LLL > 0) then ! incoming link
QucPerq1 = QucPerq1 - q1(LLLL)*ucin
else
QucPerq1 = QucPerq1 + q1(LLLL)*ucin
endif
endif
enddo
end function QucPerq1
double precision function QufPer(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 , kup ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin, snL, csL, ufx, ufy
QufPer = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else
csL = csu(LLLL) ; snL = snu(LLLL)
ufx = csL * u1(LLLL) - snL * v (LLLL)
ufy = csL * v (LLLL) + snL * u1 (LLLL)
ucin = ufx*cs + ufy*sn - u1(L)
if (LLL > 0) then ! incoming link
QufPer = QufPer - qa(LLLL)*ucin
else
QufPer = QufPer + qa(LLLL)*ucin
endif
endif
enddo
end function QufPer
double precision function QucPercu(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 , kup ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucPercu = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else
ucin = ( ucxu(LLLL) - ucx(k12) )*cs + (ucyu(LLLL) - ucy(k12) )*sn
if (LLL > 0) then ! incoming link
QucPercu = QucPercu - q1(LLLL)*ucin
else
QucPercu = QucPercu + q1(LLLL)*ucin
endif
endif
enddo
end function QucPercu
double precision function QucPeri(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucPeri = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else if ( LLL*qa(LLLL) > 0d0) then ! only incoming
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)
if (LLL > 0) then ! incoming link
QucPeri = QucPeri - qa(LLLL)*ucin
else
QucPeri = QucPeri + qa(LLLL)*ucin
endif
endif
enddo
end function QucPeri
double precision function Qucnu(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, kup ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
Qucnu = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
!if (qa(L) == 0d0 .or. L == LLLL ) then
!else
if ( qa(LLLL) > 0 ) then ! upwind cell centered velocity lies at kup=
kup = ln(1,LLLL)
else
kup = ln(2,LLLL)
endif
ucin = ucx(kup)*cs + ucy(kup)*sn - u1(L)
if (LLL > 0) then ! incoming link
Qucnu = Qucnu - qa(LLLL)*ucin
else
Qucnu = Qucnu + qa(LLLL)*ucin
endif
!endif
enddo
end function Qucnu
double precision function QucWeni(n12,L) ! sum of (Q*uc cell centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin
QucWeni = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0 .or. L == LLLL) then ! skip, this is link L itself
else if ( LLL*qa(LLLL) > 0d0) then ! only incoming
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)
if (LLL > 0) then ! incoming link
QucWeni = QucWeni - qa(LLLL)*ucin
else
QucWeni = QucWeni + qa(LLLL)*ucin
endif
endif
enddo
end function QucWeni
double precision function QunPeri(n12,L) ! sum of (Q*un face node upwind normal) at side n12 of link L
use m_flow ! advect the corner velocities (dimension: m4/s2)
use m_flowgeom ! leaving the cell = +
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12 ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin, unxu, unyu, aa
QunPeri = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) == 0d0) then ! include own link
else if ( LLL*qa(LLLL) > 0d0) then ! only incoming
unxu = 0.5d0*( ucnx(lncn(1,LLLL)) + ucnx(lncn(2,LLLL)) )
unyu = 0.5d0*( ucny(lncn(1,LLLL)) + ucny(lncn(2,LLLL)) )
ucin = unxu*cs + unyu*sn - u1(L)
if (LLL > 0) then ! incoming link
aa = acl(LLLL)
QunPeri = QunPeri - qa(LLLL)*ucin
else
aa = 1d0-acl(LLLL)
QunPeri = QunPeri + qa(LLLL)*ucin
endif
endif
enddo
end function QunPeri
subroutine QucPeripiaczek(n12,L,ai,ae,iad) ! sum of (Q*uc cell IN centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom
use m_flowtimes ! leaving the cell = +
implicit none
integer :: n12,L,iad ! for link L,
double precision ai, ae
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, kup, ja ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin, cfl, tet
ai = 0d0 ; ae = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) .ne. 0d0) then !
ja = 0
if (iad == 3) then
ja = 1 ! all in odd schemes
else if ( LLL*qa(LLLL) > 0d0 ) then
ja = 1 ! incoming only otherwise
endif
if (ja == 1) then
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn
if (LLL > 0) then ! incoming link
ae = ae - qa(LLLL)*ucin
ai = ai + qa(LLLL)
else
ae = ae + qa(LLLL)*ucin
ai = ai - qa(LLLL)
endif
endif
endif
enddo
end subroutine Qucperipiaczek
subroutine QucPeripiaczekteta(n12,L,ai,ae,volu,iad) ! sum of (Q*uc cell IN centre upwind normal) at side n12 of link L
use m_flow ! advect the cell center velocities (dimension: m4/s2)
use m_flowgeom
use m_flowtimes ! leaving the cell = +
implicit none
integer :: n12,L,iad ! for link L,
double precision ai, ae, volu
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, kup, ja ! relevant node, 1 or 2, L/R
double precision cs, sn, ucin, cfl, tet
ai = 0d0 ; ae = 0d0
cs = csu(L)
sn = snu(L)
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
if ( qa(LLLL) .ne. 0d0) then !
ja = 0
if (iad == 3) then
ja = 1 ! all in odd schemes
else if ( LLL*qa(LLLL) > 0d0 ) then
ja = 1 ! incoming only otherwise
endif
if (ja == 1) then
cfl = abs(qa(LLLL))* dts/volu
if (nd(k12)%lnx ==3) cfl=1.4d0*cfl
if (cfl > 0) then
tet = max(0d0, 1d0 - 1d0/cfl )
ucin = ucxu(LLLL)*cs + ucyu(LLLL)*sn - u1(L)*(1d0-tet)
if (LLL > 0) then ! incoming link
ae = ae - qa(LLLL)*ucin
ai = ai + qa(LLLL)*tet
else
ae = ae + qa(LLLL)*ucin
ai = ai - qa(LLLL)*tet
endif
endif
endif
endif
enddo
end subroutine Qucperipiaczekteta
double precision function Qsum(k) ! sum of Q out of k (m3/s)
use m_flow
use m_flowgeom
implicit none
integer :: k ! for node k,
! locals
integer :: LL, LLL, LLLL ! for links LL,
Qsum = 0d0
do LL = 1, nd(k)%lnx ! loop over all attached links
LLL = nd(k)%ln(LL)
LLLL = iabs(LLL)
if ( q1(LLLL) == 0d0 ) then ! skip, this is link L itself, net result = 0
else if (LLL > 0) then ! incoming link
Qsum = Qsum - q1(LLLL)
else
Qsum = Qsum + q1(LLLL)
endif
enddo
end function Qsum
double precision function qzeta(n12,L) ! average specific q in zeta point comparable to fls
use m_flow ! qdo = 0.5*(qleft+qright)
use m_flowgeom
implicit none
integer :: L ! for link L,
integer :: n12 ! find normal velocity components of the other links
! locals
integer :: LL, LLL, LLLL ! for links LL,
integer :: k12, kup ! relevant node, 1 or 2, L/R
qzeta = 0d0
k12 = ln(n12,L)
do LL = 1, nd(k12)%lnx ! loop over all attached links
LLL = nd(k12)%ln(LL)
LLLL = iabs(LLL)
qzeta = qzeta + q1(LLLL)
enddo
end function Qzeta
double precision function depumin(k) ! min hu of node k
use m_flow
use m_flowgeom
implicit none
integer :: k
! locals
integer :: L, LL ! for link L,
depumin = 1e9
do L = 1, nd(k)%lnx
LL = iabs(nd(k)%ln(L))
depumin = min( depumin,hu(L) )
enddo
end function depumin
subroutine setuniformwind()
use m_wind
use m_sferic
use m_flowgeom
implicit none
double precision :: wdir
jawind = 2
wdir = (90d0 - winddir)*dg2rd
if (.not. allocated(wx) ) then
allocate ( wx(lnx), wy(lnx) )
endif
wx = windsp*cos(wdir)
wy = windsp*sin(wdir)
call setwindstress()
end subroutine setuniformwind
!> Initializes the entire current model (geometry, boundaries, initial state)
!! @return Error status: error (/=0) or not (0)
integer function flow_modelinit() result(iresult) ! initialise flowmodel
use m_flowgeom, only: jaFlowNetChanged, ndx
use waq, only: reset_waq
use m_flow, only: zws, zws0, kmx, jasecflow, jasecf
use m_flowgeom, only: kfs, kfst0
use m_flowtimes
use network_data, only: netstat, NETSTAT_CELLS_DIRTY
use m_partitioninfo
use m_timer
use m_flowtimes
use unstruc_model ! , only: md_ident, md_restartfile, writeMDUFilepointer, md_foufile, md_flowgeomfile, md_snapshotdir, md_numthreads
use unstruc_files, only: mdia, getoutputdir
use unstruc_netcdf
use MessageHandling
use m_flowparameters, only: jawave, jatrt, jacreep, jatransportmodule
use dfm_error
!
! To raise floating-point invalid, divide-by-zero, and overflow exceptions:
! Activate the following line (See also statements below)
!use ifcore
!
#ifdef _OPENMP
use omp_lib
#endif
implicit none
integer :: jw, istat, L
integer, external :: flow_flowinit
!
! To raise floating-point invalid, divide-by-zero, and overflow exceptions:
! Activate the following 3 lines, See also statements below
!INTEGER*4 OLD_FPE_FLAGS, NEW_FPE_FLAGS
!NEW_FPE_FLAGS = FPE_M_TRAP_OVF + FPE_M_TRAP_DIV0 + FPE_M_TRAP_INV
!OLD_FPE_FLAGS = FOR_SET_FPE (NEW_FPE_FLAGS)
!
iresult = DFM_GENERICERROR
call datum2(rundat2)
L = len_trim(rundat2)
IF (ti_waq > 0d0) then
call makedir( 'DFM_DELWAQ_'//trim(md_ident)//rundat2(1:L) ) ! No problem if it exists already.
end if
md_snapshotdir = trim(getoutputdir()) ! plot output to outputdir
! Make sure output dir for plot files exists
if (len_trim(md_snapshotdir) > 0) then
call makedir(md_snapshotdir) ! No problem if it exists already.
end if
if ( jatimer.eq.1 ) then
call initimer()
end if
call resetflow()
call reset_waq()
! JRE
if (jawave == 4) then
call xbeach_wave_input() ! will set swave and lwave
endif
! TODO: unc_wri_map_header
call mess(LEVEL_INFO,'Initializing flow model geometry...')
if ( jampi.eq.0 ) then
call flow_geominit(0) ! initialise flow geometry based upon present network, time independent
! make directional wave grid
call mess(LEVEL_INFO,'Done initializing flow model geometry.')
if (ndx == 0) then
call mess(LEVEL_WARN,'no network, please check MDU-file')
iresult = DFM_MODELNOTINITIALIZED
goto 1234
end if
else
call flow_geominit(1) ! first phase only
if ( Ndx.gt.0 ) then
call mess(LEVEL_INFO,'Start partitioning model...')
if ( jatimer.eq.1 ) call starttimer(IPARTINIT)
call partition_init_2D(md_ident, iresult) ! 2D only (hence the name, thanks to Herman for pointing this out)
if ( jatimer.eq.1 ) call stoptimer(IPARTINIT)
call mess(LEVEL_INFO,'Done partitioning model.')
if ( iresult.eq.0 ) then
call update_geom(1) ! update geometry in ghost area
call flow_geominit(2) ! second phase
call update_geom(2) ! update geometry in ghost area
call disable_invalid_ghostcells_with_wu() ! disable ghost cells that are not being synchronised by setting wu's to zero
call mess(LEVEL_INFO,'Done initializing flow model geometry.')
else
call mess(LEVEL_WARN,'Error in 2D partitioning initialization.')
goto 1234
end if
else
call mess(LEVEL_WARN,'no network, please check MDU-file')
iresult = DFM_MODELNOTINITIALIZED
goto 1234
end if
end if
jasecf = jasecflow ! Eliminates the secondary flow option in 3D calculation , added by Nabi
if( kmx > 1 .and. jasecflow > 0) then ! An error announcement (or warning, with correction to jasecflow to 0) has to come here in the future GUI
jasecf = 0
call mess(LEVEL_WARN,'Warning: Secondary Flow is not applicable in 3D computation !!')
call mess(LEVEL_WARN,' Secondary flow is turned off')
endif
! 3D: flow_allocflow will set kmxn and kmxL arrays
call flow_allocflow() ! allocate flow arrays
! Construct a default griddim struct for D3D subroutines, i.e. fourier, sedmor or trachytopen
if ( len_trim(md_foufile) > 0 .or. len_trim(md_sedfile) > 0 .or. jatrt == 1) then
call D3Dflow_dimensioninit()
endif
! need number of grains for allocation of sed array
if ( len_trim(md_sedfile) > 0 ) then
call flow_sedmorinit ()
endif
! Initialise Fourier Analysis
if (len_trim(md_foufile)>0) then
call flow_fourierinit()
endif
if (jampi == 1) then
!3D: partition_init needs kmxn and kmxL arrays for 3D send- and ghostlists
if ( jatimer.eq.1 ) call starttimer(IPARTINIT)
call partition_init_3D(iresult)
if ( jatimer.eq.1 ) call stoptimer(IPARTINIT)
if (iresult /= DFM_NOERR) then
call mess(LEVEL_WARN,'Error in 3D partitioning initialization.')
goto 1234
end if
! check vertical administration
call debugit()
#ifdef _OPENMP
! If MPI is on for this model, *and* no user-define numthreads was set, then disable OpenMP.
if (md_numthreads == 0) then
call omp_set_num_threads(1)
! TODO: AvD: else, reset to maximum? Especially in library mode when multiple models can be run after one another?
else
call omp_set_num_threads(md_numthreads)
end if
#endif
else ! No MPI, but handle OpenMP settings:
#ifdef _OPENMP
if (md_numthreads /= 0) then
call omp_set_num_threads(md_numthreads)
end if
#endif
end if
if (jatrt == 1) then
call flow_trachyinit () ! initialise the trachtopes module
end if
if ( jatransportmodule.eq.1 ) then
call ini_transport()
end if
iresult = flow_flowinit() ! initialise flow arrays and time dependent params for a given user time
if (iresult /= DFM_NOERR) then
goto 1234
end if
if (jawave .eq. 4) then
call xbeach_wave_init()
end if
if (jatrt == 1) then
call flow_trachyupdate() ! Perform a trachy update step to correctly set initial field quantities
endif ! Generally flow_trachyupdate() is called from flow_setexternalforcings()
call flow_obsinit() ! initialise stations and cross sectionson flow grid + structure his
call flow_initimestep(1, iresult) ! 1 also sets zws0
call writesomeinitialoutput()
jaFlowNetChanged = 0
call mess(LEVEL_INFO, '** Model initialization was successful **')
call mess(LEVEL_INFO, '* Active Model definition:')! Print model settings in diagnostics file.
call writeMDUFilepointer(mdia, .true., istat)
call mess(LEVEL_INFO, '**')
if (len_trim(md_flowgeomfile) > 0) then ! Save initial flow geometry to file.
call unc_write_net_flowgeom(trim(md_flowgeomfile))
end if
kfst0 = kfs ! Preserve the wet/dry-state on zero time
iresult = DFM_NOERR
return
1234 continue
! BEGIN DEBUG
!call dum_makesal()
!call dum_makeflowfield()
! END DEBUG
end function flow_modelinit
subroutine D3Dflow_dimensioninit()
use m_flowgeom
use grid_dimens_module
use m_d3ddimens
use m_flow !, only: ndkx, lnkx
implicit none
! Construct a default griddim struct and gd_dimens (delft3D) struct
call d3dgrid_dimens(gddimens, gddimens_ptr, max(ndkx,lnkx), 1, ndx, lnx, ndkx, lnkx)
call simplegrid_dimens(griddim, ndxi, 1)
end subroutine D3Dflow_dimensioninit
subroutine flow_sedmorinit()
use m_sediment
use m_rdstm
use m_flow, only: kmx, ndkx
use morphology_data_module, only: nullsedtra, allocsedtra
use grid_dimens_module
use unstruc_model
use unstruc_files
use m_flowgeom
use m_flowtimes, only: julrefdat
use m_physcoef, only: rhomean
implicit none
logical :: error
character(20) , dimension(0) :: nambnd
! type(griddimtype) :: griddim
integer :: kk, k, kbot, ktop, j
!
!! executable statements -------------------------------------------------------
!
! activate morphology if sediment file has been specified in the mdu file
!
stm_included = len_trim(md_sedfile) /= 0
if (.not.stm_included) return
call rdstm(stmpar, griddim, md_sedfile, md_morfile, filtrn='', lundia=mdia, lsal=0, ltem=0, ltur=0, lsec=0, julrefday=julrefdat, nambnd=nambnd, error=error)
call nullsedtra(sedtra)
call allocsedtra(sedtra, kmx+1, stmpar%lsedsus, stmpar%lsedtot, 1, ndx, 1, lnx, stmpar%morpar%nxx)
! BEGIN DEBUG
sedtra%dxx(:,1) = stmpar%sedpar%sedd10(1)
sedtra%dxx(:,2) = stmpar%sedpar%sedd50(1)
sedtra%dxx(:,3) = stmpar%sedpar%sedd90(1)
! END DEBUG
if ( associated(mtd%hrms) .and. .false. ) then ! for re-initialize
deallocate(mtd%hrms)
deallocate(mtd%tp)
deallocate(mtd%teta)
deallocate(mtd%rlabda)
deallocate(mtd%uorb)
deallocate(mtd%ubot)
deallocate(mtd%rksr)
deallocate(mtd%rhowat)
deallocate(mtd%seddif)
deallocate(mtd%caksrho)
! deallocate(mtd%sed)
! deallocate(mtd%ws)
deallocate(mtd%depchg)
end if
! ad hoc allocation of dummy variables
allocate(mtd%hrms(ndxi))
allocate(mtd%tp(ndxi))
allocate(mtd%teta(ndxi))
allocate(mtd%rlabda(ndxi))
allocate(mtd%uorb(ndxi))
allocate(mtd%ubot(ndxi))
allocate(mtd%rksr(ndxi))
if ( kmx.eq.0 ) then
allocate(mtd%rhowat(ndx))
else
allocate(mtd%rhowat(ndkx))
end if
allocate(mtd%seddif(stmpar%lsedsus,ndkx))
allocate(mtd%caksrho(stmpar%lsedsus,ndx))
! allocate(mtd%sed(Ndx,stmpar%lsedsus))
! allocate(mtd%ws(Ndx,stmpar%lsedsus))
allocate(mtd%depchg(Ndx))
!
mtd%have_waves = .false.
mtd%hrms = 0.0_fp
mtd%tp = 0.0_fp
mtd%teta = 0.0_fp
mtd%rlabda = 0.0_fp
mtd%uorb = 0.0_fp
mtd%ubot = 0.0_fp
mtd%rksr = 0.0_fp
mtd%rhowat = rhomean ! should actually start using rho from m_flowexternalforcings
mtd%seddif = 0.0_fp
mtd%caksrho = 0.0_fp
! mtd%sed = 0.0_fp
! mtd%ws = 0.0_fp
mtd%depchg = 0.0_fp
! set number of grains (for allocation of sed array)
mxgr = stmpar%lsedtot
! need to allocate some arrays
if ( allocated(sed) ) deallocate(sed)
allocate(sed(mxgr,Ndkx))
sed = 0d0
! BEGIN DEBUG
! do kk=61,65
! call getkbotktop(kk,kbot,ktop)
! do k=kbot,kbot+max(kmx,1)-1
! do j=1,mxgr
! sed(j,k) = 0.1d0
! end do
! end do
! end do
! END DEBUG
return
end subroutine flow_sedmorinit
!! Initialise trachytope module containing FM data for trachytopes.
!! Note that arrays are dimensioned on the number of net links
!! This was done so that roughness characteristics can be specified
!! not related to the location of open boundaries, which are not
!! yet available at the time the model is constructed.
!! Besides that certain sediment transport formulae require a
!! Cf at the flow node, which can only accurately be deterimined if the
!! values at net links are known.
subroutine flow_trachyinit()
use grid_dimens_module
use network_data, only: numl, lne, xk, yk, kn
use unstruc_model ! (contains md_ptr)
use m_flowparameters
use m_flowgeom
use m_physcoef, only: ifrctypuni
use m_flow, only: kmx, zslay, ucx, ucy
use m_flowtimes, only: dts, dt_max
use m_trachy ! (FM module containing trachy data structure)
use m_rdtrt ! (contains dimtrt)
use m_trtrou ! (contains chktrt)
use unstruc_files, only: mdia
use unstruc_messages
use trachytopes_data_module, only: TRACHY_UNDEFINED, TRACHY_NOT_IN_SUBDOMAIN ! = -99999, -77777
use m_crosssections, only: crs, ncrs
use m_observations, only: namobs, numobs
use m_kdtree2
use M_MISSING
!
implicit none
!
double precision, external :: dbdistance
!
integer, pointer :: ntrtcrs
integer, pointer :: ntrtobs
!
double precision :: xE, yE, xF, yF, x, y, dist
double precision, parameter :: dtol_trachy = 1d-4 !< tolerance for distance in finding net-link numbers based on xuL,yuL
!
double precision, dimension(:), allocatable :: xuL !< xu points on net-links
double precision, dimension(:), allocatable :: yuL !< yu points on net-links
!
integer :: istat, ierror
integer :: itt
integer :: k, kL, kR, k1, k2
integer :: icrs
integer :: iobs
integer :: itrtcrs
integer :: itrtobs
integer :: L
integer :: LF
integer :: ddbval = 0
double precision :: dummy_tunit = 1d0
!
logical :: lftrto
logical :: error
logical :: lfbedfrmrou = .false. ! to be connected to gdp%gdbedformpar%lfbedfrmrou
logical :: sedim = .false. ! gdp%gdprocs%sedim => true when 'Filsed = #filename.sed#
!
character(256) :: flnmD50 = '0.002 m' ! to be connected to gdp%gdbedformpar
character(256) :: flnmD90 = '0.003 m' ! to be connected to gdp%gdbedformpar
!
if (allocated(sig )) deallocate(sig )
if (allocated(umag )) deallocate(umag )
if (allocated(bedformD50 )) deallocate(bedformD50 )
if (allocated(bedformD90 )) deallocate(bedformD90 )
if (allocated(rksr )) deallocate(rksr )
if (allocated(z0rou )) deallocate(z0rou )
if (allocated(rksmr )) deallocate(rksmr )
if (allocated(rksd )) deallocate(rksd )
if (allocated(dxx )) deallocate(dxx )
if (allocated(rhosol )) deallocate(rhosol )
if (allocated(dx_trt )) deallocate(dx_trt )
if (allocated(hu_trt )) deallocate(hu_trt )
if (allocated(kcu_trt )) deallocate(kcu_trt )
kmaxtrt = max(kmx, 1)
allocate(sig(kmaxtrt))
allocate(umag(ndx))
!
! Alluvial roughness from bedforms, megaripples and ripples
!
allocate(bedformD50(1)) ! should be ndx if spatial_bedform = .true.
allocate(bedformD90(1)) ! should be ndx if spatial_bedform = .true.
allocate(rksr(ndx))
allocate(rksmr(ndx))
allocate(rksd(ndx))
allocate(dxx(ndx,nxx))
allocate(rhosol(lsedtot))
allocate(z0rou(numl))
!
! Allocate arrays for moving data from flow links to net links
!
allocate(hu_trt(numl))
allocate(kcu_trt(numl)) ! TODO: alle deallocs oplossen, zodra FM ook een flow_finalize heeft.
allocate(dx_trt(numl))
!
rhosol = 2650.0
!
bedformD50 = 0.002 ![m] ! temporary fills _ WO
bedformD90 = 0.003 ![m] ! temporary fills _ WO
dxx(:,i50) = bedformD50(1) ! temporary fills _ WO
dxx(:,i90) = bedformD90(1) ! temporary fills _ WO
!
z0rou = 3.0*bedformD90(1)/30.0 ! temporary fills _ WO
!
rksr = 3.0*bedformD90(1) ! temporary fills _ WO
rksmr = 0.0 ! temporary fills _ WO
rksd = 0.0 ! temporary fills _ WO
!
! Delft3D sig FM slay at centre cell (FM) conversion FM to Delft3D style
! 0 = top 1 = top
do k = 1, kmx ! k = 1 -1/6 j=kmx 1 sig(1) = 1.0 - 0.5*slay(kmx) - 0.5*slay(kmx-1)
sig(k) = 1.0 - 0.5*zslay(kmx-k+1,1) - 0.5*zslay(kmx-k,1) ! k = 2 -1/2 j= 2 2/3 0.5*slay(j) + 0.5*slay(j-1) sig(2) = 1.0 - 0.5*slay(kmx-1) - 0.5*slay(kmx-1-1)
end do ! k = 3 = kmx -5/6 j= 1 1/3 sig(3) = 1.0 - 0.5*slay(kmx-2) - 0.5*slay(kmx-2-1)
! j= 0 0 sig(k) = 1.0 - 0.5*slay(kmx-k+1) - 0.5*slay(kmx-k)
! -1 = bed 0 = bed
error = .false.
! If trachytopes not defined return
!if (jatrt == 0) return
! Construct a default griddim struct (dimension is lnx = number of flow links ) ! (better dimension is numl based on number of net links)
! (Contrary to the morphology routine call (where the dimension is ndxi)
! [TO DO: make uniform, or adjust griddim structure to allow both flow nodes, net links (& flow-links)?]
call simplegrid_dimens(griddim, numl, 1)
! Construct memory structure for trachytopes on flow links
call inittrachy(trachy_fl, 1, istat)
! Read dimensions of trachytope memory structure
call dimtrt(mdia ,error ,trachy_fl, trtdef_ptr , &
& griddim )
if (error) then
call mess(LEVEL_ERROR, 'Error reading trachytope dimensions', mdia)
end if
call rdtrt(mdia ,error ,lftrto , dt_max , & !lftrto = jatrt (read twice, in unstruc_model and rdtrt), so always true after rdtrt
& kmaxtrt ,itimtt ,trachy_fl , &
& griddim ,0.1_fp ,trtdef_ptr ,.false. , &
& ddbval ,dummy_tunit)
if (error) then
call mess(LEVEL_ERROR, 'Error reading trachytopes', mdia)
end if
! Initialise kcu_trt
kcu_trt = 1
do L = 1,numl
if (kn(3,L) == 0) then
kcu_trt(L) = 0
endif
trachy_fl%dir(1)%kcu_trt(L) = kcu_trt(L) ! Copy here to be able to pass on to chktrt. TODO: choose which kcu_trt should remain (or both).
enddo
! Check if trachytopes are defined
call chktrt(mdia , error , griddim, &
& trachy_fl, flnmD50, flnmD50, lfbedfrmrou, sedim, ddbval)
if (error) then
call mess(LEVEL_ERROR, 'Error reading trachytope defintions')
end if
! check cross-section names and link to local FM cross-section index
ntrtcrs => trachy_fl%gen%ntrtcrs
do itrtcrs = 1,ntrtcrs
do icrs = 1,ncrs
if (trim(trachy_fl%gen%crs(itrtcrs)%name) == trim(crs(icrs)%name)) then
trachy_fl%gen%crs(itrtcrs)%id = icrs
end if
end do
if (trachy_fl%gen%crs(itrtcrs)%id == TRACHY_UNDEFINED) then
call mess(LEVEL_ERROR, 'Error reading trachytopes: Cross-section does not exist in "'//trim(trachy_fl%gen%md_ttdfile)//'": '//trim(trachy_fl%gen%crs(itrtcrs)%rec132), mdia)
end if
end do
! check observation-station names and link to local FM observation-station index
ntrtobs => trachy_fl%gen%ntrtobs
do itrtobs = 1,ntrtobs
do iobs = 1,numobs
if (trim(trachy_fl%gen%obs(itrtobs)%name) == trim(namobs(iobs))) then
trachy_fl%gen%obs(itrtobs)%id = iobs
end if
end do
if (trachy_fl%gen%obs(itrtobs)%id == TRACHY_UNDEFINED) then
call mess(LEVEL_ERROR, 'Error reading trachytopes: Observation station does not exist in "'//trim(trachy_fl%gen%md_ttdfile)//'": '//trim(trachy_fl%gen%obs(itrtobs)%rec132), mdia)
end if
end do
! Update neighboring links and distance weighting
do L = 1,numl
kL = lne(1,L) !flow node neighbouring net-link on from-side
kR = lne(2,L) !flow node neighbouring net-link on to-side
if (kL == 0 .and. kR == 0 ) then
cycle
elseif (kL > 0 .and. kR > 0 .and. kn(3,L).ne.0) then
! net link is not on closed boundary
trachy_fl%dir(1)%lin(1,L) = kL
trachy_fl%dir(1)%lin(2,L) = kR
trachy_fl%dir(1)%acLin(L) = acl(lne2ln(L))
else
! net link is on closed boundary
trachy_fl%dir(1)%lin(1,L) = max(kR,kL)
trachy_fl%dir(1)%lin(2,L) = max(kR,kL)
trachy_fl%dir(1)%acLin(L) = 1.0
end if
end do
!
! determine if umag is needed.
!
update_umag = .false.
do itt = 1, trachy_fl%dir(1)%nttaru
if ((trachy_fl%dir(1)%ittaru(itt,3) == 103) .or. (trachy_fl%dir(1)%ittaru(itt,3) == 104)) then ! if Van Rijn roughness predictor or Struiksma roughness predictor
update_umag = .true.
end if
end do
!
! Connection to FM definitions
!
if (ifrctypuni==0) then
rouflo = 'CHEZ'
elseif (ifrctypuni==1) then
rouflo = 'MANN'
elseif (ifrctypuni==2) then
rouflo = 'WHIT'
elseif (ifrctypuni==3) then
rouflo = 'WHIT'
else
call mess(LEVEL_ERROR, 'Unsupported friction type specified in combination with trachytopes', mdia)
endif
allocate(xuL(numL), yuL(numL))
xuL = DMISS
yuL = DMISS
do L=1,numL
k1 = kn(1,L)
k2 = kn(2,L)
xuL(L) = 0.5d0*(xk(k1)+xk(k2))
yuL(L) = 0.5d0*(yk(k1)+yk(k2))
end do
do L = 1, numl
kL = lne(1,L) ; kR = lne(2,L)
if (kL == 0 .and. kR == 0 ) cycle
LF = lne2ln(L)
if (LF > 0) then
!link is on flow-link
dx_trt(L) = dx(LF)
else
! link is not on flow-link --> closed boundary
! get x,y on midpoint of edge
xE = xuL(L)
yE = yuL(L)
! get x,y on midpoint of neighbouring flow node
xF = xz(trachy_fl%dir(1)%lin(1,L))
yF = yz(trachy_fl%dir(1)%lin(1,L))
dx_trt(L) = 2.0*dbdistance(xE,yE,xF,yF) ! determine distance (as if it were a flow node) (dx - oppervlakte/net link lengte ?) (test 2. cel-gemiddelde ruwheid) (3. veel cellen ... )
end if
enddo
! build kdtree
call build_kdtree(treeglob,numL,xuL,yuL,ierror)
call realloc_results_kdtree(treeglob,1) ! safety
do itt = 1, trachy_fl%dir(1)%nttaru
if (trachy_fl%dir(1)%ittaru(itt,4) == TRACHY_MISSING_VALUE) then
x=trachy_fl%dir(1)%rttxyz(itt,1)
y=trachy_fl%dir(1)%rttxyz(itt,2)
! z=trachy_fl%dir(1)%rttxyz(itt,3) (not used).
! fill query vector
call make_queryvector_kdtree(treeglob,x,y)
! find nearest link
call kdtree2_n_nearest(treeglob%tree,treeglob%qv,1,treeglob%results)
! get link number
L = treeglob%results(1)%idx
! check distance
dist = treeglob%results(1)%dis
! dist = dbdistance(xuL(L),yuL(L),x,y) (alternatively)
if ( dist.lt.dtol_trachy ) then
trachy_fl%dir(1)%ittaru(itt,4) = L !(net link number)
else
trachy_fl%dir(1)%ittaru(itt,4) = TRACHY_NOT_IN_SUBDOMAIN
end if
end if
end do
! deallocate
if ( allocated(xuL) ) deallocate(xuL)
if ( allocated(yuL) ) deallocate(yuL)
if ( treeglob%itreestat.ne.ITREE_EMPTY ) call delete_kdtree2(treeglob)
end subroutine flow_trachyinit
subroutine flow_trachyupdate()
use unstruc_messages
use unstruc_files, only: mdia
use m_flow, only: kmx, zslay, ucx, ucy, cftrt, hu, hs, frcu, ifrcutp, s1
use m_flowgeom, only: ndx, lnx, kcu, dx, lne2ln, ln2lne, nd, bob, bl
use m_physcoef
use m_trachy
use m_trtrou
use m_flowparameters, only: eps8, epshs
use network_data, only: numl, lne
use m_crosssections
use m_observations , only: namobs, numobs, kobs
use m_partitioninfo, only: jampi
!
implicit none
!
integer, pointer :: ntrtcrs
integer, pointer :: ntrtobs
!
integer n, L, LF, k, KL, KR
integer :: icrs
integer :: iobs
integer :: itrtcrs
integer :: itrtobs
!
logical :: error
logical, save :: init_trt = .true. !< first time function is called
!
error = .false.
!
! prepare cross-section information to pass to trachytopes module
!
ntrtcrs => trachy_fl%gen%ntrtcrs
do itrtcrs=1,ntrtcrs
icrs = trachy_fl%gen%crs(itrtcrs)%id
trachy_fl%gen%crs(itrtcrs)%val = crs(icrs)%sumvalcur(IPNT_Q1C)
end do
!
! prepare observation-station information to pass to trachytopes module
!
ntrtobs => trachy_fl%gen%ntrtobs
do itrtobs=1,ntrtobs
iobs = trachy_fl%gen%obs(itrtobs)%id
! k = max(kobs(iobs),1)
k = kobs(iobs) ! SPvdP, intentional crash if kobs<1 (0: no flownode, -1: flownode in other subdomain)
trachy_fl%gen%obs(itrtobs)%val = s1(k) ! TO DO: needs jampi implementation ?
end do
!
!
if (update_umag) then
! probably cheaper than looping over all trachtope definitions first (see code below)?
do n = 1, ndx
umag(n) = sqrt(ucx(n)**2.0 + ucx(n)**2.0)
end do
!
! Same code as above but does only updates umag where it is needed
!
! do itt = 1, trachy%dir(1)%nttaru
! if ((trachy%dir(1)%ittaru(itt,3) == 103) .or. (trachy%dir(1)%ittaru(itt,3) == 104)) then ! if Van Rijn roughness predictor or Struiksma roughness predictor
! LF = trachy%dir(1)%ittaru(itt,4) ! corresponding flow link
! do m = 1, 2
! n = trachy%dir(1)%ln(m,LF) ! corresponding cell centre
! umag(n) = sqrt(ucx(n)**2.0 + ucx(n)**2.0)
! end do
! end if
! end do
!
! Alternative: pre-determine flow links which require the variable umag to be set.
!
end if
!
! Update water levels and link info (open or closed) on net-links
!
do L = 1, numl
kL = lne(1,L) ; kR = lne(2,L)
if (kL == 0 .and. kR == 0 ) cycle
LF = lne2ln(L)
if (LF > 0) then
! flow link crosses with net link
if (hu(LF) > 0) then
kcu_trt(L) = 1 ! warning: kcu arrays in Delft3d and Dflow-FM have different meanings
else
kcu_trt(L) = 0
end if
hu_trt(L) = hu(LF)
trachy_fl%dir(1)%blu_trt(L) = min( bob(1,LF), bob(2,LF) )
else
! net link lies on boundary, take neighbouring flow node value.
hu_trt(L) = hs(trachy_fl%dir(1)%lin(1,L))
trachy_fl%dir(1)%blu_trt(L) = bl(trachy_fl%dir(1)%lin(1,L))
kcu_trt(L) = 0 !link is not on flow-link --> closed boundary
end if
enddo
!
! Update background friction and water level
!
if (init_trt) then
!
do L = 1, numl
kL = lne(1,L) ; kR = lne(2,L)
if (kL == 0 .and. kR == 0 ) cycle
trachy_fl%dir(1)%zsu_prev(L) = trachy_fl%dir(1)%blu_trt(L) + hu_trt(L)
end do
!
do LF = 1, lnx
if (ifrcutp(LF) /= ifrctypuni) then
error = .true.
call mess(LEVEL_ERROR, 'Only uniform background roughness definition supported in combination with Trachytopes', mdia)
end if
end do
do L = 1, numl
kL = lne(1,L) ; kR = lne(2,L)
if (kL == 0 .and. kR == 0 ) cycle
LF = lne2ln(L)
if (LF > 0) then
cftrt(L,3) = frcu(LF) !link is on flow-link
else
k = trachy_fl%dir(1)%lin(1,L) ! neighbouring flow node
cftrt(L,3) = 0.0
do n = 1,nd(k)%lnx
LF = iabs(nd(k)%ln(n)) ! neighbouring flow links to flow node
cftrt(L,3) = cftrt(L,3) + frcu(LF)
end do
cftrt(L,3) = cftrt(L,3)/max(nd(k)%lnx,1)
end if
enddo
init_trt = .false.
end if
!
! Perform computation of vegetation and aluvial roughness
!
call trtrou(mdia ,kmaxtrt ,numl , & ! lnx instead of numl ?
& cftrt ,rouflo ,linit ,dx_trt , &
& hu_trt ,kcu_trt ,sig , &
& z0rou ,1 ,waqol ,trachy_fl , &
& umag ,1 ,numl ,1 , ndx , & ! first entry in row r(u1) should be gdp%gderosed%umod !!WO-temp
& rhomean ,ag ,vonkar , viskin , & ! ~z0 used for what? ~viskin instead of vicmol (Delft3D)
& eps8 ,epshs , &
& lfdxx ,nxx ,dxx , i50 , i90 ,rhosol, &
& lsedtot ,spatial_bedform ,bedformD50,bedformD90, &
& rksr ,rksmr ,rksd ,error)
if (error) then
call mess(LEVEL_ERROR, 'Error computing trachytopes', mdia)
end if
!
! Return vegetation and aluvial roughness to flow-links
!
do LF = 1, lnx
L = ln2lne(LF)
frcu(LF) = cftrt(L,2) !--> cfrou (L,1) to do Delft3D check ...
end do
!
! Example Delft3D call :
!
! call trtrou(lundia ,kmax ,nmmax, &
! & r(cfurou) ,rouflo ,.false. ,r(guu) ,r(gvu) , &
! & r(hu) ,i(kcu) ,r(sig) , &
! & r(z0urou) ,1 ,waqol , gdtrachy , &
! & r(u1) ,nmlb ,nmub , & ! first entry in row r(u1) should be gdp%gderosed%umod !!WO-temp
! & rhow ,ag ,z0 , vonkar , vicmol , &
! & eps ,dryflc , &
! & lfdxx ,nxx , dxx , i50 , i90 ,rhosol, &
! & lsedtot ,spatial_bedform ,bedformD50,bedformD90, &
! & rksr ,rksmr , rksd ,error)
!
end subroutine flow_trachyupdate
subroutine cosphiunetcheck(jausererror)
use m_flowgeom
use network_data
use m_alloc
use unstruc_messages
use unstruc_display, only: jaGUI
use m_missing
use m_partitioninfo
IMPLICIT NONE
integer, intent(in) :: jausererror !< Whether or not (1/0) to topup a error message when bad ortho occurs.
double precision, external :: cosphiunet
double precision :: csph
integer :: ndraw, L
integer :: k1, k2
COMMON /DRAWTHIS/ NDRAW(40)
nlinkbadortho = 0
nlinktoosmall = 0
call realloc(linkbadqual, 1000)
! No checks if no cells are known yet.
if (nump <= 0) then
return
end if
if ( jampi.eq.0 ) then
do L = numl1D+1,numl
csph = cosphiunet(L)
if (csph /= dmiss .and. abs(csph) > cosphiutrsh) then
nlinkbadortho = nlinkbadortho+1
linkbadqual(nlinkbadortho) = L
endif
if (nlinkbadortho >= 1000) exit
enddo
else
! do not check orthogonality in parallel runs (findcells may have created non-existing cells in ghost area)
end if
if (nlinkbadortho > 0) then
if (jausererror == 1) then
if ( jagui.eq.1 ) then
call qnerror('network is not orthogonal','increase cosphiu trsh in network params if you want to create flow model anyway ', ' ')
else
call mess(LEVEL_ERROR, 'network is not orthogonal')
end if ! if ( jagui.eq.1 ) then
end if
NDRAW(2)=5 !< Automatically set 'Display > Network + crossing/quality checks'
call resetflow() ; return
end if
end subroutine cosphiunetcheck
subroutine writesomeinitialoutput()
use m_sferic
use m_flow
use m_flowgeom
use m_flowtimes
use unstruc_messages
implicit none
call datum (rundat0)
write(msgbuf,'(a,a)') 'Modelinit finished at: ' , rundat0 ; call msg_flush()
end subroutine writesomeinitialoutput
subroutine writesomefinaloutput()
use m_sferic
use m_flow
use m_flowgeom
use m_flowtimes
use unstruc_messages
use m_timer
use m_netw
use m_partitioninfo
use m_crosssections
#ifdef _OPENMP
use omp_lib
#endif
implicit none
integer :: k, mout, i
double precision :: frac, tot, dtav
if (ndx == 0) then
write(msgbuf,'(a)') 'Empty model. No statistics to report.'; call msg_flush()
return
end if
frac = cpusol(3) / max(1d-10,cpusteps(3))
tot = cpuall(3) / max(1d0, ndx*(dnt-1) )
dtav = (tstop_user - tstart_user)/max(1d0, dnt-1)
do k = 1,3
msgbuf = ' ' ; call msg_flush()
enddo
write(msgbuf,'(a,I25)') 'nr of netnodes ( ) :' , numk ; call msg_flush()
write(msgbuf,'(a,I25)') 'nr of netlinks ( ) :' , numl ; call msg_flush()
write(msgbuf,'(a,I25)') 'nr of flownodes ( ) :' , ndx ; call msg_flush()
write(msgbuf,'(a,I25)') 'nr of openbnd cells ( ) :' , ndx - ndxi ; call msg_flush()
write(msgbuf,'(a,I25)') 'nr of 1D-flownodes ( ) :' , ndxi - ndx2d ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'model area (m2) :' , sum(ba) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'model volume (m3) :' , sum(vol1(1:ndx)) ; call msg_flush()
do k = 1,3
msgbuf = ' ' ; call msg_flush()
enddo
write(msgbuf,'(a,F25.10)') 'simulation period (s) :' , tstop_user - tstart_user ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'nr of timesteps ( ) :' , dnt-1 ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'average timestep (s) :' , dtav ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time inistep (s) :' , cpuinistep(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time setumod (s) :' , cpuumod(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time furu (s) :' , cpufuru(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time solve (s) :' , cpusol(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time setexternalforc. (s) :' , cpuext(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time setexternalfbnd. (s) :' , cpuextbnd(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time steps (s) :' , cpusteps(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'time steps + plots (s) :' , cpuall(3) ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'fraction solve/steps ( ) :' , frac ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'total/(dnt*ndx) (s) :' , tot ; call msg_flush()
write(msgbuf,'(a,F25.10)') 'av nr of cont. it s1it( ) :' , dnums1it/max(dnt,1d-8) ; call msg_flush()
if ( jatimer.eq.1 ) then
write(msgbuf,'(a,F25.10)') 'time transport [s] :' , gettimer(1,ITRANSPORT)
call msg_flush()
write(msgbuf,'(a,F25.10)') 'time debug [s] :' , gettimer(1,IDEBUG)
call msg_flush()
end if
do k = 1,3
msgbuf = ' ' ; call msg_flush()
enddo
write(msgbuf,'(a,a)') 'Computation started at: ' , rundat0 ; call msg_flush()
call datum(rundat0)
write(msgbuf,'(a,a)') 'Computation finished at: ' , rundat0 ; call msg_flush()
msgbuf = ' ' ; call msg_flush()
#ifdef HAVE_MPI
if (jampi == 1) then
write(msgbuf,'(a,i0,a,i0)') 'MPI : yes. #processes : ', numranks, ', my_rank: ', my_rank; call msg_flush()
else
write(msgbuf,'(a)') 'MPI : no.' ; call msg_flush()
end if
#else
write(msgbuf,'(a)') 'MPI : unavailable.'; call msg_flush()
#endif
#ifdef _OPENMP
write(msgbuf,'(a,i0)') 'OpenMP : yes. #threads max : ', omp_get_max_threads() ; call msg_flush()
#else
write(msgbuf,'(a)') 'OpenMP : unavailable.'; call msg_flush()
#endif
do k = 1,3
msgbuf = ' ' ; call msg_flush()
enddo
call wrirstfileold(time1) ! schrijf aan het einde een .rst-file weg
call wrinumlimdt() ! number of limitating timesteps per node
! call unc_write_his(time1) ! schrijf aan het einde ook een .his-file weg
! call wrimap(time1) ! schrijf aan het einde ook een .map-file weg
msgbuf = ' ' ; call msg_flush()
if (ncrs>0) then
write(msgbuf,'(a)') 'crosssection discharges (m3/s) : ' ; call msg_flush()
do i = 1,ncrs
write(msgbuf,'(F14.3)') crs(i)%sumvalcur(1) ; call msg_flush()
enddo
write(msgbuf,'(a)') 'crosssection areas (m2/s) : ' ; call msg_flush()
do i = 1,ncrs
write(msgbuf,'(F14.3)') crs(i)%sumvalcur(2) ; call msg_flush()
enddo
endif
end subroutine writesomefinaloutput
subroutine wrinumlimdt()
use m_flowgeom
use m_flow
use m_partitioninfo
implicit none
integer :: mlim, k
if ( jampi.eq.0 ) then
call newfil(mlim, 'numlimdt.xyz')
else
call newfil(mlim, 'numlimdt'//'_'//trim(sdmn)//'.xyz')
end if
do k = 1,ndx
if (numlimdt(k) > 0) then
write(mlim, *) xz(k), yz(k), numlimdt(k)
endif
enddo
call doclose(mlim)
end subroutine wrinumlimdt
!subroutine wricir()
!use m_sferic
!use m_flow
!use m_flowgeom
!implicit none
!integer :: mout, k
!double precision :: phi, r0
!
!return
!call inisferic()
!call newfil(mout,'circ250.ldb')
!write(mout,'(a)') 'L001'
!write(mout,'(a)') '360 2'
!r0 = 125000d0
!do k = 0,360
! phi = dg2rd*k
! write(mout,*) r0*cos(phi), r0*sin(phi), r0, r0
!enddo
!call doclose(mout)
!
!end subroutine wricir
subroutine zerowaterdepth() ! restart without water
use m_flow
use m_flowgeom
implicit none
s0 = bl
s1 = bl
u0 = 0d0
u1 = 0d0
end subroutine zerowaterdepth
subroutine zerowaterlevel() ! restart without water
use m_flow
use m_flowgeom
implicit none
s0 = 0d0
s0 = max(bl,s0)
s1 = s0
u0 = 0d0
u1 = 0d0
end subroutine zerowaterlevel
!> Resets the current flow- and time-state, as well as all related (phys) parameters.
!! To be called prior to loading a new MDU and upon program startup.
subroutine resetFullFlowModel()
use m_wind
use m_physcoef
use m_turbulence
use m_flow
use m_flowexternalforcings
use m_flowparameters
use m_flowgeom
use m_flowtimes
use m_samples
use unstruc_model
use unstruc_display
use m_observations
use m_crosssections
use m_thindams
use m_fixedweirs
use m_sediment
use m_trachy
use m_kml_parameters
use m_structures
use m_heatfluxes
use m_interpolationsettings
use unstruc_channel_flow
use m_sobekdfm
implicit none
! Only reset counters and other scalars, allocatables should be
! automatically reset elsewhere (e.g., allocateandset*, flow_geominit)
! TODO: UNST-487: Add default_fourier + reset
call resetModel()
call default_kml_parameters()
call default_physcoef()
call default_wind()
call default_waves()
call default_sobekdfm()
call default_heatfluxes()
call default_sediment()
call default_trachy()
call default_turbulence()
call default_flowgeom()
call default_flowexternalforcings()
call default_channel_flow()
call default_structures()
call default_flowtimes()
call default_flowparameters()
call default_flow()
call default_interpolationsettings()
!Reset samples:
ns = 0
! Reset observations and cross sections
call deleteObservations()
call delCrossSections()
call delThinDams()
call delFixedWeirs()
end subroutine resetFullFlowModel
!> Resets the current flow- and time-state, but keeps al active parameter settings.
!! To be called upon flow_modelinit().
!! Upon program startup and loading of new model/MDU, call resetFullFlowModel() instead.
subroutine resetFlow()
use m_wind
use m_flow
use m_flowexternalforcings
use m_flowparameters
use m_statistics
use m_flowgeom
use m_flowtimes
use waq
use m_waves
use m_sobekdfm
implicit none
! Only reset counters and other scalars, allocatables should be
! automatically reset elsewhere (e.g., allocateandset*, flow_geominit)
call reset_wind()
call reset_waves()
call reset_sobekdfm()
! Reset some flow (rest is done in flow_geominit())
call reset_flowgeom()
call reset_flowexternalforcings()
call reset_flowtimes()
! call reset_flowparameters()
call reset_flow()
call reset_waq()
call reset_movobs()
call reset_statistics()
if ( jawave.eq.4 ) then
call xbeach_reset()
end if
end subroutine resetFlow
!> Reset moving observation stations.
!! Necessary because moving stations are always reread from .ext file
!! (i.e. *after* MDU read, as opposed to static stations
subroutine reset_movobs()
use m_observations
implicit none
integer :: i
do i=numobs+1,numobs+nummovobs
call deleteObservation(i)
end do
call purgeObservations()
end subroutine reset_movobs
subroutine flow_setstarttime() ! set flow starttime
use m_flowtimes
implicit none
time_user = tstart_user + dt_user
time0 = tstart_user
time1 = tstart_user
dts = dt_init
dtprev = dts
dnt = 0
dnt_user = 1
time_split0 = tstart_user
time_split = tstart_user
end subroutine
subroutine setcfuhi() ! set friction coefficients g/C2 etc
use m_flowtimes ! sqrt(g/C2) in both in 2D and in 3D
use m_flow
use m_flowgeom
use m_missing
implicit none
! locals
double precision :: h0, dzb, cz, sixth = 1d0/6d0, frcn, z00, sqcf
integer :: l, ll, n, kb, Lb, ifrctyp
! NOTE: When frcuni==0, the initial friction fields in frcu also become noneffective:
if ( jatrt.eq.0 .and. (frcuni == 0 .or. ifrctypuni == -999) ) then
cfuhi = 0 ; return
endif
if (jaconveyance2D >= 1 ) then ! .and. kmx <=1 ) then
return
endif
if (kmx <= 1) then ! 2D
if (ifrctypuni == 4) then
cfuhi = 0
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,h0,frcn,cz)
do L = lnx1D+1,lnx
if (hu(L) > 0) then
if (jaconveyance2D == 0) then ! original default
h0 = max(epshs, 1d0 / huvli(L))
else if (jaconveyance2D == -1) then ! better for straight test
h0 = max(epshs, hu(L)) ! does it whole not
endif
frcn = frcu(L)
if ( frcn.gt.0d0 ) then
call getcz(h0, frcn, ifrcutp(L), cz)
cfuhi(L) = ag/(h0*cz*cz)
else
cfuhi(L) = 0d0
end if
endif
enddo
!$OMP END PARALLEL DO
endif
endif
end subroutine setcfuhi
subroutine getcz(h1, frcn, ifrctyp, cz) ! basic get chezy coefficient, this routine is not safe for frcn == 0
use m_physcoef, only : sag, vonkar, ee
implicit none
integer, intent(in) :: ifrctyp !< friction type
double precision :: h0, h1 !< hydraulic radius
double precision, intent(in) :: frcn !< friction coeff
double precision, intent(out) :: cz !< Computed Chezy coeff
double precision :: hurou, sixth = 1d0/6d0, sqcf, z0
h0 = max(h1,1d-4)
if (ifrctyp == 0) then ! Chezy type
cz = frcn
else if (ifrctyp == 1) then ! Manning type
cz = ( h0**sixth ) / frcn
else if (ifrctyp == 2) then ! White Colebrook Delft3
z0 = min( frcn / 30d0 , h0*0.3d0)
sqcf = vonkar/log( h0/(ee*z0) )
cz = sag/sqcf
else if (ifrctyp == 3) then ! White Colebrook WAQUA
hurou = max(0.5d0, h0/frcn)
cz = 18d0*log10(12d0*hurou)
else if ( ifrctyp == 4 .or. ifrctyp == 5 .or. ifrctyp == 6 ) then ! also manning, just testing implicitness in furu
cz = ( h0**sixth ) / frcn
else
cz = 60d0 ! dummies for hydaulically smooth
endif
end subroutine getcz
subroutine getczz0(h0, frcn, ifrctyp, cz, z0) ! basic get z0 (m), this routine is not safe for frcn == 0
use m_physcoef, only : sag, vonkar, ee, ee9
implicit none
integer :: ifrctyp
double precision :: h0, frcn, cz, z0, sqcf, hurou, z02 ! hydraulic radius, friction coeff, friction typ, chezy coeff
double precision :: sixth = 1d0/6d0
h0 = max(h0,1d-4)
if (ifrctyp == 0) then ! Chezy type
cz = frcn
!z0 = h0 / ( exp (vonkar*cz/sag + 1d0) - ee9) !
z0 = h0*exp(-1d0 - vonkar*cz/sag)
else if (ifrctyp == 1) then ! Manning type
cz = ( h0**sixth ) / frcn
!z0 = h0 / ( exp (vonkar*cz/sag + 1d0) - ee9)
z0 = h0*exp(-1d0 - vonkar*cz/sag)
else if (ifrctyp == 2) then ! White Colebrook Delft3D
z0 = min( frcn / 30d0 , h0*0.3d0)
sqcf = vonkar/log( h0/(ee*z0) )
cz = sag/sqcf
else if (ifrctyp == 3) then ! White Colebrook WAQUA
hurou = max(0.5d0, h0/frcn)
cz = 18d0*log10(12d0*hurou)
!z0 = h0 / ( exp (vonkar*cz/sag + 1d0) - ee9)
z0 = h0*exp(-1d0 - vonkar*cz/sag)
else
cz = 60d0 ! dummies for hydraulically smooth
!z0 = h0 / ( exp (vonkar*cz/sag + 1d0) - ee9)
z0 = h0*exp(-1d0 - vonkar*cz/sag)
endif
end subroutine getczz0
subroutine shipcoor(n,sx1,sy1,sx2,sy2) ! get absolute shipcoordinates in sx2, sy2), input sx1, sy1 : ( 1, -1) = (bow , portside )
use m_ship ! (-1, 1) = (stern, starboard)
implicit none
double precision :: sx1,sx2,sy1,sy2,css,sns
integer :: n
css = cos(shi(n)) ; sns = sin(shi(n))
sx2 = shx(n) + sx1*shL(n)*css - sy1*shb(n)*sns ! square ship
sy2 = shy(n) + sx1*shL(n)*sns + sy1*shb(n)*css
end subroutine shipcoor
subroutine copynetcellstonetnodes() ! for smooth plotting only
use m_flowgeom
use m_flow
use m_netw
implicit none
integer :: k, kk, kkk, n, nn, nn4, ierr, ja
real, allocatable, save :: rn(:)
double precision :: znn
double precision :: znod
ja = 0
if (.not. allocated(rn) ) then
ja = 1
else if (size(rn) < numk) then
deallocate(rn) ; ja = 1
endif
if (ja == 1) then
allocate ( rn(numk) , stat = ierr)
call aerr('rn(numk)', ierr , numk)
endif
rnod = 0d0; rn = 0d0
do n = 1, ndx2d
nn4 = netcell(n)%n
znn = rlin(n)
do kk = 1, nn4
kkk = netcell(n)%nod(kk)
rnod(kkk) = rnod(kkk) + znn*ba(n)
rn (kkk) = rn(kkk) + ba(n)
enddo
enddo
do k = 1,numk
if (rn(k) > 0) then
rnod(k) = rnod(k)/rn(k)
endif
enddo
end subroutine copynetcellstonetnodes !in afwachting van isosmoothflownodes
subroutine copyznodtornod() ! for smooth plotting only
use m_flowgeom
use m_flow
use m_netw
implicit none
integer :: k, kk, kkk, n, nn, ierr, ja
real, allocatable, save :: rn(:)
double precision :: znn
double precision :: znod
ja = 0
if (.not. allocated(rn)) then
ja = 1
else if (size(rn) < numk) then
deallocate(rn) ; ja = 1
endif
if (ja == 1) then
allocate ( rn(numk) , stat = ierr)
call aerr('rn(numk)', ierr , numk); rn = 0d0
do n = 1, ndx2d
nn = size(nd(n)%nod)
do kk = 1, nn
kkk = nd(n)%nod(kk)
rn (kkk) = rn(kkk) + ba(n)
enddo
enddo
endif
rnod = 0d0
do n = 1, ndx2d
znn = znod(n)
if (znn .ne. 0d0) then
nn = size(nd(n)%nod)
do kk = 1, nn
kkk = nd(n)%nod(kk)
rnod(kkk) = rnod(kkk) + real(znn*ba(n))
enddo
endif
enddo
do k = 1,numk
if (rn(k) > 0) then
rnod(k) = rnod(k)/rn(k)
endif
enddo
end subroutine copyznodtornod
subroutine copyzlintornod() ! for smooth plotting only
use m_flowgeom
use m_flow
use m_netw
implicit none
integer :: L, k, k1, k2, ierr, ja
real, allocatable, save :: rn(:)
double precision :: zL, aL
double precision :: zlin
ja = 0
if (.not. allocated(rn) ) then
ja = 1
else if (size(rn) < numk) then
deallocate(rn) ; ja = 1
endif
if (ja == 1) then
allocate ( rn(numk) , stat = ierr)
call aerr('rn(numk)', ierr , numk)
endif
rnod = 0d0; rn = 0d0
do L = lnx1D + 1, lnxi ! regular 2D flow links
k1 = lncn(1,L) ! netnode 1
k2 = lncn(2,L) ! netnode 2
zL = zlin(L)
aL = dx(L)*wu(L)
rnod(k1) = rnod(k1) + zL*aL
rn (k1) = rn (k1) + aL
rnod(k2) = rnod(k2) + zL*aL
rn (k2) = rn (k2) + aL
enddo
do k = 1,numk
if (rn(k) > 0) then
rnod(k) = rnod(k)/rn(k)
endif
enddo
end subroutine copyzlintornod
subroutine copywaterlevelstosamples()
use m_samples
use m_flowgeom
use m_flow
USE M_MISSING
implicit none
integer :: k, n
double precision, external :: znod
k = 0
do n = 1,ndx
if ( hs(n) .gt. 1d-4 ) then
k = k + 1
call increasesam(k)
xs(k) = xz(n) ; ys(k) = yz(n) ; zs(k) = znod(n)
endif
enddo
ns = k
end subroutine copywaterlevelstosamples
subroutine copyflowcellsizetosamples()
use m_samples
use m_netw
use m_flowgeom
USE M_MISSING
implicit none
integer :: k, n
call flow_geominit(0)
k = ns
do n = 1,ndx
k = k + 1
call increasesam(k)
xs(k) = xz(n) ; ys(k) = yz(n) ; zs(k) = sqrt(ba(n))
enddo
ns = k
ndx = 0
end subroutine copyflowcellsizetosamples
subroutine copynetnodestosam()
use m_samples
use m_netw
USE M_MISSING
implicit none
integer :: in, k, n
in = -1
k = ns
KC = 0
do n = 1,numk
if (zk(n) .ne. dmiss) then
CALL DBPINPOL(XK(n), YK(n), IN)
IF (IN == 1) THEN
KC(N) = 1
K = K + 1
ENDIF
ENDIF
ENDDO
CALL INCREASESAM(k)
K = NS
do n = 1,numk
IF (KC(N) == 1) THEN
k = k + 1
xs(k) = xk(n) ; ys(k) = yk(n) ; zs(k) = zk(n)
endif
enddo
ns = k
end subroutine copynetnodestosam
!> Copy curvilinear grid to samples
subroutine copygridtosam()
use m_samples
use m_grid
USE M_MISSING
implicit none
integer :: in, k, m, n
in = -1
k = MC*NC
CALL INCREASESAM(k)
K = 0
MXSAM = MC
MYSAM = NC
xs = DMISS
ys = DMISS
zs = DMISS
IPSTAT = IPSTAT_NOTOK
do n=1,NC
do m=1,MC
k = k + 1
if ( xc(m,n).ne.DMISS .and. yc(m,n).ne.DMISS ) then
xs(k) = xc(m,n)
ys(k) = yc(m,n)
zs(k) = zc(m,n)
end if
end do
enddo
ns = k
end subroutine copygridtosam
subroutine copynetwtonetw()
use M_MAPPROPARAMETERS
use m_netw
USE M_MISSING
implicit none
integer :: in, k, n, L, k0, L0, numkn, numLn, ja
call save()
call converparameters(ja)
KC = 0 ; in = -1
numkn = 0 ; numLn = 0
do n = 1,numk
CALL DBPINPOL(XK(n), YK(n), IN)
IF (IN == 1) THEN
numkn = numkn + 1
KC(n) = numkn
ENDIF
ENDDO
do L = 1,numl
if (kc(kn(1,L)) > 0 .and. kc(kn(2,L)) > 0) then
numLn = numLn + 1
endif
enddo
K0 = numk ; L0 = numL
CALL INCREASENETW(K0+NUMKN, L0 + NUMLN)
KC = 0 ; in = -1 ! redo kc after increasenetw
numkn = 0 ; numLn = 0
do n = 1,numk
CALL DBPINPOL(XK(n), YK(n), IN)
IF (IN == 1) THEN
numkn = numkn + 1
KC(n) = numkn
ENDIF
ENDDO
numLn = 0
do L = 1,numl
if (kc(kn(1,L)) > 0 .and. kc(kn(2,L)) > 0) then
numLn = numLn + 1
kn(1,numLn+L0) = kc( kn(1,L) ) + numk
kn(2,numLn+L0) = kc( kn(2,L) ) + numk
kn(3,numLn+L0) = kn(3,L)
endif
enddo
do n = 1,numk
IF (kc(n) > 0) THEN
xk( kc(n) + numk ) = xk(n) + deltx
yk( kc(n) + numk ) = yk(n) + delty
zk( kc(n) + numk ) = zk(n)
ENDIF
ENDDO
numL = L0 + numLn
numk = K0 + NUMKN
end subroutine copynetwtonetw
subroutine samplestobl(key)
use m_samples
use m_flowgeom
use m_flow
implicit none
integer :: key
integer :: k,n
do n = 1,ns
call inflowcell(xs(n), ys(n),k)
if (k > 0) then
bl(k) = zs(n)
endif
enddo
call setbobs()
end subroutine samplestobl
subroutine inflowcell(xp,yp,k) ! is this point in a flowcell
use m_flowgeom
use m_flow
use m_flowexternalforcings
implicit none
double precision :: xp, yp
integer :: k
! locals
integer :: n, nn, in, kb, L
double precision :: dxx, dyy, r
k = 0
do n = 1,ndxi
nn = size( nd(n)%x )
IF (NN > 2) THEN
call PINPOK (Xp, Yp, Nn, nd(n)%x, nd(n)%y, IN)
if (in == 1) then
k = n
return
endif
ENDIF
enddo
do n = 1, nbndz
kb = kbndz(1,n)
L = kbndz(3,n)
dxx = xp - xz(kb)
dyy = yp - yz(kb)
r = sqrt(dxx*dxx + dyy*dyy)
if (r < 0.3d0*dx(L) ) then
k = kb
return
endif
enddo
end subroutine inflowcell
!> Drop water *during* flow computation.
!!
!! Use idir=1 for adding water, -1 for lowering it.
subroutine dropwater(xp,yp,idir)
use m_polygon
use m_flowgeom
use m_flow
implicit none
double precision, intent(in) :: xp, yp !< Clicked point, which flow node to drop. If a polygon is active, drop all contained points, independent of xp, yp.
integer, intent(in) :: idir !< direction (1 for up, -1 for down)
! locals
integer :: n, nn, in, ncol
double precision :: dropstep, s10
if (ndx == 0) return
dropstep = idir*sdropstep
if (npl > 2) then
in = -1
do n = 1,ndxi
CALL DBPINPOL( xz(n), yz(n), IN)
if (in == 1) then
s10 = s1(n)
s1(n) = max(bl(n), s1(n) + dropstep)
vol0tot = vol0tot + (s1(n)-s10)*ba(n)
call isocol(s1(n),ncol)
nn = size( nd(n)%x )
call pfiller(nd(n)%x, nd(n)%y, nn, ncol, 30)
endif
enddo
else
do n = 1,ndxi
nn = size( nd(n)%x )
call PINPOK(Xp, Yp, Nn, nd(n)%x, nd(n)%y, IN)
if (in == 1) then
s10 = s1(n)
s1(n) = max(bl(n), s1(n) + dropstep)
call isocol(s1(n),ncol)
nn = size( nd(n)%x )
call pfiller(nd(n)%x, nd(n)%y, nn, ncol, 30)
exit
endif
enddo
endif
hs = s1-bl
call volsur() ! dropwater
call flow_f0isf1() ! dropwater
volerr = 0; volerrcum = 0
if (kmx > 0) then
call setkbotktop(1) ! dropwater
endif
validateon = .false.
end subroutine dropwater
!> Drop land *during* flow computation.
!!
!! Use idir=1 for adding land, -1 for lowering it.
!! The height change is performed on net node vertical zk
!! With a polygon active: all masked net nodes,
!! without polygon: all corner points of flow cell underneath mouse pointer.
subroutine dropland(xp,yp, idir)
use network_data
use m_missing
use m_polygon
use m_flowgeom
use m_flow
use unstruc_display
use m_sediment
implicit none
double precision, intent(in) :: xp, yp !< Clicked point, which flow node to drop. If a polygon is active, drop all contained points, independent of xp, yp.
integer, intent(in) :: idir !< direction (1 for up, -1 for down)
! locals
integer :: kk, k, n, nn, in, ncol, j
double precision :: dropstep !< Amount to add (in meters, may be negative)
if (ndx == 0) return
dropstep = idir*zkdropstep
if (npl > 2) then
in = -1
do k = 1,numk
CALL DBPINPOL( xk(k), yk(k), IN)
if (in == 1 .and. zk(k) /= dmiss) then
zk(k) = zk(k) + dropstep
if (jaceneqtr == 2 .and. jased > 0) then
do j = 1,mxgr
grainlay(j, k ) = max(0d0, grainlay(j, k ) + dropstep/mxgr)
enddo
endif
call isocol(zk(k),ncol)
call movabs(xk(k),yk(k))
call hlcir2(rcir,ncol,30)
endif
enddo
else
do n = 1,ndx
nn = size( nd(n)%x )
call PINPOK(Xp, Yp, Nn, nd(n)%x, nd(n)%y, IN)
if (in == 1) then
do kk=1,nn
k = nd(n)%nod(kk)
zk(k) = zk(k) + dropstep
if (jaceneqtr == 2 .and.jased > 0) then
do j = 1,mxgr
grainlay(j, k ) = max(0d0, grainlay(j, k ) + dropstep/mxgr)
enddo
endif
call isocol(zk(k),ncol)
call movabs(xk(k),yk(k))
call hlcir2(rcir,ncol,30)
end do
exit
endif
enddo
endif
call setbobs()
s1 = max(bl,s1) ; s0=s1 ; s00 = s1
hs = s1-bl
call volsur() ! dropland
call flow_f0isf1() ! dropland
volerr = 0; volerrcum = 0
if (kmx > 0) then
call setkbotktop(1) ! dropland
endif
! NOTE: vol1tot cumulation now contains an error: new bl's have not been accounted for...
end subroutine dropland
subroutine dropk(xp,yp,idir)
use m_polygon
use m_flowgeom
use m_flow
implicit none
double precision, intent(in) :: xp, yp
integer, intent(in) :: idir
! locals
integer :: L, LL, Lb, Lt
call isln(xp, yp, LL)
if (LL > 0) then
call getLbotLtop(LL,Lb,Lt)
do L = Lb-1, Lt
turkin0(L) = turkin0(L) + 1d0
turkin1(L) = turkin0(L)
enddo
endif
return
end subroutine dropk
! updates zk value at specified net node index using diven delta
! TODO: extend it to multiple indices
subroutine update_land(node_index, new_zk)
use network_data
use m_missing
use m_polygon
use m_flowgeom
use m_flow
use unstruc_display
use m_sediment
implicit none
integer, intent(in) :: node_index
double precision, intent(in) :: new_zk
! locals
integer :: kk, k, n, nn, ncol, j, i
double precision :: old_zk
if (ndx == 0) return
k = node_index
if (npl > 2) then
old_zk = zk(k)
zk(k) = new_zk
if (jaceneqtr == 2 .and.jased > 0) then
do j = 1,mxgr
grainlay(j, k ) = max(0d0, grainlay(j, k ) + (old_zk - new_zk)/mxgr)
enddo
endif
call isocol(zk(k), ncol)
call movabs(xk(k), yk(k))
call hlcir2(rcir, ncol, 30)
else
old_zk = zk(k)
zk(k) = new_zk
if (jaceneqtr == 2 .and.jased > 0) then
do j = 1,mxgr
grainlay(j, k ) = max(0d0, grainlay(j, k) + (old_zk - new_zk)/mxgr)
enddo
endif
call isocol(zk(k),ncol)
call movabs(xk(k),yk(k))
call hlcir2(rcir,ncol,30)
endif
call setbobs()
s1 = max(bl, s1) ; s0=s1; s00 = s1
hs = s1 - bl
call volsur() ! dropland_zk
call flow_f0isf1() ! dropland_zk
volerr = 0; volerrcum = 0
if (kmx > 0) then
call setkbotktop(1) ! dropland_zk
endif
end subroutine update_land
subroutine dropzout(idir)
use m_polygon
use m_flowgeom
use m_flow
implicit none
integer, intent(in) :: idir !< direction (1 for up, -1 for down)
! locals
integer :: n, nn, in, ncol, k, kb, kt
double precision :: dropstep, s10
if (ndx == 0) return
dropstep = idir*sdropstep
if (npl > 2) then
in = -1
do n = 1,ndx
CALL DBPINPOL( xz(n), yz(n), IN)
if (in == 1) then
call getkbotktop(n,kb,kt)
if (idir == 1) then
kb = kb + kplot - 1
endif
do k = kb,kt
sam1tot = sam1tot - sa1(k)*vol0(k)
sa1(k) = max(0d0, sa1(k) + dropstep)
sam1tot = sam1tot + sa1(k)*vol1(k)
call isocol(sa1(n),ncol)
nn = size( nd(n)%x )
call pfiller(nd(n)%x, nd(n)%y, nn, ncol, 30)
enddo
endif
enddo
else
n = nplot
call getkbotktop(n,kb,kt)
k = kb + kplot - 1
sam1tot = sam1tot - sa1(k)*vol0(k)
sa1(k) = max(0d0, sa1(k) + dropstep)
sam1tot = sam1tot + sa1(k)*vol1(k)
call isocol(sa1(n),ncol)
nn = size( nd(n)%x )
call pfiller(nd(n)%x, nd(n)%y, nn, ncol, 30)
endif
if (kmx > 0) then
call setkbotktop(1) ! drop
endif
end subroutine dropzout
subroutine minmxsam()
use m_samples
use m_missing
implicit none
logical inview
double precision :: rmin, rmax
double precision :: VMAX,VMIN,DV,VAL(256)
integer :: NCOLS(256),NIS,NIE,nv,JAAUTO
common /depmax2/ vmax,vmin,dv,val,ncols,nv,nis,nie,jaauto
integer :: k, i
if (jaauto .eq. 1) then
rmin = 1d30
rmax = -1d30
do k = 1,ns
if ( zs(k)==DMISS ) cycle
if ( inview( xs(k), ys(k) ) ) then
if (zs(k) < rmin) then
rmin = zs(k)
endif
if (zs(k) > rmax) then
rmax = zs(k)
endif
endif
enddo
vmax = rmax
vmin = rmin
endif
dv = vmax - vmin
do i = 1,nv
val(i) = vmin + (i-1)*dv/(nv-1)
enddo
CALL PARAMTEXT('Samples (m)', 2 )
end subroutine minmxsam
subroutine minmxnds()
use unstruc_display ! bepaal minimum en maximum van znod in viewing area
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: i
double precision :: rmin, rmax
double precision :: znod
double precision :: zn
integer :: n, ja2, ndraw
logical inview
double precision :: VMAX,VMIN,DV,VAL(256)
integer :: NCOLS(256),NIS,NIE,nv,JAAUTO
common /depmax/ vmax,vmin,dv,val,ncols,nv,nis,nie,jaauto
COMMON /DRAWTHIS/ NDRAW(40)
if (jaauto .eq. 1) then
rmin = 1d30; ndmin = 0
rmax = -1d30; ndmax = 0
do n = 1,ndx
ja2 = 1
if (wetplot > 0d0) then
if (hs(n) < wetplot) then
ja2 = 0
endif
endif
if ( ja2 == 1 .or. ndraw(28) == 3) then
if ( inview( xz(n), yz(n) ) ) then
zn = znod(n)
if ( zn.eq.DMISS ) cycle
if (zn < rmin) then
rmin = zn ; ndmin = n
endif
if (zn > rmax) then
rmax = zn ; ndmax = n
endif
endif
endif
enddo
vmax = rmax
vmin = rmin
endif
dv = vmax - vmin
do i = 1,nv
val(i) = vmin + (i-1)*dv/(nv-1)
enddo
end subroutine minmxnds
subroutine minmxlns()
use m_flowgeom
use m_flow
use m_missing
implicit none
double precision :: zlin
double precision :: zn
double precision :: rmin, rmax
integer :: i, l, n, k1, k2
logical inview
double precision :: VMAX,VMIN,DV,VAL(256)
integer :: NCOLS(256),NIS,NIE,nv,JAAUTO
common /depmax2/ vmax,vmin,dv,val,ncols,nv,nis,nie,jaauto
if (jaauto .eq. 1) then
rmin = 1d30; lnmin = 0
rmax = -1d30; lnmax = 0
do L = 1,lnx
k1 = ln(1,L)
k2 = ln(2,L)
if (inview( xz(k1), yz(k1) ) .or. inview( xz(k2), yz(k2) ) ) then
zn = zlin(L)
if ( zn.eq.DMISS ) cycle
if (zn < rmin) then
rmin = zn ; lnmin = L
endif
if (zn > rmax) then
rmax = zn ; lnmax = L
endif
endif
enddo
vmax = rmax
vmin = rmin
endif
dv = vmax - vmin
do i = 1,nv
val(i) = vmin + (i-1)*dv/(nv-1)
enddo
return
end subroutine minmxlns
double precision function zcorn(k) ! get various values at flow cell corners
use m_flow
use m_flowgeom
implicit none
common /drawthis/ ndraw(40)
integer :: ndraw
integer :: k, nodval
nodval = ndraw(31)
if (nodval == 2) then
zcorn = ucnx(k)
else if (nodval == 3) then
zcorn = ucny(k)
else if (nodval == 4) then
zcorn = sqrt( ucnx(k)*ucnx(k) + ucny(k)*ucny(k) )
endif
end function zcorn
double precision function znod(kk) ! get various values at flow nodes
use m_flow
use m_flowgeom
use m_reduce
use m_flowtimes ! for volerr
use m_sediment
use m_missing
use m_partitioninfo
use m_xbeach_data, only: ee1, rr, ee1sum
use m_transport
use m_missing
implicit none
common /drawthis/ ndraw(40)
integer :: ndraw
integer :: kk, k, nodval,N,L, k2
double precision :: uu, seq(mxgr), wse(mxgr),hsk
nodval = ndraw(28)
if ( kk.lt.1 ) then
znod = DMISS
return
end if
k = kk
if (kmx > 0) then
k = kbot(kk) - 1 + min( kplot, kmxn(kk) )
k = min(k, ktop(kk) )
endif
znod = dmiss
!if ( jampi.eq.1 ) then
! if ( idomain(k).ne.my_rank ) return
!end if
if (nodval == 2) then
znod = s1(kk)
else if (nodval == 3) then
znod = bl(kk)
else if (nodval == 4) then
znod = ba(kk)
else if (nodval == 5) then
znod = a1(kk)
else if (nodval == 6) then
znod = vol1(k)
else if (nodval == 7) then
znod = s1(kk) - bl(kk)
else if (nodval == 8) then
znod = sqrt( ucx(k)*ucx(k) + ucy(k)*ucy(k) )
else if (nodval == 9) then
znod = ucx(k)
else if (nodval == 10) then
znod = ucy(k)
else if (nodval == 11) then
if (jasal > 0) znod = sa1(k)
else if (nodval == 12) then
if (jatem > 0) znod = tem1(k)
else if (nodval == 13) then
if (jased > 0) then
znod = sed( jgrtek, k )
endif
else if (nodval == 14) then
if (hs(k) > 0) then
znod = sqrt( ucx(k)*ucx(k) + ucy(k)*ucy(k) ) / sqrt(ag*hs(k)) ! Froude
else
znod = 0d0
endif
else if (nodval == 15) then
znod = k
else if (nodval == 16) then
znod = nd(kk)%lnx
else if (nodval == 17) then
znod = voldhu(kk) - vol1(kk) ! kcs(kk)
else if (nodval == 18) then
znod = squ(k)
else if (nodval == 19) then
znod = sqi(k)
else if (nodval == 20) then
znod = sqi(k) - squ(k)
else if (nodval == 21) then
znod = qw(k)
else if (nodval == 22) then
if (jased>0) then
call getequilibriumtransportrates(kk, seq, wse, mxgr, hsk)
znod = seq(jgrtek)
endif
else if (nodval == 23) then
znod = turkinepsws(1,k) ! qin(k)
else if (nodval == 24) then
if (mxgr > 1 .and. jaceneqtr == 1) znod = grainlay(jgrtek,kk)
else if (nodval == 25 .and. kmx > 0) then
znod = ktop(kk) - kbot(kk) + 1
else if (nodval == 26) then
znod = ducdx(k) ! tttc(k) ! aif(kk) ! bz(kk) ! kfs(kk)
else if (nodval == 27) then
if (kmx>1) znod = vicwws(k)
! 28 = substi/cg
else if (nodval == 29) then
znod = tidep(kk)
else if (nodval == 30) then
znod = dt_max
do k = kbot(kk), ktop(kk)
znod = min(znod, vol1(k) / max( squ(k), eps10) )
enddo
else if (nodval == 31) then
if (japatm > 0) znod = patm(kk)
else if (nodval == 32) then
if (numlimdt(kk) > 0) znod = numlimdt(kk)
else if (nodval == 33) then
ZNOD = ( ucx(k)*ucx(k) + ucy(k)*ucy(k) ) / (2d0*ag)
znod = u1(min(k,lnx))*u1(min(k,lnx)) / (2d0*ag)
znod = znod + s1(kk)
plotlin(kk) = znod
else if (nodval == 34) then
znod = volerror(k)
!if (abs(znod) > 1) then
! znod = 0d0
!endif
!znod = aif(kk)
else if (nodval == 35) then
znod = rho(k) ! sam0(k) ! kktop(kk) - kbot(kk) + 1
else if (nodval == 36) then
znod = dt_max
do k = kbot(kk), ktop(kk)
if (squ(k) > eps10) then
znod = min(znod, cflmx*vol1(k)/squ(k))
endif
enddo
else if (nodval == 37) then
znod = same(k)
else if (nodval == 38) then
znod = zws(k) - zws(k-1)
else if (nodval == 39) then
znod = taus(k)
else if (nodval == 40) then
znod = rain(k)
else if (nodval == 41 .and. jatem > 0) then
znod = rhum(k)
else if (nodval == 42 .and. jatem > 0) then
znod = tair(k)
else if (nodval == 43 .and. jatem > 0) then
znod = clou(k)
else if (nodval == 44 .and. jatem > 0 .and. allocated(qrad)) then
znod = qrad(k)
else if (nodval == 46 .and. jasecf > 0) then
if ( jasecf > 0 ) then
znod = spircrv(kk)
else
znod = bz(kk)
endif
else if (nodval == 47 .and. jasecf > 0) then
znod = spirint(kk)
else if (nodval == 48 .and. jasecf > 0) then
znod = spirang(kk)
else if (nodval == 49 .and. jasecf > 0) then
znod = sqrt( spirfx(kk) * spirfx(kk)+ spirfy(kk) * spirfy(kk) )
else if (nodval .eq. 45 .and. NUMCONST.gt.0 ) then
if ( iconst_cur.gt.0 .and. iconst_cur.le.NUMCONST ) then
znod = constituents(iconst_cur,k)
end if
else if (nodval >= 50 .and. nodval <= 54) then ! TODO: Johan Reyns: options 50 to 54 at not displayed now!
znod = sum(ee1(:,kk),dim=1)
!znod = ee1(1,kk)
!znod = sum(rr(:,kk),dim=1)
!znod = ee1sum(kk)
!znod = plotlin(kk)
!else if (nodval == 55) then
! znod = blinc(k)
endif
end function znod
double precision function zlin(LL) ! get various values at flow links
use m_flow
use m_flowgeom
use m_wind
use m_reduce, only : ccr, lv2
implicit none
common /drawthis/ ndraw(40)
integer :: ndraw
integer, intent(in) :: LL
integer :: L, L2,linval, ifrctyp, k1, k2, n1, n2
double precision :: cosphiu, frcn, omega1, omega2, zb1, zb2
L = LL
if (kmx > 0) then
L2 = min(LL,lnx)
L = Lbot(L2) - 1 + min (kplot, Ltop(L2) - Lbot(L2) + 1 )
endif
linval = ndraw(29)
if ( linval == 2) then
zlin = abs(u1(L))
else if ( linval == 3) then
zlin = q1(L)*wui(LL)
else if ( linval == 4) then
zlin = q1(L)
else if ( linval == 5) then
zlin = au(L)
else if ( linval == 6) then
zlin = hu(L)
else if ( linval == 7) then
zlin = frcu(LL)
else if ( linval == 8) then
zlin = dx(LL)
else if ( linval == 9) then
zlin = wu(LL)
else if ( linval ==10) then ! rust aan de ogen
zlin = bob(1,LL)
else if ( linval ==11) then
zlin = bob(2,LL)
else if ( linval == 12) then
zlin = dble(kcu(LL))
else if ( linval == 13) then
zlin = viu(L)
else if ( linval == 14) then
zlin = teta(LL)
else if ( linval == 15) then
else if ( linval == 16) then
zlin = u1(L)
else if ( linval == 17) then
if (u1(L) > 0d0) then
zlin = adve(L)
else
zlin = -adve(L)
endif
else if ( linval == 18) then
zlin = advi(L)
else if ( linval == 19) then
zlin = Fu(L)
else if ( linval == 20) then
zlin = Ru(L) ! -ag*dxi(L)*( s0(ln(2,L)) - s0(ln(1,L)) ) - adve(L)
else if ( linval == 21) then
zlin = suu(L)
else if ( linval == 22) then
zlin = aifu(LL) ! ccr(lv2(LL))
else if ( linval == 23) then
zlin = u1(L)*csu(LL)
else if ( linval == 24) then
zlin = cfuhi(LL)
else if ( linval == 25) then
zlin = wx(LL)
else if ( linval == 26) then
zlin = wy(LL)
else if ( linval == 27) then
zlin = wdsu(LL)
else if ( linval == 28) then
zlin = dabs(cosphiu(LL))
else if ( linval == 29) then
zlin = LL
else if ( linval == 30) then
zlin = v(L)
else if ( linval == 31) then
zlin = Fu(L)
else if ( linval == 32) then
zlin = Ru(L)
else if ( linval == 33) then
zlin = iadv(LL)
else if ( linval == 34) then
zlin = plotlin(L)
else if ( linval == 35) then
zlin = ln(1,L)
else if ( linval == 36) then
zlin = ln(2,L)
else if ( linval == 37) then !
zlin = plotlin(L)
else if ( linval == 38) then
zlin = plotlin(L)
else if ( linval == 39) then
zlin = dxi(LL)*( bl(ln(2,LL)) - bl(ln(1,LL)) )
else if ( linval == 40) then
zlin = ifrcutp(LL)
else if ( linval == 41) then
zlin = turkin0(L)
else if ( linval == 42) then
zlin = tureps0(L)
else if ( linval == 43) then
zlin = vicwwu(L)
else if ( linval == 44) then
zlin = ustb(LL)
else if ( linval == 45) then
if (L < ltop(LL) ) then
k1 = ln(1,L) ; k2 = ln(2,L)
n1 = ln(1,LL) ; zb1 = zws(kbot(n1)-1)
n2 = ln(2,LL) ; zb2 = zws(kbot(n2)-1)
omega1 = qw(k1) / a1(ln(1,LL))
omega2 = qw(k2) / a1(ln(2,LL))
zlin = 0.5d0*omega1 + 0.5d0*omega2 + 0.5d0*(u0(L)+u0(L+1))*( zws(k2)-zb2 - (zws(k1)-zb1) )*dxi(LL)
else
zlin = -999
endif
else if ( linval == 46) then
zlin = hu(L) - hu(L-1)
else if ( linval == 47) then
zlin = frculin(LL)
else
zlin = -999
endif
end function zlin
subroutine clearflowmodelinputs()
use m_flow
implicit none
nbndz = 0
nbndu = 0
nbnds = 0
nbndtm = 0
nbndt = 0
nbnduxy = 0
end subroutine clearflowmodelinputs
!> Initialise flow model time dependent parameters
!! @return Integer error status (0) if succesful.
integer function flow_flowinit() result(iresult)
use m_netw
use m_flowgeom
use m_flow
use m_flowtimes
use m_sferic
use unstruc_model
use unstruc_files
use m_reduce, only : nodtot, lintot
use m_samples
use m_missing
use m_fixedweirs
use m_partitioninfo
use m_sediment
use m_xbeach_data, only: s1initial
use m_transport
use dfm_error
use m_sobekdfm
use m_crosssections, only : crs, ReallocCrosssectionSums
use string_module, only: str_lower
implicit none
! locals
integer :: k, L, k1, k2, n, jw, msam
integer :: kb, kt, LL
double precision :: r,eer,r0,dep,Rossby,amp,csth, sqghi, ss, snth, x, y, uth
double precision :: xx, yy, zz, ux, uy, pin, xli, atet, slope, cz, z00, cs
double precision :: xx1, yy1, xx2, yy2, ux1, uy1, ux2, uy2, csl, snl
double precision :: xzmin, xzmax, yzmin, yzmax, xkmin, xkmax, ykmin, ykmax, bobmin
double precision :: fout, foutk, aa, blm, dis, dmu, var, rho1, hunsat, fac, zi, zido, ziup, saldo, salup
double precision, external :: dbdistance, rho_Eckart
integer :: itest = 1, ispecials, ierr, mrst, kk, La, j, nq, ierror, N1, N2, Lb, Lt, nat
double precision :: psi, samp, ct, st, omeg, t, rr, rmx, x0, y0, dxx, dyy, blmn, blmx, dbl, bot, rms, ucmk
character(len=255) :: rstfile
character(len=4) :: EXT
logical :: jawel, jawelrestart
integer, external :: flow_initexternalforcings
double precision :: xm, ym
iresult = DFM_GENERICERROR
if (ndx == 0) then
iresult = DFM_MODELNOTINITIALIZED
goto 888
end if
Lnmax = 0 ; Lnmin = 0
ndmax = 0 ; ndmin = 0
cpusteps = 0; cpusol = 0 ; cpuall = 0 ! timing to zero
call inisferic() ! also set coriolis :<
if (icorio > 0 .and. jsferic == 1) then
call inifcori()
endif
if (jsferic == 0) then
if (jatidep > 0) then
! call qnerror('Tide generating potential only supported for sferical models ' ,' ',' ')
jatidep = 0
endif
endif
call inidensconstants() ! Some density parameters
if (ti_waq > 0d0 .and. max(limtypmom, limtypsa, limtypTM) <= 0) then
call qnerror('DELWAQ requires at least one limiter (Numerical Parameters). DELWAQ output disabled for now.', ' ', ' ')
ti_waq = 0d0
end if
teta = abs(teta0) ! set spatially constant teta. Override only in setdt for ivariableteta = 2
if (teta0 == 1d0) then
ivariableteta = 0 ! fully implicit
teta = 1d0
else if (teta0 < 0 ) then
ivariableteta = 2 ! variable teta
else
ivariableteta = 1 ! constant teta
teta = teta0
endif
s1 = sini ! initial values
u1 = uini
if (jasal > 0) then
sa1 = salini
endif
if (jatem > 0) then
tem1 = temini
endif
! spiral flow
if (jasecf > 0 ) then
spirint = spirini
endif
if (jased > 0 .and. .not. stm_included) then
do k = 1,ndkx
do j = 1,mxgr
sed(j,k) = sedini(j)
enddo
enddo
endif
if (jasal == 0 .and. jatem == 0 .and. jased == 0) then
idensform = 0
endif
volerror = 0d0 ; squ = 0 ; sqi = 0
nplot = ndxi/2 ! vertical profile to be plotted at node nr
! so this is not yet time dependent...
! if (ndx .le. 100) s1(1) = s1(1) + 0.1d0
ispecials = 1
call str_lower(md_netfile) ! INTERACTOR!
if (ispecials == 1) then
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
CALL DMINMAX( xk, numk, xkmin, xkmax, numk)
if (bedslope .ne. 0d0) then
do k = 1,numk
if (zk(K) == dmiss) then
zk(k) = zkuni + xk(k)*bedslope
endif
enddo
call setbobs()
endif
if (md_IDENT(1:6) == 'wetbed' .or. md_IDENT(1:6) == 'drybed') then ! wetbed, drybed
call setbobs()
jw = 1
if (md_IDENT(1:6) == 'drybed') then
jw = 0
endif
do k = 1,ndx
if (xz(k) .le. 0.5d0*(xzmin+xzmax) ) then
s1(k) = bl(k) + 2d0
else if (jw == 1) then
s1(k) = bl(k) + hwetbed
endif
enddo
if (kmx > 0) then
call setkbotktop(1) ! wetbed
if (jasal > 0) then
do k = 1,ndx
if (xz(k) .le. 0.5d0*(xzmin+xzmax) ) then
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = 2d0
enddo
endif
enddo
endif
endif
else if (md_IDENT(1:7) == 'barocin') then ! baroclinic instability
xx1 = 0.5d0*(xzmin+xzmax) ; yy1 = 0.5d0*(xzmin+xzmax)
call setkbotktop(1) ! barocin
do k = 1,ndx
rr = dbdistance( xx1, yy1, xz(k), yz(k) )
if (rr < 3000d0 ) then
call getkbotktop(k,kb,kt)
do kk = kb+kmx/2,kt
!sa1(kk) = sa1(kk) + deltasalinity
sa1(kk) = 1.1d0*(rr/3000d0)**8 + 33.75d0
enddo
endif
enddo
else if (md_IDENT(1:16) == 'internalseichexx') then ! internal seiche hofmeister 2010
call setkbotktop(1) ! internalseichexx
salup = 0d0 ; saldo = 30d0
do k = 1,ndx
zi = -10d0*( 1d0 - 0.2d0*sin( pi*xz(k)/(xkmax-xkmin) ) ) ; ziup = zi + 2d0 ; zido = zi - 2d0
call getkbotktop(k,kb,kt)
do kk = kb,kt
zz = 0.5d0*( zws(kk) + zws(kk-1) )
if (zz > ziup) then
sa1(kk) = salup
else if (zz < zido) then
sa1(kk) = saldo
else
rr = (zz - zido) / (ziup-zido)
sa1(kk) = saldo*(1d0-rr) + salup*rr
endif
enddo
enddo
else if (md_IDENT == 'hump' .or. md_IDENT == 'humpc') then
xx1 = 5000d0 ; yy1 = 5000d0
var = 1d0 ; dmu = 0d0
do k = 1,numk
dis = dbdistance(xk(k), yk(k), xx1, yy1)
if (dis < 5d3) then
xx = dis/1000d0
yy = 5d0*1d0*sqrt(twopi*var)/sqrt(twopi*var)* exp( -(xx-dmu)**2/(2d0*var) )
zk(k) = zk(k) + yy
endif
enddo
call setbobs()
else if (md_IDENT == 'twohump') then
xx1 = 5000d0 ; yy1 = 5000d0
var = 1d0 ; dmu = 0d0
do kk = 1,2
if (kk == 1) then
xx1 = 5000d0 ; yy1 = 6500d0
else
xx1 = 5000d0 ; yy1 = 3500d0
endif
do k = 1,numk
dis = dbdistance(xk(k), yk(k), xx1, yy1)
if (dis < 5d3) then
xx = dis/1000d0
yy = 11d0*1d0*sqrt(twopi*var)/sqrt(twopi*var)* exp( -(xx-dmu)**2/(2d0*var) )
zk(k) = zk(k) + yy
endif
enddo
enddo
call setbobs()
else if (md_IDENT == '21' ) then
s1(1) = s1(1) + 1d0
else if (md_netfile(1:4) == 'rivs') then
do k = 1,ndx
if (xz(k) < 4.5d0 ) then
s1(k) = s1(k) + 1d0
endif
enddo
nplot = 450
else if (md_netfile(1:4) == 'goot') then
slope = 1d0/3004d0
do k = 1,ndx
s1(k) = -slope*( xz(k) - 1d0 )
enddo
else if (md_netfile(1:7) == 'evenaar') then
bl = -5d0; s1 = 0
ibedlevtyp = 1 ; call setbobs()
else if (index(md_ident,'saltwedge') > 0) then !
call setkbotktop(1) ! inisaltwedge
do k = 1,ndx
if (xz(k) < 0.5*(xzmin+xzmax) ) then
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = 10d0
rho1 = rho_Eckart(kk)
enddo
else
!s1(k) = bl(k) + 0.5d0*( s1(k)-bl(k) )*sqrt(rho1/998.200) ! rho = 1020 etc
endif
enddo
else if (index(md_ident,'salthori') > 0 .and. kmx > 0) then !
call setkbotktop(1) ! ini vertical salinity gradient
! call correctblforzlayerpoints() ! using kbot set bl of first z-layer
! call setkbotktop(1) ! setkbot again, now using bl at strictly horizontal level
! in z-layers, zws is now strictly horizontal, so that
! vertical salinityprofiles set in initexternalf will now yield zero baroclinic terms
do k = 1,ndx
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = max(0d0, abs( 0.5d0*(zws(kk) + zws(kk-1)) ) )
enddo
enddo
else if (index(md_ident,'lockexchange') > 0) then !
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
call setkbotktop(1) ! inisaltwedge
do k = 1,ndx
call getkbotktop(k,kb,kt)
do kk = kb,kt
if (xz(k) > 0.5*(xzmin+xzmax) ) then
sa1(kk) = 6.5d0
else
sa1(kk) = 5.0d0
endif
enddo
enddo
else if (index(md_ident,'locxx') > 0 .or. index(md_ident,'t0st') > 0) then ! Commented: It triggers on mdu-names that just include 'loc' in the name
! For instance: 'locationDelft.mdu',
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx) ! 'normalvelocities.mdu', etc.
if ( jampi.eq.1 ) then
call reduce_double_min(xzmin)
call reduce_double_max(xzmax)
end if
if ( index(md_ident,'locxxfix') > 0) then
kplot = kmx-1
do k = 1,ndx
if (xz(k) < 0.5*(xzmin+xzmax) ) then
s1 (k) = s1(k) - 6d0
endif
enddo
else
do k = 1,ndx
if (xz(k) < 0.5*(xzmin+xzmax) ) then
s1 (k) = s1(k) + 10d0*.004d0*0.5d0
endif
enddo
endif
call setkbotktop(1) ! inisaltwedge
do k = 1, ndx
call getkbotktop(k,kb,kt)
do kk = kb,kt
if ( index(md_ident,'locxxfix') > 0) then
if (kk == kb) then
sa1(kk) = 1d0
else
sa1(kk) = 1d0
endif
else
if (xz(k) > 0.5*(xzmin+xzmax) ) then
sa1(kk) = 10d0
if (jatem > 0) then
tem1(kk) = 5d0
endif
if (zws(kk) > -5d0) sa1(kk) = 5d0
else
sa1(kk) = 5d0
if (jatem > 0) then
tem1(kk) = 10d0
endif
endif
endif
sa1(k) = sa1(k) + vol1(kk)*sa1(kk)
if (jatem > 0) then
tem1(k) = tem1(k) + vol1(kk)*tem1(kk)
endif
enddo
sa1(k) = sa1(k) / vol1(k)
if (jatem > 0) then
tem1(k) = tem1(k) / vol1(k)
endif
enddo
else if (index(md_ident,'canal-lake') > 0 ) then
call setkbotktop(1) ! inisaltwedge
do k = 1, ndx
call getkbotktop(k,kb,kt)
do kk = kb,kt
if (zws(kk) < -5d0 ) then
sa1(kk) = 10d0
endif
enddo
enddo
else if (index(md_ident,'internalwave') > 0) then !
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
call setkbotktop(1) ! inisaltwedge
do k = 1,ndx
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = 0.001d0*xz(k) - (0.5d0*(zws(kk) + zws(kk-1)) - bl(k)) + 11d0
enddo
enddo
else if (index(md_ident,'slope1_5') > 0) then !
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
call setkbotktop(1) ! inisaltwedge
sa1 = 5d0
s1 = bl + 2d0
else if (index(md_ident,'huump3d') > 0) then !
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
call setkbotktop(1) !inihump3D
do k = 1,ndx
if (xz(k) < 0.5*(xzmin+xzmax) ) then
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = 10d0
enddo
else
! s1(k) = -10d0 + 10d0*sqrt(1005.750/998.200) ! rho = 1020 etc
endif
enddo
else if (index(md_netfile,'schui5') > 0) then ! schui5.net
do k = 1,ndx
if (yz(k) < -xz(k) + 6000d0 ) then
s1(k) = bl(k) + 2d0
else
s1(k) = bl(k) + .20d0
endif
enddo
else if (index(md_netfile,'schuitria') > 0 )then ! schuitria.net
do k = 1,ndx
if (yz(k) < -0.7d0*xz(k) + 1390d0 ) then
s1(k) = bl(k) + 2d0
else
s1(k) = bl(k) + .20d0
endif
enddo
else if (index(md_netfile,'vierkant') > 0 ) then ! vierkant.net
do k = 1,ndx
if (xz(k) > 1000 .and. xz(k) < 2000d0 .and. &
yz(k) > 1000 .and. yz(k) < 2000d0 ) then
s1(k) = bl(k) + 2d0
endif
enddo
s1 = 10
else if (index(md_netfile,'chan1000') > 0 ) then ! chan1000.net
do k = 1,ndx
bl(k) = -10. + 20.*(xz(k) - xz(1)) / (xz(ndx) - xz(1))
s1(k) = max (0d0, bl(k) )
enddo
ibedlevtyp = 1 ; call setbobs()
else if (index(md_ident,'thacker1d') > 0 ) then ! parab300.net
call thacker1d(1,xz,yz,s1,bl,ndx,0d0)
if (kmx > 0) then
call setkbotktop(1) ! inisaltwedge
do k = 1,ndx
if (s1(k) > 0.5d0) then
call getkbotktop(k,kb,kt)
do kk = kb,kt
sa1(kk) = 30d0
enddo
endif
enddo
endif
else if (index(md_netfile,'chezydx100') > 0 ) then
bl = -5d0 ; ibedlevtyp = 1 ; call setbobs()
s1 = 0d0
u1 = csu
else if (index(md_ident,'10player') /= 0 ) then
CALL DMINMAX( xk, numk, xkmin, xkmax, numk)
do k = 1,numk
zk(k) = -7d0 - 3d0*cos( TWOpi*(xk(k) - xkmin ) / (xkmax-xkmin) )
enddo
call setbobs()
kmx = 0
else if (index(md_ident,'checkerboard') > 0 ) then ! v40.net, v100.net
bl = 0d0
ibedlevtyp = 1 ; call setbobs()
CALL DMINMAX( xk, numk, xkmin, xkmax, numk)
n = 2
if (index(md_ident,'4') > 0 ) n = 4
if (index(md_ident,'8') > 0 ) n = 8
xli = 1d0/(xkmax-xkmin)
amp = .01d0
dep = .01d0
pin = n*pi
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
xx = 0.5d0* ( xz(k1) + xz(k2) ) * xli
yy = 0.5d0* ( yz(k1) + yz(k2) ) * xli
!k1 = lncn(1,L) ; k2 = lncn(2,L)
!xx1 = xk(k1) ; yy1 = yk(k1)
!xx2 = xk(k2) ; yy2 = yk(k2)
ux = 0d0 ; uy = 0d0
!do j = 1,10
! aa = dble(j-1)/9d0
! xx = (1d0-aa)*xx1 + aa*xx2
! yy = (1d0-aa)*yy1 + aa*yy2
ux = ux + amp*sin(pin*xx)*cos(pin*yy) ! poisson
uy = uy - amp*cos(pin*xx)*sin(pin*yy)
!enddo
!ux = 0.1d0*ux ; uy = 0.1d0*uy
u1(L) = csu(L)*ux + snu(L)*uy
enddo
do k = 1,ndx
xx = xz(k) * xli
yy = yz(k) * xli
s1(k) = dep + amp*amp*(cos(2*pin*xx)+cos(2*pin*yy))/(8*ag*pin*pin)
if (jasal > 0) then
if (yy > 0.20 .and. yy < 0.30) sa1(k) = 30.
endif
!if (xx < 0.5d0 .and. yy < 0.5d0) then
! xx = 2*xx
! yy = 2*yy
! xx = xx - 0.5d0
! yy = yy - 0.5d0
! rr = sqrt( xx*xx + yy*yy)
! sa1(k) = amp*( 1 + cos(2*pin*rr) )
! else
! sa1(k) = 0
! endif
enddo
!WIM s0 = s1
do j = 1,300
fout = 0d0
call sethu(1) ! was just call sethu()
do k = 1,ndx
sq(k) = 0d0
do kk = 1,nd(k)%lnx
L = nd(k)%ln(kk)
La = iabs(L)
if (L > 0) then
sq(k) = sq(k) + u1(La)*hu(La)
else
sq(k) = sq(k) - u1(La)*hu(La)
endif
enddo
fout = fout + abs(sq(k))
enddo
do k = 1,ndx
foutk = 0
do kk = 1,nd(k)%lnx
L = nd(k)%ln(kk)
La = iabs(L)
if (L > 0) then
foutk = foutk + sq(ln(2,La))
endif
enddo
s0(k) = s0(k) - foutk*1d-1
enddo
enddo
chkadvd = 0.0d0
s1(ndx/2) = s1(ndx/2) + 1d-5
else if (index(md_netfile,'kelvin') > 0 ) then
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
CALL DMINMAX( yz, ndx, yzmin, yzmax, ndx)
r0 = 0.5d0* (xzmax - xzmin)
x0 = 0.5d0* (xzmax + xzmin)
y0 = 0.5d0* (yzmax + yzmin)
amp = 0.05d0
dep = 10d0
call inisferic()
Rossby = sqrt(ag*dep) / fcorio
sqghi = sqrt(ag/dep)
bl = -dep
do k = 1,ndx
xx = xz(k) - x0 ; yy = yz(k) - y0
r = sqrt( xx*xx + yy*yy )
csth = xx/r ; snth = yy/r
eer = (r-r0) / Rossby
s1(k) = amp*exp(eer)*csth
ucmk = sqghi*s1(k)
ucx(k) = -ucmk*snth
ucy(k) = ucmk*csth
enddo
do l = 1, lnx
k1 = ln(1,L) ; k2 = ln(2,L)
ux = acl(L)*ucx(k1) + (1d0-acl(L))*ucx(k2)
uy = acl(L)*ucy(k1) + (1d0-acl(L))*ucy(k2)
u1(L) = ux*csu(L) + uy*snu(L)
enddo
else if (index(md_netfile,'thacker2d') > 0 ) then
call thacker2d(time0,1)
else if (md_netfile == 'chan650.net') then
bl = -5.d0 ; ibedlevtyp = 1 ; call setbobs()
s1 = 0.d0
sa1(275:375) = 5d0
! u1 = 1d0
! if (lnx .ge. 651) u1(651) = -1d0*u1(651) ! bnd always inflowing positive
else if (md_netfile == '640x480.net') then
bl = -5.d0 ; ibedlevtyp = 1 ; call setbobs()
s1 = 0.d0
else if (md_netfile == 'rec10x10.net') then
do n = 1,ndx
if (xz(n) < 1) s1(n) = s1(n) + 1d0
enddo
else if (md_netfile == 'g04.net') then
! bl = -20.0
s1 = max(0d0,bl)
else if (md_netfile == 'sqhex.net' .or. md_netfile == 'sqquad.net' .or. &
md_netfile == 'sqtri.net' .or. md_netfile(1:6) == 'sqcurv' ) then ! sqhex.net
itest = 1
if (itest == 1) then
r0 = 250000d0 ! basin width
dep = 5d0 ! depth
x0 = -180 ; y0 = 0 ; rmx = 350
do k = 1,ndx
s1(k) = dep
! if (xz(k) > -251 .and. xz(k) < -50 .and. yz(k) > -100 .and. yz(k) < 100) then
!if (xz(k) > -351 .and. xz(k) < -50 .and. yz(k) > -150 .and. yz(k) < 150) then
! sa1(k) = 10d0
!endif
dxx = xz(k) - x0 ; dyy = yz(k) - y0
rr = sqrt(dxx*dxx + dyy*dyy)
if (rr < 0.5d0*rmx) then
sa1(k) = 5d0 + 5d0*cos(twopi*rr/rmx)
sa1(k) = 10d0
endif
enddo
do l = 1, lnx
k1 = lncn(1,L) ; k2 = lncn(2,L)
xx1 = xk(k1) ; yy1 = yk(k1)
ux1 = yy1 ; uy1 = -xx1
xx2 = xk(k2) ; yy2 = yk(k2)
ux2 = yy1 ; uy2 = -xx1
call normalout(xx1, yy1, xx2, yy2, csl, snl)
ux = 0.5d0*(ux1+ux2)
uy = 0.5d0*(uy1+uy2)
k1 = ln(1,L) ; k2 = ln(2,L)
xx = 0.5d0*(xz(k1) + xz(k2))
yy = 0.5d0*(yz(k1) + yz(k2))
ux = yy
uy = -xx
u1(L) = ux*csL + uy*snL
enddo
u0 = u1
endif
else if (md_ident == 'leveque') then
do L = 1, lnx
k1 = lncn(1,L) ; k2 = lncn(2,L)
xx1 = xk(k1) ; yy1 = yk(k1)
ux1 = yy1 ; uy1 = -xx1
xx2 = xk(k2) ; yy2 = yk(k2)
ux2 = yy2 ; uy2 = -xx2
ux = 0.5d0*(ux1+ux2)/64d0
uy = 0.5d0*(uy1+uy2)/64d0
u1(L) = ux*csu(L) + uy*snu(L)
enddo
u0 = u1
CALL DMINMAX( xk, numk, xkmin, xkmax, numk)
CALL DMINMAX( yk, numk, ykmin, ykmax, numk)
x0 = 0.50d0
y0 = 0.75d0
rmx = 0.15d0
sa1 = 0d0
do k = 1,ndx
xx = ( xz(k) - xkmin ) / (xkmax-xkmin)
yy = ( yz(k) - ykmin ) / (ykmax-ykmin)
dxx = xx - x0
dyy = yy - y0
rr = sqrt(dxx*dxx + dyy*dyy)
if (xx > 0.4d0 .and. xx < 0.6d0 .and. yy > 0.7d0 .and. yy < 0.9d0 ) then
sa1(k) = 10d0
endif
enddo
itstep = 0
else if (index(md_ident,'horvic') > 0) then
if (ibedlevtyp == 1) then
bl = zkuni + xz*bedslope
else
zk = zkuni + xk*bedslope
endif
call setbobs()
s1 = xz*bedslope ! bl + 10d0
call Poiseuille(1)
do L = 1,-Lnx ! Lnx
u1(L) = 3d0*csu(L)
enddo
else if (index(md_ident,'slape') > 0) then
call setkbotktop(1)
do LL = 1,Lnx
Ltop(LL) = lbot(LL) + kmx - 1
hu(LL) = 5d0 ; frcu(LL) = frcuni
call getczz0(hu(LL), frcu(LL), ifrcutp(LL), cz, z00)
ustb(LL) = sqrt(ag*5d0*5d-5)
cs = csu(LL)
Lb = Lbot(LL) ; Lt = Ltop(LL)
do L = Lb,Lt
zz = 5d0*dble(L - Lb + 1 - 0.5d0) / dble(Lt-Lb+1)
u1(L) = cs*ustb(LL)*log(c9of1 + zz/z00) / vonkar
enddo
enddo
else if (md_ident == 'equator1d') then
call equatorial(0d0)
else if (md_ident == 'tank_1d') then
bl = 0d0 ; s1 = -10d0
do k = 1,ndx
if (xz(k) < 0.2d0) then ! linkerwand
bl(k) = 50d0
else if (xz(k) < 20d0) then
s1(k) = 30d0
if (xz(k) > 19.8d0) then
bl(k) = bl(k) + 0.01
endif
else if (xz(k) > 25d0 .and. xz(k) < 25.2d0 + 2) then
bl(k) = 3.0
else if (xz(k) > 30d0) then
bl(k) = -20d0
s1(k) = -4d0
endif
enddo
ibedlevtyp = 1 ; call setbobs()
!else if (md_ident(1:6) == 'pillar') then
! u1 = csu
! if ( jampi.eq.1 ) then
! call update_ghosts(ITYPE_U, Lnx, u1, ierror)
! end if
else if ( md_ident(1:3).eq.'lts' ) then
if ( md_ident(4:6).eq.'rot' ) then
xkmin = huge(1d0)
xkmax = -huge(1d0)
ykmin = huge(1d0)
ykmax = -huge(1d0)
do k=1,numk
xkmin = min(xkmin,xk(k))
xkmax = max(xkmax,xk(k))
ykmin = min(ykmin,yk(k))
ykmax = max(ykmax,yk(k))
end do
xm = 0.5*(xkmin+xkmax)
ym = 0.5*(ykmin+ykmax)
R = 0.5d0*max(xkmax-xkmin, ykmax-ykmin)
if ( kmx.eq.0 ) then
do L=1,Lnx
u1(L) = (-(yu(L)-ym)*csu(L) + (xu(L)-xm)*snu(L))/R
end do
else
do LL=1,Lnx
Ltop(LL) = Lbot(LL)+kmx-1
do L=lbot(LL),ltop(LL)
u1(L) = -yu(LL)*csu(LL) + xu(L)*snu(L)
end do
end do
end if
else
if ( kmx.eq.0 ) then
do L=1,Lnx
u1(L) = csu(L)
end do
else
do LL=1,Lnx
Ltop(LL) = Lbot(LL)+kmx-1
do L=lbot(LL),ltop(LL)
u1(L) = csu(LL)
end do
end do
end if
end if
itstep = 0
! ja_timestep_auto=-123
! dt_max = 5d0
endif
endif ! end ispecials
if (Slopedrop2D > 0) then !todo, uitsluitende test maken
do L = lnx1D+1,lnxi
k1 = ln(1,L) ; k2 = ln(2,L)
if (dxi(L)*abs(bl(k1) - bl(k2)) > Slopedrop2D) then
iadv(L) = 8 ; jaslopedr = 1
endif
enddo
endif
do L = 1,lnxi
k1 = ln(1,L) ; k2 = ln(2,L)
if (jaembed1D > 0 .and. kcs(k1)*kcs(k2) == 42 .or. kcu(L) == 3) then ! 2D and 1D2D nod
iadv(L) = 8 ; jaslopedr = 1 ! Slopedrop only used for flagging after this point, any positive value = ok.
endif
enddo
call statisticsini()
call setkbotktop(1) ! prior to correctblforzlayerpoints, setting kbot
!call correctblforzlayerpoints() ! using kbot set bl of first z-layer
!call setkbotktop(1) ! setkbot again, now using bl at strictly horizontal level
! in z-layers, zws is now strictly horizontal, so that
! vertical salinityprofiles set in initexternalf will now yield zero baroclinic terms
call mess(LEVEL_INFO, 'Start initializing external forcings...')
iresult = flow_initexternalforcings() ! this is the general hook-up to wind and boundary conditions
if (iresult /= DFM_NOERR) then
call qnerror('Error occurred while running, please inspect your diagnostic output.',' ', ' ')
goto 888
end if
call mess(LEVEL_INFO, 'Done initializing external forcings.')
! If constituents have been added at this point, the sum-arrays in crs require redimensioning
if (allocated(crs)) then
call ReallocCrossSectionSums(crs)
endif
if (isimplefixedweirs == 0) then
call setbobs_fixedweirs()
else
call setfixedweirs()
endif
call adjust_bobs_for_dams_and_structs()
! Floodfill water levels based on sample file.
if (len_trim(md_s1inifile) > 0) then
call savesam()
NS = 0
call oldfil(msam, md_s1inifile)
if (msam > 0) then
call reasam(msam, 0)
call flow_initfloodfill()
end if
call restoresam()
end if
if (allocated(ibot)) then
deallocate(ibot) ! after meteoiniti of ibedlevtype
end if
if (ndx > 800000) then
if (allocated (zk) ) then
! deallocate(zk)
endif
endif
do L = 1,lnx
if (L <= lnx1D) then
if (kcu(L) == 3) then
frcu(L) = frcuni1d2d
else
frcu(L) = frcuni1d
endif
else if (frcu(L) == dmiss) then
frcu(L) = frcuni
endif
if (ifrcutp(L) == -999) then
ifrcutp(L) = ifrctypuni
endif
enddo
if (jafrculin == 1) then ! plus uniform value on not found
do L = 1,lnx
if (frculin(L) == dmiss) then
frculin(L) = frcunilin
endif
enddo
endif
call setupwslopes() ! set upwind slope pointers and weightfactors
if (allocated (lnk) ) deallocate (lnk)
if (iuvfield > 0) call setvelocityfield() ! only when testing
! Load restart file (*_map.nc) assigned in the *.mdu file OR read a *.rst file
jawel = .false.
if (len_trim(md_restartfile) > 0 ) then
! Find file extention based on first full stop symbol '.' at the back of the string.
N1 = INDEX (md_restartfile,'.', .true.)
N2 = len_trim(md_restartfile)
EXT = ' '
EXT = md_restartfile(N1:N2)
! Restart from *.rst:
if ( index(md_restartfile, '.rst') > 0 .or. index(md_restartfile, '.RST') > 0) then
INQUIRE(FILE = rstFILE, EXIST=JAWEL)
IF (JAWEL) THEN
call oldfil(mrst, rstfile)
call rearst(mrst, jw)
JAWEL = (jw == 1)
endif
else ! Restart from *_YYYYMMDD_HHMMSS_rst.nc or from *_map.nc
call read_restart_from_map(md_restartfile, iresult)
if (iresult /= DFM_NOERR) then
goto 888
else
JAWEL = .true.
end if
call setucxucyucxuucyu() !reconstruct cell-center velocities
end if
end if
jawelrestart = jawel
call flow_setstarttime() ! the flow time0 and time1 are managed bij flow
! this is the only function that a user can use to influence the flow times
! TSTART MAY BE OVERWRITTEN IN REARST
call setkbotktop(1) ! set sigmabnds for ec
call flow_setexternalforcings(tstart_user, .true., iresult) ! set field oriented external forcings, flag that the call is from the initialization phase
if (iresult /= DFM_NOERR) then
goto 888
end if
call setsigmabnds()
call flow_setexternalforcingsonboundaries(tstart_user, iresult) ! set bnd oriented external forcings
if (iresult /= DFM_NOERR) then
goto 888
end if
! remember initial waterlevels at the water-level boundaries
do n=1,nbndz
k2 = kbndz(2,n)
zbndz0(n) = s1(k2)
end do
call sets01zbnd(1)
do n = 1, nbndn ! for normal velocity boundaries, also initialise velocity on link
kb = kbndn(1,n)
k2 = kbndn(2,n)
LL = kbndn(3,n)
do k = 1,kmxd
L = (LL-1)*kmxd + k
u1(L) = zbndn(n)
enddo
enddo
do nq = 1,nqbnd ! discharge boundaries
nat = 0 ; bobmin = huge(1d0)
do n = L1qbnd(nq), L2qbnd(nq)
kb = kbndu(1,n)
k2 = kbndu(2,n)
L = kbndu(3,n)
blm = min( bob(1,L), bob(2,L) )
if (s1(k2) - blm > epshu) then
nat = 1
endif
bobmin = min(bobmin,blm)
enddo
! boundary is dry: add 1 cm of water above lowest bed level
if (nat == 0) then
do n = L1qbnd(nq), L2qbnd(nq)
kb = kbndu(1,n)
k2 = kbndu(2,n)
s1(k2) = max(s1(k2), bobmin + 0.01d0)
s1(kb) = s1(k2)
enddo
else
do n = L1qbnd(nq), L2qbnd(nq)
kb = kbndu(1,n)
k2 = kbndu(2,n)
s1(kb) = s1(k2)
enddo
endif
enddo
if (lnx > lnxi) then ! boundaries always implicit
teta(lnxi+1:lnx) = 1d0
endif
if (.not. jawelrestart) then
if (japatm > 0 .and. PavIni > 0) then
do k = 1,ndxi
ss = min( 1d0, s1(k) - bl(k) ) ! reduced correction values at low depths
s1(k) = s1(k) - ss*( patm(k) - PavIni ) / (ag*rhomean)
enddo
endif
s0 = s1 ; u0 = u1
endif
s1 = max(bl, s1)
call setkbotktop(1)
! call correctblforzlayerpoints() ! using kbot set bl of first z-layer
! call setkbotktop(1)
s00 = s1
hs = s1 - bl
if (jagrw > 0) then
do k = 1,ndx
if (hs(k) > epshs) then
sgrw1(k) = bl(k)
else
if (allocated(h_unsat) ) then
sgrw1(k) = bl(k) - h_unsat(k)
else
sgrw1(k) = bl(k) - h_unsatini
endif
endif
hunsat = bl(k) - sgrw1(k)
fac = min ( 1d0, max(0d0, hunsat / h_transfer ) ) ! 0 at bed, 1 at sgrw
pgrw(k) = sgrw1(k)*fac + s1(k)*(1d0-fac)
enddo
if (allocated(h_unsat) ) then
deallocate(h_unsat)
endif
endif
call volsur() ! flowinit
call a1vol1tot()
vol0tot = vol1tot
a0tot = a1tot
call sethu(1)
vol0 = vol1
if (jasal > 0 .and. kmx > 0 .and. inisal2D > 0 ) then
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
if (inisal2D == 1) then
do k = kb, kt
sa1(k) = sa1(kk)
enddo
else
do k = kb, kt
if (kt == kb) then
rr = 1d0
else
rr = dble(k-kb)/dble(kt-kb)
endif
sa1(k) = (1d0 - rr)*sa1(kk) + rr*satop(kk)
enddo
endif
do k = kt+1, kb+kmxn(kk)-1
sa1(k) = sa1(max(kt,kb))
enddo
enddo
sa1 = max(0d0, sa1)
if ( allocated(satop) ) then
deallocate (satop)
endif
endif
if (kmx > 0 .and. initem2D > 0 ) then
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kb, kt
tem1(k) = tem1(kk)
enddo
enddo
endif
if (Sal0abovezlev .ne. dmiss) then
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kb, kt
if (zws(k) > Sal0abovezlev) then
sa1(k) = 0d0
endif
enddo
enddo
endif
if (jasal > 0) then
salmax = maxval(sa1)
endif
if (jaFlowNetChanged == 1 .or. nodtot /= ndx .or. lintot /= lnx) then
call reducept(Ndx,Ndxi,Lnx) ! also alloc arrays for reduce
end if
if ( jawave.eq.4 ) then ! JRE: remember initial water level for Riemann boundary condition
if ( allocated(s1initial) ) deallocate(s1initial)
allocate(s1initial(Ndx))
s1initial = s1
end if
! initialize constituents
if ( NUMCONST.gt.0 ) then
call fill_constituents()
end if
! BEGIN DEBUG
! if ( jampi.eq.1 ) then
! call update_ghosts(ITYPE_U,Lnx,teta,ierr)
! endif
! END DEBUG
if (kmx < 2) then ! in 2D, use 1
if ( ja_timestep_auto.ne.-123 ) then
ja_timestep_auto = 1
else
ja_timestep_auto = 0
end if
else if (ja_timestep_auto == 1) then ! if nothing specified, change to 5 for 3D
ja_timestep_auto = 5
else if (ja_timestep_auto == 4) then ! use local time-stepping in transport
ja_timestep_auto = 4 ; jalts = 1
endif ! else use what is specified
iresult = DFM_NOERR
return
888 continue ! Some error occurred, prevent further flow
ndx = 0
end function flow_flowinit
!> Fourier Analysis, copied from Delft3D:
!! Opens and reads .fou file (md_foufile, specified in the mdu)
!! and prepares the gd_fourier structure
subroutine flow_fourierinit()
use m_fourier_analysis
use m_transport, only: NUMCONST, ISALT, ITEMP
use unstruc_model, only: md_foufile
use m_flow, only: kmxd
use m_physcoef, only: ag
use m_flowgeom, only: gddimens
use m_flowtimes, only: tstart_user, tstop_user, dt_max
implicit none
integer :: minp
logical :: success
call oldfil(minp, md_foufile)
call fouini(minp, success, ag)
call alloc_fourier_analysis_arrays(gdfourier,gddimens,nofou)
call reafou(minp ,md_foufile ,kmxd ,&
& NUMCONST ,ISALT ,ITEMP ,&
& tstart_user ,tstop_user ,dt_max ,success)
if (.not.success) then
! TODO: deal with failed attempts to connect a fou-file
endif
! TODO: do some stuff with the file contents
end subroutine flow_fourierinit
!> Sets initial water level based on a 'flood fill' that originates from
!! the active sample points.
!!
!! The active samples are used as starting points, with their z-values as
!! initial water level. This level spreads out to all surrounding cells,
!! until a higher bottom (shore) is encountered, or a flood front from one
!! of the other samples.
!! Also used by flow_flowinit() for the WaterLevIniFile from the MDU.
subroutine flow_initfloodfill()
use m_samples
use m_flow
use m_flowgeom
use m_alloc
use m_kdtree2
implicit none
integer :: i, inod, iL, Lf, k, k2, nx
integer, allocatable :: kcsfill(:)
integer, allocatable :: ndroot(:)
integer, allocatable :: ndqueue(:)
integer, dimension(:), allocatable :: inodes
double precision, allocatable :: s1queue(:)
integer :: iqcur, iqtail
integer :: ierror, knew
integer :: jakdtree
jakdtree = 1
if (ndx <= 0) then
return
end if
! Each node is visited at most once: work array size <= ndx.
nx = ns+ndx-1
call realloc(kcsfill, nx, fill = 0)
call realloc(ndqueue, nx, fill = 0)
call realloc(s1queue, nx, fill = 0d0)
iqcur = 0 !< Index of current node in queue.
iqtail = 0 !< Index of most recently added element in work queue.
!find flowcells
if ( jakdtree.eq.1 ) then
allocate(inodes(Ns))
call find_flowcells_kdtree(treeglob,Ns,xs,ys,inodes,1,ierror)
end if
if ( ierror.ne.0 ) then
if ( allocated(inodes) ) deallocate(inodes)
jakdtree = 0
end if
! First associate all samples with a single flow node (1D or 2D) and put them in work queue.
do i = 1,NS
if ( jakdtree.eq.1 ) then
k = inodes(i)
else
call in_flowcell(xs(i), ys(i), k)
end if
if (k > 0 ) then
if ( zs(i) > bl(k) ) then
s1(k) = zs(i)
kcsfill(k) = 1
iqtail = iqtail+1
ndqueue(iqtail) = k
s1queue(iqtail) = zs(i)
endif
end if
end do
if ( iqtail.eq.0 ) return
! Loop over flow node queue: for each node, water level is already set,
! but now also visit its neighbouring flow nodes (this is the 'flood' step).
iqcur = 0
do
iqcur = iqcur + 1
k = ndqueue(iqcur)
if (k == 0) then
exit
endif
do iL=1,nd(k)%lnx
Lf = abs(nd(k)%ln(iL))
if (s1queue(iqcur) < minval(bob(:,Lf))) cycle ! Water level lower than link's bottom level, cannot flood across this link.
k2 = ln(1,Lf)
if (k2 == k) then
k2 = ln(2, Lf)
end if
if (kcsfill(k2) == 1) then
! Two flood areas meet: average waterlevel on their interface
s1(k2) = .5d0*(s1(k2) + s1queue(iqcur))
else if (kcsfill(k2) == 0) then
! Newly flooded point: set waterlevel and enqueue it for further flooding.
s1(k2) = s1queue(iqcur)
kcsfill(k2) = 1
iqtail = iqtail+1
ndqueue(iqtail) = k2
s1queue(iqtail) = s1queue(iqcur)
end if
end do
! All reachable nodes have been visited, rest (if any) remains unflooded at s1ini:
if (iqcur==iqtail) exit
end do
! Update water depth explicitly here, for direct plotting.
! NOTE: all other quantities a1, hu, etc. need to be updated by flow_initimestep().
hs = s1-bl
deallocate(kcsfill,ndqueue,s1queue)
if ( allocated(inodes) ) deallocate(inodes)
end subroutine flow_initfloodfill
subroutine thacker2dorg(t, ini, rms)
use m_flowgeom
use m_flow
use m_sferic
implicit none
double precision :: t, rms
integer :: ini, k, L
double precision :: xzmin, xzmax, yzmin, yzmax, s1k, x0, y0, r0, xx, yy, r, dep,omeg,psi,samp,st,ct,ux,uy
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
CALL DMINMAX( yz, ndx, yzmin, yzmax, ndx)
r0 = 0.5d0* (xzmax - xzmin)
x0 = 0.5d0* (xzmax + xzmin)
y0 = 0.5d0* (yzmax + yzmin)
dep = 10d0
omeg = twopi/(12*3600) ! period = 12 hrs
r0 = sqrt( 2d0*ag*dep/ ( omeg*( omeg+fcorio) ) ) ! Casulli 2007 (19) mind you, no - sign in front of fcorio
! r0 = sqrt( 2d0*ag*dep/ ( omeg*omeg ) )
! omeg = 0.5d0*(-fcorio+ sqrt(fcorio*fcorio + 4d0*(2d0*ag*dep/(r0*r0) ) ) )
! r0 = sqrt( 2d0*ag*dep/ ( omeg*( omeg+fcorio) ) ) ! to keep constant r0, irrespective of fcorio
psi = 0.15d0*r0
samp = psi*dep/(r0*r0)
st = sin(omeg*t)
ct = cos(omeg*t)
rms = 0d0
do k = 1,ndx
xx = xz(k) - x0 ; yy = yz(k) - y0
r = sqrt( xx*xx + yy*yy )
bl(k) = -dep*( 1d0 - (r*r)/(r0*r0) )
s1k = max( bl(k), samp*(2d0*xx*ct - 2d0*yy*st - psi) )
if (ini == 1) then
s1(k) = s1k
else
rms = rms + abs (s1k - s1(k)) ! **2
endif
enddo
!rms = sqrt(rms)/ndx
rms = rms/ndx
if (ini == 1) then
ux = -psi*omeg*st
uy = -psi*omeg*ct
do L = 1,lnx
u1(L) = ux*csu(L) + uy*snu(L)
enddo
call setbobs()
endif
end subroutine thacker2dorg
subroutine thacker2d(t, ini)
use m_netw, only : xk, yk, zk, numk
use m_flowgeom
use m_flow
use m_sferic
implicit none
double precision :: t, rms
integer :: ini, k, L, k1, k2
double precision :: xzmin, xzmax, yzmin, yzmax, s1k, x0, y0, r0, xx, yy, r, dep,omeg,psi,samp,st,ct,ux,uy
double precision :: h0, zz0, a, a1c, a12, sa12, rr0, ur, ut, cs, sn
CALL DMINMAX( xz, ndx, xzmin, xzmax, ndx)
CALL DMINMAX( yz, ndx, yzmin, yzmax, ndx)
r0 = 0.5d0* (xzmax - xzmin)*0.85
x0 = 0.5d0* (xzmax + xzmin)
y0 = 0.5d0* (yzmax + yzmin)
h0 = 10d0
zz0 = 2d0
omeg = twopi/(12*3600) ! period = 12 hrs
omeg = sqrt(8*ag*h0/(r0*r0))
fcorio = 0d0 ! omeg/2
a = ( (h0+zz0)**2 - h0*h0 ) / ( (h0+zz0)**2 + h0*h0 )
r0 = sqrt( 8d0*ag*h0 / ( omeg*omeg -fcorio*fcorio) ) ! Casulli 2008 (31) mind you, no - sign in front of fcorio
st = sin(omeg*t)
ct = cos(omeg*t)
if (ibedlevtyp == 3) then
do k = 1,numk
xx = xk(k) - x0 ; yy = yk(k) - y0
r = sqrt( xx*xx + yy*yy )
rr0 = (r*r)/(r0*r0)
zk(k) = -h0*( 1d0 - rr0 )
enddo
call setbobs()
endif
rms = 0d0
do k = 1,ndx
xx = xz(k) - x0 ; yy = yz(k) - y0
r = sqrt( xx*xx + yy*yy )
rr0 = (r*r)/(r0*r0)
if (ibedlevtyp .ne. 3) then
bl(k) = -h0*( 1d0 - rr0 )
endif
a1c = 1d0-a*ct
a12 = 1d0-a*a
sa12 = sqrt(a12)
s1k = h0*( sa12/a1c - 1d0 - rr0*( a12/(a1c*a1c) -1d0) )
s1k = max(bl(k), s1k)
if (ini == 1) then
s1(k) = s1k
ur = omeg*r*a*st/(2d0*a1c)
ut = ( fcorio*r/(2d0*a1c) )*(sa12 + a*ct -1d0)
cs = xx/r ; sn = yy/r
ucx(k) = ur*cs - ut*sn
ucy(k) = ur*sn + ut*cs
else
rms = rms + abs (s1k - s1(k)) ! **2
endif
enddo
! rms = sqrt(rms)/ndx
rms = rms/ndx
if (ini == 1) then
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
u1(L) = ( acl(L)*ucx(k1) + (1d0-acl(L))*ucx(k2) ) *csu(L) &
+ ( acl(L)*ucy(k1) + (1d0-acl(L))*ucy(k2) ) *snu(L)
enddo
call setbobs()
endif
end subroutine thacker2d
subroutine thacker1d(ini,xz,yz,s1,bl,ndx,t)
use m_netw
use m_sferic
use m_physcoef
use m_flowparameters
implicit none
integer :: ndx, ini
double precision :: dep, xz(ndx), yz(ndx), s1(ndx), bl(ndx), t
integer :: is, k
double precision :: omeg, r, r0, rr0, psi, samp, st, ct, ux, uy, s1k, dif, xx, yy, period
logical :: inview
dep = 10d0
fcorio = 0d0
! omeg = twopi/(12*3600) ! period = 12 hrs
! r0 = sqrt( 2d0*ag*dep/ ( omeg*( omeg+fcorio) ) ) ! Casulli 2007 (19) mind you, no - sign in front of fcorio
r0 = 120d0
omeg = sqrt(2d0*ag*dep/(r0*r0))
period = twopi / omeg
if (ini == 1) then
if ( ibedlevtyp == 3) then
do k = 1,numk
r = xk(k) - 150D0
rr0 = (r*r)/(r0*r0)
zk(k) = -dep*( 1d0 - rr0 )
enddo
else
do k = 1,ndx
r = xz(k) - 150D0
rr0 = (r*r)/(r0*r0)
bl(k) = -dep*( 1d0 - rr0 )
enddo
endif
call setbobs()
endif
!psi = 0.25d0*r0
psi = 0.23d0*r0
samp = psi*dep/(r0*r0)
st = sin(omeg*t)
ct = cos(omeg*t)
is = 0
call statisticsnewstep()
do k = 1,ndx
! r = xz(k) - 150d0 ! sqrt( xz(k)*xz(k) + yz(k)*yz(k) )
! s1k = samp*r*ct
xx = xz(k) - 150d0 ; yy = 0
s1k = samp*(2d0*xx*ct - 2d0*yy*st - psi*ct*ct)
if (ini == 1) then
s1(k) = max( bl(k), s1k)
endif
if ( s1k > bl(k) ) then
dif = abs(s1(k) - s1k)
if ( inview( xz(k), yz(k) ) ) then
call statisticsonemorepoint(dif)
endif
if (is == 0) then
call movabs(xz(k), s1k) ; is = 1
else
call lnabs (xz(k), s1k)
endif
endif
enddo
call statisticsfinalise()
ux = -psi*omeg*st
uy = -psi*omeg*ct
end subroutine thacker1d
subroutine statisticsnewstep()
use m_statistics
implicit none
avedif = 0d0 ! for now only, cum dif with analytic sol
sqadif = 0d0 ! for now only, cum dif with analytic sol
dmxdif = 0d0 ! for now only, cum dif with analytic sol
numdif = 0
end subroutine statisticsnewstep
subroutine statisticsini()
use m_statistics
implicit none
call statisticsnewstep()
cumavedif = 0d0 ! for now only, cum dif with analytic sol
cumrmsdif = 0d0 ! for now only, cum dif with analytic sol
cumdmxdif = 0d0 ! for now only, cum dif with analytic sol
numcum = 0
end subroutine statisticsini
subroutine statisticsonemorepoint(dif)
use m_statistics
implicit none
double precision :: dif
avedif = avedif + dif
sqadif = sqadif + dif*dif
dmxdif = max(dmxdif,dif)
numdif = numdif + 1
end subroutine statisticsonemorepoint
subroutine statisticsfinalise()
use m_statistics
implicit none
if (numdif .ne. 0) then
avedif = avedif/numdif
cumavedif = cumavedif + avedif
rmsdif = sqrt( sqadif / numdif )
cumrmsdif = cumrmsdif + rmsdif
dmxdif = max(cumdmxdif, dmxdif)
numcum = numcum + 1
endif
end subroutine statisticsfinalise
subroutine inifcori()
use m_flowgeom
use m_flow
use m_sferic
implicit none
integer :: ierr, L, k
if (allocated(fcori) ) then
deallocate(fcori)
endif
allocate ( fcori(lnx), stat = ierr )
call aerr('fcori(lnx)', ierr, lnx )
do L = 1,lnx
fcori(L) = 2d0*omega*sin(yu(L)*dg2rd)
enddo
! Corilios in flow node, added by Nabi
if (allocated(fcoris) ) then
deallocate(fcoris)
endif
allocate ( fcoris(ndx), stat = ierr )
call aerr('fcoris(ndx)', ierr, ndx )
do k = 1,ndx
fcoris(k) = 2d0*omega*sin(yz(k)*dg2rd)
enddo
end subroutine inifcori
!> set field oriented boundary conditions
subroutine flow_setexternalforcings(tim, l_initPhase, iresult)
use m_flowtimes
use m_flowgeom
use m_flow
use m_sferic
use timespace
use m_missing
use m_structures
use m_meteo
use m_trachy, only : itimtt
use dfm_error
implicit none
double precision, intent(in) :: tim !< Time in seconds
logical :: l_initPhase
integer, intent(out) :: iresult !< Integer error status: DFM_NOERR==0 if succesful.
double precision :: timmin
double precision :: ntrtsteps !< variable to determine if trachytopes should be updated
integer :: k, L, i, k1, k2
logical, external :: flow_initwaveforcings_runtime
iresult = DFM_EXTFORCERROR
call klok(cpuext(1))
timmin = tim/60d0 ! talking to Meteo1 is in minutes
success = .true.
if (jawind == 1) then ! setwind
! Retrieve wind's x- and y-component for ext-file quantity 'windxy'.
if (item_windxy_x /= ec_undef_int .and. item_windxy_y /= ec_undef_int) then
success = ec_gettimespacevalue(ecInstancePtr, item_windxy_x, tim)
!success = ec_gettimespacevalue(ecInstancePtr, item_windxy_y, tim) ! Due to removal of up-to-date check in ec_item.f90::ecItemGetValues.
if (.not. success) then
goto 888
end if
end if
! Retrieve wind's p-, x- and y-component for ext-file quantity 'airpressure_windx_windy'.
if (item_apwxwy_p /= ec_undef_int .and. item_apwxwy_x /= ec_undef_int .and. item_apwxwy_y /= ec_undef_int) then
success = ec_gettimespacevalue(ecInstancePtr, 'airpressure_windx_windy', tim)
if (.not. success) then
goto 888
end if
! FM performs an additional spatial interpolation:
do L = 1,lnxi
k1 = ln(1,L) ; k2 = ln(2,L)
wx(L) = 0.5d0*( ec_pwxwy_x(k1) + ec_pwxwy_x(k2) )
wy(L) = 0.5d0*( ec_pwxwy_y(k1) + ec_pwxwy_y(k2) )
enddo
end if
! Retrieve wind's x-component for ext-file quantity 'windx'.
if (item_windx /= ec_undef_int) then
success = ec_gettimespacevalue(ecInstancePtr, item_windx, tim)
if (.not. success) then
goto 888
endif
endif
! Retrieve wind's y-component for ext-file quantity 'windy'.
if (item_windy /= ec_undef_int) then
success = ec_gettimespacevalue(ecInstancePtr, item_windy, tim)
if (.not. success) then
goto 888
endif
endif
if (jawave == 1 .or. jawave == 2) then
call tauwavefetch()
endif
call setwindstress()
endif
!$OMP PARALLEL SECTIONS
if (jatem > 1) then
! Update arrays rhum, tair and clou in a single method call.
! Nothing happens in case quantity 'humidity_airtemperature_cloudiness' has never been added through ec_addtimespacerelation.
success = ec_gettimespacevalue(ecInstancePtr, 'humidity_airtemperature_cloudiness', tim)
! Update arrays rhum, tair, clou and qrad in a single method call.
! Nothing happens in case quantity 'humidity_airtemperature_cloudiness_solarradiation' has never been added through ec_addtimespacerelation.
success = ec_gettimespacevalue(ecInstancePtr, 'humidity_airtemperature_cloudiness_solarradiation', tim)
endif
!$OMP SECTION
! Get wave parameters within this parallel section:
if (jawave == 3) then
!
! This part must be skipped during initialization
if (.not.l_initPhase) then
! Finally the delayed external forcings can be initialized
success = flow_initwaveforcings_runtime()
if (allocated (hwav) ) then
! Don't make them zero: ecGetValues might do nothing
!hwav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_hrms, tim)
endif
if (allocated (twav) ) then
! Don't make them zero: ecGetValues might do nothing
!twav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_tp, tim)
endif
if (allocated (phiwav) ) then
! Don't make them zero: ecGetValues might do nothing
!phiwav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_dir, tim)
endif
if (allocated (sxwav) ) then
! Don't make them zero: ecGetValues might do nothing
!sxwav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_fx, tim)
endif
if (allocated (sywav) ) then
! Don't make them zero: ecGetValues might do nothing
!sywav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_fy, tim)
endif
if (allocated (sbxwav) ) then
! Don't make them zero: ecGetValues might do nothing
!sxwav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_wsbu, tim)
endif
if (allocated (sbywav) ) then
! Don't make them zero: ecGetValues might do nothing
!sywav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_wsbv, tim)
endif
if (allocated (mxwav) ) then
! Don't make them zero: ecGetValues might do nothing
!mxwav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_mx, tim)
endif
if (allocated (mywav) ) then
! Don't make them zero: ecGetValues might do nothing
!mywav = 0.0
success = success .and. ecGetValues(ecInstancePtr, item_my, tim)
endif
endif
if (.not. success) then
!
! success = .false. : Most commonly, WAVE data has not been written to the com-file yet:
! - Print a warning
! - Continue with the calculation
! - Just try it the next timestep again
! - success must be set to .true., otherwise the calculation is aborted
!
message = dumpECMessageStack(LEVEL_WARN,callback_msg)
success=.true.
end if
!
! SWAN data used via module m_waves
! Data from FLOW 2 SWAN: s1 (water level), bl (bottom level), ucx (vel. x), ucy (vel. y), FlowElem_xcc, FlowElem_ycc, wx, wy
! NOTE: all variables defined @ cell circumcentre of unstructured grid
! different from Delft3D. There all variables are defined on the velocity points.
! Data from SWAN 2 FLOW: wavefx, wavefy, hrms (or 0.5*sqrt(2)*hm0), rtp, tp/tps/rtp, phi (= wavedirmean), Uorb, wlen
! NOTE:
! not necessary are; tmean (Tm01), urms, wavedirpeak
!
call wave_comp_stokes_velocities()
call tauwaveswan()
! wavfu: wave force at links, to be used in the advection equation
call setwavfu()
call setwavmubnd()
endif
!$OMP SECTION
! Retrieve wind's p-component for ext-file quantity 'atmosphericpressure'.
if (japatm > 0 .and. item_atmosphericpressure /= ec_undef_int) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_atmosphericpressure, tim)
do k = 1,ndx
if (patm(k) == dmiss) patm(k) = 101325d0
enddo
endif
!$OMP SECTION
! Retrieve rainfall for ext-file quantity 'rainfall'.
if (jarain > 0) then
if (item_rainfall /= ec_undef_int) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_rainfall, tim)
endif
endif
!$OMP SECTION
if (ngate > 0) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_gateloweredgelevel, tim, zgate)
endif
!$OMP SECTION
if (ncdam > 0) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_damlevel, tim, zcdam)
endif
!$OMP SECTION
if (ncgen > 0) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_generalstructure, tim, zcgen)
call update_zcgen_widths_and_heights() ! TODO: replace by Jan's LineStructure from channel_flow
endif
!$OMP SECTION
if (npump > 0) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_pump, tim, qpump)
endif
!$OMP SECTION
if (numsrc > 0) then
success = success .and. ec_gettimespacevalue(ecInstancePtr, item_discharge_salinity_temperature_sorsin, tim)
endif
!$OMP SECTION
call klok(cpuext(2)) ; cpuext(3) = cpuext(3) + cpuext(2) - cpuext(1)
if (jatidep > 0) then
call flow_settidepotential(timmin)
endif
!$OMP END PARALLEL SECTIONS
if (.not. success) then
goto 888
end if
if (jatem > 0) then
call heatu(timmin/60d0)
endif
if (jatrt == 1) then
ntrtsteps = (time1 - tstart_user)/dt_max/itimtt
if (abs(ntrtsteps - floor(ntrtsteps)) .lt. 1e-6 ) then
call flow_trachyupdate() ! perform a trachy update step
end if
end if
iresult = DFM_NOERR
return ! return with success
! Error handling:
888 continue
iresult = DFM_EXTFORCERROR
call mess(LEVEL_WARN, 'Error while updating meteo/structure forcing at time=', tim)
end subroutine flow_setexternalforcings
subroutine setwindstress()
use m_flowgeom
use m_flow
implicit none
double precision :: uwi, cdw, tuwi, roro
integer :: L, numwav ! windstuff
wdsu = 0
roro = rhoair/rhomean
windxav = 0d0; windyav = 0d0; numwav = 0
do L = 1, lnx
if ( wx(L) .ne. 0 .or. wy(L) .ne. 0 ) then ! only if some wind
uwi = sqrt( wx(L)*wx(L) + wy(L)*wy(L) )
call setcdwcoefficient(uwi,cdw,L)
if (jatem == 5) then
cdwcof(L) = cdw
endif
tuwi = roro*cdw*uwi
if (kmx > 0) then
ustw(L) = sqrt(roro*cdw)*uwi
endif
wdsu(L) = tuwi*( wx(L)*csu(L) + wy(L)*snu(L) )
windxav = windxav + wx(L)
windyav = windyav + wy(L)
numwav = numwav + 1
endif
enddo
if (numwav > 0) then
windxav = windxav/numwav ; windyav = windyav/numwav
endif
end subroutine setwindstress
! JRE, to do for wave input jawave == 4
!> set boundary conditions
subroutine flow_setexternalforcingsonboundaries(tim, iresult)
use m_flowtimes
use m_flowgeom
use m_flow
use m_sferic
use timespace
use m_ship
use m_observations
use m_timer
use m_partitioninfo
use m_meteo
use m_ec_magic_number
use m_ec_parameters
use dfm_error
use m_sobekdfm
implicit none
double precision, intent(in) :: tim ! (s)
integer, intent(out) :: iresult !< Integer error status: DFM_NOERR==0 if succesful.
integer :: i, n, k, k2, kb, kt, ki, L, itrac
double precision :: timmin
character(maxMessageLen) :: message123
iresult = DFM_EXTFORCERROR
call klok(cpuextbnd(1))
if ( jawave.eq.4 .and. allocated(zbndu)) then
! restore zbndu
zbndu = zbndu_store
end if
if (nzbnd > nqhbnd) then
success = ec_gettimespacevalue(ecInstancePtr, item_waterlevelbnd, tim)
if (.not. success) then
goto 888
end if
end if
if (nqhbnd > 0) then
! loop over nqhbnd (per pli)
do i = 1, nqhbnd
! prepare qtot array
atqh_all(i) = 0d0
do n = L1qhbnd(i), L2qhbnd(i)
kb = kbndz(1,n)
k2 = kbndz(2,n)
L = kbndz(3,n)
if (jampi .eq. 0) then
atqh_all(i) = atqh_all(i) - q1(L) ! flow link always directed inwards
else
! exclude ghost cells
if ( idomain(k2).eq.my_rank ) then
atqh_all(i) = atqh_all(i) - q1(L) ! flow link always directed inwards
end if
end if
end do
end do
! do communication between domains
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_atqh_all()
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
magic_array = atqh_all ! TODO: Eliminate the need for this magic array.
success = ec_gettimespacevalue(ecInstancePtr, item_qhbnd, tim)
if (.not. success) then
goto 888
end if
! vind bijbehorende zbndz punten
do i = 1,nqhbnd
do n = L1qhbnd(i), L2qhbnd(i)
zbndz(n) = qhrelax*qhbndz(i) + (1d0-qhrelax)*s1( kbndz(1,n) )
end do
end do
endif
if (nbndu > 0 ) then
success = ec_gettimespacevalue(ecInstancePtr, item_velocitybnd, tim)
if (.not. success) then
goto 888
end if
end if
! JRE
if (jawave == 4) then
if (nbndw > 0) then
!success = ec_gettimespacevalue(ecInstancePtr, item_waveenergybnd, tim)
if (.not. success) then
goto 888
end if
endif
endif
if (nbnds > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_salinitybnd, tim)
if (.not. success) then
goto 888
endif
endif
if (nbndTM > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_temperaturebnd, tim)
if (.not. success) then
goto 888
endif
endif
if (nbndsd > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_sedimentbnd, tim)
if (.not. success) then
goto 888
end if
end if
do itrac=1,numtracers
if (nbndtr(itrac) > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_tracerbnd(itrac), tim)
if (.not. success) then
goto 888
end if
end if
end do
if (nbndt > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_tangentialvelocitybnd, tim)
if (.not. success) then
goto 888
end if
end if
if (nbnduxy > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_uxuyadvectionvelocitybnd, tim)
if (.not. success) then
goto 888
end if
end if
if (nbndn > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_normalvelocitybnd, tim)
if (.not. success) then
goto 888
end if
end if
if (nbnd1d2d > 0 ) then
! NOTE: no gettimespacevalue is needed here: zbnd1d2d should be filled via BMI (forcing is REALTIME by coupler program)
end if
if (nshiptxy > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_shiptxy, tim)
if (.not. success) then
goto 888
endif
endif
if (nummovobs > 0) then
success = ec_gettimespacevalue(ecInstancePtr, item_movingstationtxy, tim)
if (success) then
do i=1,nummovobs
call updateObservationXY(numobs+i, xyobs(2*(i-1)+1), xyobs(2*(i-1)+2))
end do
call obs_on_flowgeom(1)
else
goto 888
end if
endif
if(jatransportmodule>0 .and. allocated(threttim)) then
call fm_thahbc()
endif
call klok(cpuextbnd(2)) ; cpuextbnd(3) = cpuextbnd(3) + cpuextbnd(2) - cpuextbnd(1)
iresult = DFM_NOERR
return ! Return with success
! Error handling:
888 continue
iresult = DFM_EXTFORCERROR
write(msgbuf,'(a,f13.3)') 'Error while updating boundary forcing at time=', tim
call mess(LEVEL_WARN, trim(msgbuf))
end subroutine flow_setexternalforcingsonboundaries
subroutine flow_settidepotential(timmin)
use m_flow
use m_flowgeom
use m_flowtimes
use timespace_data
use m_sferic
use unstruc_model
use m_equatorial
implicit none
double precision :: timmin
integer, save :: ini = 0
integer :: ierr, kk
double precision :: Omeg, tt
call meteo_tidepotential( julrefdat, TIMmin , xz , yz , tidep, ndx, doodsonstart, doodsonstop , doodsoneps)
if (md_ident == 'equator1d' ) then
tt = 60d0*(timmin-tstart_user)
do kk = 1,ndx
tidep(kk) = ZP*sin(om*tt - nmode*dg2rd*xz(kk) )
enddo
endif
end subroutine flow_settidepotential
subroutine setcdwcoefficient(uwi, cd10, L)
use m_wind
use m_flow , only : ag, hs, jaCdwusp, Cdwusp
use m_flowgeom , only : ln
! use m_physcoef , only: vonkar
use m_sferic , only: pi, twopi
use m_waves , only: twav
use m_physcoef
use m_missing
implicit none
integer, intent (in) :: L
integer :: k1, maxnit = 100, nit
double precision :: uwi, cd10, rk, hsurf = 10d0
double precision :: omw, cdL2, dkpz0, s, sold, eps = 1d-4
if (icdtyp == 1) then ! Constant
cd10 = cdb(1)
if (jaCdwusp == 1) then
if (Cdwusp(L) .ne. dmiss) then
cd10 = Cdwusp(L)
endif
endif
else if (icdtyp == 2 ) then ! Smith and Banks 2 breakpoints
if (uwi <= wdb(1) ) then
cd10 = cdb(1)
else if (uwi <= wdb(2) ) then
cd10 = cdb(1) + (uwi - wdb(1)) * (cdb(2) - cdb(1) ) / (wdb(2) - wdb(1) )
else
cd10 = cdb(2)
endif
else if (icdtyp == 3 ) then ! Smith and Banks like 3 breakpoints
if (uwi <= wdb(1) ) then
cd10 = cdb(1)
else if (uwi <= wdb(2) ) then
cd10 = cdb(1) + (uwi - wdb(1)) * (cdb(2) - cdb(1) ) / (wdb(2) - wdb(1) )
else if (uwi <= wdb(3) ) then
cd10 = cdb(2) + (uwi - wdb(2)) * (cdb(3) - cdb(2) ) / (wdb(3) - wdb(2))
else
cd10 = cdb(3)
endif
else if (icdtyp == 4) then ! Charnock 1955
! Charnock drag coefficient formulation, logarithmic wind velocity profile in the turbulent layer
! above the free surface:
! uwi 1 z z=10 m, for U10
! ---- = ----- ln (---)
! u* kappa z0
! where u* is the friction velocity, kappa is the Von Karman constant
! z is the vertical height above the free surface and z0 is the roughness height:
! z0 = b * u*^2/g
! with b the dimensionless Charnock coefficient and g the gravity acceleration.
! Cd = u*^2/uwi^2, so we have an implicit relation between drag coefficient Cd and wind speed Ws.
! Newton-Raphson :
nit = 0
s = 19.6d0
sold = 0d0
do while ( abs(sold-s).gt.(eps*s) )
nit = nit + 1
sold = s
s = sold*(log(hsurf*ag*sold*sold / (max(0.001,cdb(1)*uwi*uwi)))-2d0)/(vonkar*sold-2d0)
if ( nit.ge.maxnit ) then
cd10 = 1d-3
exit
endif
enddo
if (s > 0d0) then
cd10 = 1d0/(s*s)
endif
else if (icdtyp == 5) then ! Whang 2005, wave frequency dependent
k1 = ln(1,L)
omw = twopi/twav(k1) ! wave frequency
cdL2 = 0.001289d0*(omw*uwi/ag)**0.815d0 ! Cd at half wavelength above surface(11a)
dkpz0 = pi*exp(-vonkar/sqrt(CdL2)) ! (5)
call getwavenr(hs(k1),twav(k1),rk)
cd10 = vonkar*vonkar/ (log(10d0*rk/dkpz0))**2
endif
end subroutine setcdwcoefficient
subroutine flow_externalinput(tim) ! receive signals etc
use m_flowtimes
use m_flow
implicit none
double precision :: tim
end subroutine flow_externalinput
!> Write solution data to output files (map/his/restart/waq).
!! Each output type has its own interval (see m_flowtimes),
!! and output is only written if the current time tim exceeds the last
!! written interval.
subroutine flow_externaloutput(tim) ! give signals etc, write map, his etc
use m_flowtimes
use m_flow
use unstruc_model
use unstruc_netcdf
use m_xbeach_netcdf
use waq
use m_timer
use m_reduce, only : nocgiter
use m_partitioninfo, only : ndomains, jampi, my_rank
use unstruc_files, only : getoutputdir
#ifdef _OPENMP
use omp_lib
#endif
implicit none
double precision, intent(in) :: tim !< Current time, should in fact be time1, since all writers use s1, q1, etc.
double precision :: time_map_int, time_map_mpt
double precision :: runtime
integer :: mpt_minval
character(len=16) :: filepostfix
integer :: numomp
call inctime_split(tim)
if (ti_his > 0) then
if (tim >= time_his) then
if ( jampi.eq.0 .or. ( jampi.eq.1 .and. my_rank.eq.0 ) ) then
call unc_write_his(tim) ! wrihis
end if
if (ti_his > 0) then
time_his = max(ti_hiss + (floor((tim-ti_hiss)/ti_his)+1)*ti_his,ti_hiss)
else
time_his = tstop_user
endif
if (time_his > ti_hise) then
time_his = tstop_user
endif
endif
endif
if (.not. allocated(ti_mpt) ) then
allocate ( ti_mpt(1), ti_mpt_rel(1) ) ; ti_mpt(1) = 0 ; ti_mpt_rel(1) = 0
endif
if (ti_map > 0 .or. ti_mpt(1) > 0) then
if (tim >= time_map) then
call wrimap(tim)
ti_mpt_rel = ti_mpt - tim
time_map_mpt = tim + minval(ti_mpt_rel, mask=ti_mpt_rel.gt.0)
if (ti_map > 0) then
time_map_int = max(ti_maps + (floor((tim-ti_maps)/ti_map)+1)*ti_map,ti_maps)
else
time_map_int = tstop_user
endif
if (time_map_int > ti_mape .or. time_map_int < 0) then
time_map = min(time_map_mpt, tstop_user )
else
time_map = min(time_map_int, time_map_mpt)
endif
endif
endif
!! JRE time-averaged output
if ((jawave.eq.4) .and. (ti_wav > 0) .and. (jaavgwavquant .eq. 1)) then
if (tim >= time_wav) then
call unc_write_wav(tim)
call xbeach_clearaverages()
if (ti_wav > 0) then
time_wav = max(ti_wavs + (floor((tim-ti_wavs)/ti_wav)+1)*ti_wav,ti_wavs)
else
time_wav = tstop_user
endif
if (time_wav > ti_wave) then
time_wav = tstop_user
endif
endif
end if
! FM does not know whether the com-file for this time step will be used
! To be safe: always write the com-file at each user_timestep
if (tim==tstart_user .or. tim>=time_user) then
call wricom(tim)
endif
!if (ti_xls > 0) then
! if (tim >= time_xls) then
! call wrihistek(tim) ; time_xls = tim + ti_xls ! wrihis xls
! endif
!endif
if (ti_rst > 0) then
if (tim >= time_rst) then
call wrirst(tim) ;
if (ti_rst > 0) then
time_rst = max(ti_rsts + (floor((tim-ti_rsts)/ti_rst)+1)*ti_rst,ti_rsts)
else
time_rst = tstop_user
endif
if (time_rst > ti_rste) then
time_rst = tstop_user
endif
endif
endif
if (ti_waq > 0) then
if (tim >= time_waq) then
if (it_waq == 0) then ! First time of writing: write time-independent model files as well.
call waq_wri_model_files()
end if
! this is taken care of ! call volsur() ! TODO: move volsur in flow_initimestep to end of flow_singletimestep (is duplicate now)
call waq_wri_couple_files(tim) ; time_waq = tim + ti_waq
endif
endif
if (ti_stat > 0) then
if (tim >= time_stat) then
call step_to_screen() ; time_stat = tim + ti_stat
endif
else if ( ti_stat.lt.0d0 ) then
! base statistics output on wallclock time, if available
if (jatimer.gt.0 ) then
runtime = gettimer(1,ITOTAL)
if ( runtime.gt.time_stat ) then
call step_to_screen
time_stat = runtime + abs(ti_stat)
end if
end if
endif
if ( (jatimer.eq.1) .and. (ti_timings.gt.0) ) then
if ( tim.ge.time_timings ) then
! output timings
call makedir( trim(getoutputdir()) ) ! safety, no problem if it exists already.
call print_timings(trim(getoutputdir())//trim(md_ident)//'_timings.txt', time1)
! the following code changes timings filename, which is unfortunate for post-processing
! if (len_trim(md_timingsfile) == 0) then
! filepostfix = ' '
! if (jampi == 1) then
! write(filepostfix, '(a,i0)') '_MPI', ndomains
! end if
!#ifdef _OPENMP
! numomp = omp_get_max_threads()
! write(filepostfix, '(a,i0)') '_OMP', numomp
!#endif
! md_timingsfile = trim(getoutputdir()) // trim(md_ident) // trim(filepostfix) // '_timings.txt'
! end if
! call print_timings(md_timingsfile, time1)
time_timings = tim + ti_timings
! call initimer() ! reset timers
end if
end if
end subroutine flow_externaloutput
!> Writes current state immediately to files, typically used in
!! case of 'emergencies', without checking output intervals.
!!
!! Writes his/map/rst data to the (existing) files.
!! Note: no timings/waq output.
subroutine flow_externaloutput_direct()
use m_flowtimes
use unstruc_messages
use time_module
implicit none
integer :: iyear, imonth, iday, ihour, imin, isec
call mess(LEVEL_INFO, 'Performing direct write of solution state...')
! Compute current absolute date time, based on time1 since refdat
call datetime_from_refdat(time1, iyear, imonth, iday, ihour, imin, isec)
write (msgbuf, '(a,i0,a,f12.2,a,a,a,a)') 'Simulation current time: nt = ', int(dnt, 8), ', time1 = ', time1, 's ', &
'(', trim(datetime_to_string(iyear, imonth, iday, ihour, imin, isec)), ').'
call msg_flush()
call wrimap(time1)
call unc_write_his(time1)
call wrirst(time1)
call mess(LEVEL_INFO, 'Done writing solution state.')
end subroutine flow_externaloutput_direct
!> Increment the time-splitting upcoming time, if input time argument lies on or beyond that time.
!! Each output file with name base_timesplit0_.. will contain output for time_split0 < time1 <= time_split.
!! (Only for time1=tstart_user, time_split0 <= time1, i.e. first map file in sequence will have one more snapshot.)
subroutine inctime_split(tim)
use m_flowtimes
use unstruc_messages
implicit none
double precision, intent(in) :: tim !< Current time, used to checked whether an increment is necessary at all.
integer :: iyear, imonth, iday, ihour, imin, isec, add_seconds
! Do nothing if time splitting is switched off
if (ti_split <= 0d0) then
return
end if
! Do nothing if time is still before upcoming time_split.
if (tim <= time_split) then
return
end if
time_split0 = time_split
do ! increment time_split until tim <= time_split
! First, get y/M/d/h/m/s values for current time_split since refdat:
call datetime_from_refdat(time_split, iyear, imonth, iday, ihour, imin, isec)
! Second, add the ti_split increment to them, based on ti_split_unit
add_seconds = 0
select case (ti_split_unit)
case ('Y')
iyear = iyear + ti_split
case ('M')
imonth = imonth + ti_split
if (imonth > 12) then
imonth = mod(imonth, 12)
iyear = iyear + floor(real(imonth)/12.0)
end if
case ('D')
add_seconds = ti_split*24*3600
case ('h')
add_seconds = ti_split*3600
case('m')
add_seconds = ti_split*60
case ('s')
add_seconds = ti_split
case default
call mess(LEVEL_WARN, 'Invalid time partitioning unit: '//ti_split_unit) ! should not be possible, handled by readMDU
return
end select
! Finally convert the new absolute date time values to a time in seconds since refdat.
call seconds_since_refdat(iyear, imonth, iday, ihour, imin, isec+add_seconds, time_split)
if (tim <= time_split) then
exit
end if
end do ! until tim <= time_split
end subroutine inctime_split
!> Write history data in NetCDF format.
subroutine unc_write_his(tim) ! wrihis
use m_flowtimes
use m_flow
use m_flowgeom
use m_observations
use m_crosssections
use m_missing
use netcdf
use unstruc_files, only: defaultFilename, getoutputdir
use unstruc_netcdf, only: unc_create, unc_close, unc_addcoordatts
use unstruc_messages
use m_sferic, only: jsferic
use m_partitioninfo
use m_timer
use unstruc_model, only: md_ident
use m_sediment
use m_flowexternalforcings, only: numtracers, trnames
use m_transport, only: NUMCONST, ITRA1, ITRAN, const_names
use m_structures, only: cgendisch, pumpdisch, pumpcapac, gatedisch, cdamdisch, gategendisch, weirdisch, &
jahiscgen, jahispump, jahisgate, jahiscdam, jahisweir, jaoldstr, gategenflowh
implicit none
double precision, intent(in) :: tim !< Current time, should in fact be time1, since the data written is always s1, ucx, etc.
! locals
integer, save :: ihisfile = 0, id_laydim , id_laydimw, &
id_statdim, id_mstatdim, id_strlendim, id_crsdim, id_crslendim, id_crsptsdim, id_timedim, &
id_statx, id_staty, id_statid, id_statname, id_time, &
id_mstatx, id_mstaty, id_mstatname, &
id_crsx, id_crsy, id_crsname, &
id_vars, id_varucx, id_varucy, id_varucz, id_varsal, id_vartem, id_varsed, &
id_varQ, id_varQint, id_varQavg, &
id_varAu, id_varAuavg, &
id_varu, id_varuavg, id_varwx, id_varwy, id_varpatm, &
id_qsun, id_qeva, id_qcon, id_qlong, id_qfreva, id_qfrcon, id_qtot, &
id_turkin, id_tureps , id_vicwwu, id_rich, id_zcs, id_zws, &
id_wind, id_patm, id_tair, id_rhum, id_clou, &
id_E, id_R, id_H, id_D, id_DR, id_thetamean, &
id_cwav, id_cgwav, id_sigmwav, id_hs, &
id_pumpdim, id_pumpname, id_pump_dis, id_pump_cap, & ! id_pump_head,
id_gatedim, id_gatename, id_gate_dis, id_gate_edgel, & ! id_gate_head,
id_cdamdim, id_cdamname, id_cdam_dis, id_cdam_cresth, & ! id_cdam_head,
id_weirgendim, id_weirgenname, id_weirgen_dis, id_weirgen_cresth, id_weirgen_crestw, & ! id_weirgen_head,
id_gategendim, id_gategenname, id_gategen_dis, id_gategen_sillh, id_gategen_sillw, id_gategen_edgel, id_gategen_openw, & ! id_gategen_head,
id_genstrudim, id_genstruname, id_genstru_dis, id_genstru_cresth, id_genstru_crestw, id_genstru_edgel, id_genstru_openw, & ! id_genstru_head,
id_gategen_flowh
integer, allocatable, save :: id_tra(:)
integer, allocatable, save :: id_const(:), id_voltot(:)
double precision, allocatable, save :: valobsT(:,:)
integer :: IP, num, ntmp, n
double precision, save :: curtime_split = 0d0 ! Current time-partition that the file writer has open.
integer :: ntot, mobs, k, i, j, i1, ierr, mnp, kk, kb, kt, klay, idims(3), LL,Lb,Lt,L
logical :: jawel
double precision :: xp, yp, qsum, vals, valx, valy, valwx, valwy, valpatm, wind
character(len=255) :: filename
integer :: igen
! Another time-partitioned file needs to start, reset iteration count (and file).
if (ti_split > 0d0 .and. curtime_split /= time_split0) then
it_his = 0
curtime_split = time_split0
end if
! Close/reset any previous hisfile.
if (ihisfile > 0 .and. it_his == 0) then
ierr = unc_close(ihisfile)
ihisfile = 0
end if
! When no crs/obs present, return immediately.
if (numobs+nummovobs <= 0 .and. ncrs <= 0 .and. jahisbal <= 0 .and. jahiscgen <= 0) then
if (ihisfile == 0) then
call mess(LEVEL_WARN, 'No observations nor cross sections defined. Will not produce a history file.')
end if
ihisfile = -1 ! -1 stands for: no file open, no obs/crs defined.
return
end if
if (ihisfile == 0) then
call realloc(id_tra, ITRAN-ITRA1+1, keepExisting = .false.)
call realloc(id_const, NUMCONST, keepExisting = .false.)
call realloc(id_voltot, MAX_IDX, keepExisting = .false.)
! Possibly a different model, so make valobs transpose at correct size again.
call realloc(valobsT, (/ size(valobs, 2), size(valobs, 1) /), keepExisting = .false.)
if (ti_split > 0d0) then
filename = defaultFilename('his', timestamp=time_split0)
else
filename = defaultFilename('his')
end if
ierr = unc_create(filename, 0, ihisfile)
if (ierr /= nf90_noerr) then
call mess(LEVEL_WARN, 'Could not create history file.')
end if
ierr = nf90_def_dim(ihisfile, 'time', nf90_unlimited, id_timedim)
ierr = nf90_def_dim(ihisfile, 'name_len', 64, id_strlendim)
if (numobs > 0) then
ierr = nf90_def_dim(ihisfile, 'stations', numobs+nummovobs, id_statdim)
if (kmx > 0) then
ierr = nf90_def_dim(ihisfile, 'laydim', kmx, id_laydim)
ierr = nf90_def_dim(ihisfile, 'laydimw', kmx+1, id_laydimw)
end if
ierr = nf90_def_var(ihisfile, 'station_x_coordinate', nf90_double, id_statdim, id_statx)
ierr = nf90_def_var(ihisfile, 'station_y_coordinate', nf90_double, id_statdim, id_staty)
ierr = unc_addcoordatts(ihisfile, id_statx, id_staty, jsferic)
ierr = nf90_def_var(ihisfile, 'station_id', nf90_char, (/ id_strlendim, id_statdim /), id_statid)
ierr = nf90_put_att(ihisfile, id_statid, 'cf_role', 'timeseries_id')
! ierr = nf90_put_att(ihisfile, id_statid, 'standard_name', 'station_id') ! REF
ierr = nf90_put_att(ihisfile, id_statid, 'long_name' , 'Observation station identifier') ! REF
ierr = nf90_def_var(ihisfile, 'station_name', nf90_char, (/ id_strlendim, id_statdim /), id_statname)
ierr = nf90_put_att(ihisfile, id_statname, 'cf_role', 'timeseries_id')
! ierr = nf90_put_att(ihisfile, id_statname, 'standard_name', 'station_id') ! REF
ierr = nf90_put_att(ihisfile, id_statname, 'long_name' , 'Observation station name') ! REF
ierr = nf90_def_var(ihisfile, 'waterlevel', nf90_double, (/ id_statdim, id_timedim /), id_vars)
ierr = nf90_put_att(ihisfile, id_vars, 'standard_name', 'sea_surface_height') ! sorry for inland water people
ierr = nf90_put_att(ihisfile, id_vars, 'long_name', 'Water level')
ierr = nf90_put_att(ihisfile, id_vars, 'units', 'm')
ierr = nf90_put_att(ihisfile, id_vars, 'coordinates', 'station_x_coordinate station_y_coordinate station_name')
ierr = nf90_put_att(ihisfile, id_vars, '_FillValue', dmiss)
idims(1) = id_statdim
idims(2) = id_timedim
call definencvar(ihisfile,id_hs, nf90_double, idims, 2, 'Waterdepth' , 'Waterdepth', 'm', 'station_x_coordinate station_y_coordinate station_name')
if ( kmx.gt.0 ) then
ierr = nf90_def_var(ihisfile, 'x_velocity', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_varucx)
ierr = nf90_def_var(ihisfile, 'y_velocity', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_varucy)
ierr = nf90_def_var(ihisfile, 'z_velocity', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_varucz)
else
ierr = nf90_def_var(ihisfile, 'x_velocity', nf90_double, (/ id_statdim, id_timedim /), id_varucx)
ierr = nf90_def_var(ihisfile, 'y_velocity', nf90_double, (/ id_statdim, id_timedim /), id_varucy)
end if
if ( kmx.gt.0 ) then
ierr = nf90_put_att(ihisfile, id_varucz, 'standard_name', 'upward_sea_water_velocity')
ierr = nf90_put_att(ihisfile, id_varucz, 'long_name', 'Vertical/upward component of cell center velocity vector.') ! sorry for inland water people
ierr = nf90_put_att(ihisfile, id_varucz, 'units', 'm s-1')
ierr = nf90_put_att(ihisfile, id_varucz, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
ierr = nf90_put_att(ihisfile, id_varucz, '_FillValue', dmiss)
idims(1) = id_laydim
idims(2) = id_statdim
idims(3) = id_timedim
call definencvar (ihisfile, id_zcs, nf90_double, idims,3, 'Zcoordinate_c' , 'Vertical Center Coordinate' , 'm', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
ierr = nf90_put_att(ihisfile, id_zcs, 'positive' , 'up')
idims(1) = id_laydimw
idims(2) = id_statdim
idims(3) = id_timedim
call definencvar (ihisfile, id_zws, nf90_double, idims,3, 'Zcoordinate_w' , 'Vertical Interface Coordinate' , 'm', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_w')
ierr = nf90_put_att(ihisfile, id_zws, 'positive' , 'up')
if (iturbulencemodel == 3) then
call definencvar(ihisfile,id_turkin,nf90_double, idims,3, 'Tke' , 'Kinectic energy' , 'm2/s2', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_w')
call definencvar(ihisfile,id_tureps,nf90_double, idims,3, 'Eps' , 'Energy Dissipation', '1/s' , 'station_x_coordinate station_y_coordinate station_name Zcoordinate_w')
call definencvar(ihisfile,id_vicwwu,nf90_double, idims,3, 'Vicww' , 'Eddy viscosity' , 'm2/s' , 'station_x_coordinate station_y_coordinate station_name Zcoordinate_w')
endif
if (jarichardsononoutput > 0) then
call definencvar(ihisfile,id_rich,nf90_double, idims,3, 'Rich' , 'Richardson Nr' , ' ' , 'station_x_coordinate station_y_coordinate station_name Zcoordinate_w')
end if
end if
ierr = nf90_put_att(ihisfile, id_varucx, 'standard_name', 'eastward_sea_water_velocity')
ierr = nf90_put_att(ihisfile, id_varucy, 'standard_name', 'northward_sea_water_velocity')
if (jaeulervel==0) then
ierr = nf90_put_att(ihisfile, id_varucx, 'long_name', 'Eastward component of cell center velocity vector.') ! sorry for inland water people
ierr = nf90_put_att(ihisfile, id_varucy, 'long_name', 'Northward component of cell center velocity vector.') ! sorry for inland water people !Vertical == onhandige woordkeuze als 3d wordt gerekend
else
ierr = nf90_put_att(ihisfile, id_varucx, 'long_name', 'Eastward component of cell center Eulerian velocity vector.') ! sorry for inland water people
ierr = nf90_put_att(ihisfile, id_varucy, 'long_name', 'Northward component of cell center Eulerianvelocity vector.') ! sorry for inland water people !Vertical == onhandige woordkeuze als 3d wordt gerekend
endif
ierr = nf90_put_att(ihisfile, id_varucx, 'units', 'm s-1')
ierr = nf90_put_att(ihisfile, id_varucy, 'units', 'm s-1')
ierr = nf90_put_att(ihisfile, id_varucx, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
ierr = nf90_put_att(ihisfile, id_varucy, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
ierr = nf90_put_att(ihisfile, id_varucx, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_varucy, '_FillValue', dmiss)
if (jasal > 0) then
if ( kmx.gt.0 ) then
ierr = nf90_def_var(ihisfile, 'salinity', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_varsal)
else
ierr = nf90_def_var(ihisfile, 'salinity', nf90_double, (/ id_statdim, id_timedim /), id_varsal)
end if
ierr = nf90_put_att(ihisfile, id_varsal, 'units', 'ppt')
ierr = nf90_put_att(ihisfile, id_varsal, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_varsal, 'standard_name', 'salinity')
ierr = nf90_put_att(ihisfile, id_varsal, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
endif
! JRE XBeach
if (jawave .eq. 4) then
!ierr = nf90_def_var(ihisfile, 'E', nf90_double, ((/ id_statdim, id_timedim /)) , id_E)
!ierr = nf90_put_att(ihisfile, id_E, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_E, 'standard_name', 'sea_surface_bulk_wave_energy') ! not CF
!ierr = nf90_put_att(ihisfile, id_E, 'long_name' , 'wave energy per square meter')
!ierr = nf90_put_att(ihisfile, id_E, 'units' , 'J m-2')
!ierr = nf90_put_att(ihisfile, id_E, '_FillValue', dmiss)
!
ierr = nf90_def_var(ihisfile, 'R', nf90_double, ((/ id_statdim, id_timedim /)) , id_R)
ierr = nf90_put_att(ihisfile, id_R, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
ierr = nf90_put_att(ihisfile, id_R, 'standard_name', 'sea_surface_bulk_roller_energy') ! not CF
ierr = nf90_put_att(ihisfile, id_R, 'long_name' , 'roller energy per square meter')
ierr = nf90_put_att(ihisfile, id_R, 'units' , 'J m-2')
ierr = nf90_put_att(ihisfile, id_R, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'DR', nf90_double, ((/ id_statdim, id_timedim /)) , id_DR)
!ierr = nf90_put_att(ihisfile, id_DR, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_DR, 'standard_name', 'sea_surface_bulk_roller_dissipation') ! not CF
!ierr = nf90_put_att(ihisfile, id_DR, 'long_name' , 'roller energy dissipation per square meter')
!ierr = nf90_put_att(ihisfile, id_DR, 'units' , 'W m-2')
!ierr = nf90_put_att(ihisfile, id_DR, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'D', nf90_double, ((/ id_statdim, id_timedim /)) , id_D)
!ierr = nf90_put_att(ihisfile, id_D, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_D, 'standard_name', 'sea_surface_wave_breaking_dissipation') ! not CF
!ierr = nf90_put_att(ihisfile, id_D, 'long_name' , 'wave breaking energy dissipation per square meter')
!ierr = nf90_put_att(ihisfile, id_D, 'units' , 'W m-2')
!ierr = nf90_put_att(ihisfile, id_D, '_FillValue', dmiss)
!
ierr = nf90_def_var(ihisfile, 'H', nf90_double, ((/ id_statdim, id_timedim /)) , id_H)
ierr = nf90_put_att(ihisfile, id_H, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
ierr = nf90_put_att(ihisfile, id_H, 'standard_name', 'sea_surface_wave_significant_height')
ierr = nf90_put_att(ihisfile, id_H, 'long_name' , 'significant wave height')
ierr = nf90_put_att(ihisfile, id_H, 'units' , 'm')
ierr = nf90_put_att(ihisfile, id_H, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'thetamean', nf90_double, ((/ id_statdim, id_timedim /)) , id_thetamean)
!ierr = nf90_put_att(ihisfile, id_thetamean, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_thetamean, 'standard_name', 'sea_surface_wave_from_direction') ! not CF
!ierr = nf90_put_att(ihisfile, id_thetamean, 'long_name' , 'mean wave angle')
!ierr = nf90_put_att(ihisfile, id_thetamean, 'units' , 'rad')
!ierr = nf90_put_att(ihisfile, id_thetamean, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'cwav', nf90_double, ((/ id_statdim, id_timedim /)) , id_cwav)
!ierr = nf90_put_att(ihisfile, id_cwav, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_cwav, 'standard_name', 'sea_surface_wave_phase_velocity') ! not CF
!ierr = nf90_put_att(ihisfile, id_cwav, 'long_name' , 'mean wave angle')
!ierr = nf90_put_att(ihisfile, id_cwav, 'units' , 'm s-1')
!ierr = nf90_put_att(ihisfile, id_cwav, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'cgwav', nf90_double, ((/ id_statdim, id_timedim /)) , id_cgwav)
!ierr = nf90_put_att(ihisfile, id_cgwav, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_cgwav, 'standard_name', 'sea_surface_wave_group_velocity') ! not CF
!ierr = nf90_put_att(ihisfile, id_cgwav, 'long_name' , 'mean wave angle')
!ierr = nf90_put_att(ihisfile, id_cgwav, 'units' , 'm s-1')
!ierr = nf90_put_att(ihisfile, id_cgwav, '_FillValue', dmiss)
!
!ierr = nf90_def_var(ihisfile, 'sigmwav', nf90_double, ((/ id_statdim, id_timedim /)) , id_sigmwav)
!ierr = nf90_put_att(ihisfile, id_sigmwav, 'coordinates' , 'station_x_coordinate station_y_coordinate station_name')
!ierr = nf90_put_att(ihisfile, id_sigmwav, 'standard_name', 'sea_surface_wave_mean_frequency') ! not CF
!ierr = nf90_put_att(ihisfile, id_sigmwav, 'long_name' , 'mean wave frequency')
!ierr = nf90_put_att(ihisfile, id_sigmwav, 'units' , 'rad s-1')
!
end if
if (jatem > 0) then
if ( kmx.gt.0 ) then
ierr = nf90_def_var(ihisfile, 'temperature', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_vartem)
else
ierr = nf90_def_var(ihisfile, 'temperature', nf90_double, (/ id_statdim, id_timedim /), id_vartem)
end if
ierr = nf90_put_att(ihisfile, id_vartem, 'units', 'degree Celsius')
ierr = nf90_put_att(ihisfile, id_vartem, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_vartem, 'standard_name', 'temperature')
ierr = nf90_put_att(ihisfile, id_vartem, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
if (jamapheatflux > 0) then ! here less verbose
idims(1) = id_statdim
idims(2) = id_timedim
call definencvar(ihisfile,id_wind ,nf90_double,idims,2, 'Wind' , 'Windspeed', 'm/s', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_tair ,nf90_double,idims,2, 'Tair' , 'Air Temperature', 'degC', 'station_x_coordinate station_y_coordinate station_name')
if (jatem == 5) then
call definencvar(ihisfile,id_rhum ,nf90_double,idims,2, 'Rhum' , 'Relative humidity', ' ','station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_clou ,nf90_double,idims,2, 'Clou' , 'Cloudiness', ' ', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_qsun ,nf90_double,idims,2, 'Qsun' , 'Solar influx', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_Qeva ,nf90_double,idims,2, 'Qeva' , 'Evaporative heat flux', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_Qcon ,nf90_double,idims,2, 'Qcon' , 'Sensible heat flux', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_Qlong ,nf90_double,idims,2, 'Qlong' , 'Long wave back radiation', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_Qfreva ,nf90_double,idims,2, 'Qfreva', 'Free convection evaporative heat flux', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
call definencvar(ihisfile,id_Qfrcon ,nf90_double,idims,2, 'Qfrcon', 'Free convection sensible heat flux', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
endif
if (jatem > 1) then
call definencvar(ihisfile,id_Qtot ,nf90_double,idims,2, 'Qtot' , 'Total heat flux', 'W/m2', 'station_x_coordinate station_y_coordinate station_name')
end if
endif
endif
if (ITRA1 > 0) then
do j=ITRA1,ITRAN
i = j-ITRA1+1 ! tracer nr
if ( kmx > 0 ) then
ierr = nf90_def_var(ihisfile, const_names(j), nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_tra(i))
else
ierr = nf90_def_var(ihisfile, const_names(j), nf90_double, (/ id_statdim, id_timedim /), id_tra(i))
end if
ierr = nf90_put_att(ihisfile, id_tra(i), 'units', 'ppt')
ierr = nf90_put_att(ihisfile, id_tra(i), '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_tra(i), 'standard_name', const_names(j))
ierr = nf90_put_att(ihisfile, id_tra(i), 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
enddo
endif
if (jased > 0) then
if ( kmx.gt.0 ) then
ierr = nf90_def_var(ihisfile, 'sediment_concentration', nf90_double, (/ id_laydim, id_statdim, id_timedim /), id_varsed)
else
ierr = nf90_def_var(ihisfile, 'sediment_concentration', nf90_double, (/ id_statdim, id_timedim /), id_varsed)
end if
ierr = nf90_put_att(ihisfile, id_varsed, 'units', 'kg m-3')
ierr = nf90_put_att(ihisfile, id_varsed, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_varsed, 'standard_name', 'sediment_concentration')
ierr = nf90_put_att(ihisfile, id_varsed, 'coordinates', 'station_x_coordinate station_y_coordinate station_name Zcoordinate_c')
endif
if (japatm > 0) then
call definencvar(ihisfile,id_varpatm ,nf90_double,idims,2, 'Patm' , 'Atmospheric Pressure', 'N/m2', 'station_x_coordinate station_y_coordinate station_name')
endif
if (jawind > 0) then
ierr = nf90_def_var(ihisfile, 'windx', nf90_double, (/ id_statdim, id_timedim /), id_varwx)
ierr = nf90_put_att(ihisfile, id_varwx, 'units', 'm/s')
ierr = nf90_put_att(ihisfile, id_varwx, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_varwx, 'standard_name', 'x-component windspeed')
ierr = nf90_put_att(ihisfile, id_varwx, 'coordinates', 'station_x_coordinate station_y_coordinate station_name')
ierr = nf90_def_var(ihisfile, 'windy', nf90_double, (/ id_statdim, id_timedim /), id_varwy)
ierr = nf90_put_att(ihisfile, id_varwy, 'units', 'm/s')
ierr = nf90_put_att(ihisfile, id_varwy, '_FillValue', dmiss)
ierr = nf90_put_att(ihisfile, id_varwy, 'standard_name', 'y-component windspeed')
ierr = nf90_put_att(ihisfile, id_varwy, 'coordinates', 'station_x_coordinate station_y_coordinate station_name')
endif
end if
if (ncrs > 0) then
mnp = 0
do i=1,ncrs
mnp = max(mnp, crs(i)%path%np)
end do
ierr = nf90_def_dim(ihisfile, 'cross_section', ncrs, id_crsdim)
ierr = nf90_def_dim(ihisfile, 'cross_section_name_len', 64, id_crslendim)
ierr = nf90_def_dim(ihisfile, 'cross_section_pts', mnp+1, id_crsptsdim)
ierr = nf90_def_var(ihisfile, 'cross_section_x_coordinate', nf90_double, (/ id_crsptsdim, id_crsdim /), id_crsx)
ierr = nf90_def_var(ihisfile, 'cross_section_y_coordinate', nf90_double, (/ id_crsptsdim, id_crsdim /), id_crsy)
ierr = nf90_def_var(ihisfile, 'cross_section_name', nf90_char, (/ id_crslendim, id_crsdim /), id_crsname)
ierr = unc_addcoordatts(ihisfile, id_crsx, id_crsy, jsferic)
ierr = nf90_def_var(ihisfile, 'cross_section_discharge', nf90_double, (/ id_crsdim, id_timedim /), id_varQ)
ierr = nf90_put_att(ihisfile, id_varQ, 'units', 'm^3/s')
ierr = nf90_put_att(ihisfile, id_varQ, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_discharge_int', nf90_double, (/ id_crsdim, id_timedim /), id_varQint)
ierr = nf90_put_att(ihisfile, id_varQint, 'units', 'm^3/s')
ierr = nf90_put_att(ihisfile, id_varQint, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_discharge_avg', nf90_double, (/ id_crsdim, id_timedim /), id_varQavg)
ierr = nf90_put_att(ihisfile, id_varQavg, 'units', 'm^3/s')
ierr = nf90_put_att(ihisfile, id_varQavg, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_area', nf90_double, (/ id_crsdim, id_timedim /), id_varAu)
ierr = nf90_put_att(ihisfile, id_varAu, 'units', 'm^2')
ierr = nf90_put_att(ihisfile, id_varAu, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_area_avg', nf90_double, (/ id_crsdim, id_timedim /), id_varAuavg)
ierr = nf90_put_att(ihisfile, id_varAuavg, 'units', 'm^2')
ierr = nf90_put_att(ihisfile, id_varAuavg, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_velocity', nf90_double, (/ id_crsdim, id_timedim /), id_varu)
ierr = nf90_put_att(ihisfile, id_varu, 'units', 'm/s')
ierr = nf90_put_att(ihisfile, id_varu, 'coordinates', 'cross_section_name')
ierr = nf90_def_var(ihisfile, 'cross_section_velocity_avg', nf90_double, (/ id_crsdim, id_timedim /), id_varuavg)
ierr = nf90_put_att(ihisfile, id_varuavg, 'units', 'm/s')
ierr = nf90_put_att(ihisfile, id_varuavg, 'coordinates', 'cross_section_name')
if( jatransportmodule == 1 ) then
do num = 1,NUMCONST
ierr = nf90_def_var(ihisfile, 'cross_section_'//trim(const_names(num)), nf90_double, (/ id_crsdim, id_timedim /), id_const(num))
ierr = nf90_put_att(ihisfile, id_const(num), 'long_name', 'Cumulative flux (based on upwind cell) for '//const_names(num)//'.')
ierr = nf90_put_att(ihisfile, id_const(num), 'units', '-')
ierr = nf90_put_att(ihisfile, id_const(num), 'coordinates', 'cross_section_name')
enddo
endif
end if
if (jahisbal > 0) then
do num = 1,MAX_IDX
ierr = nf90_def_var(ihisfile, 'WaterBalance_'//trim(voltotname(num)), nf90_double, (/ id_timedim /), id_voltot(num))
ierr = nf90_put_att(ihisfile, id_voltot(num), 'units', 'm3')
enddo
end if
if (jaoldstr == 1) then
ntmp = ncgensg
else
ntmp = ngenstru
end if
if(jahiscgen > 0 .and. ntmp > 0) then
ierr = nf90_def_dim(ihisfile, 'general_structures', ntmp, id_genstrudim)
ierr = nf90_def_var(ihisfile, 'general_structure_name', nf90_char, (/ id_strlendim, id_genstrudim /), id_genstruname)
ierr = nf90_def_var(ihisfile, 'general_structure_discharge', nf90_double, (/ id_genstrudim, id_timedim /), id_genstru_dis)
!ierr = nf90_put_att(ihisfile, id_genstru_dis, 'standard_name', 'integral_of_discharge_wrt_time') ! TODO: introduce time windows in nc
ierr = nf90_put_att(ihisfile, id_genstru_dis, 'long_name', 'General structure discharge')
ierr = nf90_put_att(ihisfile, id_genstru_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_genstru_dis, 'coordinates', 'general_structure_name')
ierr = nf90_def_var(ihisfile, 'general_structure_crest_level', nf90_double, (/ id_genstrudim, id_timedim /), id_genstru_cresth)
!ierr = nf90_put_att(ihisfile, id_genstru_cresth, 'standard_name', 'cgen_crest_level')
ierr = nf90_put_att(ihisfile, id_genstru_cresth, 'long_name', 'General structure crest level')
ierr = nf90_put_att(ihisfile, id_genstru_cresth, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_genstru_cresth, 'coordinates', 'general_structure_name')
ierr = nf90_def_var(ihisfile, 'general_structure_crest_width', nf90_double, (/ id_genstrudim, id_timedim /), id_genstru_crestw)
!ierr = nf90_put_att(ihisfile, id_genstru_crestw, 'standard_name', 'genstru_crest_width')
ierr = nf90_put_att(ihisfile, id_genstru_crestw, 'long_name', 'General structure crest width')
ierr = nf90_put_att(ihisfile, id_genstru_crestw, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_zcgen3, 'coordinates', 'general_structure_name')
ierr = nf90_def_var(ihisfile, 'general_structure_lower_edge_level', nf90_double, (/ id_genstrudim, id_timedim /), id_genstru_edgel)
ierr = nf90_put_att(ihisfile, id_genstru_edgel, 'standard_name', 'genstru_lower_edge_level')
ierr = nf90_put_att(ihisfile, id_genstru_edgel, 'long_name', 'General structure lower edge level')
ierr = nf90_put_att(ihisfile, id_genstru_edgel, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_genstru_edgel, 'coordinates', 'general_structure_name')
ierr = nf90_def_var(ihisfile, 'general_structure_opening_width', nf90_double, (/ id_genstrudim, id_timedim /), id_genstru_openw)
ierr = nf90_put_att(ihisfile, id_genstru_openw, 'standard_name', 'genstru_opening_width')
ierr = nf90_put_att(ihisfile, id_genstru_openw, 'long_name', 'General structure opening width')
ierr = nf90_put_att(ihisfile, id_genstru_openw, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_genstru_openw, 'coordinates', 'general_structure_name')
endif
if(jahispump > 0 .and. npumpsg > 0) then
ierr = nf90_def_dim(ihisfile, 'pumps', npumpsg, id_pumpdim)
!ierr = nf90_def_dim(ihisfile, 'pump_name_len', 64, id_pumplendim)
ierr = nf90_def_var(ihisfile, 'pump_name', nf90_char, (/ id_strlendim, id_pumpdim /), id_pumpname)
ierr = nf90_def_var(ihisfile, 'pump_discharge', nf90_double, (/ id_pumpdim, id_timedim /), id_pump_dis)
!ierr = nf90_put_att(ihisfile, id_pump_dis, 'standard_name', 'pump_discharge')
ierr = nf90_put_att(ihisfile, id_pump_dis, 'long_name', 'Pump discharge')
ierr = nf90_put_att(ihisfile, id_pump_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_pump_dis, 'coordinates', 'pump_name')
ierr = nf90_def_var(ihisfile, 'pump_capacity', nf90_double, (/ id_pumpdim, id_timedim /), id_pump_cap)
!ierr = nf90_put_att(ihisfile, id_pump_cap, 'standard_name', 'pump_capacity')
ierr = nf90_put_att(ihisfile, id_pump_cap, 'long_name', 'Pump capacity')
ierr = nf90_put_att(ihisfile, id_pump_cap, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_pump_cap, 'coordinates', 'pump_name')
endif
if(jahisgate > 0 .and. ngatesg > 0 ) then
ierr = nf90_def_dim(ihisfile, 'gates', ngatesg, id_gatedim)
ierr = nf90_def_var(ihisfile, 'gate_name', nf90_char, (/ id_strlendim, id_gatedim /), id_gatename)
ierr = nf90_def_var(ihisfile, 'gate_discharge', nf90_double, (/ id_gatedim, id_timedim /), id_gate_dis)
!ierr = nf90_put_att(ihisfile, id_gate_dis, 'standard_name', 'gate_discharge')
ierr = nf90_put_att(ihisfile, id_gate_dis, 'long_name', 'Gate discharge')
ierr = nf90_put_att(ihisfile, id_gate_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_gate_dis, 'coordinates', 'gate_name')
ierr = nf90_def_var(ihisfile, 'gate_lower_edge_level', nf90_double, (/ id_gatedim, id_timedim /), id_gate_edgel)
ierr = nf90_put_att(ihisfile, id_gate_edgel, 'standard_name', 'gate_lower_edge_level')
ierr = nf90_put_att(ihisfile, id_gate_edgel, 'long_name', 'Gate lower edge level')
ierr = nf90_put_att(ihisfile, id_gate_edgel, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_gate_edgel, 'coordinates', 'gate_name')
endif
if(jahisgate > 0 .and. ngategen > 0 ) then
ierr = nf90_def_dim(ihisfile, 'gategens', ngategen, id_gategendim)
ierr = nf90_def_var(ihisfile, 'gategen_name', nf90_char, (/ id_strlendim, id_gategendim /), id_gategenname)
ierr = nf90_def_var(ihisfile, 'gategen_discharge', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_dis)
!ierr = nf90_put_att(ihisfile, id_gategen_dis, 'standard_name', 'integral_of_discharge_wrt_time') ! TODO: introduce time windows in nc
ierr = nf90_put_att(ihisfile, id_gategen_dis, 'long_name', 'Gate discharge (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_gategen_dis, 'coordinates', 'gategen_name')
ierr = nf90_def_var(ihisfile, 'gategen_sill_level', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_sillh)
!ierr = nf90_put_att(ihisfile, id_gategen_sillh, 'standard_name', 'gategen_sill_level')
ierr = nf90_put_att(ihisfile, id_gategen_sillh, 'long_name', 'Gate sill level (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_sillh, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_gategen_sillh, 'coordinates', 'gategen_name')
ierr = nf90_def_var(ihisfile, 'gategen_sill_width', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_sillw)
!ierr = nf90_put_att(ihisfile, id_gategen_sillw, 'standard_name', 'gategen_sill_width')
ierr = nf90_put_att(ihisfile, id_gategen_sillw, 'long_name', 'Gate sill width (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_sillw, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_zcgen3, 'coordinates', 'gategen_name')
ierr = nf90_def_var(ihisfile, 'gategen_lower_edge_level', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_edgel)
ierr = nf90_put_att(ihisfile, id_gategen_edgel, 'standard_name', 'gategen_lower_edge_level')
ierr = nf90_put_att(ihisfile, id_gategen_edgel, 'long_name', 'Gate lower edge level (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_edgel, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_gategen_edgel, 'coordinates', 'gategen_name')
ierr = nf90_def_var(ihisfile, 'gategen_flow_through_height', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_flowh)
ierr = nf90_put_att(ihisfile, id_gategen_flowh, 'standard_name', 'gategen_flow_through_height')
ierr = nf90_put_att(ihisfile, id_gategen_flowh, 'long_name', 'Gate flow through height (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_flowh, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_gategen_flowh, 'coordinates', 'gategen_name')
ierr = nf90_def_var(ihisfile, 'gategen_opening_width', nf90_double, (/ id_gategendim, id_timedim /), id_gategen_openw)
ierr = nf90_put_att(ihisfile, id_gategen_openw, 'standard_name', 'gategen_opening_width')
ierr = nf90_put_att(ihisfile, id_gategen_openw, 'long_name', 'Gate opening width (via general structure)')
ierr = nf90_put_att(ihisfile, id_gategen_openw, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_gategen_openw, 'coordinates', 'gategen_name')
endif
if(jahiscdam > 0 .and. ncdamsg > 0 ) then
ierr = nf90_def_dim(ihisfile, 'dams', ncdamsg, id_cdamdim)
!ierr = nf90_def_dim(ihisfile, 'cdam_name_len', 64, id_cdamlendim)
ierr = nf90_def_var(ihisfile, 'cdam_name', nf90_char, (/ id_strlendim, id_cdamdim /), id_cdamname)
ierr = nf90_def_var(ihisfile, 'cdam_discharge', nf90_double, (/ id_cdamdim, id_timedim /), id_cdam_dis)
!ierr = nf90_put_att(ihisfile, id_cdam_dis, 'standard_name', 'cdam_discharge')
ierr = nf90_put_att(ihisfile, id_cdam_dis, 'long_name', 'Controllable dam discharge')
ierr = nf90_put_att(ihisfile, id_cdam_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_cdam_dis, 'coordinates', 'cdam_name')
ierr = nf90_def_var(ihisfile, 'cdam_crest_level', nf90_double, (/ id_cdamdim, id_timedim /), id_cdam_cresth)
!ierr = nf90_put_att(ihisfile, id_cdam_cresth, 'standard_name', 'cdam_crest_level')
ierr = nf90_put_att(ihisfile, id_cdam_cresth, 'long_name', 'Controllable dam crest level')
ierr = nf90_put_att(ihisfile, id_cdam_cresth, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_cdam_cresth, 'coordinates', 'cdam_name')
endif
if(jahisweir > 0 .and. nweirgen > 0 ) then
ierr = nf90_def_dim(ihisfile, 'weirgens', nweirgen, id_weirgendim)
ierr = nf90_def_var(ihisfile, 'weirgen_name', nf90_char, (/ id_strlendim, id_weirgendim /), id_weirgenname)
ierr = nf90_def_var(ihisfile, 'weirgen_discharge', nf90_double, (/ id_weirgendim, id_timedim /), id_weirgen_dis)
!ierr = nf90_put_att(ihisfile, id_weirgen_dis, 'standard_name', 'integral_of_discharge_wrt_time') ! TODO: introduce time windows in nc
ierr = nf90_put_att(ihisfile, id_weirgen_dis, 'long_name', 'Weir discharge (via general structure)')
ierr = nf90_put_att(ihisfile, id_weirgen_dis, 'units', 'm3/s')
!ierr = nf90_put_att(ihisfile, id_weirgen_dis, 'coordinates', 'weirgen_name')
ierr = nf90_def_var(ihisfile, 'weirgen_crest_level', nf90_double, (/ id_weirgendim, id_timedim /), id_weirgen_cresth)
!ierr = nf90_put_att(ihisfile, id_weirgen_cresth, 'standard_name', 'weirgen_crest_level')
ierr = nf90_put_att(ihisfile, id_weirgen_cresth, 'long_name', 'Weir crest level (via general structure)')
ierr = nf90_put_att(ihisfile, id_weirgen_cresth, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_weirgen_cresth, 'coordinates', 'weirgen_name')
ierr = nf90_def_var(ihisfile, 'weirgen_crest_width', nf90_double, (/ id_weirgendim, id_timedim /), id_weirgen_crestw)
!ierr = nf90_put_att(ihisfile, id_weirgen_crestw, 'standard_name', 'weirgen_crest_width')
ierr = nf90_put_att(ihisfile, id_weirgen_crestw, 'long_name', 'Weir crest width (via general structure)')
ierr = nf90_put_att(ihisfile, id_weirgen_crestw, 'units', 'm')
!ierr = nf90_put_att(ihisfile, id_weirgen_crestw, 'coordinates', 'weirgen_name')
endif
ierr = nf90_def_var(ihisfile, 'time', nf90_double, id_timedim, id_time)
ierr = nf90_put_att(ihisfile, id_time, 'units' , 'seconds since '//refdat(1:4)//'-'//refdat(5:6)//'-'//refdat(7:8)//' 00:00:00')
ierr = nf90_put_att(ihisfile, id_time, 'standard_name', 'time')
ierr = nf90_enddef(ihisfile)
do i=1,numobs+nummovobs
! ierr = nf90_put_var(ihisfile, id_statx, xobs(i), (/ i /))
! ierr = nf90_put_var(ihisfile, id_staty, yobs(i), (/ i /))
ierr = nf90_put_var(ihisfile, id_statid, trim(namobs(i)), (/ 1, i /))
ierr = nf90_put_var(ihisfile, id_statname, trim(namobs(i)), (/ 1, i /)) ! TODO: long names for stations?
end do
if (ncrs > 0) then
do i=1,ncrs
ierr = nf90_put_var(ihisfile, id_crsx, crs(i)%path%xp(1:crs(i)%path%np), (/ 1, i /))
ierr = nf90_put_var(ihisfile, id_crsy, crs(i)%path%yp(1:crs(i)%path%np), (/ 1, i /))
ierr = nf90_put_var(ihisfile, id_crsname, trim(crs(i)%name), (/ 1, i /))
end do
end if
if (jahiscgen > 0 .and. ntmp > 0) then
do i=1,ntmp
if (jaoldstr == 1) then
igen = i
else
igen = genstru2cgen(i)
end if
ierr = nf90_put_var(ihisfile, id_genstruname, trim(cgen_ids(igen)), (/ 1, i /))
end do
end if
if (jahispump > 0 .and. npumpsg > 0) then
do i=1,npumpsg
ierr = nf90_put_var(ihisfile, id_pumpname, trim(pump_ids(i)), (/ 1, i /))
end do
end if
if (jahisgate > 0 .and. ngatesg > 0) then
do i=1,ngatesg
ierr = nf90_put_var(ihisfile, id_gatename, trim(gate_ids(i)), (/ 1, i /))
end do
end if
if (jahisgate > 0 .and. ngategen > 0) then
do i=1,ngategen
igen = gate2cgen(i)
ierr = nf90_put_var(ihisfile, id_gategenname, trim(cgen_ids(igen)), (/ 1, i /))
end do
end if
if (jahiscdam > 0 .and. ncdamsg > 0) then
do i=1,ncdamsg
ierr = nf90_put_var(ihisfile, id_cdamname, trim(cdam_ids(i)), (/ 1, i /))
end do
end if
if (jahisweir > 0 .and. nweirgen > 0 .and. allocated(weir2cgen)) then
do i=1,nweirgen
igen = weir2cgen(i)
ierr = nf90_put_var(ihisfile, id_weirgenname, trim(cgen_ids(igen)), (/ 1, i /))
end do
end if
endif
! Increment output counters in m_flowtimes.
time_his = tim
it_his = it_his + 1
ierr = nf90_put_var(ihisfile, id_time, time_his, (/ it_his /))
! Observation points (fixed+moving)
valobsT = transpose(valobs)
ntot = numobs + nummovobs
ierr = nf90_put_var(ihisfile, id_vars, valobsT(:,IPNT_S1), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_hs , valobsT(:,IPNT_HS), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_statx, xobs(:), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_staty, yobs(:), start = (/ 1, it_his /), count = (/ ntot, 1 /))
if ( jawave.eq.4 ) then
ierr = nf90_put_var(ihisfile, id_H, valobsT(:,IPNT_WAVEH), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_R, valobsT(:,IPNT_WAVER), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if
if (japatm > 0) then
ierr = nf90_put_var(ihisfile, id_varpatm, valobsT(:,IPNT_patm), start = (/ 1, it_his /), count = (/ ntot, 1 /))
endif
if (jawind > 0) then
ierr = nf90_put_var(ihisfile, id_varwx, valobsT(:,IPNT_wx), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_varwy, valobsT(:,IPNT_wy), start = (/ 1, it_his /), count = (/ ntot, 1 /))
endif
if ( kmx>0 ) then
! 3D
do kk = 1,kmx
ierr = nf90_put_var(ihisfile, id_varucx, valobsT(:,IPNT_UCX+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_varucy, valobsT(:,IPNT_UCY+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_varucz, valobsT(:,IPNT_UCZ+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
if (jasal > 0) then
ierr = nf90_put_var(ihisfile, id_varsal, valobsT(:,IPNT_SA1 +kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
end if
if (jatem > 0) then
ierr = nf90_put_var(ihisfile, id_vartem, valobsT(:,IPNT_TEM1+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
end if
if (jased > 0) then
ierr = nf90_put_var(ihisfile, id_varsed, valobsT(:,IPNT_SED +kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
end if
if (IVAL_TRA1 > 0) then
do j = IVAL_TRA1,IVAL_TRAN ! enumerators of tracers in valobs array (not the pointer)
i = j - IVAL_TRA1 + 1
ierr = nf90_put_var(ihisfile, id_tra(i), valobsT(:,IPNT_TRA1 + i-1+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1/))
enddo
end if
enddo
else
! 2D
ierr = nf90_put_var(ihisfile, id_varucx, valobsT(:,IPNT_UCX), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_varucy, valobsT(:,IPNT_UCY), start = (/ 1, it_his /), count = (/ ntot, 1 /))
if (jasal > 0) then
ierr = nf90_put_var(ihisfile, id_varsal, valobsT(:,IPNT_SA1), start = (/ 1, it_his /), count = (/ ntot, 1 /))
endif
if (jatem > 0) then
ierr = nf90_put_var(ihisfile, id_vartem, valobsT(:,IPNT_TEM1), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if
if (IVAL_TRA1 > 0) then
do j = IVAL_TRA1,IVAL_TRAN ! enumerators of tracers in valobs array (not the pointer)
i = j - IVAL_TRA1 + 1
ierr = nf90_put_var(ihisfile, id_tra(i), valobsT(:,IPNT_TRA1 + i-1), start = (/ 1, it_his /), count = (/ ntot, 1/))
end do
end if
if (jased > 0) then
ierr = nf90_put_var(ihisfile, id_varsed, valobsT(:,IPNT_SED), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if
endif
if (jatem > 0 .and. jamapheatflux > 0) then
ierr = nf90_put_var(ihisfile, id_Wind , valobsT(:,IPNT_WIND), start = (/ 1, it_his /), count = (/ ntot, 1 /))
if ( jatem.gt.1 ) then ! also heat modelling involved
ierr = nf90_put_var(ihisfile, id_Tair , valobsT(:,IPNT_TAIR), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if
if (jatem == 5 .and. allocated(Rhum) .and. allocated(Clou) ) then
ierr = nf90_put_var(ihisfile, id_Rhum , valobsT(:,IPNT_RHUM), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Clou , valobsT(:,IPNT_CLOU), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if
if (jatem == 5 ) then
ierr = nf90_put_var(ihisfile, id_Qsun , valobsT(:,IPNT_QSUN), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Qeva , valobsT(:,IPNT_QEVA), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Qcon , valobsT(:,IPNT_QCON), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Qlong , valobsT(:,IPNT_QLON), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Qfreva , valobsT(:,IPNT_QFRE), start = (/ 1, it_his /), count = (/ ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_Qfrcon , valobsT(:,IPNT_QFRC), start = (/ 1, it_his /), count = (/ ntot, 1 /))
endif
ierr = nf90_put_var(ihisfile, id_Qtot , valobsT(:,IPNT_QTOT), start = (/ 1, it_his /), count = (/ ntot, 1 /))
end if ! jamapheatflux > 0! jatem > 0
if (kmx > 0 ) then
do kk = 1, kmx+1
ierr = nf90_put_var(ihisfile, id_zws, valobsT(:,IPNT_ZWS+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
if (kk > 1) then
ierr = nf90_put_var(ihisfile, id_zcs, valobsT(:,IPNT_ZCS+kk-2), start = (/ kk-1,1, it_his /), count = (/ 1, ntot, 1 /))
endif
if (iturbulencemodel == 3) then
ierr = nf90_put_var(ihisfile, id_turkin, valobsT(:,IPNT_TKIN +kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_tureps, valobsT(:,IPNT_TEPS +kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
ierr = nf90_put_var(ihisfile, id_vicwwu, valobsT(:,IPNT_VICWW+kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
endif
if (idensform > 0 .and. jaRichardsononoutput > 0) then
ierr = nf90_put_var(ihisfile, id_rich, valobsT(:,IPNT_RICH +kk-1), start = (/ kk, 1, it_his /), count = (/ 1, ntot, 1 /))
endif
enddo
endif
! Cross sections
if (ncrs > 0) then
do i=1,ncrs
! Discharges Q
ierr = nf90_put_var(ihisfile, id_varQ, crs(i)%sumvalcur(IPNT_Q1C), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_varQint, crs(i)%sumvalcum(IPNT_Q1C), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_varQavg, crs(i)%sumvalavg(IPNT_Q1C), (/ i, it_his /))
! Cross sectional areas A*u
ierr = nf90_put_var(ihisfile, id_varAu, crs(i)%sumvalcur(IPNT_AUC), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_varAuavg, crs(i)%sumvalavg(IPNT_AUC), (/ i, it_his /))
! Average velocity Q/Au
ierr = nf90_put_var(ihisfile, id_varu, crs(i)%sumvalcur(IPNT_U1A), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_varuavg, crs(i)%sumvalavg(IPNT_U1A), (/ i, it_his /))
if( jatransportmodule == 1 ) then
IP = IPNT_HUA
do num = 1,NUMCONST
IP = IP + 1
ierr = nf90_put_var(ihisfile, id_const(num), crs(i)%sumvalcur(IP), (/ i, it_his /))
end do
endif
end do
end if
if (jaoldstr == 1) then
ntmp = ncgensg
else
ntmp = ngenstru
end if
if (jahiscgen > 0 .and. ntmp > 0) then
do i=1,ntmp
if( jaoldstr == 0 ) then
igen = genstru2cgen(i)
else
igen = i
endif
ierr = nf90_put_var(ihisfile, id_genstru_dis, cgendisch(i), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_genstru_cresth, zcgen(3*igen-2), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_genstru_edgel, zcgen(3*igen-1), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_genstru_openw, zcgen(3*igen ), (/ i, it_his /))
end do
end if
if (jahispump > 0 .and. npumpsg > 0) then
do i=1,npumpsg
ierr = nf90_put_var(ihisfile, id_pump_dis, pumpdisch(i), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_pump_cap, pumpcapac(i), (/ i, it_his /))
end do
end if
if (jahisgate > 0 .and. ngatesg > 0) then
do i=1,ngatesg
ierr = nf90_put_var(ihisfile, id_gate_dis , gatedisch(i) , (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_gate_edgel, zgate(i) , (/ i, it_his /))
end do
end if
if (jahisgate > 0 .and. ngategen > 0) then
do i=1,ngategen
igen = gate2cgen(i)
ierr = nf90_put_var(ihisfile, id_gategen_dis , gategendisch(i), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_gategen_sillh, zcgen(3*igen-2), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_gategen_edgel, zcgen(3*igen-1), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_gategen_flowh, gategenflowh(i), (/ i, it_his /))
! TODO: AvD sillw
ierr = nf90_put_var(ihisfile, id_gategen_openw, zcgen(3*igen ), (/ i, it_his /))
end do
end if
if (jahiscdam > 0 .and. ncdamsg > 0) then
do i=1,ncdamsg
ierr = nf90_put_var(ihisfile, id_cdam_dis, cdamdisch(i), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_cdam_cresth, zcdam(i) , (/ i, it_his /))
end do
end if
if (jahisweir > 0 .and. nweirgen > 0) then
do i=1,nweirgen
igen = weir2cgen(i)
ierr = nf90_put_var(ihisfile, id_weirgen_dis, weirdisch(i), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_weirgen_cresth, zcgen(3*igen-2), (/ i, it_his /))
ierr = nf90_put_var(ihisfile, id_weirgen_crestw, zcgen(3*igen), (/ i, it_his /)) ! TODO: AvD: is zcgen(3) to be interpreted as crestw or openw?
end do
end if
do num = 1,MAX_IDX
ierr = nf90_put_var(ihisfile, id_voltot(num), voltot(num), start=(/ it_his /))
enddo
if( jahisgate > 0 .and. ngatesg+ngategen > 0) then ! Nabi
! todo: remove all do loops
! ngatesg ! Old-fashioned gates 'gateloweredgelevel'
! Actual discharge:
!ierr = nf90_put_var(ihisfile, id_gatedisch, gatedisch(1:ngatesg+ngategen), start=(/ 1, it_his /), count = (/ ngatesg+ngategen, 1 /))
!'pump_discharge_pumpA'
!'pump_discharge_pumpB' (1:ntimes)
!'pump_names' (1:npumps)
!'pump_discharge' (1:ntimes, 1:npumps)
! Door lower edge level
! ierr = nf90_put_var(ihisfile, id_zgate, work ... (1:ngatesg+ngategen), start=(/ 1, it_his /), count = (/ ngatesg+ngategen, 1 /))
! id_gatesill: not for old style gates, they are just at bed level, so leave empty value in the file on columns 1:ngatesg
! ierr = nf90_put_var(ihisfile, id_gatesill, gatesill(ngatesg+1:ngatesg+ngategen), start=(/ ngatesg+1, it_his /), count = (/ ngategen, 1 /))
! ierr = nf90_put_var(ihisfile, id_zgate(num) , zgate(num) , start=(/ it_his /))
! do num=1,ngategen ! New-style gate, via generalstructure
! igen=gate2cgen(num)
! ipos = ! Just add new style gates at the back of the old style gates
! ierr = nf90_put_var(ihisfile, id_gatedisch, gatedisch(ipos), start=(/ it_his /))
! ierr = nf90_put_var(ihisfile, id_zgate(num) , zgate(num) , start=(/ it_his /))
endif
if( jahiscdam > 0 .and. ncdamsg + nweirgen > 0) then ! Nabi
! see gates
do num = 1,ncdamsg
! ierr = nf90_put_var(ihisfile, id_cdamdisch(num), cdamdisch(num), start=(/ it_his /))
! ierr = nf90_put_var(ihisfile, id_zcdam(num) , zcdam(num) , start=(/ it_his /))
enddo
endif
ierr = nf90_sync(ihisfile) ! Flush file
end subroutine unc_write_his
! fill observation stations array
subroutine fill_valobs()
use m_flow
use m_transport
use m_flowgeom
use m_observations
use m_sediment
use m_xbeach_data, only: H, R
implicit none
integer :: i, j, kk, k, kb, kt, klay, L, LL, Lb, Lt
valobs = DMISS
do i = 1,numobs+nummovobs
k = max(kobs(i),1)
if ( kobs(i).gt.0 ) then ! rely on reduce_kobs to have selected the right global flow nodes
if ( kmx.gt.0 ) then
call getkbotktop(k,kb,kt)
call reconstructucz(k)
else
kb = k
kt = k
end if
! store values in valobs work array
valobs(:,i) = 0d0 ! should not be DMISS, as DMISS is used to mark observation stations outside subdomain in reduce_valobs
valobs(IPNT_S1,i) = s1(k)
valobs(IPNT_HS,i) = s1(k) - bl(k)
valobs(IPNT_CMX,i) = cmxobs(i)
if (jawind > 0) then
valobs(IPNT_wx,i) = wx(k)
valobs(IPNT_wy,i) = wy(k)
endif
if (jaPATM > 0 .and. allocated(patm)) then
valobs(IPNT_PATM,i) = PATM(k)
ENDIF
if ( jawave.eq.4 .and. allocated(H) .and. allocated(R) ) then
valobs(IPNT_WAVEH,i) = H(k)
valobs(IPNT_WAVER,i) = R(k)
end if
do kk=kb,kt
klay = kk-kb+1
valobs(IPNT_UCX+klay-1,i) = ucx(kk)
valobs(IPNT_UCY+klay-1,i) = ucy(kk)
if (jaeulervel==1 .and. hs(k) > epshu) then
valobs(IPNT_UCX+klay-1,i) = valobs(IPNT_UCX+klay-1,i) - Mxwav(k)/hs(k)
valobs(IPNT_UCY+klay-1,i) = valobs(IPNT_UCY+klay-1,i) - Mywav(k)/hs(k)
endif
if ( kmx>0 ) then
valobs(IPNT_UCZ+klay-1,i) = ucz(kk)
end if
if ( jasal.gt.0 ) then
valobs(IPNT_SA1+klay-1,i) = sa1(kk)
end if
if ( jatem.gt.0 ) then
valobs(IPNT_TEM1+klay-1,i) = tem1(kk)
end if
if ( IVAL_TRA1.gt.0 ) then
do j=IPNT_TRA1,IPNT_TRAN
valobs(j+klay-1,i) = constituents(ITRA1+j-IPNT_TRA1, kk)
end do
end if
if ( jased.gt.0 ) then
valobs(IPNT_SED+klay-1,i) = sed(1, kk)
end if
valobs(IPNT_CMX,i) = max( valobs(IPNT_UCX,i), sqrt( ucx(kk)**2 + ucy(kk)**2 ) )
end do
valobs(IPNT_SMX,i) = max( smxobs(i), s1(k) )
if ( kmx.gt.0 ) then
LL = iabs(nd(k)%ln(1))
call getLbotLtop(LL,Lb,Lt)
do L = Lb-1, Lt
klay = L-Lb+2
valobs(IPNT_ZWS+klay-1,i) = zws(kb + L-Lb)
if (klay > 1) then
valobs(IPNT_ZCS+klay-2,i) = 0.5d0*(zws(kb + klay-2)+zws(kb + klay-3))
endif
if ( iturbulencemodel.ge.2 ) then
valobs(IPNT_VICWW + klay-1,i) = vicwwu (L)
end if
if ( iturbulencemodel.ge.3 ) then
valobs(IPNT_TKIN + klay-1,i) = turkin1(L)
valobs(IPNT_TEPS + klay-1,i) = tureps1(L)
endif
if (idensform > 0 .and. jaRichardsononoutput > 0) then
valobs(IPNT_RICH + klay-1,i) = rich(L)
endif
enddo
end if
! Heatflux
if (jatem > 0 .and. jamapheatflux > 0) then
LL = iabs(nd(k)%ln(1))
if ( jawind.gt.0 ) then
valobs(IPNT_WIND,i) = sqrt(wx(LL)*wx(LL) + wy(LL)*wy(LL))
end if
if ( jatem.gt.1 ) then ! also heat modelling involved
valobs(IPNT_TAIR,i) = Tair(k)
end if
if (jatem == 5 .and. allocated(Rhum) .and. allocated(Clou) ) then
valobs(IPNT_RHUM,i) = Rhum(k)
valobs(IPNT_CLOU,i) = Clou(k)
endif
if (jatem == 5 ) then
valobs(IPNT_QSUN,i) = Qsunmap(k)
valobs(IPNT_QEVA,i) = Qevamap(k)
valobs(IPNT_QCON,i) = Qconmap(k)
valobs(IPNT_QLON,i) = Qlongmap(k)
valobs(IPNT_QFRE,i) = Qfrevamap(k)
valobs(IPNT_QFRC,i) = Qfrconmap(k)
endif
if (jatem > 1 ) then
valobs(IPNT_QTOT,i) = Qtotmap(k)
end if
end if
else
valobs(:,i) = DMISS
end if
end do
return
end subroutine fill_valobs
!> update observation station data
subroutine updateValuesOnObervationStations()
use m_observations
use m_partitioninfo
use m_timer
implicit none
call fill_valobs()
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IOUTPUTMPI)
call reduce_valobs(IPNT_NUM,numobs+nummovobs,valobs)
if ( jatimer.eq.1 ) call stoptimer(IOUTPUTMPI)
end if
return
end subroutine updateValuesOnObervationStations
subroutine definencvar(ncid, idq, itype, idims, n, name, desc, unit, namecoord)
use netcdf
use unstruc_netcdf
use m_sferic
implicit none
integer, intent(in) :: ncid ! file unit
integer, intent(inout) :: idq ! quantity id
integer, intent(in) :: itype ! double or integer etc
integer, intent(in) :: n ! dim of idim
integer, intent(in) :: idims(n)
character(len=*), intent(in) :: name, desc, unit, namecoord
integer :: ierr
ierr = 0
ierr = nf90_def_var(ncid, name , itype, idims , idq)
ierr = nf90_put_att(ncid, idq , 'coordinates' , namecoord)
ierr = nf90_put_att(ncid, idq , 'standard_name', '*'//name)
ierr = nf90_put_att(ncid, idq , 'long_name' , desc)
ierr = nf90_put_att(ncid, idq , 'units' , unit)
ierr = unc_add_gridmapping_att(ncid, (/idq/), jsferic)
end subroutine definencvar
subroutine wrirst(tim)
use m_flow
use m_flowtimes
use m_observations
use unstruc_netcdf
use unstruc_model
use unstruc_files , only: defaultFilename
implicit none
double precision, intent(in) :: tim
! locals
integer, save :: irstfile = 0
integer :: ierr
character(len=256) :: filnam
if (irstfile == 0) then
filnam = defaultFilename('rst', timestamp=tim)
ierr = unc_create(filnam , 0, irstfile)
if (ierr /= nf90_noerr) then
call mess(LEVEL_WARN, 'Could not create rst file.')
irstfile = 0
end if
endif
if (irstfile .ne. 0) then
call unc_write_rst_filepointer(irstfile,tim)
endif
ierr = unc_close(irstfile) ! Do more than flushing: close the file, it is not needed anymore
end subroutine wrirst
subroutine wrimap(tim)
use m_flow
use m_flowtimes
use m_observations
use unstruc_netcdf
use unstruc_model
use unstruc_files , only: defaultFilename
implicit none
double precision, intent(in) :: tim
! locals
type(t_unc_mapids), save :: mapids ! TODO: AvD: move this to global state (so that it can be reset as well, just like old it_map)
integer :: ierr
integer :: i
integer :: len
integer, save :: mtecfil = 0
integer, external :: numuni
character(len=256) :: filnam
logical :: unitused
double precision, save :: curtime_split = 0d0 ! Current time-partition that the file writer has open.
! Another time-partitioned file needs to start, reset iteration count (and file).
if (ti_split > 0d0 .and. curtime_split /= time_split0) then
mapids%idx_curtime = 0
it_map = 0
it_map_tec = 0
curtime_split = time_split0
end if
if ( md_mapformat.eq.IFORMAT_NETCDF .or. md_mapformat.eq.IFORMAT_NETCDF_AND_TECPLOT .or. md_mapformat == IFORMAT_UGRID) then ! NetCDF output
if (mapids%ncid /= 0 .and. ((md_unc_conv == UNC_CONV_UGRID .and. mapids%idx_curtime == 0) .or. (md_unc_conv == UNC_CONV_CFOLD .and. it_map == 0))) then
ierr = unc_close(mapids%ncid)
mapids%ncid = 0
end if
if (mapids%ncid == 0) then
if (ti_split > 0d0) then
filnam = defaultFilename('map', timestamp=time_split0)
else
filnam = defaultFilename('map')
end if
ierr = unc_create(filnam , 0, mapids%ncid)
if (ierr /= nf90_noerr) then
call mess(LEVEL_WARN, 'Could not create map file.')
mapids%ncid = 0
end if
endif
if (mapids%ncid .ne. 0) then
if (md_unc_conv == UNC_CONV_UGRID) then
call unc_write_map_filepointer_ugrid(mapids,tim) ! wrimap
else
call unc_write_map_filepointer(mapids%ncid,tim) ! wrimap
endif
endif
ierr = nf90_sync(mapids%ncid) ! Flush file
end if
if ( md_mapformat.eq.IFORMAT_TECPLOT .or. md_mapformat.eq.IFORMAT_NETCDF_AND_TECPLOT ) then ! TecPlot output
!if (mtecfil /= 0 .and. it_map_tec == 0) then
! call doclose(mtecfil)
!end if
!if (it_map_tec == 0) then
! if (ti_split > 0d0) then
! filnam = defaultFilename('tec', timestamp=time_split0)
! else
! filnam = defaultFilename('tec')
! end if
! call newfil(mtecfil, filnam)
!endif
!call tecplot_out(mtecfil, tim, it_map_tec==0)
! write grid in Tecplot format only once
if ( it_map_tec.eq.0 ) then
filnam = defaultFilename('net.plt')
call wrinet_tecplot(filnam,0) ! do not call findcells
end if
! write solution in Tecplot format
filnam = defaultFilename('map.plt', timestamp=tim)
call wrimap_tecplot(filnam)
it_map_tec = it_map_tec+1
end if
end subroutine wrimap
subroutine wricom(tim)
use m_flow
use m_flowtimes
use m_observations
use unstruc_netcdf
use unstruc_model
use unstruc_files , only: defaultFilename
implicit none
double precision, intent(in) :: tim
! locals
type(t_unc_mapids), save :: comids
integer :: ierr
character(len=256), save :: filnam
character(len=256) :: msg
logical :: file_exists
! When leaving netcdf-file open and using nf90_sync:
! Data did not appear during debugging
! This problem was solved by closing/opening the file everytime
!
if (comids%ncid/=0 .and. jawave==3) then
!
! Existing/ongoing communication via com file:
! com file already exists
!
ierr = nf90_open(filnam, NF90_WRITE, comids%ncid)
elseif (comids%ncid==0 .and. jawave==3) then
!
! No communication yet via com file:
! Check whether com file exists
!
filnam = defaultFilename('com')
md_wavefile = filnam
inquire(file=filnam,exist=file_exists)
if ( file_exists ) then
write(msg,'(3a)') "File '",trim(filnam), "' already exists. Assuming that it contains valid WAVE information. FLOW data will be added."
call mess(LEVEL_WARN, trim(msg))
ierr = nf90_open(filnam, NF90_WRITE, comids%ncid)
else
! No com file yet. Create a new one and write FLOW parameters
!
ierr = unc_create(filnam , 0, comids%ncid)
if (ierr /= nf90_noerr) then
call mess(LEVEL_WARN, 'Could not create com file.')
comids%ncid = 0
endif
endif
endif
if (comids%ncid /= 0) then
call unc_write_map_filepointer(comids%ncid,tim, 2)
endif
ierr = nf90_close(comids%ncid) ! Flush file
end subroutine wricom
!> Writes the current water balance quantities to file.
!! File format is ascii, one time per line, all quantities in columns.
subroutine wribal()
use m_flowtimes
use m_flow
use unstruc_files, only: defaultFilename
implicit none
! locals
integer, save :: ibalfile = 0
integer :: ierr
if (ibalfile /= 0 .and. dnt == 1) then
call doclose(ibalfile)
ibalfile = 0
end if
if (ibalfile == 0) then
call newfil(ibalfile, defaultFilename('bal'))
write(ibalfile,'(100(a26))') 'time1', 'dts', 'vol1tot', 'volerr', ' volerrcum'
end if
write(ibalfile,'(100(F26.15))') time1, dts, vol1tot, volerr, volerrcum
end subroutine wribal
!> Given time in seconds from refdat, fill dateandtime string
!! NOTE: maketime and maketimeinverse are not compatible, because of minutes versus seconds, and different format string.
subroutine maketime(dateandtime,tim)
use m_flowtimes
implicit none
character, intent(out) :: dateandtime*(*) !< Output datetime string, format '20000101_000000', note: includes seconds.
double precision, intent(in) :: tim !< Input time in seconds since refdat.
integer :: iday, imonth, iyear, ihour, imin, isec
dateandtime = '20000101_000000'
! TODO: AvD: maketime and maketimeinverse are now inconsistent since the addition of this '_'
call datetime_from_refdat(tim, iyear, imonth, iday, ihour, imin, isec)
write(dateandtime( 1:4 ),'(i4)') iyear
write(dateandtime( 5:6 ),'(i2.2)') imonth
write(dateandtime( 7:8 ),'(i2.2)') iday
write(dateandtime(10:11),'(i2.2)') ihour
write(dateandtime(12:13),'(i2.2)') imin
write(dateandtime(14:15),'(i2.2)') isec
return
end subroutine maketime
SUBROUTINE MAKETIMEjul0(TEX,TNr) ! maketime with jul0 already in module
use m_flowtimes
implicit none
double precision :: tnr ! time in hours
CHARACTER TEX*(*)
double precision :: Tuur, Tmin
integer :: nuur, nmin, nsec, iyyy,mm,id,ndag, jul0
TEX = '20010101 000000'
JUL0 = julrefdat
NDAG = TNR / 24.0
CALL CALDAT(JUL0+NDAG,MM,ID,IYYY)
TUUR = TNR - NDAG*24
NUUR = TUUR
TMIN = (TUUR - NUUR)*60
NMIN = TMIN
NSEC = (TMIN - NMIN)*60
WRITE(TEX(1:4),'(I4.4)') IYYY
WRITE(TEX(5:6),'(I2.2)') MM
WRITE(TEX(7:8),'(I2.2)') ID
WRITE(TEX(10:11),'(I2.2)') NUUR
WRITE(TEX(12:13),'(I2.2)') NMIN
WRITE(TEX(14:15),'(I2.2)') NSEC
END SUBROUTINE MAKETIMEjul0
!> Given datetime string, compute time in seconds from refdat
subroutine maketimeinverse(dateandtime,timsec,stat)
use m_flowtimes
implicit none
character, intent(in) :: dateandtime*(*) !< Input datetime string, format '201201010000', note that seconds are ignored.
integer, intent(out) :: stat
double precision :: timmin
double precision, intent(out) :: timsec
integer :: iday ,imonth ,iyear ,ihour , imin, isec
integer :: iostat
! dateandtime = '20120101000000'
stat = 0
read(dateandtime( 1:4 ),'(i4)',err=666,iostat=iostat) iyear
read(dateandtime( 5:6 ),'(i2.2)',err=666,iostat=iostat) imonth
read(dateandtime( 7:8 ),'(i2.2)',err=666,iostat=iostat) iday
read(dateandtime( 9:10),'(i2.2)',err=666,iostat=iostat) ihour
read(dateandtime(11:12),'(i2.2)',err=666,iostat=iostat) imin
read(dateandtime(13:14),'(i2.2)',err=666,iostat=iostat) isec
666 if (iostat/=0) then
stat=iostat
return
endif
call seconds_since_refdat(iyear, imonth, iday, ihour, imin, isec, timsec)
timmin = timsec/60d0
!timmin = (jul - jul0)*24d0*60d0 + ihour*60d0 + imin
return
end subroutine maketimeinverse
!> Calculates the relative time in seconds since refdat, given an absolute datetime.
!! The input datetime is in separate year/month/../seconds values.
!! \see maketimeinverse
subroutine seconds_since_refdat(iyear, imonth, iday, ihour, imin, isec, timsec)
use m_flowtimes
implicit none
integer, intent(in) :: iyear, iday, imonth, ihour, imin, isec !< Input absolute date time components
double precision, intent(out) :: timsec !< Output seconds since refdate for the specified input datetime.
integer :: jul, jul0, iyear0, imonth0, iday0
integer, external :: julday
read(refdat(1:4),*) iyear0
read(refdat(5:6),*) imonth0
read(refdat(7:8),*) iday0
jul0 = julday(imonth0,iday0,iyear0)
jul = julday(imonth ,iday ,iyear )
timsec = (jul - jul0)*24d0*3600d0 + ihour*3600d0 + imin*60d0 + isec
end subroutine seconds_since_refdat
!> Calculate absolute date time values, given a time in seconds since refdat.
!! \see maketime
subroutine datetime_from_refdat(timsec, iyear, imonth, iday, ihour, imin, isec)
use m_flowtimes
implicit none
double precision, intent(in) :: timsec !< Time in seconds since refdate
integer, intent(out) :: iyear, imonth, iday, ihour, imin, isec !< Actual date, split up in year/month, etc.
integer :: jul, jul0, iyear0, imonth0, iday0
double precision :: tnr, tsec
integer :: ndag
integer, external :: julday
read(refdat(1:4),*) iyear0
read(refdat(5:6),*) imonth0
read(refdat(7:8),*) iday0
jul0 = julday(imonth0,iday0,iyear0)
tnr = timsec / 3600d0
ndag = tnr / 24d0
call caldat(jul0+ndag,imonth,iday,iyear)
tsec = timsec - ndag*24d0*3600d0
ihour = tsec/3600d0
imin = (tsec - ihour*3600d0)/60d0
isec = (tsec - ihour*3600d0 - imin*60d0)
end subroutine datetime_from_refdat
integer function julday(mm,id,iyyy)
implicit none
integer :: igreg
integer :: mm, id, iyyy
integer :: jy, jm, ja
parameter (igreg=15+31*(10+12*1582))
! if (iyyy.eq.0) pause 'there is no year zero.'
if (iyyy.lt.0) iyyy=iyyy+1
if (mm.gt.2) then
jy=iyyy
jm=mm+1
else
jy=iyyy-1
jm=mm+13
endif
julday=int(365.25*jy)+int(30.6001*jm)+id+1720995
if (id+31*(mm+12*iyyy).ge.igreg) then
ja=int(0.01*jy)
julday=julday+2-ja+int(0.25*ja)
endif
return
end function julday
subroutine caldat(julian,mm,id,iyyy)
implicit none
integer :: julian,mm,id,iyyy
integer :: igreg
parameter (igreg=2299161)
integer :: jalpha, ja, jb, jc, jd, je
if(julian.ge.igreg)then
jalpha=int(((julian-1867216)-0.25)/36524.25)
ja=julian+1+jalpha-int(0.25*jalpha)
else
ja=julian
endif
jb=ja+1524
jc=int(6680.+((jb-2439870)-122.1)/365.25)
jd=365*jc+int(0.25*jc)
je=int((jb-jd)/30.6001)
id=jb-jd-int(30.6001*je)
mm=je-1
if(mm.gt.12)mm=mm-12
iyyy=jc-4715
if(mm.gt.2)iyyy=iyyy-1
if(iyyy.le.0)iyyy=iyyy-1
return
end subroutine caldat
subroutine getnumknuml(k,L)
use m_netw
implicit none
integer :: k
integer :: L
k = NUMK
L = NUML
end subroutine getnumknuml
subroutine iadvecini()
use m_flowgeom
use m_flow
use unstruc_messages
implicit none
integer :: L, jado
jado = 0
if (jado == 1) then
if (cflmx > 0.9d0 ) then
if (iadvec == 3) then
iadvec = 5
else if (iadvec == 4) then
iadvec = 6
else
iadvec = 5
endif
call mess(LEVEL_INFO, 'CFLMax > 0.9, Advectype switched to semi implicit Piaczek&Williams ')
else if (cflmx < 0.71d0) then
if (iadvec == 5) then
iadvec = 3
call mess(LEVEL_INFO, 'CFLMax < 0.71 Advectype switched to explicit ')
else if (iadvec == 6) then
iadvec = 4
call mess(LEVEL_INFO, 'CFLMax < 0.71 Advectype switched to explicit ')
endif
endif
endif
if (kmx > 0) iadvec1D = iadvec ! for now, same if 3D
do L = 1,lnx
if (iadv(L) .ne. -1) then
iadv(L) = iadvec
if (L <= Lnx1D) then
if ( iadvec .ne. 0) iadv(L) = iadvec1D ! voorlopig altijd piacz impl 4 voor 1D
endif
endif
enddo
end subroutine iadvecini
subroutine wricells(mout) ! write flow cell surrounding netnodes
use m_netw
use m_flowgeom
implicit none
integer :: mout, n, j
write(mout,'(A,I12)') 'NR of NETNODES = ', numk ! nump = ndx
write(mout,'(A,I12)') 'NR of NETLINKS = ', numL ! nump = ndx
write(mout,'(A,I12)') 'NR of internal FLOWCELLS = ', nump ! nump = ndx
do n = 1,nump
write(mout,'(10I10)') netcell(n)%n, (netcell(n)%NOD(j), j=1,netcell(n)%n )
enddo
end subroutine wricells
subroutine checkcellfile(mout) ! check first two lines for consistency
use m_netw
use m_flowgeom
implicit none
integer :: mout, numkr, numlr, L1
character (len=256) :: rec
read(mout,'(A)',end = 999) rec
L1 = index(rec,'=') + 1
read (rec(L1:), *, err = 888) numkr
if (numkr .ne. numk) then
call doclose(mout) ; mout = 0 ; return
endif
read(mout,'(A)',end = 999) rec
L1 = index(rec,'=') + 1
read (rec(L1:), *, err = 777) numlr
if (numLr .ne. numL) then
call doclose(mout) ; mout = 0 ; return
endif
return
999 call eoferror(mout)
888 call qnreaderror('trying to read nr of net nodes but getting',rec,mout)
777 call qnreaderror('trying to read nr of net links but getting',rec,mout)
end subroutine checkcellfile
subroutine flow_geominit(iphase) ! initialise flow geometry
use m_netw
use m_flowgeom
use unstruc_model
use m_flowexternalforcings
use m_physcoef
use m_flowparameters
use m_sferic
use m_missing
use m_alloc
use unstruc_files, only : basename
use m_orthosettings
use m_xbeach_data, only: swave, Lwave
use m_heatfluxes
use unstruc_boundaries
use m_partitioninfo
implicit none
integer, intent(in) :: iphase ! phase in geominit, 0 (all), 1 (first) or 2 (second)
character(len=100) :: fnam
! locals
integer :: m,n,k,k1,k2,k3,k4,L,Lf,LL,LLL,ierr,i12,nn,ja,kh, numswap, Li, n12, kk, La
integer :: n1, n2, n1a, n2a, jaslopes, ja1D, ka, kb
integer :: mcel ! unit nr Cells And Links file
integer :: jarcinfo = 1
integer :: makecelfile, nc1, nc2, nex
double precision :: zzz, sig ! for bottom level help
double precision :: dbdistance ! double distance function
double precision :: dxn1e ! node 1 - edge distance
double precision :: dxn2e ! node 2 - edge distance
double precision :: x12, y12 ! link center coordinates
double precision :: x34, y34 ! face center coordinates
double precision :: rn,rt ! for link L, normal and tangent base vectors
double precision :: rnl,rtl ! for other links LL, normal and tangent base vectors
double precision :: fi,fix,fiy ! weight factor inverse area (m2)
double precision :: fil ! distance center to edge times edge width (m2)
double precision :: si, prodin ! sign to make all links either incoming or outgoing, see down
double precision :: ortho, avortho ! inner product of link and face
double precision :: af, csza ! only for subr readyy
double precision :: askew, aflat, triskew,triflat, bla, xza, yza, xx(6), yy(6), zz(2) ! for skewness
logical :: jawel ! filecheck
logical :: isbadlink ! Bad link (e.g. too short)
character(len=5) :: txt
integer :: nw, L1, L2, LLA , nw11 ! wall stuff
integer :: icn ! corner stuff
integer :: kk1,kk2,kk3 , mout ! banf stuff
double precision :: dlength, dlenmx
double precision :: dxx, dyy, rrr, cs, sn, dis, c11, c22, c12, xn, yn, xt, yt, rl, sf, hdx, alfa, dxlim, dxlink
double precision :: atpf_org, circumormasscenter_org
integer :: itatp_org, jaend ! , jarerun=0
double precision, allocatable :: banh(:) , rr(:) ! temp
integer , allocatable :: nbanh(:,:) , nr(:) ! temp
double precision, external :: getdx, getdy, cosphiu, getdxofconnectedkcu1
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
if (numk <= 2 .or. numl <= 1 ) return ! only do this for sufficient network
call readyy ('geominit',0d0)
if ( iphase.eq.2 ) then
! skip to start of second phase
goto 9002
end if
call inisferic() ! initialise spherical parameters
do k = 1,numk
if (kc(k) .ne. 0) kc(k) = 1 ! all active grid nodes are now kc = 1 : only to cure old net files
enddo
call findcells(0) ! shortest walks in network (0 means: look for all shapes, tris, quads, pentas, hexas)
call delete_drypoints_from_netgeom()
call find1dcells()
! if (makeorthocenters .gt. 0 .and. jglobe == 0) then
if (makeorthocenters .gt. 0) then
call make_orthocenters(0.5d-2,makeorthocenters)
endif
call thindams_on_netgeom() ! Convert thin dam-type cross sections to real thin dams in network kn.
! AvD: NOTE: We could also place this cosphiunetcheck *after* the nsmalllink
! check (see some blocks below). But then again based on flow links. Such
! that too small flow link lengths do *not* lead to large cosphiunet values. (TODO?)
call cosphiunetcheck(1) ! Check for bad orthogonality on netlinks
if (nlinkbadortho > 0) then
call checknetwork() ! If badortho, check entire network for net link crossings.
lnx = 0
ndx = 0
return
end if
! move partition domain ghostcells back in array
! call partition_arrange_ghostcells(numpi,nump1d2di)
NDX2D = NUMP ! NR OF 2d CELLS=NUMP
NDX = NUMP1d2d ! NR OF 1d and 2d CELLS, = ndxi
LNX1D = NUML1D
! so after this loop the only points with kc = 1 are 1D points
call readyy ('geominit-FINDLINKS',0.1d0)
! Renumber (internal) flow nodes.
! Based on link data in lne (ln not yet available), which is almost
! correct, except for the links that will be eliminated if distance
! between circumcenters is very small.
!if (jased > 0) jarenumber = 0
if (jarenumber == 1 .and. nump > 0) then
call renumberFlowNodes()
end if
do n = 1,nump
do m = 1,netcell(n)%n
k = netcell(n)%NOD(m)
kc(k) = 2 ! all corners of cells are now 2, 1D nodes are still 1
enddo
enddo
! TODO add elemnode and flowelemnode here...
call findexternalboundarypoints() ! total nr of closed boundaries to be opened
ndxi = NDX ! total nr of 2D cellS (tris, quads, pentas and hexas) plus 1D cells
ndx = ndxi + numbnp ! add open boundaries
if ( allocated(kcs) ) then
deallocate ( nd, bl, bai, kcs, aif) ! and allocate geometry related node arrays
endif
allocate ( nd(ndx), bl(ndx), bai(ndx), kcs(ndx), aif(ndx) , stat = ierr )
call aerr('nd(ndx), bl(ndx), bai(ndx), kcs(ndx), aif(ndx)', ierr, 8*ndx ) ; kcs = 1 ; aif = 1d0
bl = zkuni
if ( allocated (kfs) ) deallocate(kfs)
if ( allocated (kfst0) ) deallocate(kfst0)
allocate(kfs(ndx)) ; kfs = 0
allocate(kfst0(ndx)) ; kfst0 = 0 ! to be overridden by the actual kfs in the first timestep of the fourier analysis window
! Reallocate circumcenters with extra space for 1D nodes, but keep existing 2D data.
call realloc(xz , ndx)
call realloc(yz , ndx)
call realloc(xzw, ndx)
call realloc(yzw, ndx)
call realloc(ba , ndx); ba = 0d0
do k = 1,ndx
nd(k)%lnx = 0
enddo
M = max(ndx2d/100, 1)
sarea = 0d0
!jacenterinside = 1
do n = 1,ndx2d ! get cell center coordinates 2D
kcs(n) = 2
if (mod(n,M) == 0) then
af = 0.2d0 + 0.6d0*dble(n)/dble(ndx2d)
call readyy('geominit-cell areas ba',af)
endif
! Cell circumcenters for ndx2d were already determined in findcells.
call getcellsurface(n, ba(n), xzw(n), yzw(n) )
sarea = sarea + ba(n)
call allocateandset2Dnodexyarrays( n ) ! only for plotting...
enddo
! jacenterinside = 0
fwind = (5d6 / max(sarea,1d4) )**0.05d0 ! Only for jatem == 3, excess model.
DO L = 1, NUML1D ! get cell center coordinates 1D
IF ( KN(3,L) == 1 ) THEN
K1 = KN(1,L) ; K2 = KN(2,L)
nc1 = lne(1,L) ; nc2 = lne(2,L)
N1 = IABS(NC1) ; N2 = IABS(NC2)
if (nc1 < 0 ) then
xz(N1) = xk(k1) ; yz(N1) = yk(k1); BL(N1) = ZK(K1); xzw(n1) = xz(n1) ; yzw(n1) = yz(n1)
!allocate ( nd(n1)%nod(1), stat=ierr ) ! Store original net node with this flow node
!call aerr('nd(n1)%nod(1)', ierr, 1)
!nd(n1)%nod(1) = k1
endif
if (nc2 <0 ) then
xz(n2) = xk(k2) ; yz(n2) = yk(k2); BL(N2) = ZK(K2) ; xzw(n2) = xz(n2) ; yzw(n2) = yz(n2)
!allocate ( nd(n2)%nod(1), stat=ierr )
!call aerr('nd(n2)%nod(1)', ierr, 1)
!nd(n2)%nod(1) = k2
endif
endif
enddo
lnxi = 0
lnx1D = 0
nlinktoosmall = 0
do L = 1,numl ! count nr of edges that connect cells, ie. have nd1 and nd2
n1 = iabs(lne(1,L)) ; n2 = iabs(lne(2,L))
if (n1 .ne. 0 .and. n2 .ne. 0 .and. KN(3,L) /= 0) then ! so that you know the nr of lins to be allocated
isbadlink = .false.
! Check on too short flow links. Only for 2D. 1D is always considered 'good'.
if (KN(3,L) == 2) then
dxlim = 0.9d0*removesmalllinkstrsh*0.5d0*(sqrt(ba(n1)) + sqrt(ba(n2)))
dxlink = dbdistance(xz(n1), yz(n1), xz(n2), yz(n2) )
if (dxlink < dxlim) then
isbadlink = .true.
end if
end if
if (.not. isbadlink) then
lnxi = lnxi + 1 ! prevents connection between overlying identical elements
if (KN(3,L) == 1 .or. kn(3,L) == 3) then ! Also recount 1D flow links (in case some are
lnx1D = lnx1D+1 ! thrown away by this distance check)
end if
else
nlinktoosmall = nlinktoosmall + 1
if (nlinkbadortho+nlinktoosmall > size(linkbadqual)) then
call realloc(linkbadqual, ceiling(1.2*nlinkbadortho+nlinktoosmall))
end if
linkbadqual(nlinkbadortho+nlinktoosmall) = L
lne(1,L) = 0 ; lne(2,L) = 0 ; LNN(L) = 0
endif
else
continue
endif
enddo
if (nlinktoosmall > 0) then
write (txt,'(i5)') nlinktoosmall
call qnerror(txt//' small flow links discarded. Run remove small flow links or increase trhs.', ' ', ' ')
NDRAW(2)=5 !< Automatically set 'Display > Network + crossing/quality checks'
end if
if (lnxi == 0 .and. numbnp.eq.0 ) return
lnx = lnxi + numbnp ! add open boundary points
call readyy ('geominit-NODELINKS ',0.5d0)
if (allocated (ln) ) deallocate(ln,lncn,bob,dx,dxi,wu,wui,kcu,csu,snu,acl,iadv,teta)
if (allocated(ibot)) deallocate(ibot)
allocate ( ln (2,lnx) , stat=ierr )
call aerr( 'ln (2,lnx)', ierr, 2*lnx)
allocate ( lncn (2,lnx) , stat=ierr )
call aerr( 'lncn (2,lnx)', ierr, 2*lnx)
allocate ( bob (2,lnx) , stat=ierr )
call aerr( 'bob (2,lnx)', ierr, 2*lnx)
allocate ( dx ( lnx) , stat=ierr )
call aerr( 'dx ( lnx)', ierr, lnx )
allocate ( dxi ( lnx) , stat=ierr )
call aerr( 'dxi ( lnx)', ierr, lnx )
allocate ( wu ( lnx) , stat=ierr )
call aerr( 'wu ( lnx)', ierr, lnx )
allocate ( wui ( lnx) , stat=ierr )
call aerr( 'wui ( lnx)', ierr, lnx )
allocate ( kcu ( lnx) , stat=ierr ); kcu = 0
call aerr( 'kcu ( lnx)', ierr, lnx )
allocate ( csu ( lnx) , stat=ierr )
call aerr( 'csu ( lnx)', ierr, lnx )
allocate ( snu ( lnx) , stat=ierr )
call aerr( 'snu ( lnx)', ierr, lnx )
allocate ( acl ( lnx) , stat=ierr )
call aerr( 'acl ( lnx)', ierr, lnx )
allocate ( acn (2,lnx) , stat=ierr ) ! will be deallocated after cornerweights
call aerr( 'acn (2,lnx)', ierr, lnx )
allocate ( iadv (lnx) , stat= ierr); iadv = 0
call aerr( 'iadv (lnx)', ierr, lnx )
allocate ( teta (lnx) , stat= ierr); teta = 0
call aerr( 'teta (lnx)', ierr, lnx )
allocate ( ibot (lnx) , stat= ierr); ibot = 0
call aerr( 'ibot (lnx)', ierr, lnx )
if (allocated(xu) ) deallocate(xu,yu,blu)
allocate ( xu(lnx), yu(lnx) , blu(lnx) , stat = ierr)
call aerr('xu(lnx), yu(lnx) , blu(lnx)', ierr, 3*lnx) ; blu = zkuni
if (allocated (ln2lne) ) deallocate ( ln2lne, lne2ln )
nex = max(lnx,numl)
allocate ( ln2lne (nex) , stat=ierr ) ! local array
call aerr( 'ln2lne (nex)', ierr, nex ); ln2lne = 0
allocate ( lne2ln (nex) , stat=ierr ) ! local array
call aerr( 'lne2ln (nex)', ierr, nex ); lne2ln = 0
call readyy ('geominit',0.86d0)
Lf = 0
do L = 1,numl ! again count nr of edges and fill in links
n1 = lne(1,L) ; n2 = lne(2,L)
n1a = iabs(n1) ; n2a = iabs(n2)
! if (n1 .ne. 0 .and. n2 .ne. 0) then ! L=net, Lf=flow
if (n1 .ne. 0 .and. n2 .ne. 0 .and. KN(3,L) /= 0) then ! L=net, Lf=flow
Lf = Lf + 1
ln(1,LF) = n1a
ln(2,LF) = n2a
ln2lne(LF) = L
lne2ln(L) = LF
if (kn(3,L) == 1) then
k1 = kn(1,L) ; k2 = kn(2,L)
jaend = 0
if (nmk(k1) == 1 .or. nmk(k2) == 1) then
jaend = 1
endif
if (jaend == 1 .and. n1a > ndx2d .and. n2a <= ndx2d .or. & ! 1D2D link
jaend == 1 .and. n2a > ndx2d .and. n1a <= ndx2d ) then
kcu(Lf) = 4
nc2 = n2a
if (n1a <= ndx2d) then
nc2 = n1a
endif
call WHICH2DNETLINKWASCROSSED(nc2,k1,k2,LL ) ! TEMP STORE CROSSED 2d NETLINK IN LC
ln2lne(LF) = LL ! refer back to crossed 2D netlink instead of to 1D netlink
else ! 1D link
kcu(Lf) = 1
endif
else if (kn(3,L) == 3) then
kcu(Lf) = 3
if (n1a <= ndx2d) then
kcs(n1a) = 21
endif
if (n2a <= ndx2d) then
kcs(n2a) = 21
endif
else if (kn(3,L) == 2) then ! 2D link
kcu(Lf) = 2
endif
else if (n1 == 0) then ! if negative, refer back to attached node
lne2ln(L) = -n2
else if (n2 == 0) then
lne2ln(L) = -n1
endif
enddo
call setbathymetryfromextfile() ! set bl bathymetry if specified through file, so ibedlevtype must be 1
call addexternalboundarypoints() ! add links due to open boundaries
numswap = 0
do L = 1,lnx ! for all 2d links, check positivity
k1 = ln(1,L) ! o---4---o 1,2: flow nodes, 3,4: net nodes
k2 = ln(2,L) ! | 1 | 2 | L: 1--2 Ln=ln2lne(L): 3--4
k3 = kn(1,ln2lne(L)) ! o---3---o lncn(:,L) = 3--4, or 4--3 if
k4 = kn(2,ln2lne(L)) ! ||3--4 X 1--2|| < 0,
! i.e., flux is 'to the right' through net link 3--4.
if (abs(kcu(L)) == 2) then
call normalin(xz(k1), yz(k1), xz(k2), yz(k2), rnl, rtl) ! in pos L direction
call normalin(xk(k3), yk(k3), xk(k4), yk(k4), rn , rt ) ! edge
if (rnl*rt - rtl*rn < 0) then ! checking/ensuring positive local axis orientation
kh = k4
k4 = k3
k3 = kh
numswap = numswap + 1
endif ! indeed, now this may occur
lncn(1,L) = k3 ! used in eddy visc terms
lncn(2,L) = k4
else if ( kcu(L) == 1 ) then ! keep natural reference
lncn(1,L) = k3
lncn(2,L) = k4
else if ( kcu(L) == -1 ) then ! refer twice to last netnode
if (nmk(k3) == 1) then
lncn(1,L) = k3
lncn(2,L) = k3
else if (nmk(k4) == 1) then
lncn(1,L) = k4
lncn(2,L) = k4
endif
else if ( kcu(L) == 3 .or. kcu(L) == 4 ) then ! 1D2D, inherit 2D keep natural reference
lncn(1,L) = k3
lncn(2,L) = k4
endif
enddo
call readyy ('geominit',0.88d0)
do L = 1,lnx ! for all links, count nr of links attached to a node
k1 = ln(1,L)
nd(k1)%lnx = nd(k1)%lnx + 1
k2 = ln(2,L)
nd(k2)%lnx = nd(k2)%lnx + 1
enddo
call readyy ('geominit',0.90d0)
do k = 1,ndx ! for all nodes, allocate linknrs
! GD: memory leak
! if(allocated(nd(k)%ln)) deallocate(nd(k)%ln)
allocate ( nd(k)%ln ( nd(k)%lnx ) ,stat=ierr)
call aerr('nd(k)%ln ( nd(k)%lnx',ierr, nd(k)%lnx )
nd(k)%ln = 0 ! set to zero for recount
nd(k)%lnx = 0
enddo
do L = 1,lnx ! for all links, recount nr of links attached to a node
k1 = ln(1,L)
nd(k1)%lnx = nd(k1)%lnx + 1
nd(k1)%ln(nd(k1)%lnx) = - L ! outflowing, negative indexnr
k2 = ln(2,L)
nd(k2)%lnx = nd(k2)%lnx + 1
nd(k2)%ln(nd(k2)%lnx) = L ! inflowing, positive indexnr
enddo
! sort flowlinks
call sort_flowlinks_ccw()
! start of second phase
9002 continue
call readyy ('geominit-METRICS ',0.92d0)
if ( allocated(cn) ) deallocate(cn,ucnx,ucny,ban) ! vort
allocate ( cn (numk) , stat = ierr) ! some cell corner related stuff
call aerr(' cn (numk)', ierr, numk)
allocate ( ucnx(numk) , stat = ierr)
call aerr('ucnx(numk)', ierr, numk)
allocate ( ucny(numk) , stat = ierr)
call aerr('ucny(numk)', ierr, numk)
allocate ( ban (numk) , stat=ierr ) ! for keeps, netnode area
call aerr('ban (numk)', ierr, numk )
cn (1:numk)%lnx = 0
cn (1:numk)%nwx = 0
ucnx(1:numk) = 0
ucny(1:numk) = 0
ban (1:numk) = 0
do L = 1,lnx ! for all links, set dx and coordinates
k1 = ln(1,L)
k2 = ln(2,L)
k3 = lncn(1,L)
k4 = lncn(2,L)
dx(L) = dbdistance ( xz(k1), yz(k1), xz(k2), yz(k2) ) ! set link length
ja1D = 0
if (kcu(L) == 1 .or. kcu(L) == -1 .or. kcu(L) == 4) then
ja1D = 1
endif
if (kcu(L) == 4) then ! take dx projected on 2D normal
call normalout(xk(k3), yk(k3), xk(k4), yk(k4), xn, yn)
call normalin (xz(k1), yz(k1), xz(k2), yz(k2), xt, yt)
if ( xn*xt + yn*yt < 0d0) then
lncn(1,L) = k4
lncn(2,L) = k3
endif
dx(L) = dx(L) * abs( xn*xt + yn*yt )
else if (kcu(L) == 3) then ! some averaged 2D length
k = 0
if (kcs(k1) == 21) k = k1
if (kcs(k2) == 21) k = k2
if (k == 0) then
call qnerror('1d2d link kcu=3 not connected to kcs=21 ',' ',' ')
else
dx(L) = 0.5d0*sqrt(ba(k))
endif
endif
if (ja1D == 1) then
hdx = 0.5d0*dx(L)
xu(L) = 0.3d0*xz(k1) + 0.7d0*xz(k2)
yu(L) = 0.3d0*yz(k1) + 0.7d0*yz(k2)
else
xu(L) = 0.5d0*( xk(k3) + xk(k4) )
yu(L) = 0.5d0*( yk(k3) + yk(k4) )
endif
! for partition_init: compute temporary csu, snu (will be overwritten in phase 2), based on xzw, yzw (instead of xz, yz)
if (kcu(L) .ne. 4) then
call normalin (xzw(k1), yzw(k1), xzw(k2), yzw(k2), rn, rt) ! = normalin (k1,k2)
else
call normalout(xk(k3), yk(k3), xk(k4), yk(k4), rn, rt) ! 1D2D
endif
csu(L) = rn ; snu(L) = rt
enddo
! end of first phase
if ( iphase.eq.1 ) then
return
end if
IF (ALLOCATED (prof1D) ) deallocate( prof1D)
allocate ( prof1D(3,lnx1D) , stat= ierr)
call aerr ('prof1D(3,lnx1D)', ierr, 2*lnx1D)
IF (ALLOCATED (Lbnd1D) ) deallocate( Lbnd1D)
allocate ( Lbnd1D(lnxi+1:lnx) , stat= ierr) ; Lbnd1D = 0
call aerr ('Lbnd1D(lnxi+1:lnx)', ierr, lnx-lnxi+1)
call setprofs1D() ! get prof1D by reading and interpolating profiles
do L = 1,lnx ! for all links, set link width
k1 = ln(1,L)
k2 = ln(2,L)
k3 = lncn(1,L)
k4 = lncn(2,L)
if (kcu(L) == 1 .or. kcu(L) == -1 .or. kcu(L) == 3 .or. kcu(L) == 4) then
LL = L
if ( kcu(L) == -1) then ! 1D boundary link, find attached regular link
if (iabs(nd(k2)%ln(1)) == L) then
LBND1D(L) = iabs ( nd(k2)%ln(2) )
endif
if (iabs(nd(k2)%ln(2)) == L) then
LBND1D(L) = iabs ( nd(k2)%ln(1) ) ! and store in LBND1D
endif
LL = LBND1D(L) ! LL refers to prof1D
endif
if (kcu(L) == 4) then ! 1D2D inherits 2D
wu(L) = dbdistance ( xk(k3), yk(k3), xk(k4), yk(k4) ) ! set 2D link width
else if (kcu(L) == 3) then ! 1D2D inherits 2D
wu(L) = getdxofconnectedkcu1(L) ! dbdistance ( xk(k3), yk(k3), xk(k4), yk(k4) ) ! set 2D link width
else
IF ( prof1D(1,LL) > 0) THEN
wu(L) = prof1d(1,LL) ! todo, wu1DUNI from max width of profile interpolations
ELSE
KA = -PROF1D(1,LL); KB = -PROF1D(2,LL); ALFA = PROF1D(3,LL)
WU(L) = (1D0-ALFA)*PROFILES1D(KA)%WIDTH + ALFA*PROFILES1D(KB)%WIDTH
ENDIF
endif
hdx = 0.5d0*dx(L)
if (k1 > ndx2d) ba(k1) = ba(k1) + hdx*wu(L) ! todo, on 1d2d nodes, choose appropriate wu1DUNI = min ( wu1DUNI, intersected 2D face)
if (k2 > ndx2d) ba(k2) = ba(k2) + hdx*wu(L)
else
wu(L) = dbdistance ( xk(k3), yk(k3), xk(k4), yk(k4) ) ! set 2D link width
endif
enddo
do L = lnxi+1,Lnx
k1 = ln(1,L) ; k2 = ln(2,L)
ba(k1) = ba(k2) ! set bnd ba to that of inside point
enddo
k = 0 ! count MAX nr of 1D endpoints, dir zijn dead ends
do L = 1,lnx
if ( kcu(L) == 1) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (nd(k1)%lnx == 1) then
k = k + 1
endif
if (nd(k2)%lnx == 1) then
k = k + 1
endif
endif
enddo
mx1Dend = k
if (allocated(n1Dend) ) deallocate (n1Dend)
allocate ( n1Dend(mx1Dend) , stat = ierr ) ; n1Dend = 0
call aerr('n1Dend(mx1Dend)', ierr, mx1Dend)
k = 0
do L = 1,lnx
if ( kcu(L) == 1) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (nd(k1)%lnx == 1) then
k = k + 1
n1Dend(k) = k1
endif
if (nd(k2)%lnx == 1) then
k = k + 1
n1Dend(k) = k2
endif
endif
enddo
mx1Dend = k
do k = 1, mx1Dend
k1 = n1Dend(k)
ba(k1) = 2D0*ba(k1)
enddo
! fraction of dist(nd1->edge) to link lenght dx
call readyy ('geominit',0.94d0)
acl =0.5d0 ; acn = 0.5d0 ! for pipes
do L = 1,lnx ! for all links,
k1 = ln(1,L)
k2 = ln(2,L)
k3 = lncn(1,L)
k4 = lncn(2,L)
if (iabs(kcu(L)) == 2 .or. iabs(kcu(L)) == 4) then ! override for 2D
! x34 = 0.5d0*( xk(k3) + xk(k4) )
! y34 = 0.5d0*( yk(k3) + yk(k4) )
! dxn1e = dbdistance(xz(k1),yz(k1),x34,y34) !
! dxn2e = dbdistance(xz(k2),yz(k2),x34,y34) !
CALL DLINEDIS2(xz(k1), yz(k1), xk(k3), yk(k3), xk(k4), yk(k4), JA, dxn1e, XN, YN, RL)
CALL DLINEDIS2(xz(k2), yz(k2), xk(k3), yk(k3), xk(k4), yk(k4), JA, dxn2e, XN, YN, RL)
if ( abs(dxn1e+dxn2e).lt.1d-15 ) then
dxn1e = 5d-16
dxn2e = 5d-16
end if
acl(L) = dxn1e / (dxn1e + dxn2e) ! weight factor of nd1
! SPvdP: the following may cause problems for periodic sperical coordinates
x12 = 0.5d0*( xz(k1) + xz(k2) )
y12 = 0.5d0*( yz(k1) + yz(k2) )
dxn1e = dbdistance(xk(k3),yk(k3),x12,y12) !
dxn2e = dbdistance(xk(k4),yk(k4),x12,y12) !
acn(1,L) = dxn1e / (dxn1e + dxn2e) ! weight factor of nd1
acn(2,L) = dxn2e / (dxn1e + dxn2e) ! weight factor of nd2, sum = 1d0 !
endif
if (kcu(L) .ne. 4) then
call normalin (xz(k1), yz(k1), xz(k2), yz(k2), rn, rt) ! = normalin (k1,k2)
else
call normalout(xk(k3), yk(k3), xk(k4), yk(k4), rn, rt) ! 1D2D
endif
csu(L) = rn ; snu(L) = rt !
enddo
do L = 1,lnx
! the max func after setting dx1 fraction
dxi(L) = 1d0/dx(L) ! dxi to minimise nr. of divisions
if (wu(L) > 0) then
wui(L) = 1d0/wu(L)
else
call qnerror ('wu=0',' ',' ')
endif
enddo
do n = 1,ndx
bai(n) = 1d0/ba(n) ! inbitially, ba based on 'max wet envelopes', take bai used in linktocentreweights
enddo
n12 = 4 ; fnam = '*.cut'
! call message ('cutcell call 4',' ',' ')
if (allocated (kfs)) deallocate(kfs)
allocate (kfs(ndx)) ; kfs = 0
call cutcell_list(n12,'*.cut',5) ! trim(fnam)) ! CUT CELLS, N12 = 4, flag cells to be cut in kfs, prior to setlinktocenter/CORNERweights calls below
call setlinktocenterweights()
call setlinktocornerweights()
do n = ndx2D+1, ndxi
call allocateandset1Dnodexyarrays(n) ! na csu en snu
enddo
call readyy ('geominit',0.98d0)
call iadvecini() ! set desired advection for non (-1) links
avortho = 0d0
do L = lnx1D+1,lnx ! for all links, check link orthogonality
if (abs(kcu(L)) == 1) cycle
k1 = ln(1,L)
k2 = ln(2,L)
k3 = lncn(1,L)
k4 = lncn(2,L)
call normalin(xz(k1), yz(k1), xz(k2), yz(k2), rnl, rtl) ! in pos LL direction
call normalin(xk(k3), yk(k3), xk(k4), yk(k4), rn , rt ) ! = normalin (k1,k2)
ortho = rnl*rn + rtl*rt
avortho = avortho + ortho
enddo
avortho = avortho / lnx
n12 = 5 ; fnam = '*.cut'
! call message ('cutcell call 5',' ',' ')
call cutcell_list(n12,'*.cut',5 ) ! trim(fnam)) ! CUT CELLS, N12 = 5, WU AND BA ADAPTATION
deallocate(kfs) ; allocate(kfs(ndx))
call readyy ('geominit',-1d0)
if (isimplefixedweirs == 0) call fixedweirs_on_flowgeom() ! Impose fixed weirs paths on all crossed flow links.
call setbobs()
!-------------------------------------------------- CLOSED WALL (STRESS) RELATED -----------------------------------------------
! add some closed boundary administration for stress terms
nw = 0
do L = lnx1D+1,numl ! first count nr of closed walls
if (lne2ln(L) < 0) then
nw = nw + 1
endif
enddo
if ( allocated (walls) ) deallocate(walls)
allocate ( walls(17,nw) , stat = ierr ) ; walls = 0
call aerr('walls(17,nw)', ierr, nw*16 )
nw = 0 ! number of closed walls
do L = 1, numl
if (lne2ln(L) < 0) then
nw = nw + 1
k1 = abs(lne2ln(L))
k3 = kn(1,L)
k4 = kn(2,L)
walls(1,nw) = k1 ! waterlevel point on the inside
walls(2,nw) = k3 ! first wall corner
walls(3,nw) = k4 ! second wall corner
call duitpl(xzw(k1), yzw(k1), xk(k3), yk(k3), xzw(k1), yzw(k1), xk(k4), yk(k4), sig)
call dlinedis(xzw(k1), yzw(k1), xk(k3), yk(k3), xk(k4), yk(k4),JA,DIS,XN,YN)
dxx = getdx( xk(k3), yk(k3), xk(k4), yk(k4) ) ! xk(k4) - xk(k3)
dyy = getdy( xk(k3), yk(k3), xk(k4), yk(k4) ) ! yk(k4) - yk(k3)
rrr = sqrt(dxx*dxx + dyy*dyy)
cs = 0 ; sn = 0
if (rrr .ne. 0) then
cs = sig*dxx/rrr
sn = sig*dyy/rrr
endif
if (wall_z0 > 0) then
sf = vonkar/log(c9of1 + dis/wall_z0)
! us = utangential, un = unormal
! us = ucx*cs + ucy*sn, ustar = sf*us
walls(6,nw) = sf ! sux = -cs*ustar
endif
walls(7,nw) = cs ! suy = -sn*ustar ( )
walls(8,nw) = sn ! sinus ( )
walls(9,nw) = rrr ! length of the wall (m)
L1 = 0 ; L2= 0
do LL = 1,nd(k1)%lnx
LLL = nd(k1)%ln(LL) ; LLA = iabs(LLL)
if (lncn(1,LLA) == k3 .or. lncn(2,LLA) == k3) then
L1 = LLA
walls(4,nw) = L1 ! link 1 to which this wall contributes
if (LLL < 0) then ! outflowing link: use alfa1
walls(10,nw) = acl(L1)
else
walls(10,nw) = (1d0-acl(L1))
endif
endif
if (lncn(1,LLA) == k4 .or. lncn(2,LLA) == k4) then
L2 = LLA
walls(5,nw) = L2 ! link 2 to which this wall contributes
if (LLL < 0) then
walls(11,nw) = acl(L2)
else
walls(11,nw) = (1d0-acl(L2))
endif
endif
enddo
walls(12,nw) = 0.5d0*dis ! half of distance circumcentre to the wall (m)
walls(13,nw) = bl(k1) ! cell bottom level (m)
walls(14,nw) = abs(zk(k4)-zk(k3)) ! bottom level difference (m)
walls(15,nw) = walls(14,nw) / walls(9,nw) ! bottom level inclination()
walls(17,nw) = walls(12,nw) * walls(9,nw)
endif
enddo
mxwalls = nw
!-------------------------------------------------- CELL CORNER RELATED -----------------------------------------------
do L = lnx1D+1,lnx ! for all links,
k3 = lncn(1,L)
k4 = lncn(2,L)
cn(k3)%lnx = cn(k3)%lnx + 1 ! count nr of links attached to a cell corner
cn(k4)%lnx = cn(k4)%lnx + 1
enddo
do k = 1,numk
m = cn(k)%lnx
if (m > 0) then
! GD: memory leak
! if(allocated(cn(k)%ln)) deallocate(cn(k)%ln)
allocate ( cn(k)%ln (m) , stat = ierr ) ! allocate nr of links attached to a cell corner
call aerr('cn(k)%ln (m)', ierr, m )
cn(k)%lnx = 0
endif
enddo
do L = lnx1D+1,lnx ! for all links,
k3 = lncn(1,L)
k4 = lncn(2,L)
cn(k3)%lnx = cn(k3)%lnx + 1
m = cn(k3)%lnx
cn(k3)%ln(m) = L ! set attached linknrs
cn(k4)%lnx = cn(k4)%lnx + 1
m = cn(k4)%lnx
cn(k4)%ln(m) = -L ! set attached linknrs
enddo
do nw = 1,mxwalls ! for all closed walls
k3 = walls(2,nw) ! first wall corner
k4 = walls(3,nw) ! first wall corner
cn(k3)%nwx = cn(k3)%nwx + 1 ! count nr of walls attached to a cell corner
cn(k4)%nwx = cn(k4)%nwx + 1
enddo
do k = 1,numk
m = cn(k)%nwx
if (m > 0) then
allocate ( cn(k)%nw (m) , stat = ierr ) ! allocate nr of links attached to a cell corner
call aerr('cn(k)%nw (m)', ierr, m )
cn(k)%nwx = 0
endif
enddo
do nw = 1,mxwalls ! for all closed walls
k3 = walls(2,nw) ! first wall corner
k4 = walls(3,nw) ! first wall corner
cn(k3)%nwx = cn(k3)%nwx + 1 ! count nr of walls attached to a cell corner
m = cn(k3)%nwx
cn(k3)%nw(m) = nw ! set attached wallnrs
cn(k4)%nwx = cn(k4)%nwx + 1 ! count nr of walls attached to a cell corner
m = cn(k4)%nwx
cn(k4)%nw(m) = -nw ! set attached wallnrs
enddo
nwalcnw = 0
do icn = 1,nrcnw ! attach closed walls to closed corners
k = kcnw(icn)
if (cn(k)%nwx == 0) then
m = icn
else
if (cn(k)%nwx > 0) then
nwalcnw(1,icn) = cn(k)%nw(1)
endif
if (cn(k)%nwx > 1) then
nwalcnw(2,icn) = cn(k)%nw(2)
endif
endif
enddo
do icn = 1,nrcnw
sf = 0d0 ; n = 0
if (abs(nwalcnw(1,icn)) > 0) then
sf = walls(6, abs(nwalcnw(1,icn) ) ) ; n = n + 1
endif
if (abs(nwalcnw(2,icn)) > 0) then
sf = walls(6, abs(nwalcnw(2,icn) ) ) + sf ; n = n + 1
endif
if ( sf > 0d0 ) then
sfcnw(icn) = sf / dble(n) ! averaged
endif
enddo
dx = max(dx,dxmin)
dxi = 1d0/dx
do n = 1, ndxi ! after all metrics, maximise ba and dx for better conditioning
if (n > ndx2D) then ! reset ba on strictly 1D nodes, to bamin1D or to specified manhole area's (todo)
ba(n) = max(ba(n), bamin1D)
else
ba(n) = max(ba(n), bamin) ! bai zit in Perot wegingen, die maxen we niet
endif
enddo
do L = lnxi+1,Lnx
ba(ln(1,L)) = ba(ln(2,L)) ! set bnd ba to that of inside point
enddo
if (allocated (banf) ) then
deallocate(banf,nban)
endif
if (nump > 0 .and. Jaconveyance2D > 0) then
mxban = 0
do k = 1,nump
mxban = mxban + netcell(k)%n
enddo
allocate ( banf(mxban) , stat=ierr ) ! for keeps, netnode/flownode subarea
call aerr('banf(mxban)' , ierr, mxban ) ; banf = 0d0
allocate ( nban(4,mxban) , stat=ierr ) ! for keeps, banf admin
call aerr('nban(4,mxban)' , ierr, mxban ) ; nban = 0
allocate ( rr(mxban), nr(mxban) , stat=ierr ) ! for temp
call aerr('rr(mxban), nr(mxban)' , ierr, mxban )
allocate ( banh (mxban) , stat=ierr )
call aerr('banh (mxban)' , ierr, mxban ) ; banh = 0d0
allocate ( nbanh(4,mxban) , stat=ierr )
call aerr('nbanh(4,mxban)' , ierr, mxban ) ; nbanh = 0
ka = 0 ! set netnode/flownode subarea array ban
do k = 1,nump
nn = netcell(k)%n
do kk2 = 1,nn ! walk in netcells
ka = ka + 1 ! subarea nr
kk1 = kk2 - 1 ; if (kk1 < 1 ) kk1 = nn
kk3 = kk2 + 1 ; if (kk3 > nn ) kk3 = 1
K1 = netcell(k)%nod(kk1) ! k1 , k2, k3 subsequent netcell nrs
K2 = netcell(k)%nod(kk2)
K3 = netcell(k)%nod(kk3)
xx(1) = xz(k) ; yy(1) = yz(k)
xx(2) = 0.5d0*( xk(k1)+xk(k2) ) ; yy(2) = 0.5d0*( yk(k1)+yk(k2) )
xx(3) = xk(k2) ; yy(3) = yk(k2)
xx(4) = 0.5d0*( xk(k2)+xk(k3) ) ; yy(4) = 0.5d0*( yk(k2)+yk(k3) )
call dAREAN( XX, YY, 4, banh(ka) , DLENGTH, DLENMX )
nbanh(1,ka) = k2 ! netnode nr
nbanh(2,ka) = k ! flownode nr
rr(ka) = k2
do kk3 = 1, nd(k)%lnx
L = iabs(nd(k)%ln(kk3))
La = iabs(L)
if (lncn(1,La) == k2 .or. lncn(2,La) == k2) then
if (nbanh(3,ka) == 0) then
nbanh(3,ka) = La
else if (nbanh(4,ka) == 0) then
nbanh(4,ka) = La
endif
endif
enddo
enddo
enddo
CALL INDEXX(mxban,rr,nr)
do k = 1, mxban
ka = nr(k)
nban(1,k) = nbanh(1,ka)
nban(2,k) = nbanh(2,ka)
nban(3,k) = nbanh(3,ka)
nban(4,k) = nbanh(4,ka)
banf (k) = banh (ka)
enddo
ban = 0d0
do k = 1, mxban ! netnode area
n = nban(1,k)
ban(n) = ban(n) + banf(k)
enddo
deallocate(banh,nbanh,rr,nr)
endif
if (jaconveyance2D >= 1 ) then ! set link based bed skewness array aifu
! bed skewness is not intended for bedlevel type < 3
if ( ibedlevtyp.lt.3 ) then
call qnerror('bed-level type and conveyance type do not match', ' ', ' ')
else
if (allocated (aifu) ) deallocate(aifu, bz)
allocate ( aifu(lnx), bz(ndx) )
call setaifu()
end if ! if ( ibedlevtyp.lt.3 )
endif
if (jased == 0) then
if (allocated (banf) ) deallocate (banf, nban)
endif
!IF (NDX > 800000) THEN ! TODO: AvD: this breaks takrailinebathy (xk gone)
! CALL DEALLOCNET()
!ENDIF
!JRE
if ( jawave.eq.4 ) then
call xbeach_makethetagrid()
end if
!call newfil(mout,'depthgr.xyz')
!do L = 1,Lnx
! write(mout, *) xu(L), yu(L), abs ( bl(ln(1,L)) - bl(ln(2,L)) ) * dxi(L)
!enddo
!call doclose(mout)
! BEGIN DEBUG
! acl = 0.5d0
! END DEBUG
end subroutine flow_geominit
subroutine setaifu() ! set bed skewness array for roughness
use m_flow
use m_flowgeom
use m_netw
implicit none
integer :: k,L,m,n,k1,k2
double precision :: zu, ai, bi
aifu = 1d0 ; bz = 0d0
do m = 1, mxban ! bz based on netnodes area
k = nban(1,m)
n = nban(2,m)
bz(n) = bz(n) + banf(m)*zk(k)
enddo
bz = bz/ba
do L = lnx1D+1, Lnx ! next, link bed slope
k1 = Ln(1,L) ; k2 = Ln(2,L)
ai = (bob(2,L) - bob(1,L))*wui(L)
if (L > Lnxi) then
zu = 0.5d0*(bob(1,L) + bob(2,L))
bi = (bz(k2) - zu)*dxi(L)/max(eps4, 1d0-acL(L))
else
bi = (bz(k2) - bz(k1))*dxi(L)
endif
if (jaconveyance2D == 1) then
aifu(L) = 1d0 + bi*bi
else
aifu(L) = 1d0 + ai*ai + bi*bi
endif
aifu(L) = sqrt(aifu(L))
enddo
end subroutine setaifu
double precision function getdxofconnectedkcu1(Lf) ! width of connection link has lenght of connected 1D links
use m_flowgeom
use m_flow
use m_netw
implicit none
integer :: Lf, L, LL, k, kk, n, k1, k2
double precision :: wu1
wu1 = 0d0 ; n = 0
!if (kcs(ln(1,L) ) == 21) k = ln(2,L)
!if (kcs(ln(2,L) ) == 21) k = ln(1,L)
!do kk = 1,nd(k)%lnx
! if (kcu(L) == 1) then
! n = n + 1
! LL = iabs( nd(k)%ln(kk) )
! wu1 = wu1 + dx(L)
! endif
! enddo
L = ln2lne(Lf)
k1 = kn(1,L)
k2 = kn(2,L)
if (nmk(k1) == 1) k = k2
if (nmk(k2) == 1) k = k1
do kk = 1, nmk(k)
LL = iabs(nod(k)%lin(kk))
if (kn(3,LL) == 1) then
n = n + 1
wu1 = wu1 + dx(lne2ln(LL))
endif
enddo
if (n > 0) then
wu1 = wu1 / n
endif
getdxofconnectedkcu1 = wu1 ! both 1D sides flood at the same moment, no division by 2
end function getdxofconnectedkcu1
subroutine sortnetlinks()
use m_netw
implicit none
integer, allocatable :: n1(:), in(:), ni(:)
integer :: L1, k, kk, L
if (numL == 0) return
allocate ( n1(numL), in(numL), ni(numL) )
L1 = numl1D+1
do L = L1, numL
n1(L) = lne(1,L)
enddo
call indexxi(numL-L1+1, n1(L1:), IN(L1:) )
do L = 1,numl1D
in(L) = L
enddo
do L = L1, numL
in(L) = in(L) + numL1D
enddo
do L = 1,numL
ni(in(L)) = L
enddo
do L = L1, numL
n1(L) = lne(1,L)
enddo
do L = L1, numL
lne(1,L) = n1(in(L))
enddo
do L = L1, numL
n1(L) = lne(2,L)
enddo
do L = L1, numL
lne(2,L) = n1(in(L))
enddo
do L = L1, numL
n1(L) = kn(1,L)
enddo
do L = L1, numL
kn(1,L) = n1(in(L))
enddo
do L = L1, numL
n1(L) = kn(2,L)
enddo
do L = L1, numL
kn(2,L) = n1(in(L))
enddo
do L = L1, numL
n1(L) = kn(3,L)
enddo
do L = L1, numL
kn(3,L) = n1(in(L))
enddo
do L = L1, numL
n1(L) = lnn(L)
enddo
do L = L1, numL
lnn(L) = n1(in(L))
enddo
do k = 1,numk
do kk = 1,nmk(k)
NOD(K)%LIN(kk) = ni(NOD(K)%LIN(kk))
enddo
enddo
do k = 1,nump
do kk = 1,netcell(k)%n
netcell(K)%LIN(kk) = ni(netcell(K)%LIN(kk))
enddo
enddo
deallocate(n1, in, ni)
end subroutine sortnetlinks
subroutine which2Dnetlinkwascrossed(NC1,K1,K2,L) ! find the crossed 2D link
use m_flowgeom
use m_netw
implicit none
integer :: NC1,K1,K2,LL
integer :: nn,kk,kku,jacros,k3,k4,L
double precision :: SL,SM,XCR,YCR,CRP
LL = 0
nn = NETCELL(nc1)%N
do kk = 1,nn
L = NETCELL(Nc1)%lin(kk)
K3 = kn(1,L)
K4 = kn(2,L)
call CROSS(xk(k1), yk(k1), xk(k2), yk(k2), xk(k3), yk(k3), xk(k4), yk(k4), JACROS,SL,SM,XCR,YCR,CRP)
if (jacros == 1) then
LL = L
return
endif
enddo
end subroutine which2Dnetlinkwascrossed ! TEMP STORE CROSSED 2d LINK IN LC
subroutine setprofs1D()
use m_flowgeom
use m_flow
USE UNSTRUC_MODEL
use m_netw
use m_profiles
USE M_MISSING
use unstruc_messages
use m_partitioninfo
IMPLICIT NONE
integer :: ierr, MINP, LS, L, K, LF, IBR, LL,LA,K1,K2,KA,KB,NRL,NSK, KK, ja, ium
DOUBLE PRECISION :: XL, ZL, ALFA
logical :: jawel
character (len=256) :: fnam
INTEGER, allocatable :: LSAM(:) ! sample K IS ON NET LINK LSAM
INTEGER, allocatable :: NSbr (:) ! nr of profiles on branch
INTEGER :: NSBRMX ! MX NR OF PROFILES ON BRANCH
INTEGER, allocatable :: IDX(:) ! INDEX ARR, SIZE = NSBRMX
INTEGER, allocatable :: KLH(:), KLHH(:) ! INDEX ARR, + SORTED BY IDX
double precision, allocatable :: XLH(:), XLHH(:) ! LENGTH ARR, + SORTED BY IDX
double precision, allocatable :: ZLH(:), ZLHH(:) ! VALUE ARR, + SORTED BY IDX
type tKBSAM !< TEMP
integer, allocatable :: KS (:) !< successive SAMPLE nrs ON BRANCH
end type tKBSAM
TYPE (TKBSAM), dimension(:), ALLOCATABLE :: KBSAM ! ARRAY OF SAMPLES PER BRANCH
double precision, dimension(:), allocatable :: XLLin
double precision, dimension(:), allocatable :: XLsam ! link and sample line distances
double precision, dimension(:), allocatable :: distsam ! distance from sample to link
integer, dimension(:), allocatable :: iconnsam ! globally connected branch number associated with sample
double precision :: dbdistance, XLS, YLS, XLB, DXB, dum
if ( jampi.ne.1 ) then
if (lnx1D == 0) return
end if
if ( lnx1D.gt.0 ) then
prof1D(1,1:lnx1D) = wu1Duni ! prof1d(1,*) > 0 : width or prof1d(1,*) < 0 : ka ref
prof1D(2,1:lnx1D) = hh1Duni ! prof1d(2,*) > 0 : height or prof1d(2,*) < 0 : kb ref
prof1D(3,1:lnx1D) = iproftypuni ! prof1d(3,*) > 0 : ityp or prof1d(3,*) < 0 : alfa tussen a en b
end if
if (iproftypuni .ne. 2 .and. iproftypuni .ne. 3) then
nonlin = 1
endif
if (jaembed1D >= 2) nonlin = 1
if (jaembed1D >= 3) nonlin2D = 1
fnam = trim(md_proflocfile)
inquire(file=trim(fnam) , exist=jawel)
if (jawel) then
call oldfil(minp, fnam )
call readprofilesloc(minp) ! read profloc
call readprofilesdef(ja) ! read profdef
if (ja == 0) then
call qnerror( ' Profs not ok. ', ' ',' ')
return
endif
if (nproflocs > 0) then
CALL SETBRANCH_LC(ium)
if ( jampi.eq.1 ) then
call global_netbranch_numbering()
end if
if (allocated(xllin) ) then
deallocate(xllin)
endif
ierr = 0
allocate ( XLLIN(numL) , stat = ierr)
call aerr('XLLIN(numL)', ierr, numL )
allocate ( XLSAM(Nproflocs) , stat = ierr)
call aerr('XLSAM(Nproflocs) ', ierr, Nproflocs )
allocate ( LSAM(Nproflocs) , stat = ierr)
call aerr('LSAM(Nproflocs) ', ierr, Nproflocs )
if ( jampi.eq.1 ) then
allocate(distsam(Nproflocs), stat=ierr)
call aerr('distsam(Nproflocs)', ierr, Nproflocs)
allocate(iconnsam(Nproflocs), stat=ierr)
call aerr('iconnsam(Nproflocs)', ierr, Nproflocs)
end if
if ( Lnx1D.gt.0 ) then
do ibr = 1,mxnetbr ! SET UP BRANCH DISTANCE COORDINATE
if ( jampi.eq.0 ) then
XLB = 0d0
else
XLB = netbr(ibr)%doff
end if
do LL = 1, netbr(ibr)%NX
L = netbr(ibr)%ln(LL); LA = iabs(L)
if (L > 0) then
k1 = kn(1,La); k2 = kn(2,LA)
else
k2 = kn(1,La); k1 = kn(2,LA)
endif
dxB = dbdistance( xk(k1), yk(k1), xk(k2), yk(k2) )
XLB = XLB + dxB
XLLIN(LA) = xLB
enddo
enddo
DO K = 1,nproflocs ! SET UP BRANCH DISTANCE COORDINATE OF SAMPLE POINTS
if ( jampi.eq.0 ) then
CALL CLOSETO1Dnetlink(Xpr(K),Ypr(K),LS,XLS,YLS,dum)
else
CALL CLOSETO1Dnetlink(Xpr(K),Ypr(K),LS,XLS,YLS,distsam(k))
ibr = LC(LS)
iconnsam(k) = netbr(ibr)%iconn
end if
NRL = NRLB(LS)
K1 = K1BR(NRL)
IF (K1 == KN(1,LS) )THEN ! K1 = FIRST IN BRANCH, K2 = SECOND
K2 = KN(2,LS)
ELSE
K2 = K1
K1 = KN(2,LS)
ENDIF
XLSAM(K) = XLLIN(LS) - DBDISTANCE(XLS,YLS,XK(K2),YK(K2))
LSAM(K) = LS
!DO L = 1,NUML
! IF (LC(L) == LC(LS)) THEN
! LF = LNE2LN(L)
! PROF1D(1,LF) = ZS(K)
! ENDIF
!ENDDO
ENDDO
else
xlsam = 0d0
distsam = 1d99
iconnsam = 0
end if
! parallel: reduce XLSAM and the connected branch numbers
if ( jampi.eq.1 ) then
call reduce_xlsam(Nproflocs, xlsam, distsam, iconnsam)
! else
! write(6,*) (xlsam(k), k=1,Nproflocs)
end if
if ( Lnx1D.gt.0 ) then
do ibr = 1,mxnetbr ! SET UP BRANCH AGAIN, NOW WITH LINK POSITIONS
if ( jampi.eq.0 ) then
XLB = 0d0
else
XLB = netbr(ibr)%doff
end if
do LL = 1, netbr(ibr)%NX
L = netbr(ibr)%ln(LL); LA = iabs(L)
if (L > 0) then
k1 = kn(1,La); k2 = kn(2,LA)
else
k2 = kn(1,La); k1 = kn(2,LA)
endif
dxB = dbdistance( xk(k1), yk(k1), xk(k2), yk(k2) )
XLB = XLB + dxB
XLLIN(LA) = xLB - 0.5D0*DXB
enddo
enddo
ALLOCATE ( NSBR (MXNETBR) , STAT=IERR) ; NSBR = 0
CALL AERR('NSBR (MXNETBR)', IERR, MXNETBR)
ALLOCATE ( KBSAM(MXNETBR) , STAT=IERR)
CALL AERR('KBSAM(MXNETBR)', IERR, MXNETBR)
DO K = 1,Nproflocs ! COUNT NR OF SAMPLES PER BRANCH
L = LSAM(K)
IBR = LC(L)
if ( jampi.eq.0 ) then
NSBR(IBR) = NSBR(IBR) + 1
else
! parallel: add profile to all branches that are in the corresponding connected branch
do ibr=1,mxnetbr
if ( iconnsam(k).eq.netbr(ibr)%iconn ) then
NSBR(IBR) = NSBR(IBR) + 1
end if
end do
end if
ENDDO
DO IBR = 1,MXNETBR ! ALLOC BRANCH SAMPLES BACKREF.
IF (NSBR(IBR) > 0) THEN
ALLOCATE(KBSAM(IBR)%KS(NSBR(IBR) ) )
ENDIF
ENDDO
NSBR = 0; NSBRMX = 0
DO K = 1,Nproflocs ! REFER BACK TO SAMPLES ON BRANCH
L = LSAM(K)
IBR = LC(L)
if ( jampi.eq.0 ) then
NSBR(IBR) = NSBR(IBR) + 1
KBSAM(IBR)%KS(NSBR(IBR)) = K
NSBRMX = MAX( NSBRMX,NSBR(IBR) )
else
do ibr=1,mxnetbr
if ( iconnsam(k).eq.netbr(ibr)%iconn ) then
NSBR(IBR) = NSBR(IBR) + 1
KBSAM(IBR)%KS(NSBR(IBR)) = K
NSBRMX = MAX( NSBRMX,NSBR(IBR) )
end if
end do
end if
enddo
ALLOCATE ( KLH (NSBRMX), XLH (NSBRMX), ZLH (NSBRMX), IDX(NSBRMX) )
ALLOCATE ( KLHH(NSBRMX), XLHH(NSBRMX), ZLHH(NSBRMX) )
DO IBR = 1,MXNETBR ! ORDER SAMPLES ON BRANCH AND INTERP LINKS INTO IT
IF (NSBR(IBR) > 0) THEN ! ER ZITTEN PROFIELEN OP
DO KK = 1,NSBR(IBR)
K = KBSAM(IBR)%KS(KK)
XLH(KK) = XLSAM(K)
!ZLH(KK) = Zpr(K)
KLH(KK) = K
ENDDO
CALL INDEXX(NSBR(IBR),XLH,IDX)
DO KK = 1,NSBR(IBR) ! NU GESORTEERD NAAR AFSTAND
XLHH(KK) = XLH(IDX(KK))
!ZLHH(KK) = ZLH(IDX(KK))
KLHH(KK) = KLH(IDX(KK))
ENDDO
K1 = 0; K2 = 1
DO LL = 1, netbr(ibr)%NX
LA = IABS( NETBR(IBR)%LN(LL) )
XL = XLLIN(LA)
DO WHILE (XL > XLHH(K2) .AND. K2 < NSBR(IBR) )
K2 = K2 + 1; K1 = K1 + 1
ENDDO
IF (XL > XLHH(K2)) THEN
K1 = K2
ENDIF
IF (K1 == 0) THEN ! IN FIRST SEGMENT, VALUE IS THAT OF K1
ALFA = 0D0
ELSE IF (K1 == NSBR(IBR) ) THEN ! IN LAST SEGMENT, VALUE IS THAT OF K2
ALFA = 1D0
ELSE ! IN BETWEEN, REGULAR INTERPOLATION
ALFA = ( XL - XLHH(K1) ) / ( XLHH(K2) - XLHH(K1) )
ENDIF
IF (K1 == 0) THEN
KA = KLHH(K2)
ELSE
KA = KLHH(K1)
ENDIF
IF (K1 == NSBR(IBR)) THEN
KB = KLHH(K1)
ELSE
KB = KLHH(K2)
ENDIF
KA = NPR(KA) ; KB = NPR(KB)
IF (profiles1D(ka)%ityp <= 3 .and. profiles1D(ka)%ityp == profiles1D(kb)%ityp ) THEN ! identical simple profs are interpolated immediately
PROF1D(1,LA) = (1D0-alfa)*profiles1D(ka)%width + alfa*profiles1D(kb)%width
PROF1D(2,LA) = (1D0-alfa)*profiles1D(ka)%height + alfa*profiles1D(kb)%height
PROF1D(3,LA) = PROFILES1D(KA)%ITYP
IF (PROFILES1D(KA)%ITYP .NE. 2 .AND. PROFILES1D(KA)%ITYP .NE. 3) THEN ! SWITCH NONLIN FOR PROFILES WITH VARYING WIDTH
NONLIN = 1
ENDIF
ELSE ! POINTEREN VOOR YZPROF OR MIXED PROFILE TYPES
PROF1D(1,LA) = -KA
PROF1D(2,LA) = -KB
PROF1D(3,LA) = ALFA
IF (PROFILES1D(KA)%ITYP .NE. 2 .AND. PROFILES1D(KA)%ITYP .NE. 3) THEN ! SWITCH NONLIN FOR PROFILES WITH VARYING WIDTH
NONLIN = 1
ENDIF
IF (PROFILES1D(KB)%ITYP .NE. 2 .AND. PROFILES1D(KB)%ITYP .NE. 3) THEN ! SWITCH NONLIN FOR PROFILES WITH VARYING WIDTH
NONLIN = 1
ENDIF
ENDIF
!call mess('profile interpolation ready',nproflocs) ! EN NU IS DE INTERPOLATIE KLAAR
ENDDO
ENDIF
ENDDO
DEALLOCATE ( IBN , LIB , K1BR , NRLB)
DEALLOCATE ( KLH , XLH , ZLH , IDX )
DEALLOCATE ( KLHH , XLHH , ZLHH )
endif ! if ( Lnx1D.gt.0 ) then
endif ! if (nproflocs > 0) then
! parallel: reduce nonlin
call reduce_key(nonlin)
call restoresam()
deallocate(XLLIN, XLSAM)
if ( Lnx1D.gt.0 ) then
if ( allocated(NSBR) ) deallocate(NSBR)
if ( allocated(KBSAM) ) deallocate(KBSAM)
end if
deallocate(xpr, ypr, zpr, npr)
if ( jampi.eq.1 ) then
if ( allocated(distsam) ) deallocate(distsam)
if ( allocated(iconnsam) ) deallocate(iconnsam)
end if
endif
! nonlin = 0
end subroutine setprofs1D
subroutine readprofilesloc(minp)
use m_profiles
implicit none
integer :: minp
character rec*256
integer :: ierr, n
minproflocnr = 99999999 ; maxproflocnr = 0
n = 0
10 read(minp,'(a)',end=999) rec
if (rec(1:1) == '*') goto 10
n = n + 1
goto 10
999 rewind(minp)
allocate (xpr(n), ypr(n), zpr(n), npr(n), stat=ierr)
n = 0
20 read(minp,'(a)',end=888) rec
if (rec(1:1) == '*') goto 20
n = n + 1
read(rec,*) xpr(n), ypr(n), npr(n)
goto 20
888 call doclose(minp)
nproflocs = n
end subroutine readprofilesloc
subroutine readprofilesdef(ja) ! in afwachting van een module die profieldefinities leest
USE UNSTRUC_MODEL
use m_flowgeom
use m_profiles
use m_physcoef, only: ifrctypuni, frcuni1D
use m_missing
use messagehandling
use m_alloc
implicit none
integer :: ja
integer :: minp, n, nr, ierr, k, L, Lp,lnumuniq, nyz, npfx, myzprofs, mxprof
logical :: jawel
character (len=256) :: rec
integer, allocatable :: npr2(:)
double precision :: yp, zp, base, talud, width, height
integer, parameter :: mx = 1000
double precision :: yyh(mx), zzh(mx)
myzprofs = 0
rec = trim (md_profdeffile)
inquire(file = rec , exist=jawel)
ja = 0
if (jawel) then
call oldfil(minp, md_profdeffile )
mxprof = nproflocs
if (allocated (profiles1D) ) deallocate (profiles1D)
allocate ( profiles1D(mxprof) , stat=ierr)
call aerr('profiles1D(mxprof)', ierr, 40*nprofdefs)
allocate ( npr2(mxprof) ) ; npr2 = 0
profiles1D(1:mxprof)%ityp = 0
profiles1D(1:mxprof)%width = 0
profiles1D(1:mxprof)%height = 0
20 read(minp, '(A)', end = 888) rec
Lp = index(rec,'PROFNR=')
if (Lp > 0) then
read(rec(Lp+7:),*) nr ! profile NR
n = 0
do k = 1, nproflocs
if (npr(k) == nr) then
if (n == 0) then
n = k
endif
npr2(k) = n
npr(k) = 0
endif
enddo
if (n > 0) then
L = index(rec,'TYPE=') ! profile type
if (L > 0) then
read(rec(L+5:),*) profiles1D(n)%ityp
endif
L = index(rec,'WIDTH=') ! profile width
if (L > 0) then
read(rec(L+6:),*) profiles1D(n)%width
endif
L = index(rec,'HEIGHT=') ! profile height
if (L > 0) then
read(rec(L+7:),*) profiles1D(n)%height
endif
L = index(rec,'BASE=') ! trapezoid base
base = 0d0
if (L > 0) then
read(rec(L+5:),*) base
endif
L = index(rec,'TALUD=') ! trapezoid base
talud = 0d0
if (L > 0) then
read(rec(L+6:),*) talud
endif
L = index(rec,'FRCTP=') ! friction type
if (L > 0) then
read(rec(L+6:),*) profiles1D(n)%frctp
else
profiles1D(n)%frctp = ifrctypuni
endif
L = index(rec,'FRCCF=') ! friction coefficient
if (L > 0) then
read(rec(L+6:),*) profiles1D(n)%frccf
else
profiles1D(n)%frccf = frcuni1D
endif
if ( profiles1D(n)%ityp == 200 .or. profiles1D(n)%ityp == 201) then ! todo read true y,z or xyz profile
if (myzprofs == 0 .and. len( trim(md_profdefxyzfile) ) > 1) then
call oldfil(myzprofs, md_profdefxyzfile )
endif
if (myzprofs == 0) then
call qnerror('xyzprofile (TYPE= 200 or 201) is referenced, but profdefxyzfile not specified in mdu',' ',' ')
endif
nyz = 0
call readyzprofnr(myzprofs, nr, nyz, yyh, zzh, mx, width, height)
if (nyz == 0) then
call qnerror(' xyzprofile not found ',' ',' ')
else
allocate ( profiles1D(n)%y(nyz ), stat = ierr )
allocate ( profiles1D(n)%z(nyz ), stat = ierr )
do k = 1,nyz
profiles1D(n)%y(k) = yyh(k)
profiles1D(n)%z(k) = zzh(k)
enddo
profiles1D(n)%width = width
profiles1D(n)%height = height
profiles1D(n)%ityp = profiles1D(n)%ityp - 100 ! internally only distinguish 100 and 101
endif
endif
if ( profiles1D(n)%ityp == 4 .or. profiles1D(n)%ityp == 5) then ! V-shape comes as a yz type
nyz = 3
allocate ( profiles1D(n)%y(nyz ), stat = ierr )
allocate ( profiles1D(n)%z(nyz ), stat = ierr )
do k = 1,nyz
profiles1D(n)%y(k) = profiles1D(n)%width * ( dble(k-1)/dble(nyz-1) - 0.5d0 )
profiles1D(n)%z(k) = profiles1D(n)%height
enddo
profiles1D(n)%z(2) = 0d0
profiles1D(n)%ityp = profiles1D(n)%ityp + 96
endif
if ( profiles1D(n)%ityp == 6 .or. profiles1D(n)%ityp == 7) then ! Trapezoid comes as a yz type
if (base == 0d0 .and. talud .ne. 0.d0) then
base = max(0d0, profiles1D(n)%width - 2d0*profiles1D(n)%height*talud)
endif
nyz = 4
allocate ( profiles1D(n)%y(nyz ), stat = ierr )
allocate ( profiles1D(n)%z(nyz ), stat = ierr )
profiles1D(n)%y(1) = -profiles1D(n)%width / 2d0
profiles1D(n)%y(2) = profiles1D(n)%y(1) + (profiles1D(n)%width-base) / 2d0
profiles1D(n)%y(3) = profiles1D(n)%y(2) + base
profiles1D(n)%y(4) = profiles1D(n)%width / 2d0
profiles1D(n)%z(1) = profiles1D(n)%height
profiles1D(n)%z(2) = 0d0
profiles1D(n)%z(3) = 0d0
profiles1D(n)%z(4) = profiles1D(n)%height
profiles1D(n)%ityp = profiles1D(n)%ityp + 94
endif
endif
endif
goto 20
888 call doclose(minp)
ja = 1
do k = 1,nproflocs
if (npr2(k) == 0) then
ja = 0
call mess(LEVEL_info, 'Profloc nr. not found in profdef : ' , npr(k) )
npr2(k) = 0
endif
enddo
if (ja == 0) then
call mess(LEVEL_error, 'Errors in 1D profile references' )
endif
npr = npr2
deallocate (npr2)
ja = 1
if (myzprofs > 0) then
call doclose(myzprofs)
endif
endif
end subroutine readprofilesdef
subroutine readyzprofnr(myzprofs, iprofnr, nyz, yy, zz, mx, width, height)
use unstruc_messages
implicit none
integer :: myzprofs, iprofnr, nyz, mx
double precision :: yy(mx), zz(mx), width, height, yh(9999), zh(9999)
integer :: L, nr, n, ikp(9999), n0, n1, n2, nn
character (len=256) :: rec
double precision :: xx0, yy0, zz0, xx1, yy1, zz1, zmin, zmax, a, b, dif, zn1, y01, y02, dy
nyz = 0
rewind (myzprofs)
10 read (myzprofs,'(a)',end= 999) rec
if (index(rec,'PROFNR') > 0) then
L = index(rec, '=') + 1
read(rec(L:) , *) nr
if (nr == iprofnr) then
read(myzprofs,'(a)',end=999) rec
read(rec,*, err = 888) nyz
read(myzprofs,'(a)',end=999) rec
read(rec,*, err = 888) xx0, yy0, zz0
yy(1) = 0d0
zz(1) = zz0
zmin = zz0
nn = 1
do n = 2, nyz
read(myzprofs,*) xx1, yy1, zz1
dy = sqrt( (xx1-xx0)**2 + (yy1-yy0)**2)
if (dy > 0d0) then
nn = nn+1
yy(nn) = yy(nn-1) + dy
zz(nn) = zz1
xx0 = xx1
yy0 = yy1
else
write(msgbuf, '(a,i0,a,i0,a)') ' While reading PROFNR=', nr, ': point #', n, ' discarded, because it is the same as previous point.'
call warn_flush()
end if
zmin = min(zmin, zz1)
enddo
nyz = nn ! Some points may have been discarded
zmax = -9d9
do n = 1, nyz
zz(n) = zz(n) - zmin
zmax = max(zmax, zz(n))
enddo
width = yy(nyz)
height = zmax
if (nyz > 2) then ! throw away points that can be represented by linear interpolation
ikp(1) = 1
ikp(nyz) = 1
do n1 = 2, nyz-1
n0 = n1-1 ; n2 = n1+1
y02 = yy(n2) - yy(n0)
y01 = yy(n2) - yy(n1)
a = y01/y02 ; b = 1d0 - a
zn1 = b*zz(n0) + a*zz(n2)
dif = abs(zz(n1) - zn1)
if (dif > 1d-3) then
ikp(n1) = 1
else
ikp(n1) = 0
endif
enddo
n = 0
do n1 = 1, nyz
if (ikp(n1) == 1) then
n = n + 1
yy(n) = yy(n1)
zz(n) = zz(n1)
endif
enddo
nyz = n
endif
return
endif
endif
goto 10
999 return
888 call readerror('reading x,y,z , but getting ', rec, myzprofs)
end subroutine readyzprofnr
subroutine triarea3D(xx,yy,zz,triarea) ! input: two vectors starting from zero
implicit none
double precision :: xx(2), yy(2), zz(2), triarea
double precision :: d(3)
d(1) = yy(1)*zz(2) - yy(2)*zz(1)
d(2) =-1d0*(xx(1)*zz(2) - xx(2)*zz(1))
d(3) = xx(1)*yy(2) - xx(2)*yy(1)
triarea = 0.5d0*sqrt( d(1)*d(1) + d(2)*d(2) + d(3)*d(3) )
end subroutine triarea3D
!> Initializes all administration encessary for writing output to his-files.
!! That is: snap observation stations to flow cells, cross sections to flow links.
!! And bookkeeping for time series output on structures.
subroutine flow_obsinit()
use m_observations, only: init_valobs
use m_structures
implicit none
call crosssections_on_flowgeom()
call obs_on_flowgeom(0)
! for the following, it is assumed that the moving obsrevation stations have been initialized (in flow_init_externalforcings)
call init_valobs() ! (re)initialize work array and set pointers for observation stations
call updateValuesOnObervationStations() ! and fill first value
call init_structure_hisvalues()
end subroutine flow_obsinit
double precision function cosphiu(L) ! get link cos
use m_flowgeom
use m_netw
implicit none
integer :: L ! for link L,
! locals
integer :: k1, k2, k3, k4
double precision :: rn, rt, rnl, rtl
k1 = ln(1,L)
k2 = ln(2,L)
k3 = lncn(1,L)
k4 = lncn(2,L)
call normalin(xz(k1), yz(k1), xz(k2), yz(k2), rnl, rtl) ! in pos LL direction
call normalin(xk(k3), yk(k3), xk(k4), yk(k4), rn , rt ) ! = normalin (k1,k2)
cosphiu = rnl*rn + rtl*rt
end function cosphiu
double precision function cosphiunet(L) ! get link cos on net link
use m_flowgeom
use m_netw
implicit none
integer :: L ! for net link L,
double precision, external :: dcosphi
! locals
integer :: k1, k2, k3, k4
double precision :: rn, rt, rnl, rtl
! Check: no findcells done yet. Report 'all bad'.
if (nump <= 0) then
cosphiunet = 1
return
end if
! Check: 1D or closed boundary link: report 'good'.
if (lnn(L) < 2) then
cosphiunet = 0
return
elseif (lne(1,L) <= 0 .or. lne(2,L) <= 0) then
cosphiunet = 0
return
end if
k1 = lne(1,L)
k2 = lne(2,L)
k3 = kn(1,L)
k4 = kn(2,L)
cosphiunet = dcosphi(xz(k1), yz(k1), xz(k2), yz(k2), xk(k3), yk(k3), xk(k4), yk(k4) )
end function cosphiunet
subroutine ispointinsidecells( xz, yz, nn ) ! check if certain point is inside other cells
use m_netw
implicit none
double precision :: xz, yz, x(10), y(10)
integer :: nn
! locals
integer :: m,n,k
do n = 1,nump
do m = 1,netcell(n)%n
k = netcell(n)%NOD(m)
x(m) = xk(k)
y(m) = yk(k)
enddo
call pinpok(xz,yz,netcell(n)%n,x,y,nn)
if (nn .ne. 0) then
nn = n ; return
endif
enddo
end subroutine ispointinsidecells
subroutine allocateandset2Dnodexyarrays(n)
use m_netw
use m_flowgeom
use m_sferic
implicit none
integer :: n, IERR
! locals
integer :: m,k,nn
double precision :: xmn, xmx
nn = netcell(n)%n
! GD: memory leak
if(allocated(nd(n)%x)) deallocate(nd(n)%x)
if(allocated(nd(n)%y)) deallocate(nd(n)%y)
if(allocated(nd(n)%nod)) deallocate(nd(n)%nod)
allocate ( nd(n)%x(nn), nd(n)%y(nn), nd(n)%nod(nn), stat=ierr )
call aerr('nd(n)%x(nn), nd(n)%y(nn), nd(n)%nod(nn)', ierr, nn*3)
do m = 1,nn
k = netcell(n)%NOD(m)
nd(n)%x(m) = xk(k)
nd(n)%y(m) = yk(k)
nd(n)%nod(m) = k;
enddo
if (jsferic == 1) then ! jglobe
xmn = minval( nd(n)%x )
xmx = maxval( nd(n)%x )
if (xmx - xmn > 180d0) then
do m = 1,nn
k = netcell(n)%NOD(m)
if ( xmx - nd(n)%x(m) > 180d0) then
nd(n)%x(m) = nd(n)%x(m) + 360d0
endif
enddo
endif
endif
end subroutine allocateandset2Dnodexyarrays
subroutine allocateandset1Dnodexyarrays( n ) ! only for plotting ....
use m_netw
use m_flowgeom
use m_sferic
use m_missing
implicit none
integer :: n, LL
! locals
integer :: m,k,nn, no, L, La, n1, n2, ierr, JACROS
double precision :: x1, y1, x2, y2, hwu, cs, sn
double precision :: x1a, y1a, x2a, y2a, x1b, y1b, x2b, y2b
double precision :: SL,SM,XCR,YCR,CRP
integer :: K1, K2
double precision :: getdx, getdy
double precision :: dxt, dyt, phi
integer, allocatable :: linnrs(:)
double precision, allocatable :: arglins(:), arglin(:)
m = 3*nd(n)%lnx+1
if (nd(n)%lnx == 1) m = m+1
allocate ( nd(n)%x(m), nd(n)%y(m) , stat=ierr )
call aerr('nd(n)%x(m), nd(n)%y(m)', ierr, m*2 )
! Sort nd%ln in counterclockwise order
allocate(linnrs(nd(n)%lnx), arglins(nd(n)%lnx), arglin(nd(n)%lnx))
do L=1,nd(n)%lnx
K1 = LN(1,abs(nd(n)%ln(L))); K2 = LN(2,abs(nd(n)%ln(L)))
if (K2 == n) then
K2 = K1
K1 = n
end if
dxt = getdx(xz(k1), yz(k1), xz(k2), yz(k2))
dyt = getdy(xz(k1), yz(k1), xz(k2), yz(k2))
if (abs(dxt) < 1d-14 .and. abs(dyt) < 1d-14) then
if (dyt < 0) then
phi = -pi/2
else
phi = pi/2
end if
else
phi = atan2(dyt, dxt)
end if
arglin(L) = phi
end do
linnrs = 0
! Do a basic insertion sort (#links is small)
do L=1,nd(n)%lnx
do LL=1,L-1
if (arglin(L) < arglins(LL)) then
exit
end if
end do
arglins(LL+1:L) = arglins(LL:L-1)
arglins(LL) = arglin(L)
linnrs (LL+1:L) = linnrs(LL:L-1)
linnrs (LL) = nd(n)%ln(L)
end do
! links are locally sorted in linnrs
m = 0
x1 = xz(n)
y1 = yz(n)
! For each link, save its 'bottom' side (wrt counterclockwise view) and its tip (i.e., 3 points)
! The intersection between this bottom side and the 'top' side of previous link
! is computed. This yields a good contour line in nd%x/y.
! Use last link to prepare connection for 1st link in following loop:
La = abs(linnrs(nd(n)%lnx))
cs = csu(La) ; sn = snu(La)
hwu = 0.5d0*wu(La)
if (jsferic == 1) then
hwu = rd2dg*hwu/ra
endif
no = ln(2,La)
if (no == n) then
no = ln(1,La)
cs = -cs ! Flip link means: negate normal components
sn = -sn
end if
x1b = x1 - sn * hwu
y1b = y1 + cs * hwu
x2b = 0.5*(x1+xz(no)) - sn * hwu
y2b = 0.5*(y1+yz(no)) + cs * hwu
do LL = 1,nd(n)%lnx
L = linnrs(LL)
La = iabs(L)
n1 = ln(1,La) ; n2 = ln(2,La)
cs = csu(La) ; sn = snu(La)
hwu = 0.5d0*wu(La)
if (jsferic == 1) then
hwu = rd2dg*hwu/ra
endif
no = n2 ! N on Other side = no
if (no == n) then
no = n1
cs = -cs
sn = -sn
end if
x2 = 0.5*(x1+xz(no))
y2 = 0.5*(y1+yz(no))
x1a = x1 + sn*hwu
y1a = y1 - cs*hwu
x2a = x2 + sn*hwu
y2a = y2 - cs*hwu
SL = dmiss; SM = dmiss
call dCROSS(x1b, y1b, x2b,y2b, x1a, y1a, x2a, y2a,JACROS,SL,SM,XCR,YCR,CRP)
!if (SL /= dmiss .and. SM /= dmiss) then
IF (JACROS == 1) THEN
x1a = xcr
y1a = ycr
! else: parallel, use original x1a, y1a
end if
m = m + 1
nd(n)%x(m) = x1a
nd(n)%y(m) = y1a
m = m + 1
nd(n)%x(m) = x2a
nd(n)%y(m) = y2a
x1b = x1 - sn*hwu
y1b = y1 + cs*hwu
x2b = x2 - sn*hwu
y2b = y2 + cs*hwu
m = m + 1
nd(n)%x(m) = x2b
nd(n)%y(m) = y2b
enddo
! Only a single link, add fourth (extra) point.
if (nd(n)%lnx == 1) then
m = m + 1
nd(n)%x(m) = x1b
nd(n)%y(m) = y1b
end if
! For pfiller, close contour
m = m + 1
nd(n)%x(m) = nd(n)%x(1)
nd(n)%y(m) = nd(n)%y(1)
deallocate(linnrs, arglins, arglin)
end subroutine allocateandset1Dnodexyarrays
subroutine getAVCOR( n, xz, yz, zz ) ! average coordinate values
use m_netw
implicit none
double precision :: xz, yz, zz !
integer :: m, n, nn, k
xz = 0d0 ; yz = 0d0 ; zz = 0d0
nn = netcell(n)%n ! zwaartepunt
do m = 1,nn
k = netcell(n)%NOD(m)
xz = xz + xk(k)
yz = yz + yk(k)
zz = zz + zk(k)
enddo
xz = xz / nn
yz = yz / nn
zz = zz / nn
end subroutine getAVCOR
!> Compute circumcenter of a netcell and its average depth value.
!! See also getcellcircumcenter
subroutine GETCELLCIRCUMCENTER( n, xz, yz, zz ) ! circumcenter etc, depending on celltype
use network_data
use m_sferic
implicit none
integer, intent(in) :: n !< Netcell number
double precision, intent(out) :: xz, yz !< Coordinates of circumcenter point, undefined for void cells.
double precision, intent(out) :: zz !< Depth value at cc point, undefined for void cells.
integer, parameter :: Msize=10
double precision, dimension(Msize) :: xv, yv
integer, dimension(Msize) :: lnnl(Msize)
integer :: nn, m, mp1, num, k1, k2, i1, i2, i3, i4
nn = netcell(n)%n
if ( nn.lt.1 ) return ! safety
call get_cellpolygon(n, Msize, nn, xv, yv, LnnL, zz)
call getcircumcenter(nn, xv, yv, lnnl, xz, yz)
end subroutine GETCELLCIRCUMCENTER
!> circumcenter of a polygon defined by set of vertices.
!! See also getcellcircumcenter
subroutine GETCIRCUMCENTER( nn, xv, yv, lnnl, xz, yz)
use m_sferic
use network_data, only: dcenterinside
implicit none
integer, intent(in) :: nn !< Nr. of vertices
double precision, intent(inout) :: xv(nn), yv(nn) !< Coordinates of vertices (may be changed to avoid alloc overhead)
integer, intent(in) :: lnnl(nn) !< Local lnn codes for all netlinks between vertices.
double precision, intent(out) :: xz, yz !< Circumcenter coordinates
! locals
double precision :: xzw, yzw ! zwaartepunt
double precision :: xn, yn ! normal out
double precision :: dis
integer :: m,k,k1,k2
double precision :: xz2, yz2 ! only for help 4 corners
double precision :: xe3,ye3,xe1,ye1,xe2,ye2,tex,tey,dp,dotp, &
xccf,yccf,xccc,yccc,xcccf,ycccf,xccfo,yccfo,alf
double precision :: xh(6), yh(6)
double precision :: xr(6), yr(6), SL,SM,XCR,YCR,CRP
double precision :: eps = 1d-3, xcc3, ycc3, xf, xmx, xmn
double precision :: getdx, getdy
double precision :: dfac
integer :: jacros, in, m2, nintlinks ! nr of internal links = connected edges
logical :: isnan
double precision, external :: dbdistance
! integer, parameter :: N6=6
! double precision, dimension(N6) :: xhalf, yhalf
double precision, parameter :: dtol=1d-4
xzw = 0d0 ; yzw = 0d0
if (jsferic == 1) then ! jglobe ! regularise sferic coordinates
xmx = maxval(xv(1:nn))
xmn = minval(xv(1:nn))
if (xmx - xmn > 180d0) then
do m = 1,nn
if ( xmx - xv(m) > 180d0) then
xv(m) = xv(m) + 360d0
endif
enddo
endif
endif
do m = 1,nn
xzw = xzw + xv(m)
yzw = yzw + yv(m)
enddo
xzw = xzw / nn
yzw = yzw / nn
!--------------------------
! test
! if ( nn.gt.N6 ) then
! call qnerror('getcircumcenter: nn>N6', ' ', ' ')
! stop
! end if
! xhalf(1:nn) = 0.5d0*(xv(1:nn)+(/ xv(2:nn), xv(1) /))
! yhalf(1:nn) = 0.5d0*(yv(1:nn)+(/ yv(2:nn), yv(1) /))
! call comp_circumcenter(nn, xv, yv, xhalf, yhalf, xz, yz)
! goto 1234
! end test
!--------------------------
! if (nn == 333) then
if (nn == 3 .and. jglobe == 0 ) then ! for triangles
call circumcenter3(nn, xv, yv, xz, yz )
else
! default case
if (jsferic == 1) then
eps = 9d-10 ! 111km = 0-e digit.
endif
xccf = xzw
yccf = yzw
alf = 0.1d0
if (jsferic == 1) then
xf = 1d0/dcos( dg2rd*yzw )
endif
nintlinks = 0
do m = 1,nn
if ( lnnl(m) == 2) then
nintlinks = nintlinks + 1
endif
enddo
if (nintlinks > 1 .or. nn.eq.3) then ! nn.eq.3: always for triangles
do k = 1,100 ! Zhang, Schmidt and Perot 2002, formula A3
xccfo = xccf
yccfo = yccf
do m = 1,nn
if ( lnnl( m ) == 2 .or. nn.eq.3) then ! nn.eq.3: always for triangles
xe1= xv(m)
ye1= yv(m)
m2 = m + 1; if (m == nn) m2 = 1
xe2= xv(m2)
ye2= yv(m2)
! If two subsequent corners are on top of each other, see them as one.
if (xe1 == xe2 .and. ye1 == ye2) then
cycle
end if
xe3= 0.5d0*(xe1+xe2)
ye3= 0.5d0*(ye1+ye2)
call normalin(xe1,ye1,xe2,ye2,tex,tey)
xcc3 = getdx(xe3,ye3,xccf,yccf)
ycc3 = getdy(xe3,ye3,xccf,yccf)
dp = -alf*dotp(xcc3,ycc3,tex,tey) ! - sign not present in given formula
if (jsferic == 1) then
dp = rd2dg*dp/ra
xccf = xccf + tex*dp*xf ! even erbijblijven voor beste resultaat
yccf = yccf + tey*dp
else
xccf = xccf + tex*dp
yccf = yccf + tey*dp
endif
! dp = -alf*dotp(xccf - xe3,yccf - ye3, tex, tey) ! - sign not present in given formula
! call cirr(xccf,yccf,31)
! call waitesc()
endif
enddo
if (k > 1 .and. abs(xccf-xccfo) < eps .and. abs(yccf-yccfo) < eps) then
m = 1
exit
endif
enddo
xz = xccf
yz = yccf
else
xz = xzw
yz = yzw
endif
endif
1234 continue
! if (jsferic == 1) then ! jglobe ! regularisatie tbv tidal force routine
! if ( xz < -180d0 ) then
! xz = xz + 360d0
! endif
! ENDIF
if ( dcenterinside .le. 1d0 .and. dcenterinside.ge.0d0 ) then
if ( nn.le.3 ) then ! triangles
dfac = 1d0
else
dfac = dcenterinside
end if
do m=1,nn
xh(m) = dfac*xv(m)+(1-dfac)*xzw
yh(m) = dfac*yv(m)+(1-dfac)*yzw
end do
call pinpok(xz,yz,nn,xh,yh,in) ! circumcentre may not lie outside cell
if (in == 0) then
do m = 1,nn
m2 = m + 1; if (m == nn) m2 = 1
call CROSS(xzw, yzw, xz, yz, xh(m ), yh(m ), xh(m2), yh(m2),&
JACROS,SL,SM,XCR,YCR,CRP)
if (jacros == 1) then
! xz = 0.5d0*( xh(m) + xh(m2) ) ! xcr
! yz = 0.5d0*( yh(m) + yh(m2) ) ! ycr
xz = xcr
yz = ycr
exit
endif
enddo
endif
endif
end subroutine GETCIRCUMCENTER
!> computes dot product of two two-dimensional vectors defined by (x1,y1) and (x2,y2) respectively
double precision function dotp(x1,y1,x2,y2) ! dot produkt
implicit none
double precision :: x1, y1, x2, y2
dotp = x1*x2 + y1*y2
end function dotp
!> compute circumcenter of a triangle
subroutine circumcenter3(nn, x, y, xz, yz ) ! of triangle n ! todo : sferic
use m_sferic
implicit none
integer :: nn
double precision :: x(nn), y(nn), xz, yz, xf, phi
double precision :: getdx, getdy
! locals
double precision :: z,den,dx2,dx3,dy2,dy3
dx2 = x(2)-x(1)
dx3 = x(3)-x(1)
dy2 = y(2)-y(1)
dy3 = y(3)-y(1)
dx2 = getdx( x(1),y(1),x(2),y(2) )
dy2 = getdy( x(1),y(1),x(2),y(2) )
dx3 = getdx( x(1),y(1),x(3),y(3) )
dy3 = getdy( x(1),y(1),x(3),y(3) )
den = dy2*dx3-dy3*dx2
if (den .ne. 0) then
z=(dx2*(dx2-dx3)+dy2*(dy2-dy3))/den
else
! call qnerror('coinciding points',' ',' ')
z = 0d0
endif
if (jsferic == 1) then
phi = (y(1)+y(2)+y(3))/3d0
xf = 1d0/dcos( dg2rd*phi )
xz = x(1) + xf*0.5d0*(dx3-z*dy3)*rd2dg/ra
yz = y(1) + 0.5d0*(dy3+z*dx3)*rd2dg/ra
else
xz = x(1) + 0.5d0*(dx3-z*dy3)
yz = y(1) + 0.5d0*(dy3+z*dx3)
endif
end subroutine circumcenter3
!> Prepares a mirror cell as candidate for an open boundary cell, and a probe point 'uitsteker' for use in selectelset().
!! This is done by determining a representative half cell size:
!! dis = MAX(.5*sqrt(cell area), distance from mass center to edge)
!! The mirrored circumcenter is obtained by projecting cell circumcenter onto edge, and from there extend by dis (i.e., half approximate cell 'width').
!! The probe point is also obtained by projecting cell circumcenter onto edge, and from there extend by rrtol*dis (i.e., rrtol*apprimate cell 'width')
subroutine mirrorcell( n, x3, y3, x4, y4, xci, yci, xcb, ycb, xmir, ymir, xx, yy ) !
use m_netw ! bounday segment !intern circumcentre, boundary circumcentre, mirrorpoint, cell corners
use m_flowgeom
use m_sferic
implicit none
integer, intent(in) :: n !< cell number (in 1:nump)
double precision, intent(in) :: x3, y3, x4, y4 !< net node coordinates of a boundary edge of this cell
double precision, intent(out) :: xci, yci !< cell circumcenter coordinates for this cell (i.e., xz(n), yz(n))
double precision, intent(out) :: xcb, ycb !< cell circumcenter coordinates for the 'mirror' cell
double precision, intent(out) :: xmir, ymir !< 'Uitsteker' probe point, used for testing for open boundary in selectelset
double precision, intent(out) :: xx(4), yy(4) !< Coordinates for mirrored cell contour (counter clockwise), contains x3,y3 and also x4,y4.
double precision :: rtol
double precision :: dis, dis2, diszw, edge, zci, rdot, rx, ry, xd, yd
double precision, external :: dbdistance, dprodin
integer :: ja
! call getcellWEIGHTEDcenter( n, xci, yci, zci )
! edge = dbdistance(x3,y3,x4,y4)
! dis = ar/edge
CALL DLINEDIS(Xz(n),Yz(n),X3,Y3,X4,Y4,JA,DIS,Xd,Yd) ! dis is half cell size in boundary normal dir
dis = max(dis,0.5d0*sqrt(ba(n)))
call normaloutchk(x3, y3, x4, y4, xzw(n), yzw(n), rx, ry, ja)
! Convert back to sferic, if necessary
if (jsferic == 1) then
dis = dis*rd2dg/ra
endif
xci = xz(n)
yci = yz(n)
CALL DLINEDIS(Xci,Yci,X3,Y3,X4,Y4,JA,DIS2,Xd,Yd) ! dis is half cell size in boundary normal dir
xcb = xd + rx*dis
ycb = yd + ry*dis
xmir = xd + rx*2d0*rrtol*dis
ymir = yd + ry*2d0*rrtol*dis
!call movabs(xci, yci)
!call lnabs(xmir, ymir)
!call toemaar()
! store ordered contour of cell
if (rx*(y4-y3) - ry*(x4-x3) > 0d0) then
xx(1) = x3 ; yy(1) = y3
xx(2) = x3 + dis*rx ; yy(2) = y3 + dis*ry
xx(3) = x4 + dis*rx ; yy(3) = y4 + dis*ry
xx(4) = x4 ; yy(4) = y4
else
xx(4) = x3 ; yy(4) = y3
xx(3) = x3 + dis*rx ; yy(3) = y3 + dis*ry
xx(2) = x4 + dis*rx ; yy(2) = y4 + dis*ry
xx(1) = x4 ; yy(1) = y4
end if
end subroutine mirrorcell
!> Computes the bottom area of a cell and the center of mass coordinates.
subroutine getcellsurface ( n, ba, xzwr, yzwr ) ! bottom area of cell nr n ! todo : sferic
use m_netw
use m_sferic
use m_missing
implicit none
double precision :: ba, xzwr, yzwr
integer :: n
! locals
integer :: nn
integer, parameter :: MMAX=10 ! maximum cell polygon size
double precision, dimension(MMAX) :: xh, yh ! cell polygon node coordinates
integer, dimension(MMAX) :: LnnL ! cell polygon link Lnn (not used here)
double precision :: zz
integer :: jaccw ! counterclockwise (1) or not (0) (not used here)
call get_cellpolygon(n,Mmax,nn,xh,yh,LnnL,zz)
call comp_masscenter(nn, xh , yh, xzwr, yzwr, ba, jaccw)
end subroutine getcellsurface
!> computes the cell-weighted center
subroutine getcellweightedcenter(n, xz, yz, zz)
use M_ORTHOSETTINGS
implicit none
double precision :: xz, yz, zz
integer :: n
integer, parameter :: MMAX = 10
double precision, dimension(MMAX) :: xv, yv
integer, dimension(MMAX) :: LnnL
integer :: nn
integer :: jaccw ! counterclockwise (1) or not (0) (not used here)
double precision :: ba, xzw, yzw
! get the cell polygon that is safe for periodic, spherical coordinates, inluding poles
call get_cellpolygon(n,Mmax,nn,xv,yv,LnnL,zz)
! get cell circumcenter
call getcircumcenter(nn, xv, yv, lnnl, xz, yz)
if (circumormasscenter .ne. 1d0) then
! update with cell mass center
call comp_masscenter(nn, xv, yv, xzw, yzw, ba, jaccw)
xz = circumormasscenter*xz + (1d0-circumormasscenter)*xzw
yz = circumormasscenter*yz + (1d0-circumormasscenter)*yzw
endif
! CALL CIRR(XZ,YZ,31)
end subroutine getcellweightedcenter
!> compute the length of a netlink
double precision function linksize(L)
use m_netw
implicit none
integer :: L, k1, k2
double precision dbdistance
k1 = kn(1,L) ; k2 = kn(2,L)
linksize = dbdistance ( xk(k1), yk(k1), xk(k1), yk(k2) )
end function linksize
!> initialize sferical coordinate frame
subroutine inisferic()
use m_sferic
implicit none
double precision :: sidereal
pi = acos(-1d0)
twopi = 2d0*pi
dg2rd = pi/180d0
rd2dg = 180d0/pi
sidereal = 23d0*3600d0 + 56d0*60d0 + 4.1d0
omega = twopi/sidereal
fcorio = 2d0*omega*sin(anglat*dg2rd)
dy2dg = rd2dg/ra
end subroutine inisferic
subroutine flow_allocflow() ! initialise flow model time independent parameters
use m_netw, only : kn
use m_flowgeom
use m_flow
use m_flowtimes
use m_flowexternalforcings
use m_missing
use unstruc_model
use m_netw, only : netcell, numk, numl
use m_alloc
use m_waves
use m_xbeach_data
use m_xbeach_avgoutput
use m_flowexternalforcings, only: nbndw
use m_sediment
use m_ship
use m_sferic
use m_partitioninfo
use m_transport, only : numconst
implicit none
integer :: ierr, n, k, mxn, j, kj, kk, LL, L, k1, k2, k3, k4, n1, n2, n3, n4, nL, kb1, kb2, numkmin, numkmax, kbc1, kbc2
integer :: nlayb, nrlay, nlayb1, nrlay1, nlayb2, nrlay2, Lb, Lt, mx, ltn, mpol, Lt1, Lt2, Lt3, Ld1, Ld2, Ld3, Ldn
integer :: laybed, laytop, nrlayL, Lf, kuni, kb
double precision :: zmn, zmx, dzm, zw, zkk ! for 3D
double precision :: xL, xR, dLR, alf, xfixed, xsigma, gf, d1, di, w1, w2, w3, zbt, zbb, dzb, gfi, gfk, sumcof
logical :: jawel
integer :: ierror
if (ndx == 0) return
! if ( jampi.eq.1 ) then
!! synchronise bed level
! call update_ghosts(ITYPE_SALL, 1, Ndx, bl, ierror)
! end if
call ilowercase(md_netfile) ! INTERACTOR!
! node related
if (allocated(s0) ) then
deallocate(s0,s1,a0,a1,hs,s00,cfs)
endif
allocate ( s0 (ndx) , s1 ( ndx) , stat = ierr)
call aerr('s0 (ndx) , s1 (ndx)', ierr, 2*ndx) ; s0 = 0 ; s1 = 0
allocate ( a0 (ndx) , a1 (ndx) , stat = ierr)
call aerr('a0 (ndx) , a1 (ndx)', ierr, 2*ndx) ; a0 = 0 ; a1 = 0
allocate ( hs (ndx) , s00 (ndx) , stat = ierr)
call aerr('hs (ndx) , s00 (ndx)', ierr, 2*ndx) ; hs = 0 ; s00 = 0
allocate ( cfs (ndx) , stat = ierr)
call aerr('cfs (ndx)', ierr, ndx) ; cfs = 0
!if ( allocated(volau) ) deallocate (volau)
!allocate ( volau(ndx) )
if (allocated (kbot) ) then
deallocate( kbot,ktop,ktop0,kmxn,Lbot,Ltop,kmxL )
endif
allocate ( kbot (ndx) , stat= ierr )
call aerr('kbot (ndx)', ierr, ndx )
allocate ( ktop (ndx) , stat= ierr )
call aerr('ktop (ndx)', ierr, ndx )
allocate ( ktop0(ndx) , stat= ierr )
call aerr('ktop0(ndx)', ierr, ndx )
allocate ( kmxn (ndx) , stat= ierr )
call aerr('kmxn (ndx)', ierr, ndx )
allocate ( Lbot (Lnx) , stat= ierr )
call aerr('Lbot (Lnx)', ierr, Lnx )
allocate ( Ltop (Lnx) , stat= ierr )
call aerr('Ltop (Lnx)', ierr, Lnx )
allocate ( kmxL (Lnx) , stat= ierr )
call aerr('kmxL (Lnx)', ierr, Lnx )
if (allocated (ustb) ) deallocate(ustb, ustw)
allocate ( ustb (lnx) , stat= ierr )
call aerr('ustb (lnx)', ierr, lnx ) ; ustb = 0
allocate ( ustw (lnx) , stat= ierr )
call aerr('ustw (lnx)', ierr, lnx ) ; ustw = 0
if (allocated (laydefnr) ) deallocate(laydefnr, laytyp, laymx)
allocate ( laydefnr(ndx) , stat= ierr )
call aerr('laydefnr(ndx)' , ierr, ndx )
allocate ( laytyp(mxlaydefs) , stat= ierr )
call aerr('laytyp(mxlaydefs)' , ierr, mxlaydefs )
allocate ( laymx(mxlaydefs) , stat= ierr )
call aerr('laymx(mxlaydefs)' , ierr, mxlaydefs )
do k=1,Ndx
kbot(k) = k
ktop(k) = k
kmxn(k) = 1
end do
do L=1,Lnx
Lbot(L) = L
Ltop(L) = L
kmxL(L) = 1
end do
if (kmx > 0) then
numkmin = int(1d8) ; numkmax = -numkmin
do Lf = Lnx1D+1, Lnx ! we only need netnode nrs in 2D, todo: trim to numkmin
L = ln2lne(Lf)
if (kn(3,L) == 2) then
numkmin = min(numkmin, kn(1,L), kn(2,L) )
numkmax = max(numkmax, kn(1,L), kn(2,L) )
endif
enddo
numkmax = numk
if (allocated ( kbotc) ) then
deallocate( kbotc, kmxc )
endif
allocate ( kbotc(numkmax) , stat= ierr) ! may also be numkmin -> numkmax
call aerr('kbotc(numkmax)' , ierr, numkmax)
allocate ( kmxc (numkmax) , stat= ierr)
call aerr('kmxc (numkmax)' , ierr, numkmax)
kbot = 1 ; ktop = 1 ; kmxn = 1
Lbot = 1 ; Ltop = 1 ; kmxL = 1
kbotc = 1 ; kmxc = 1
mxlays = kmx ; numvertdis = 3 ! mxlayz = 6
mxlaydefs = numvertdis ; mx = 0;
laydefnr = 1
if (layertype == 3) then
inquire (file = md_vertplizfile, exist = jawel)
if (jawel) then
call oldfil(mpol, md_vertplizfile )
else
call qnerror( 'vertical_layering.pliz not found, switch back to sigma', ' ', ' ')
layertype = 1
endif
endif
if (layertype == 1 .or. layertype == 4 ) then ! all sigma
mxlaydefs = 1
laytyp(1) = 1
laymx(1) = kmx
if (layertype == 4 ) then
if (allocated (dkx)) deallocate (dkx, sdkx)
allocate ( sdkx(ndx), dkx(ndx) )
endif
else if (layertype == 2) then ! all z
mxlaydefs = 1
laytyp(1) = 2
zmn = 1d30
do n = 1,ndx
zmn = min(bl(n),zmn)
enddo
if ( jampi.eq.1 ) then
call reduce_double_min(zmn)
end if
if (Floorlevtoplay == dmiss) then
zmx = sini
else
zmx = Floorlevtoplay
endif
if (dztopuniabovez == dmiss) then
zbt = zmn
else
zbt = dztopuniabovez
endif
if (dztop == dmiss) then
dzm = (zmx - zbt) / mxlayz
else
dzm = dztop ; mxlayz = (zmx - zbt) / dzm
endif
kuni = mxlayz ; mx = kuni
if (zbt > zmn) then ! count extra layers needed to fill out till bottom
zbb = zbt ; dzb = dzm
do while (zbb > zmn .and. mx < kmxx-1)
dzb = dzb*sigmagrowthfactor
zbb = zbb - dzb
mx = mx + 1
enddo
endif
dzm = max(dzm, 1d-2)
toplayminthick = 0.01d0 ! 0.5d0*dzm
mxlayz = mx
kmx = mx ! repair code
laymx(1) = mx
else if (layertype == 3) then ! combination in polygons
call polygonlayering(mpol)
endif
do k = 1,mxlaydefs
mx = max(mx, laymx(k) )
enddo
if (allocated (zslay) ) deallocate (zslay, dzslay)
allocate ( zslay (0:mx, mxlaydefs) , stat = ierr ) ! nr of layer distributions
allocate ( dzslay (0:mx, mxlaydefs) , stat = ierr ) ; dzslay = 0d0
if( iStrchType == STRCH_USER ) then
sumcof = abs( sum( laycof ) - 100d0 )
if( sumcof > 1d-8 ) then
call mess(LEVEL_ERROR, 'Error : The sum of sigma layer thicknesses must be equal to 100!')
endif
endif
if( iStrchType == STRCH_USER ) then
do j = 1,mxlaydefs
mx = laymx(j)
do k = 1,mx
dzslay(k,j) = laycof(k) / 100d0
enddo
enddo
!!!elseif( iStrchType == STRCH_EXPONENT ) then
!!! gf = laycof(1)
!!! do j = 1,mxlaydefs
!!! mx = laymx(j)
!!! gfk = gf**mx
!!! if( gfk == 1d0 ) then
!!! gf = 1d0
!!! dzslay(1,j) = 1.0 / mx
!!! else
!!! dzslay(1,j) = ( 1d0 - gf ) / ( 1d0 - gfk )
!!! endif
!!! do k = 2,mx
!!! dzslay(k,j) = dzslay(k-1,j) * gf
!!! enddo
!!! enddo
elseif( iStrchType == STRCH_EXPONENT ) then
gfi = 1d0 / laycof(2)
gf = laycof(3)
do j = 1,mxlaydefs
mx = laymx(j)
k1 = laycof(1) * mx
gfk = gfi**k1
if( gfk == 1d0 ) then
gfi = 1d0
dzslay(1,j) = 1d0 / mx
else
dzslay(1,j) = ( 1d0 - gfi ) / ( 1d0 - gfk )* laycof(1)
endif
do k = 2,k1
dzslay(k,j) = dzslay(k-1,j) * gfi
enddo
gfk = gf**(kmx-k1)
if( gfk == 1d0 ) then
gf = 1d0
dzslay(k1+1,j) = 1d0 / mx
else
dzslay(k1+1,j) = ( 1d0 - gf ) / ( 1d0 - gfk ) * ( 1d0 - laycof(1) )
endif
do k = k1+2,mx
dzslay(k,j) = dzslay(k-1,j) * gf
enddo
enddo
else
do j = 1,mxlaydefs
mx = laymx(j)
do k = 1,mx
dzslay(k,j) = 1d0 / mx
enddo
enddo
endif
do j = 1,mxlaydefs
mx = laymx(j)
if (laytyp(j) == 1) then
zslay(0,j) = 0d0
do k = 1, mx
zslay(k,j) = zslay(k-1,j) + dzslay(k,j)
enddo
else if (laytyp(j) == 2) then
if ( allocated(zslay) ) deallocate(zslay)
allocate ( zslay (0:mx, mxlaydefs) , stat = ierr ) ! nr of layer distributions
zslay(0,j) = zmn ; zslay(mx,j) = zmx
do k = mx-1, mx - kuni , -1
zslay(k,j) = zslay(k+1,j) - dzm
enddo
dzb = dzm
do k = mx - kuni, 1, -1
dzb = dzb*sigmagrowthfactor
zslay(k,j) = zslay(k+1,j) - dzb
enddo
endif
enddo
kk = Ndx
do n = 1,ndx
kbot(n) = 0
kk = kk + 1 ! spoke cell for everyone
Ldn = laydefnr(n)
if (Ldn >= 1) then
if ( laytyp(Ldn) == 1 ) then
mx = laymx(Ldn)
kmxn(n) = mx
else if ( laytyp(Ldn) == 2 ) then
call getzlayerindices(n,nlayb,nrlay)
kmxn(n) = nrlay
! mx = laymx(Ldn)
! do k = 1,mx
! if ( zslay(k,Ldn) > bl(n) ) then
! kmxn(n) = mx - k + 1
! exit
! endif
! enddo
endif
endif
enddo
kk = Ndx
do n = 1,ndx ! Count ndkx + set kbot array
kbot(n) = 0
kk = kk + 1
Ldn = laydefnr(n)
if (Ldn == 0) then
k1 = indlaynod(1,n) ; k2 = indlaynod(2,n) ; k3 = indlaynod(3,n)
w1 = wflaynod(1,n) ; w2 = wflaynod(2,n) ; w3 = wflaynod(3,n)
kmxn(n) = max(1, nint( w1*kmxn(k1) + w2*kmxn(k2) + w3*kmxn(k3) ) )
! kmxn(n) = max( kmxn(k1), kmxn(k2), kmxn(k3) )
endif
do k = 1, kmxn(n)
kk = kk + 1
if (k == 1) then
kbot(n) = kk
endif
enddo
enddo
ndkx = kk
LL = Lnx ! Stapelen vanaf grondlaag
do L = 1,lnx
n1 = ln(1,L) ; n2 = ln(2,L)
kmxL(L) = min( kmxn(n1), kmxn(n2) ) ! 30-04 ! kmxL(L) = max ( kmxn(n1), kmxn(n2) )
if (abs(kcu(L)) == 2) then
n3 = lncn(1,L) ; n4 = lncn(2,L)
kmxc(n3) = max( kmxc(n3), kmxL(L) )
kmxc(n4) = max( kmxc(n4), kmxL(L) )
endif
do k = 0, kmxL(L)
LL = LL + 1
enddo
enddo
Lnkx = LL
call realloc(ln , (/ 2, Lnkx /) )
call realloc(lncn, (/ 2, Lnkx /) )
LL = Lnx ! Stapelen vanaf grondlaag
kk = numk ! setup cornerpoint admin
do n = numkmin, numkmax
do k = 0, kmxc(n)
kk = kk + 1
if (k == 1) then
kbotc(n) = kk
endif
enddo
enddo
call realloc(ucnx, kk )
call realloc(ucny, kk )
do L = 1,lnx
n1 = ln (1,L) ; n2 = ln (2,L)
n3 = lncn(1,L) ; n4 = lncn(2,L)
Lt1 = 0 ; Lt2 = 0
if ( laydefnr(n1) > 0 .and. laydefnr(n2) > 0) then
Lt1 = laytyp( laydefnr(n1) ) ; Lt2 = laytyp( laydefnr(n2) )
endif
if ( Lt1 == 2 .and. Lt2 == 2) then
call getzlayerindices(n1,nlayb1,nrlay1)
call getzlayerindices(n2,nlayb2,nrlay2)
kb1 = max(0, nlayb2-nlayb1)
kb2 = max(0, nlayb1-nlayb2)
laybed = max( nlayb1,nlayb2 )
laytop = min( nlayb1+nrlay1, nlayb2+nrlay2 ) ! should be identical for n1,n2,n3,n4
nrlayL = laytop - laybed + 1
kbc1 = kmxc(n3) - nrlayL
kbc2 = kmxc(n4) - nrlayL
else
kb1 = 0 ; kb2 = 0 ! linking starts at kbot(n1) + kb1 on left and at kbot(n2) + kb2 on right
kbc1 = 0 ; kbc2 = 0
endif
do k = 0, kmxL(L) ! 1 extra below bedlayer k = 1
LL = LL + 1
if (k == 1) then
Lbot(L) = LL
endif
if (k > 0) then
ln(1,LL) = kbot (n1) + kb1
ln(2,LL) = kbot (n2) + kb2
kb1 = kb1 + 1 ; kb1 = min(kb1, kmxn(n1))
kb2 = kb2 + 1 ; kb2 = min(kb2, kmxn(n2))
if (abs(kcu(L)) == 2) then
lncn(1,LL) = kbotc(n3) + kbc1
lncn(2,LL) = kbotc(n4) + kbc2
kbc1 = kbc1 + 1 ; kbc1 = min(kbc1, kmxc(n3))
kbc2 = kbc2 + 1 ; kbc2 = min(kbc2, kmxc(n4))
endif
endif
enddo
enddo
call realloc(ln0 , (/ 2, Lnkx /) )
ln0 = ln
do LL = 1,lnx ! only checking
Lb = Lbot(LL)
Lt = Lb + kmxL(LL) - 1
n1 = ln(1,LL) ; n2 = ln(2,LL)
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (k1 > kbot(n1) + kmxn(n1) - 1) then
ln(1,L) = k1
endif
if (k2 > kbot(n2) + kmxn(n2) - 1) then
ln(2,L) = k2
endif
enddo
enddo
else
ndkx = ndx
Lnkx = Lnx
endif
if (allocated(rho) ) deallocate(rho)
allocate ( rho (ndkx) , stat= ierr )
call aerr('rho (ndkx)', ierr, ndkx ) ; rho = rhomean
if (jasal > 0 .or. jatem > 0 .or. jased> 0 .or. stm_included ) then
if (abs(jabaroctimeint) >= 2) then
if (jacreep == 1 .or. abs(jabaroctimeint) >= 3) then
if (allocated(dpbdx0) ) deallocate(dpbdx0)
allocate ( dpbdx0 (lnkx) , stat= ierr )
call aerr('dpbdx0 (lnkx)', ierr, lnkx ) ; dpbdx0 = 0d0
endif
if (abs(jabaroctimeint) .ne. 3) then
if (allocated(rho0) ) deallocate(rho0)
allocate ( rho0 (ndkx) , stat= ierr )
call aerr('rho0 (ndkx)', ierr, ndkx ) ; rho0 = rhomean
endif
endif
endif
if (kmx > 0) then
if (allocated(zws) ) deallocate (zws,zws0,ww1,qw)
allocate ( ww1 (ndkx) , stat=ierr )
call aerr('ww1 (ndkx)', ierr, ndkx ) ; ww1 = 0
allocate ( qw (ndkx) , stat=ierr )
call aerr('qw (ndkx)', ierr, ndkx ) ; qw = 0
allocate ( zws (ndkx) , stat= ierr )
call aerr('zws (ndkx)', ierr, ndkx ) ; zws = 0
allocate ( zws0(ndkx) , stat= ierr )
call aerr('zws0(ndkx)', ierr, ndkx ) ; zws0 = 0
do n1 = 1,ndx
Ldn = laydefnr(n1)
Ltn = laytyp(Ldn)
kb = kbot(n1)
if (Ltn == 2) then
call getzlayerindices(n1,nlayb1,nrlay1)
zws(kb-1) = zslay(nlayb1-1,Ldn)
else
zws(kb-1) = bl(n1)
endif
enddo
endif
kmxd = max(1,kmx)
if (allocated (ucx) ) then
deallocate (ucx,ucy,ucxq,ucyq,qin,vih,dvxc,dvyc,cfli,squ,sqi,sq,vol0,vol1,volerror)
endif
if (allocated (squ2D)) then
deallocate (squ2d)
endif
if (allocated (uqcx) ) then
deallocate (uqcx, uqcy)
endif
if (allocated (ucz) ) then
deallocate (ucz)
endif
allocate ( ucx (ndkx) , ucy (ndkx) , stat = ierr)
call aerr('ucx (ndkx) , ucy (ndkx)', ierr, 2*ndkx) ; ucx = 0 ; ucy = 0
if (kmx > 0) then
allocate ( ucz (ndkx) , stat = ierr)
call aerr('ucz (ndkx)', ierr, ndkx) ; ucz = 0
endif
if( allocated(workx) ) then
deallocate( workx, worky, work1 )
endif
allocate ( workx (ndkx) , stat = ierr)
call aerr('workx (ndkx)', ierr, ndkx) ; workx = 0
allocate ( worky (ndkx) , stat = ierr)
call aerr('worky (ndkx)', ierr, ndkx) ; worky = 0
allocate ( work1 (max(kmx,1),max(ndx,lnx)) , stat = ierr)
call aerr('work1 ( max(kmx,1),max(ndx,lnx))', ierr, max(kmx,1)*max(ndx,lnx)) ; work1 = 0
! Secondary Flow
if (jasecf > 0) then
if (allocated (spircrv) ) then
deallocate ( spircrv, spirint, spirsrc, spirang, spirfx, spirfy, spirucm, czusf, czssf )
endif
allocate ( spircrv( ndkx ) , stat = ierr )
call aerr('spircrv( ndkx )', ierr, ndkx ) ; spircrv = 0
allocate ( spirint( ndkx ) , stat = ierr )
call aerr('spirint( ndkx )', ierr, ndkx ) ; spirint = 0
allocate ( spirsrc( ndkx ) , stat = ierr )
call aerr('spirsrc( ndkx )', ierr, ndkx ) ; spirsrc = 0
allocate ( spirang( ndkx ) , stat = ierr )
call aerr('spirang( ndkx )', ierr, ndkx ) ; spirang = 0
allocate ( spirfx ( ndkx ) , stat = ierr )
call aerr('spirfx ( ndkx )', ierr, ndkx ) ; spirfx = 0
allocate ( spirfy ( ndkx ) , stat = ierr )
call aerr('spirfy ( ndkx )', ierr, ndkx ) ; spirfy = 0
allocate ( spirucm( ndkx ) , stat = ierr )
call aerr('spirucm( ndkx )', ierr, ndkx ) ; spirucm = 0
allocate ( czusf ( lnkx ) , stat = ierr )
call aerr('czusf ( lnkx )', ierr, lnkx ) ; czusf = 0
allocate ( czssf ( ndkx ) , stat = ierr )
call aerr('czssf ( ndkx )', ierr, ndkx ) ; czssf = 0
endif
if (limtypmom == 6) then
if (allocated (ducdx) ) deallocate (ducdx,ducdy)
allocate ( ducdx (ndkx) , stat = ierr)
call aerr ('ducdx (ndkx)', ierr, ndkx) ; ducdx = 0
allocate ( ducdy (ndkx) , stat = ierr)
call aerr ('ducdy (ndkx)', ierr, ndkx) ; ducdy = 0
endif
if (limtypsa == 6) then
if (allocated (dsadx) ) deallocate (dsadx,dsady)
allocate ( dsadx (ndkx) , stat = ierr)
call aerr ('dsadx (ndkx)', ierr, ndkx) ; dsadx = 0
allocate ( dsady (ndkx) , stat = ierr)
call aerr ('dsady (ndkx)', ierr, ndkx) ; dsady = 0
endif
! if (allocated (dudx) ) then
! deallocate (dudx,dudy,dvdx,dvdy,rsi,uc3rsi,rsiexact)
! deallocate (dsdx,dsdy)
! endif
! Secondary Flow
! if (kmx < 2) then
! allocate ( dudx (ndkx) , stat = ierr)
! call aerr('dudx (ndkx)', ierr, ndkx) ; dudx = 0
! allocate ( dsdx (ndkx) , stat = ierr)
! call aerr('dsdx (ndkx)', ierr, ndkx) ; dsdx = 0
! allocate ( dsdy (ndkx) , stat = ierr)
! call aerr('dsdy (ndkx)', ierr, ndkx) ; dsdx = 0
! allocate ( dudy (ndkx) , stat = ierr)
! call aerr('dudy (ndkx)', ierr, ndkx) ; dudy = 0
! allocate ( dvdx (ndkx) , stat = ierr)
! call aerr('dvdx (ndkx)', ierr, ndkx) ; dudx = 0
! allocate ( dvdy (ndkx) , stat = ierr)
! call aerr('dvdy (ndkx)', ierr, ndkx) ; dudy = 0
! allocate ( rsi (ndkx) , stat = ierr)
! call aerr('rsi (ndkx)', ierr, ndkx) ; rsi = 0
! allocate ( rsiexact (ndkx) , stat = ierr)
! call aerr('rsiexact (ndkx)', ierr, ndkx) ; rsiexact = 0
! allocate ( uc3rsi (ndkx) , stat = ierr)
! call aerr('uc3rsi (ndkx)', ierr, ndkx) ; uc3rsi = 0
! endif
! Anti-creep
if ( jacreep == 1 .and. ( jasal > 0 .or. jatem > 0 .or. jased> 0 .or. stm_included ) ) then
if( allocated( dsalL ) ) then
deallocate( dsalL, dtemL )
endif
if( kmx >= 2 ) then
allocate ( dsalL(lnkx) , stat = ierr )
call aerr('dsalL(lnkx)', ierr, lnkx ) ; dsalL = 0
allocate ( dtemL(lnkx) , stat = ierr )
call aerr('dtemL(lnkx)', ierr, lnkx ) ; dtemL = 0
endif
endif
allocate ( uqcx(ndkx) , uqcy(ndkx) , stat = ierr)
call aerr('uqcx(ndkx) , uqcy(ndkx)', ierr, 2*ndkx) ; uqcx = 0 ; uqcy = 0
allocate ( ucxq(ndkx) , ucyq(ndkx) , stat = ierr)
call aerr('ucxq(ndkx) , ucyq(ndkx)', ierr, 2*ndkx) ; ucxq = 0 ; ucyq = 0
allocate ( qin (ndkx) , vih (ndkx) , stat = ierr)
call aerr('qin (ndkx) , vih (ndkx)', ierr, 2*ndkx) ; qin = 0 ; vih = 0
allocate ( dvxc(ndkx) , dvyc(ndkx) , stat = ierr)
call aerr('dvxc(ndkx) , dvyc(ndkx)', ierr, 2*ndkx) ; dvxc = 0 ; dvyc = 0
allocate ( cfli(ndkx) , stat=ierr )
call aerr('cfli(ndkx)', ierr, ndkx) ; cfli = 0
allocate ( squ (ndkx) , stat=ierr )
call aerr('squ (ndkx)', ierr, ndkx) ; squ = 0
if (kmx > 0 .and. (ja_timestep_auto == 3 .or. ja_timestep_auto == 4) ) then
allocate ( squ2D(ndkx) , stat=ierr )
call aerr('squ2D(ndkx)', ierr, ndkx) ; squ2D = 0
endif
allocate ( sqi (ndkx) , stat=ierr )
call aerr('sqi (ndkx)', ierr, ndkx) ; sqi = 0
allocate ( sq (ndkx) , stat=ierr )
call aerr('sq (ndkx)', ierr, ndx ) ; sq = 0
allocate ( vol0(ndkx) , stat = ierr)
call aerr('vol0(ndkx)', ierr, ndkx) ; vol0 = 0
allocate ( vol1(ndkx) , stat = ierr)
call aerr('vol1(ndkx)', ierr, ndkx) ; vol1 = 0
allocate ( volerror(ndkx) , stat = ierr)
call aerr('volerror(ndkx)', ierr, ndx) ; volerror = 0
if (allocated(voldhu)) deallocate (voldhu)
allocate ( voldhu(ndx) , stat = ierr)
call aerr('voldhu(ndx)' , ierr, lnx)
if (jsferic == 1) then
if (allocated (tidep) )deallocate(tidep)
allocate ( tidep (ndx) , stat = ierr)
call aerr('tidep (ndx)', ierr, ndx) ; tidep = 0
endif
call realloc(sqa, ndkx, keepExisting=.false., fill = 0d0, stat=ierr)
call aerr('sqa(ndkx)', ierr, ndx ) ; sqa = 0
if (kmx > 0) then ! 7 turbulence arrays (0:kmx)
if (allocated(turkin0) ) then
deallocate (turkin0, turkin1, tureps0, tureps1, tkepro, tkedis, vicwwu, vicwws)
endif
allocate ( turkin0 (Lnkx) , stat= ierr )
call aerr('turkin0 (Lnkx)', ierr, Lnkx ) ; turkin0 = 0
allocate ( turkin1 (Lnkx) , stat= ierr )
call aerr('turkin1 (Lnkx)', ierr, Lnkx ) ; turkin1 = epstke
allocate ( tureps0 (Lnkx) , stat= ierr )
call aerr('tureps0 (Lnkx)', ierr, Lnkx ) ; tureps0 = 0
allocate ( tureps1 (Lnkx) , stat= ierr )
call aerr('tureps1 (Lnkx)', ierr, Lnkx ) ; tureps1 = epseps
allocate ( tkepro (ndkx) , stat= ierr )
call aerr('tkepro (ndkx)', ierr, ndkx ) ; tkepro = 0
allocate ( tkedis (ndkx) , stat= ierr )
call aerr('tkedis (ndkx)', ierr, ndkx ) ; tkedis = 0
allocate ( vicwwu (Lnkx) , stat= ierr )
call aerr('vicwwu (Lnkx)', ierr, Lnkx ) ; vicwwu = 0
allocate ( vicwws (ndkx) , stat= ierr )
call aerr('vicwws (ndkx)', ierr, ndkx ) ; vicwws = 0
if (allocated (turkinepsws) ) then
deallocate (turkinepsws)
endif
allocate ( turkinepsws (2,ndkx) , stat= ierr )
call aerr('turkinepsws (2,ndkx)', ierr, ndkx ) ; turkinepsws = 0
if (allocated (sqcu) ) then
deallocate(sqcu, tqcu, eqcu)
endif
allocate ( sqcu(Ndkx) , stat= ierr )
call aerr('sqcu(Ndkx)', ierr, ndkx ) ; sqcu = 0
allocate ( tqcu(Ndkx) , stat= ierr )
call aerr('tqcu(Ndkx)', ierr, ndkx ) ; tqcu = 0
allocate ( eqcu(Ndkx) , stat= ierr )
call aerr('eqcu(Ndkx)', ierr, ndkx ) ; eqcu = 0
endif
! link related
if (allocated(cfuhi) ) then
deallocate(cfuhi, wdsu, u0,u1,q1,qa,v,ucxu,ucyu,hu, huvli, au, viu, cflj, tetaj, suu, advi, adve, plotlin, numlimdt)
endif
if (allocated (rhou) ) deallocate(rhou)
if (jawave == 3) then
call realloc(taubpu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('taubpu (lnx)', ierr, lnx)
call realloc(wavfu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('wavfu (lnx)', ierr, lnx)
call realloc(wavmu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('wavmu (lnx)', ierr, lnx)
call realloc(wavmubnd, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('wavmubnd (lnx)', ierr, lnx)
call realloc(taus, ndxi, stat=ierr, keepExisting = .false., fill = 0d0) ! in subroutine gettaus for jawave <= 2 ..
call aerr('taus (ndxi)', ierr, ndxi)
call realloc(hwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('hwav (ndx)', ierr, ndx)
call realloc(phiwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('phiwav (ndx)', ierr, ndx)
call realloc(sxwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sxwav (ndx)', ierr, ndx)
call realloc(sywav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sywav (ndx)', ierr, ndx)
call realloc(sbxwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sbxwav (ndx)', ierr, ndx)
call realloc(sbywav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sbywav (ndx)', ierr, ndx)
call realloc(uorbwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('uorbwav (ndx)', ierr, ndx)
call realloc(wlenwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('wlenwav (ndx)', ierr, ndx)
call realloc(mxwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('mxwav(ndx)', ierr, ndx)
call realloc(mywav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('mywav(ndx)', ierr, ndx)
call realloc(ustokes, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ustokes(lnx)', ierr, lnx)
call realloc(vstokes, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vstokes(lnx)', ierr, lnx)
call realloc(rlabda, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('rlabda(ndx)', ierr, ndx)
call realloc(taubmx, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('taubmx(ndx)', ierr, ndx)
call realloc(taubmy, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('taubmy(ndx)', ierr, ndx)
call realloc(phiu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('phiu(lnx)', ierr, lnx)
call realloc(hsu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('hsu(lnx)', ierr, lnx)
call realloc(bluf, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('bluf(lnx)', ierr, lnx)
call realloc(taubxu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('taubxu(lnx)', ierr, lnx)
call realloc(cvalu0, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cvalu0(lnx)', ierr, lnx)
call realloc(z0ucur, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('z0ucur(lnx)', ierr, lnx)
call realloc(dfu, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('dfu(lnx)', ierr, lnx)
call realloc(deltau, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('deltau(lnx)', ierr, lnx)
call realloc(ypar, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ypar(lnx)', ierr, lnx)
call realloc(cfwavhi, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cfwavhi(lnx)', ierr, lnx)
endif
if (jawave > 0) then
call realloc(uorb, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('uorb (ndx)', ierr, ndx)
call realloc(twav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('twav (ndx)', ierr, ndx)
endif
if (jawave .eq. 4) then ! JRE XBeach related
call realloc(ee0, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ee0 (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(ee1, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ee1 (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(cwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cwav (ndx)', ierr, ndx)
call realloc(cgwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cgwav (ndx)', ierr, ndx)
call realloc(kwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('kwav (ndx)', ierr, ndx)
call realloc(nwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('nwav (ndx)', ierr, ndx)
call realloc(ctheta, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ctheta (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(sigmwav, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigmwav (ndx)', ierr, ndx)
call realloc(sigt, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigt (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(ee1sum, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ee1sum (ndx)', ierr, ndx)
call realloc(horadvec, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('horadvec (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(thetaadvec, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetaadvec (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(rrhoradvec, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('rrhoradvec (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(rrthetaadvec, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('rrthetaadvec (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(rr, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('rr (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(H, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('H (ndx)', ierr, ndx)
call realloc(E, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('E (ndx)', ierr, ndx)
call realloc(DR, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('DR (ndx)', ierr, ndx)
call realloc(R, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('R (ndx)', ierr, ndx)
call realloc(rr, (/ntheta,ndx/), stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('rr (ntheta,ndx)', ierr, ntheta*ndx)
call realloc(Sxx, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Sxx (ndx)', ierr, ndx)
call realloc(Syy, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Syy (ndx)', ierr, ndx)
call realloc(Sxy, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Sxy (ndx)', ierr, ndx)
call realloc(Fx, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fx (lnx)', ierr, lnx)
call realloc(Fy, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fy (lnx)', ierr, lnx)
call realloc(urms, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('urms (lnx)', ierr, lnx)
call realloc(ust, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ust (lnx)', ierr, lnx)
call realloc(vst, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vst (lnx)', ierr, lnx)
call realloc(thetamean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean (ndx)', ierr, ndx)
call realloc(Qb, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Qb (ndx)', ierr, ndx)
call realloc(D, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('D (ndx)', ierr, ndx)
call realloc(BR, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('BR (ndx)', ierr, ndx)
call realloc(uin, nbndu, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('uin (nbndu)', ierr, nbndu)
call realloc(vin, nbndu, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vin (nbndu)', ierr, nbndu)
call realloc(bi, nbndw, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('bi (nbndw)', ierr, nbndw)
call realloc(L1, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('L1 (ndx)', ierr, ndx)
call realloc(Ltemp, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Ltemp (ndx)', ierr, ndx)
call realloc(L0, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('L0 (ndx)', ierr, ndx)
call realloc(khdisp, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('khdisp (ndx)', ierr, ndx)
call realloc(hdisp, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('hdisp (ndx)', ierr, ndx)
if (jaavgwavquant .eq. 1) then !! arrays for statistical output wave quantities
call realloc(E_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('E_mean (ndx)', ierr, ndx)
call realloc(E_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('E_var (ndx)', ierr, ndx)
call realloc(E_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('E_min (ndx)', ierr, ndx)
call realloc(E_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('E_max (ndx)', ierr, ndx)
call realloc(E_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('E_varcross (ndx)', ierr, ndx)
call realloc(E_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('E_varsquare (ndx)', ierr, ndx)
call realloc(H_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('H_mean (ndx)', ierr, ndx)
call realloc(H_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('H_var (ndx)', ierr, ndx)
call realloc(H_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('H_min (ndx)', ierr, ndx)
call realloc(H_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('H_max (ndx)', ierr, ndx)
call realloc(H_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('H_varcross (ndx)', ierr, ndx)
call realloc(H_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('H_varsquare (ndx)', ierr, ndx)
call realloc(R_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('R_mean (ndx)', ierr, ndx)
call realloc(R_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('R_var (ndx)', ierr, ndx)
call realloc(R_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('R_min (ndx)', ierr, ndx)
call realloc(R_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('R_max (ndx)', ierr, ndx)
call realloc(R_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('R_varcross (ndx)', ierr, ndx)
call realloc(R_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('R_varsquare (ndx)', ierr, ndx)
call realloc(D_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('D_mean (ndx)', ierr, ndx)
call realloc(D_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('D_var (ndx)', ierr, ndx)
call realloc(D_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('D_min (ndx)', ierr, ndx)
call realloc(D_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('D_max (ndx)', ierr, ndx)
call realloc(D_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('D_varcross (ndx)', ierr, ndx)
call realloc(D_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('D_varsquare (ndx)', ierr, ndx)
call realloc(DR_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('DR_mean (ndx)', ierr, ndx)
call realloc(DR_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('DR_var (ndx)', ierr, ndx)
call realloc(DR_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('DR_min (ndx)', ierr, ndx)
call realloc(DR_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('DR_max (ndx)', ierr, ndx)
call realloc(DR_varcross, ndx, stat=ierr, keepExisting = .false., fill = tiny(0d0))
call aerr('DR_varcross (ndx)', ierr, ndx)
call realloc(DR_varsquare, ndx, stat=ierr, keepExisting = .false., fill = tiny(0d0))
call aerr('DR_varsquare (ndx)', ierr, ndx)
call realloc(ust_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ust_mean (lnx)', ierr, lnx)
call realloc(ust_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ust_var (lnx)', ierr, lnx)
call realloc(ust_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('ust_min (lnx)', ierr, lnx)
call realloc(ust_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('ust_max (lnx)', ierr, lnx)
call realloc(ust_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ust_varcross (lnx)', ierr, lnx)
call realloc(ust_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('ust_varsquare (lnx)', ierr, lnx)
call realloc(vst_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vst_mean (lnx)', ierr, lnx)
call realloc(vst_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vst_var (lnx)', ierr, lnx)
call realloc(vst_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('vst_min (lnx)', ierr, lnx)
call realloc(vst_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('vst_max (lnx)', ierr, lnx)
call realloc(vst_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vst_varcross (lnx)', ierr, lnx)
call realloc(vst_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('vst_varsquare (lnx)', ierr, lnx)
call realloc(urms_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('urms_mean (lnx)', ierr, lnx)
call realloc(urms_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('urms_var (lnx)', ierr, lnx)
call realloc(urms_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('urms_min (lnx)', ierr, lnx)
call realloc(urms_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('urms_max (lnx)', ierr, lnx)
call realloc(urms_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('urms_varcross (lnx)', ierr, lnx)
call realloc(urms_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('urms_varsquare (lnx)', ierr, lnx)
call realloc(thetamean_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_mean (ndx)', ierr, ndx)
call realloc(thetamean_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_var (ndx)', ierr, ndx)
call realloc(thetamean_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('thetamean_min (ndx)', ierr, ndx)
call realloc(thetamean_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('thetamean_max (ndx)', ierr, ndx)
call realloc(thetamean_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_varcross (ndx)', ierr, ndx)
call realloc(thetamean_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_varsquare (ndx)', ierr, ndx)
call realloc(thetamean_sin, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_sin (ndx)', ierr, ndx)
call realloc(thetamean_cos, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('thetamean_cos (ndx)', ierr, ndx)
call realloc(sigmwav_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigmwav_mean (ndx)', ierr, ndx)
call realloc(sigmwav_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigmwav_var (ndx)', ierr, ndx)
call realloc(sigmwav_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('sigmwav_min (ndx)', ierr, ndx)
call realloc(sigmwav_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('sigmwav_max (ndx)', ierr, ndx)
call realloc(sigmwav_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigmwav_varcross (ndx)', ierr, ndx)
call realloc(sigmwav_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('sigmwav_varsquare (ndx)', ierr, ndx)
call realloc(cwav_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cwav_mean (ndx)', ierr, ndx)
call realloc(cwav_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cwav_var (ndx)', ierr, ndx)
call realloc(cwav_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('cwav_min (ndx)', ierr, ndx)
call realloc(cwav_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('cwav_max (ndx)', ierr, ndx)
call realloc(cwav_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cwav_varcross (ndx)', ierr, ndx)
call realloc(cwav_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cwav_varsquare (ndx)', ierr, ndx)
call realloc(cgwav_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cgwav_mean (ndx)', ierr, ndx)
call realloc(cgwav_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cgwav_var (ndx)', ierr, ndx)
call realloc(cgwav_min, ndx, stat=ierr, keepExisting = .false., fill =huge(0d0))
call aerr('cgwav_min (ndx)', ierr, ndx)
call realloc(cgwav_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('cgwav_max (ndx)', ierr, ndx)
call realloc(cgwav_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cgwav_varcross (ndx)', ierr, ndx)
call realloc(cgwav_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('cgwav_varsquare (ndx)', ierr, ndx)
call realloc(s1_mean, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('s1_mean (ndx)', ierr, ndx)
call realloc(s1_var, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('s1_var (ndx)', ierr, ndx)
call realloc(s1_min, ndx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('s1_min (ndx)', ierr, ndx)
call realloc(s1_max, ndx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('s1_max (ndx)', ierr, ndx)
call realloc(s1_varcross, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('s1_varcross (ndx)', ierr, ndx)
call realloc(s1_varsquare, ndx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('s1_varsquare (ndx)', ierr, ndx)
call realloc(Fx_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fx_mean (lnx)', ierr, lnx)
call realloc(Fx_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fx_var (lnx)', ierr, lnx)
call realloc(Fx_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('Fx_min (lnx)', ierr, lnx)
call realloc(Fx_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('Fx_max (lnx)', ierr, lnx)
call realloc(Fx_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fx_varcross (lnx)', ierr, lnx)
call realloc(Fx_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fx_varsquare (lnx)', ierr, lnx)
call realloc(Fy_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fy_mean (lnx)', ierr, lnx)
call realloc(Fy_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fy_var (lnx)', ierr, lnx)
call realloc(Fy_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('Fy_min (lnx)', ierr, lnx)
call realloc(Fy_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('Fy_max (lnx)', ierr, lnx)
call realloc(Fy_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fy_varcross (lnx)', ierr, lnx)
call realloc(Fy_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('Fy_varsquare (lnx)', ierr, lnx)
call realloc(u_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('u_mean (lnx)', ierr, lnx)
call realloc(u_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('u_var (lnx)', ierr, lnx)
call realloc(u_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('u_min (lnx)', ierr, lnx)
call realloc(u_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('u_max (lnx)', ierr, lnx)
call realloc(u_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('u_varcross (lnx)', ierr, lnx)
call realloc(u_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('u_varsquare (lnx)', ierr, lnx)
call realloc(v_mean, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('v_mean (lnx)', ierr, lnx)
call realloc(v_var, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('v_var (lnx)', ierr, lnx)
call realloc(v_min, lnx, stat=ierr, keepExisting = .false., fill = huge(0d0))
call aerr('v_min (lnx)', ierr, lnx)
call realloc(v_max, lnx, stat=ierr, keepExisting = .false., fill = -1d0*huge(0d0))
call aerr('v_max (lnx)', ierr, lnx)
call realloc(v_varcross, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('v_varcross (lnx)', ierr, lnx)
call realloc(v_varsquare, lnx, stat=ierr, keepExisting = .false., fill = 0d0)
call aerr('v_varsquare (lnx)', ierr, lnx)
end if
end if
if (allocated(frcu) ) then
deallocate (frcu)
endif
if (allocated(ifrcutp) ) then
deallocate (ifrcutp)
endif
if (allocated(cftrt) ) then
deallocate (cftrt)
endif
if (allocated(czs) ) then
deallocate (czs)
endif
allocate ( cfuhi(lnx) , stat=ierr) ! hk: hier stond + 1, heb ik weggehaald
call aerr('cfuhi(lnx)' , ierr, lnx) ; cfuhi = 0
allocate ( frcu (lnx) , stat = ierr)
call aerr('frcu (lnx)' , ierr, ndx) ; frcu = dmiss
allocate ( ifrcutp(lnx) , stat = ierr)
call aerr('ifrcutp(lnx)' , ierr, ndx) ; ifrcutp = abs(ifrctypuni)
allocate ( wdsu (lnx) , stat=ierr )
call aerr('wdsu (lnx)' , ierr, lnx ) ; wdsu = 0
if (jatrt.eq.1) then
allocate ( cftrt(numl,3) , stat=ierr)
call aerr('cftrt(numl,3)' , ierr, numl) ; cftrt = 0
end if
if (jamapchezy > 0) then
allocate ( czs(ndx) , stat=ierr)
call aerr('czs(ndx)' , ierr, ndx) ; czs = 0
endif
if (allocated (frculin) ) then
deallocate (frculin)
endif
allocate ( frculin (lnx) , stat = ierr)
call aerr('frculin (lnx)' , ierr, ndx) ; frculin = dmiss
allocate ( u0 (lnkx) , stat = ierr)
call aerr('u0 (lnkx)', ierr , lnkx ) ; u0 = 0
allocate ( u1 (lnkx) , stat = ierr)
call aerr('u1 (lnkx)', ierr , lnkx ) ; u1 = 0
allocate ( q1 (lnkx) , stat = ierr)
call aerr('q1 (lnkx)', ierr , lnkx ) ; q1 = 0
allocate ( qa (lnkx) , stat = ierr)
call aerr('qa (lnkx)', ierr , lnkx ) ; qa = 0
allocate ( v (lnkx) , stat = ierr)
call aerr('v (lnkx)', ierr , lnkx ) ; v = 0
allocate ( ucxu (lnkx) , stat = ierr)
call aerr('ucxu (lnkx)', ierr , lnkx ) ; ucxu = 0
allocate ( ucyu (lnkx) , stat = ierr)
call aerr('ucyu (lnkx)', ierr , lnkx ) ; ucxu = 0
allocate ( hu (lnkx) , stat = ierr)
call aerr('hu (lnkx)', ierr , lnkx ) ; hu = 0
allocate ( huvli(lnkx) , stat =ierr )
call aerr('huvli(lnkx)', ierr, lnkx ) ; huvli = 0
allocate ( au (lnkx) , stat = ierr)
call aerr('au (lnkx)', ierr , lnkx ) ; au = 0
allocate ( viu (lnkx) , stat =ierr )
call aerr('viu (lnkx)', ierr, lnkx ) ; viu = 0
allocate ( cflj (lnkx) , stat =ierr )
call aerr('cflj (lnkx)', ierr, lnkx ) ; cflj = 0
allocate ( tetaj(lnkx) , stat =ierr )
call aerr('tetaj(lnkx)', ierr, lnkx ) ; tetaj = 0
allocate ( suu (lnkx) , stat = ierr)
call aerr('suu (lnkx)', ierr , lnkx ) ; suu = 0
allocate ( advi (lnkx) , stat = ierr)
call aerr('advi (lnkx)', ierr , lnkx ) ; advi = 0
allocate ( adve (lnkx) , stat = ierr)
call aerr('adve (lnkx)', ierr , lnkx ) ; adve = 0
if (jarhoxu > 0) then
allocate ( rhou (lnkx) , stat = ierr)
call aerr('rhou (lnkx)', ierr , lnkx ) ; rhou = rhomean
endif
allocate ( plotlin(max(lnkx,ndkx)) , stat = ierr)
call aerr('plotlin(max(lnkx,ndkx))', ierr , lnkx ) ; plotlin = 0
allocate ( numlimdt(ndx) , stat = ierr)
call aerr('numlimdt(ndx)', ierr , ndx ) ; numlimdt = 0
! solving related
if (allocated(fu) ) then
deallocate(fu, ru, bb, dd)
endif
allocate ( bb (ndx ) , stat = ierr)
call aerr('bb (ndx )', ierr, ndx) ; bb = 0
allocate ( dd (ndx ) , stat = ierr)
call aerr('dd (ndx )', ierr, ndx) ; dd = 0
allocate ( fu (lnkx) , stat = ierr)
call aerr('fu (lnkx)', ierr, ndx) ; fu = 0
allocate ( ru (lnkx) , stat = ierr)
call aerr('ru (lnkx)', ierr, ndx) ; ru = 0
if (jasal > 0 .or. kmx > 0) then
if ( .not. allocated (sa1) .or. size (sa1) .ne. ndkx) then
if (allocated (sa1) ) deallocate (sa1)
allocate ( sa1 (ndkx) , stat = ierr)
call aerr('sa1 (ndkx)', ierr, ndkx) ; sa1 = salini
endif
if ( .not. allocated (supq) .or. size (supq) .ne. ndkx) then
if ( allocated (supq) ) deallocate (supq, qsho)
allocate ( supq(ndkx), qsho(lnkx) , stat = ierr)
call aerr('supq(ndkx), qsho(lnkx) ', ierr, ndkx)
endif
if (allocated (sam0) ) deallocate (sam0, sam1, same)
allocate (sam0(ndkx), sam1(ndkx), same(ndkx) ) ; sam0 = 0 ; sam1 = 0 ; same = 0
jasalsrc = 1
if (jasalsrc > 0) then
if (allocated (salsrc) ) deallocate (salsrc)
allocate ( salsrc(ndkx) , stat = ierr)
call aerr('salsrc(ndkx)', ierr, ndkx) ; salsrc = 0d0
endif
endif
if (jatem > 0) then
if ( .not. allocated (tem1) .or. size (tem1) .ne. ndkx) then
if ( allocated (tem1) ) deallocate (tem1)
allocate ( tem1(ndkx) , stat = ierr)
call aerr('tem1(ndkx) ', ierr, 2*ndkx) ; tem1 = temini
endif
if ( .not. allocated (tupq) .or. size (tupq) .ne. ndkx) then
if ( allocated (tupq) ) deallocate (tupq, qtho, heatsrc, heatsrc0)
allocate ( tupq(ndkx), qtho(lnkx), heatsrc(ndkx), heatsrc0(ndkx) , stat = ierr) ; heatsrc = 0d0 ; heatsrc0 = 0d0
call aerr('tupq(ndkx), qtho(lnkx), heatsrc(ndkx), heatsrc0(ndkx)', ierr, ndkx)
endif
if (jatem > 1) then ! also heat modelling involved
if ( allocated (tair) ) deallocate (tair, rhum, clou)
allocate ( tair(ndx), rhum(ndx), clou(ndx) , stat = ierr)
call aerr('tair(ndx), rhum(ndx), clou(ndx)', ierr, 3*ndx)
tair = backgroundairtemperature
rhum = backgroundhumidity
clou = backgroundcloudiness
if ( allocated (qrad) ) deallocate (qrad)
allocate ( qrad(ndx) , stat = ierr)
call aerr('qrad(ndx)', ierr, ndx)
qrad = 0d0
endif
if (jatem == 5) then ! save cd coeff if heat modelling also involved
if (allocated (cdwcof) ) deallocate(cdwcof)
allocate ( cdwcof(lnx) , stat = ierr)
call aerr('cdwcof(lnx)', ierr , lnx) ; cdwcof = 0d0
if (jamapheatflux > 0) then ! map output
if (allocated(qsunmap)) deallocate (Qsunmap, Qevamap, Qconmap, Qlongmap, Qfrevamap, Qfrconmap, Qtotmap)
allocate ( Qsunmap(ndx) , stat = ierr) ; Qsunmap = 0d0
call aerr('Qsunmap(ndx)' , ierr , ndx )
allocate ( Qevamap(ndx) , stat = ierr) ; Qevamap = 0d0
call aerr('Qevamap(ndx)' , ierr , ndx )
allocate ( Qconmap(ndx) , stat = ierr) ; Qconmap = 0d0
call aerr('Qconmap(ndx)' , ierr , ndx )
allocate ( Qlongmap(ndx) , stat = ierr) ; Qlongmap = 0d0
call aerr('Qlongmap(ndx)' , ierr , ndx )
allocate ( Qfrevamap(ndx) , stat = ierr) ; Qfrevamap = 0d0
call aerr('Qfrevamap(ndx)', ierr , ndx )
allocate ( Qfrconmap(ndx) , stat = ierr) ; Qfrconmap = 0d0
call aerr('Qfrconmap(ndx)', ierr , ndx )
allocate ( Qtotmap(ndx) , stat = ierr) ; Qtotmap = 0d0
call aerr('Qtotmap(ndx)' , ierr , ndx )
endif
endif
endif
if (jased > 0 .and. .not. stm_included) then
if ( allocated (sed) ) deallocate (sed, sdupq, grainlay)
allocate ( sed (mxgr,ndkx) , sdupq (mxgr,ndkx) , stat = ierr)
call aerr('sed (mxgr,ndkx) , sdupq (mxgr,ndkx)' , ierr, 2*ndkx*mxgr)
do k = 1,ndkx
do j = 1,mxgr
sed(j,k) = sedini(j)
enddo
enddo
if (jaceneqtr == 1) then ! cell centre equilibrium transport concentration
mxn = ndx
if (allocated(blinc)) deallocate(blinc)
allocate ( blinc(ndx) , stat=ierr)
call aerr ('blinc(ndx)', ierr , ndx) ; blinc = 0d0
else ! cell corner equilibrium transport concentration
mxn = numk
if (allocated(sedi)) deallocate(sedi)
allocate ( sedi(mxgr,ndkx) , stat = ierr)
call aerr('sedi(mxgr,ndkx)' , ierr, ndkx*mxgr) ; sedi = 0d0
endif
allocate ( grainlay(mxgr,mxn) , stat=ierr)
call aerr('grainlay(mxgr,mxn)', ierr, mxgr*mxn); grainlay = 0d0
!if ( allocated (tauu) ) deallocate (taucx,taucy,tauu)
!allocate ( taucx(ndx) , stat=ierr)
!call aerr('taucx(ndx)', ierr, ndx); taucx = 0d0
!allocate ( taucy(ndx) , stat=ierr)
!call aerr('taucy(ndx)', ierr, ndx); taucy = 0d0
!allocate ( tauu (lnx) , stat=ierr)
!call aerr('tauu (lnx)', ierr, ndx); tauu = 0d0
endif
if (idensform > 0 .and. jaRichardsononoutput > 0) then
if (allocated (rich) ) deallocate(rich)
allocate ( rich(lnkx) , stat=ierr)
call aerr ('rich(lnkx)', ierr , ndkx) ; rich = 0d0
else
jaRichardsononoutput = 0
endif
if (ti_waq > 0) then
call realloc(q1waq, lnkx, keepExisting = .false., fill = 0d0, stat = ierr)
if (kmx > 0) then
call realloc(qwwaq, ndkx, keepExisting = .false., fill = 0d0, stat = ierr)
end if
end if
if ( itstep.eq.4 ) then ! explicit time-step
if ( allocated(sqwave) ) deallocate(sqwave)
allocate ( sqwave (ndx) , stat=ierr )
call aerr('sqwave (ndx)', ierr, ndx) ; sqwave = 0
end if
if (jagrw > 0) then
if (allocated (sgrw0) ) deallocate (sgrw0, sgrw1, pgrw)
allocate ( sgrw0(ndx) , stat=ierr)
call aerr ('sgrw0(ndx)', ierr , ndx) ; sgrw0 = 0d0
allocate ( sgrw1(ndx) , stat=ierr)
call aerr ('sgrw1(ndx)', ierr , ndx) ; sgrw1 = 0d0
allocate ( pgrw (ndx) , stat=ierr)
call aerr ('pgrw (ndx)', ierr , ndx) ; pgrw = 0d0
endif
if (jarain > 0) then
call realloc(rain, ndx, keepExisting = .false., fill = 0d0, stat = ierr)
end if
call realloc(shL, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('shL(2)', ierr, 2)
call realloc(shB, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('shB(2)', ierr, 2)
call realloc(shd, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('shd(2)', ierr, 2)
call realloc(stuw, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('stuw(2)', ierr, 2)
call realloc(fstuw, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('fstuw(2)', ierr, 2)
call realloc(stuwmx, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('stuwmx(2)', ierr, 2)
call realloc(roer, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('roer(2)', ierr, 2)
call realloc(froer, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('froer(2)', ierr, 2)
call realloc(roermx, 2, keepExisting = .false., fill = 0d0, stat = ierr)
call aerr('roermx(2)', ierr, 2)
! for Jan's weirs
if ( javillemonte.eq.1 ) then
call realloc(weircont, Lnx, keepExisting=.false., fill=1d0, stat=ierr)
call aerr ('weircont', ierr, Lnx)
call realloc(weircos, Lnx, keepExisting=.false., fill=1d0, stat=ierr)
call aerr ('weircos', ierr, Lnx)
call realloc(weirdte, Lnx, keepExisting=.false., fill=0d0, stat=ierr)
call aerr ('weirdte', ierr, Lnx)
end if
if (ifixedweirscheme == 8) then ! Tabellenboek
call realloc(weirdte, Lnx, keepExisting=.false., fill=0d0, stat=ierr)
call aerr ('weirdte', ierr, Lnx)
endif
end subroutine flow_allocflow
subroutine setkbotktop(jazws0) ! initialise vertical coordinates
use m_netw
use m_flowgeom
use m_flow
use m_flowtimes
implicit none
integer :: jazws0
integer :: k2, kb, k, n, kk, nL, nR, nlayb, nlayt, nrlay, ktx, kL, ndz, i
integer :: ktmn, ktmx, kt0, kt1, kt2, kt3, LL, L, Lb, Lt, n1,n2, kb1,kb2,ki,kt, kkk, Ltn, Ldn
double precision :: zkk, h0, zks, zkz, sigm, hdz, toplaymint, volkt, savolkt, dtopsi
double precision :: w1, w2, w3, h1, h2, h3, dz1, dz2, dz3, zw1, zw2, zw3, bL1, bL2, bL3, ht1, ht2, ht3
integer :: k1, k3, kb3, Lt1, Lt2, Lt3, Ld1, Ld2, Ld3, kk1, kk2, kk3, numtopsig2
integer :: numbd, numtp, j
double precision :: drhok, dzk, a, aa, h00, zsl, aaa, sig, dsig, dsig0
if (kmx == 0) return
zws0 = zws
ktop0 = ktop
vol1 = 0d0
nL = 1
nR = 2
if (Layertype == 1) then ! sigma only
do n = 1,ndx
kb = kbot(n)
! zws(kb-1) = bl(n)
h0 = s1(n) - zws(kb-1) ! bl(n)
do k = 1, kmxn(n)
kk = kb + k - 1
zws(kk) = zws(kb-1) + h0*zslay(k,1)
vol1(kk) = ba(n)*(zws(kk) - zws(kk-1)) ! just for now here
vol1(n) = vol1(n) + vol1(kk)
enddo
ktop(n) = kb - 1 + kmxn(n)
enddo
return ! sigma only: quick exit
else if (Layertype == 4) then ! density controlled sigma
dkx = 0.5d0
do n = 1,ndx
drhok = 0.01d0
kb = kbot(n) ; kt = kb - 1 + kmxn(n) ; ktop(n) = kt
do k = kb+1,kt
if ( abs(rho(k) - rho(k-1)) > drhok ) then
drhok = abs( rho(k) - rho(k-1) )
dkx(n) = dble(k - kb) / dble(kt - kb + 1)
dkx(n) = min( 0.8d0, dkx(n) )
dkx(n) = max( 0.2d0, dkx(n) )
endif
enddo
enddo
do j = 1, 10
sdkx = 0d0
do L = 1,Lnx
k1 = ln(1,L) ; k2 = ln(2,L)
sdkx(k1) = sdkx(k1) + dkx(k2)
sdkx(k2) = sdkx(k2) + dkx(k1)
enddo
a = 0.25d0
do n = 1,ndx
dkx(n) = a*dkx(n) + (1d0-a)*sdkx(n) / dble(nd(n)%lnx)
enddo
enddo
numbd = 0.5d0*kmx ; numtp = kmx - numbd ; aaa = 1.05d0 ; aa = min(1d0, exp(-dts/Tsigma) )
dkx = 0.5d0
do n = 1,ndx
call getkbotktop(n,kb,kt)
h0 = s1(n) - zws(kb-1) ; h00 = max(epshu, zws0(kt) - zws0(kb-1) ) ; sig = 0d0
dsig0 = 0.1d0/dble(numtp)
do k = 1, kmxn(n)
if (k == 1) then
dsig = dkx(n)*(1d0-aaa) / (1d0-aaa**numbd)
dsig = dsig*aaa**(numbd-1)
else if ( k <= numbd ) then
dsig = dsig / aaa
else if (k == numbd + 1) then
dsig = (1d0-sig)*(1d0-aaa) / (1d0-aaa**numtp)
else
dsig = dsig*aaa
endif
!if (k == 1) then
! dsig = dkx(n) / numbd
!else if ( k <= numbd ) then
!
!else if (k == numbd + 1) then
! aaa = ( (1d0-dkx(n))**(1d0/dble(numbd)) - dsig0 ) / dsig0
! dsig = dsig0
!else
! dsig = dsig*(1d0 + a)
!endif
sig = sig + dsig
kk = kb + k - 1
if ( k == kmxn(n) ) then
zws(kk) = s1(n)
else
if (jazws0 == 1) then
zsl = zslay(k,1)
else
zsl = (1d0-aa)*sig + aa*(zws0(kk) - zws0(kb-1) ) / h00
endif
zws(kk) = zws(kb-1) + h0*zsl
endif
vol1(kk) = ba(n)*(zws(kk) - zws(kk-1)) ! just for now here
vol1(n) = vol1(n) + vol1(kk)
enddo
enddo
return ! sigma only: quick exit
else if (Layertype == 2) then ! z only
! toplayminthick = 0.5d0*( zslay(1,1) - zslay(0,1) )
numtopsig2 = numtopsig / 2
do n = 1,ndx
kb = kbot(n)
ktx = kb + kmxn(n) - 1
! zws(kb-1) = bl(n)z
call getzlayerindices(n,nlayb,nrlay)
! zws(kb-1) = zslay(nlayb-1,1)
do k = kb, ktx
kk = k - kb + nlayb
zkk = zslay(kk,1)
if (zkk < s1(n) - toplayminthick .and. k < ktx ) then
zws(k) = zkk
else
zws(k) = s1(n)
ktop(n) = k
if (ktx > k) then
zws (k+1:ktx) = zws(k)
endif
exit
endif
enddo
if (numtopsig > 0) then
kt1 = max(kb-1, ktx - numtopsig )
if ( ktop(n) > kt1 + 1) then
h0 = s1(n) - zws(kt1)
dtopsi = 1d0/dble(ktx - kt1)
do k = kt1 + 1, ktx
kk = k - kt1
zws(k) = zws(kt1) + h0*dble(kk)*dtopsi
enddo
ktop(n) = ktx
endif
endif
enddo
else if (Layertype == 3) then ! mix : first do sigma and z
do n = 1,ndx
kb = kbot(n)
Ldn = laydefnr(n)
if (Ldn > 0) then
! zws(kb-1) = bl(n)
if (Laytyp(Ldn) == 1) then ! sigma
h0 = s1(n) - zws(kb-1) ! bl(n)
do k = 1, kmxn(n) - 1
zws(kb + k - 1) = zws(kb-1) + h0*zslay(k,Ldn)
enddo
ktop(n) = kb + kmxn(n) - 1
zws(ktop(n)) = s1(n)
else if (Laytyp(Ldn) == 2) then ! z
ktx = kb + kmxn(n) - 1
call getzlayerindices(n,nlayb,nrlay)
toplayminthick = 0.5d0*( zslay(2,1) - zslay(1,1) )
do k = kb, ktx
kk = k - kb + nlayb
zkk = zslay(kk,Ldn)
if (zkk < s1(n) - toplayminthick .and. k < ktx ) then
zws(k) = zkk
else
zws(k) = s1(n)
ktop(n) = k
if (ktx > k) then
zws (k+1:ktx) = zws(k)
endif
exit
endif
enddo
endif
endif
enddo
endif
do n = 1,ndx
kb = kbot(n)
ktx = kb - 1 + kmxn(n)
! zws(kb-1) = bl(n)
if (laydefnr(n) == 0) then ! overlap zone
w1 = wflaynod(1,n) ; w2 = wflaynod(2,n) ; w3 = wflaynod(3,n)
k1 = indlaynod(1,n) ; k2 = indlaynod(2,n) ; k3 = indlaynod(3,n)
kb1 = kbot(k1) ; kb2 = kbot(k2) ; kb3 = kbot(k3)
bL1 = zws(kb1-1) ; bL2 = zws(kb2-1) ; bL3 = zws(kb3-1)
h1 = s1(k1)-bL1 ; h2 = s1(k2)-bL2 ; h3 = s1(k3)-bL3 ; h0 = s1(n)-zws(kb-1)
kt1 = ktop(k1) ; kt2 = ktop(k2) ; kt3 = ktop(k3)
ht1 = zws(kt1)-zws(kt1-1)
ht2 = zws(kt2)-zws(kt2-1)
ht3 = zws(kt3)-zws(kt3-1)
!Ld1 = laydefnr(k1) ; Ld2 = laydefnr(k2) ; Ld3 = laydefnr(k3)
!dz1 = 0d0 ; dz2 = 0d0 ; dz3 = 0d0
!if (laytyp(Ld1) == 2) dz1 = 0.5d0*zslay(2,Ld1) - zslay(1,Ld1)
!if (laytyp(Ld2) == 2) dz2 = 0.5d0*zslay(2,Ld2) - zslay(1,Ld2)
!if (laytyp(Ld3) == 2) dz3 = 0.5d0*zslay(2,Ld3) - zslay(1,Ld3)
!toplaymint = w1*dz1 + w2*dz2 + w3*dz3
toplaymint = 0.1d0 ! 0.5d0*min(ht1,ht2,ht3)
do k = 1, kmxn(n)
kk = kb + k - 1
kk1 = kb1 + k - 1
if ( kk1 > kt1 ) then
! zw1 = 2d0*zws(kt1) - zws(kt1-1)
! zw1 = zw1 + 0.5d0*(ht2 + ht3)
zw1 = zw1 + min (zw2,zw3)
else
zw1 = ( zws(kk1)-bL1 ) / h1
endif
kk2 = kb2 + k - 1
if ( kk2 > kt2 ) then
! zw2 = 2d0*zws(kt2) - zws(kt2-1)
! zw2 = zw2 + 0.5d0*(ht1 + ht3)
zw2 = zw2 + min(zw1,zw3)
else
zw2 = ( zws(kk2)-bL2 ) / h2
endif
kk3 = kb3 + k - 1
if ( kk3 > kt3 ) then
! zw3 = 2d0*zws(kt3) - zws(kt3-1)
! zw3 = zw3 + 0.5d0*(ht1 + ht2)
zw3 = zw3 + min(zw1,zw2)
else
zw3 = ( zws(kk3)-bL3 ) / h3
endif
zkk = zws(kb-1) + (w1*zw1 + w2*zw2 + w3*zw3) * h0
!sigm = dble(k) / dble( kmxn(n) )
!zkk = bl(n) + h0*sigm
if (zkk < s1(n) - toplaymint .and. k < kmxn(n) ) then
zws(kk) = zkk
else
zws(kk) = s1(n)
ktop(n) = kk
if (ktx > kk) then
zws (kk+1:ktx) = zws(kk)
endif
exit
endif
enddo
endif
kt = ktop(n)
kkk = kt - kb + 1 ! nr of layers
if (kkk >= 2 .and. sigmagrowthfactor > 0) then ! bedlayers equal thickness
! zws(kb) = 0.5d0*(zws(kb+1) + zws(kb-1))
endif
if (kkk >= 3) then
! zws(kt-1) = 0.5d0*(zws(kt) + zws(kt-2)) ! toplayers equal thickness
endif
do kk = kb,kt ! x
vol1(kk) = ba(n)*(zws(kk) - zws(kk-1)) ! just for now here
vol1(n) = vol1(n) + vol1(kk)
enddo
kt0 = ktop0(n)
if (kt0 > kt) then
volkt = vol0(kt)
savolkt = volkt*sa1(kt)
do kkk = kt0 , kt+1, -1 ! old volumes above present ktop are lumped in ktop
volkt = volkt + vol0(kkk)
vol0(kt) = volkt
savolkt = savolkt + vol0(kkk)*sa1(kkk)
vol0(kkk) = 0d0
enddo
if (volkt > 0) then
sa1(kt) = savolkt/volkt
if (ktx > kt) then
sa1(kt+1:ktx) = sa1(kt)
endif
endif
else if (kt0 < kt) then
! do kkk = kt0 + 1, kt
! vol1(kt0) = vol1(kt0) + vol1(kkk)
! sq (kt0) = sq(kt0) + sq (kkk)
! enddo
endif
enddo
if (jazws0 == 1) then ! at initialise, store zws in zws0
zws0 = zws
endif
if (layertype > 1) then ! ln does not change in sigma only
do LL = 1,Lnx
n1 = ln(1,LL) ; n2 = ln(2,LL)
kt1 = ktop(n1) ; kt2 = ktop(n2)
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
ln(1,L) = min(ln0(1,L), kt1)
ln(2,L) = min(ln0(2,L), kt2)
enddo
enddo
endif
end subroutine setkbotktop
subroutine setsigmabnds()
use m_netw
use m_flowgeom
use m_flow
implicit none
integer :: i, k, ki, kb, kt, itrac
if (layertype == 2) return
if ( kmx.eq.0 ) then ! 2D, set dummy values
if ( allocated(sigmabnds) ) sigmabnds = 0d0
if ( allocated(sigmabndTM) ) sigmabndTM = 0d0
! if ( allocated(sigmabndtr) ) sigmabndtr = 0d0
else ! 3D
do i = 1, nbnds
ki = kbnds(2,i)
call getkbotktop(ki,kb,kt)
do k = kb, kt
sigmabnds(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / max(epshs, (zws(kt)-zws(kb-1)) )
end do
! if ( zws(kt)-zws(kb-1) .gt. epshs ) then
! do k = kb, kt
! sigmabnds(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / (zws(kt)-zws(kb-1))
! end do
!else ! fix for dry points
! do k = kb, kt
! sigmabnds(kmx*(i-1)+k-kb+1) = dble(k-kb)/dble(kt-kb) ! hk: this goes wrong if kt==kb
! end do
!end if
end do
do i = 1, nbndTM
ki = kbndTM(2,i)
call getkbotktop(ki,kb,kt)
do k = kb, kt
sigmabndTM(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / max(epshs, (zws(kt)-zws(kb-1)) )
end do
! if ( zws(kt)-zws(kb-1) .gt. epshs ) then
! do k = kb, kt
! sigmabndTM(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / (zws(kt)-zws(kb-1))
! end do
! else ! fix for dry points
! do k = kb, kt
! sigmabndTM(kmx*(i-1)+k-kb+1) = dble(k-kb)/dble(kt-kb)
! end do
! end if
end do
do i = 1, nbnduxy
ki = kbnduxy(2,i)
call getkbotktop(ki,kb,kt)
do k = kb, kt
sigmabnduxy(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / max(epshs, (zws(kt)-zws(kb-1)) )
end do
! if ( zws(kt)-zws(kb-1) .gt. epshs ) then
! do k = kb, kt
! sigmabnduxy(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / (zws(kt)-zws(kb-1))
! end do
! else ! fix for dry points
! do k = kb, kt
! sigmabnduxy(kmx*(i-1)+k-kb+1) = dble(k-kb)/dble(kt-kb)
! end do
! end if
end do
do itrac=1,numtracers
do i=1,nbndtr(itrac)
ki = bndtr(itrac)%k(2,i)
call getkbotktop(ki,kb,kt)
do k=kb,kt
bndtr(itrac)%sigma(kmx*(i-1)+k-kb+1) = (0.5d0*(zws(k-1)+zws(k))-zws(kb-1)) / max(epshs, (zws(kt)-zws(kb-1)) )
end do
end do
end do
end if
end subroutine setsigmabnds
subroutine polygonlayering(mpol)
use m_flow
use m_flowgeom
use m_polygon
use m_samples
use m_missing
use m_triangle
implicit none
integer :: mpol
integer :: k, j, jstart, jend, ierr, jdla, ipoint , jakdtree, ndim , n, in, nspl, n1
integer, allocatable :: indxn (:,:) , nds(:), inp(:), ndn(:)
double precision, allocatable :: wfn (:,:), zz(:)
call reapol(mpol,0)
call doclose(mpol)
call increasesam(npl+ndx)
if ( allocated (indlaynod) ) deallocate (indlaynod, wflaynod)
allocate ( indlaynod(3,ndxi) , stat= ierr ) ; indlaynod = 0
call aerr('indlaynod(3,ndxi)' , ierr, ndxi )
allocate ( wflaynod(3,ndxi) , stat= ierr ) ; wflaynod = 0d0
call aerr(' wflaynod(3,ndxi)' , ierr, ndxi )
allocate ( ndn(ndxi+npl) , stat= ierr )
call aerr('ndn(ndxi+npl)' , ierr, ndxi+npl ) ; ndn = 0
allocate ( zz(ndxi) , stat= ierr )
call aerr('zz(ndxi)' , ierr, ndxi ) ; zz = dmiss
mxlaydefs = 0 ; ipoint = 1 ! first count and allocate
jstart = 0 ; jend = 0 ; k = 0
do while (ipoint <= npl) ! nr of layers in first polygonpoint, layertype in second point
call get_startend(npl-ipoint+1, xpl(ipoint:npl), ypl(ipoint:npl), jstart, jend)
jstart = ipoint+jstart-1
jend = ipoint+jend-1
ipoint = jend + 1
mxlaydefs = mxlaydefs + 1
enddo
deallocate (laymx, laytyp)
allocate ( laymx(mxlaydefs), laytyp(mxlaydefs) , stat = ierr )
call aerr ('laymx(mxlaydefs), laytyp(mxlaydefs)', ierr, mxlaydefs )
mxlaydefs = 0 ; ipoint = 1 ! then fill
jstart = 0 ; jend = 0 ; k = 0
do while (ipoint <= npl) ! nr of layers in first polygonpoint, layertype in second point
call get_startend(npl-ipoint+1, xpl(ipoint:npl), ypl(ipoint:npl), jstart, jend)
jstart = ipoint+jstart-1
jend = ipoint+jend-1
ipoint = jend + 1
mxlaydefs = mxlaydefs + 1
if (zpl(jstart) > kmx) then
call error('increase kmx to allow for nr of layers specified in vertical_layering.pliz', ' ', ' ')
endif
laymx (mxlaydefs) = zpl(jstart) ! first point = nr of layers
laytyp(mxlaydefs) = zpl(jstart + 1) ! second point = type
zpl(jstart:jend) = mxlaydefs ! now only point to laydef nr
do j = jstart, jend ! add to sample set
k = k + 1
xs(k) = xpl(j)
ys(k) = ypl(j)
zs(k) = mxlaydefs
enddo
enddo
nspl = k
laydefnr = 0
in = -1
do n = 1,ndx ! add flownodes in polygon/laydef nr in to samples
call inwhichpolygon( xz(n), yz(n), in)
if (in > 0) then
k = k + 1
xs(k) = xz(n) ; ys(k) = yz(n) ; zs(k) = in; laydefnr(n) = in; ndn(k) = n
endif
enddo
ns = k
jdla = 1; jakdtree = 1; ndim = 1
jagetwf = 1
allocate ( indxx(3,ndxi), wfxx(3,ndxi) ) ! if module variable jagetw == 1, make weightfactor_index arrays
call TRIINTfast(XS,YS,ZS,NS,NDIM,Xz,Yz,Zz,ndxi,Xpl,Ypl,0,JDLA,jakdtree) !
allocate (nds(nspl))
do j = 1, nspl
call CLOSEdefinedflownode(Xs(j),Ys(j),N1)
if (n1 == 0) then
nds(j) = 0
else
nds(j) = n1
endif
enddo
do n = 1,ndx ! refer back to flownode instead of polygonpoint
if (laydefnr(n) == 0) then
do k = 1,3
if (indxx(k,n) <= nspl) then
indlaynod(k,n) = nds( indxx(k,n) )
wflaynod (k,n) = wfxx(k,n)
else
indlaynod(k,n) = ndn( indxx(k,n) )
wflaynod (k,n) = wfxx(k,n)
endif
enddo
endif
enddo
ns = 0; npl = 0
deallocate (indxx, wfxx, zz, nds, ndn )
end subroutine polygonlayering
subroutine getkbotktop(n,kb,kt)
use m_flow
use m_flowgeom
implicit none
integer :: n,kb,kt
if (kmx == 0) then
kb = n ; kt = n
else
kb = kbot(n) ; kt = ktop(n)
endif
end subroutine getkbotktop
subroutine getkbotktopmax(n,kb,ktx)
! Variation on getkbotktop. Always returns the maximum possible layer range instead of the actual range.
use m_flow
use m_flowgeom
implicit none
integer :: n,kb,ktx
if (kmx == 0) then
kb = n ; ktx = n
else
kb = kbot(n) ; ktx = kb + kmxn(n) - 1
endif
end subroutine getkbotktopmax
subroutine getLbotLtop(LL,Lb,Lt)
use m_flow
use m_flowgeom
implicit none
integer :: LL,Lb,Lt
if (kmx == 0) then
Lb = LL
if (hu(LL) > 0) then
Lt = LL
else
Lt = 0
endif
else
Lb = Lbot(LL) ; Lt = Ltop(LL)
endif
end subroutine getLbotLtop
subroutine getLbotLtopmax(LL,Lb,Ltx)
! Variation on getLbotLtop. Always returns the maximum possible layer range in stead of the actual range.
use m_flow
use m_flowgeom
implicit none
integer :: LL,Lb,Ltx
if (kmx == 0) then
Lb = LL
if (hu(LL) > 0) then
Ltx = LL
else
Ltx = 0
endif
else
Lb = Lbot(LL) ; Ltx = Lbot(LL) + kmxL(LL) - 1
endif
end subroutine getLbotLtopmax
subroutine getzlayerindices(n,nlayb,nrlay)
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: n,nlayb, nrlay
integer :: j,j1,j3,k, Ltn, mx ! layerdistribution indexes
Ltn = laydefnr(n)
mx = laymx(Ltn)
nlayb = mx ; nrlay = 1 ! default
do k = 1,mx
if ( zslay(k,Ltn) > bl(n) ) then
nlayb = k
nrlay = mx - k + 1
exit
endif
enddo
end subroutine getzlayerindices
subroutine reabar2pli(mthd, mout) ! convert barrier v file to model independent, barv content = m,n,sill depth
use m_grid
implicit none
integer :: mthd, mout
double precision :: xce, yce,dep
character (len = 132) :: rec
character (len = 1 ) :: uv
integer :: m,n,m2,n2, mn, mx, nn, nx, i
10 read(mthd,'(a)', end = 999) rec
read(rec,*) m,n,dep
write(mout,'(a)') 'Line'
write(mout,'(a)') ' 2 2'
if ( index(rec,'u') > 0 .or. index(rec,'U') > 0 ) then
write(mout,*) xc(m,n-1), yc(m,n-1) ,-dep
write(mout,*) xc(m,n) , yc(m,n) ,-dep
else
write(mout,*) xc(m-1,n), yc(m-1,n) ,-dep
write(mout,*) xc(m,n) , yc(m,n) ,-dep
endif
goto 10
999 call doclose (mthd)
call doclose (mout)
end subroutine reabar2pli
subroutine readry2pli(mthd, mout) ! convert barrier v file to model independent, barv content = m,n,sill depth
use m_grid
implicit none
integer :: mthd, mout
double precision :: xce, yce, z=9999d0
character (len = 132) :: rec
character (len = 1 ) :: uv
integer :: m,n,m2,n2, mn, mx, nn, nx, i
10 read(mthd,'(a)', end = 999) rec
read(rec,*) m,n
write(mout,'(a)') 'Line'
write(mout,'(a)') ' 5 3'
write(mout,*) xc(m ,n-1), yc(m ,n-1), z
write(mout,*) xc(m ,n ), yc(m ,n ), z
write(mout,*) xc(m-1,n ), yc(m-1,n ), z
write(mout,*) xc(m-1,n-1), yc(m-1,n-1), z
write(mout,*) xc(m ,n-1), yc(m ,n-1), z
goto 10
999 call doclose (mthd)
call doclose (mout)
end subroutine readry2pli
subroutine reathd2pli(mthd, mout) ! convert d3d obs file to model independent
use m_grid
implicit none
integer :: mthd, mout
double precision :: xce, yce
character (len = 132) :: rec
character (len = 1 ) :: uv
integer :: m,n,m2,n2, mn, mx, nn, nx, i
10 read(mthd,'(a)', end = 999) rec
read(rec,*) m,n,m2,n2,uv
write(mout,'(a)') 'Line'
write(mout,'(a)') ' 2 2'
if ( index(rec,'u') > 0 .or. index(rec,'U') > 0 ) then
nn = min(n,n2) ; nx = max(n,n2)
write(mout,*) xc(m,nn-1) , yc(m,nn-1)
do i = nn, nx
write(mout,*) xc(m,i), yc(m,i)
enddo
else
mn = min(m,m2) ; mx = max(m,m2)
write(mout,*) xc(mn-1,n) , yc(mn-1,n)
do i = mn, mx
write(mout,*) xc(i,n), yc(i,n)
enddo
endif
goto 10
999 call doclose (mthd)
call doclose (mout)
end subroutine reathd2pli
subroutine reaobs2stat(mobs, mout) ! convert d3d obs file to model independent
use m_grid
implicit none
integer :: mobs, mout
double precision :: xce, yce
character (len = 132) :: rec
character (len = 20 ) :: name
integer :: m,n
10 read(mobs,'(a)', end = 999) rec
read(rec( 1:),'(a)') name
read(rec(21:),* ) m,n
xce = 0.25d0*( xc(m-1,n) + xc(m-1,n-1) + xc(m,n) + xc(m,n-1) )
yce = 0.25d0*( yc(m-1,n) + yc(m-1,n-1) + yc(m,n) + yc(m,n-1) )
write(mout,*) xce, yce, name
goto 10
999 call doclose (mobs)
call doclose (mout)
end subroutine reaobs2stat
subroutine reabnd2pol(mbnd,mbca) ! convert d3d boundaryes stuf to model independent
use m_grid
use m_polygon
USE M_MISSING
implicit none
character :: rec*132 , fnam*20
integer, allocatable :: ma(:), na(:), mb(:), nb(:)
integer :: mmx=1000, k=0, mbnd, mbca
character (len = 132):: a(100), b(100)
integer :: i, j
integer :: kx, nra, kd, ku, kk, nr
double precision :: x1, x2, x3, x4
allocate ( ma(mmx), na(mmx), mb(mmx), nb(mmx) )
if ( allocated(ijyes) ) deallocate (ijyes)
allocate ( ijyes(mc+1, nc+1) ) ; ijyes = 0
DO I = 2,MC ! set up flow oriented ijyes array, sorry for the inconvenience
DO J = 2,NC
X1 = Xc(I-1,J-1)
X2 = Xc(I ,J-1)
X3 = Xc(I ,J )
X4 = Xc(I-1,J )
IF (X1 .NE. XYMIS .AND. X2 .NE. XYMIS .AND. &
X3 .NE. XYMIS .AND. X4 .NE. XYMIS ) IJYES(I,J) = 1
enddo
enddo
10 read(mbnd, '(a)', end = 666) rec
k = k + 1
read(rec(25:) ,* ) ma(k), na(k), mb(k), nb(k)
goto 10
666 continue
kx = k; nra = 0
do k = 1,kx
kd = max(1,k-1) ; ku = min(kx, k+1)
if (mbca > 0) then
kk = 9
call readset(kk+1,mbca, a) ! ; call readset(kk,mbca, b)
endif
fnam = 'kham_0001.cmp'
! if (k==1 .or. ma(k).ne.mb(kd) .and. na(k).ne.nb(kd) ) then
call bndpoint2pol( ma(k), na(k) )
if (mbca > 0) then
nr = nr + 1 ; call writeset(kk,fnam,nr,a)
endif
! endif
! call bndpoint2pol( mb(k), nb(k) )
! if (mbca > 0) then
! nr = nr + 1 ; call writeset(kk,fnam,nr,b)
! endif
! if ( k.ne.kx .and. mb(k).ne.ma(ku) .and. nb(k).ne.na(ku) ) then
! npl = npl + 1 ; xpl(npl) = dmiss; ypl(npl) = dmiss ; nr = 0
! endif
enddo
deallocate (ma, na, mb, nb, ijyes)
if (mbnd .ne. 0) call doclose(mbnd)
if (mbca .ne. 0) call doclose(mbca)
return
end subroutine reabnd2pol
!> Writes a set of template component files (_xxxx.cmp) associated with the current polyline.
!! Should only be called directly after savepol has been called.
!! If the current polyline was then saved to polname.pli, then
!! polname_0001.cmp up to polname_xxxn.cmp will be saved (with n the nr 'npl' of polyline points).
subroutine wricmps(fnam)
use m_polygon
use m_missing
implicit none
character (len=*), intent(in) :: fnam !< Filename from .pli file (should have been saved just before)
integer :: mou2, L, n
logical :: jawel
character (len=len(fnam)) :: fnamc
L = index( fnam, '.pli' )
if (L == 0) return
fnamc = fnam
L = L-1
do n = 1, 1 ! min(2,npl)
write(fnamc(l+1:l+1) , '(a)' ) '_'
write(fnamc(l+2:l+5) , '(i4.4)') n
inquire (file = fnamc(1:L+5)//'.cmp', exist = jawel)
if (.not. jawel) then
call newfil (mou2, fnamc(1:L+5)//'.cmp')
write(mou2,'(a)') '* COLUMNN=3'
write(mou2,'(a)') '* COLUMN1=Period (min) or Astronomical Componentname'
write(mou2,'(a)') '* COLUMN2=Amplitude (ISO)'
write(mou2,'(a)') '* COLUMN3=Phase (deg)'
write(mou2,'(a)') '0.0 1.0 0.0 '
call doclose(mou2)
endif
if (xpl(n) == dmiss) exit ! only for 1st polygon
enddo
end subroutine wricmps
subroutine csmfinebnds2unstruc()
implicit none
double precision x,y,amp,phas, x0, y0, d
character fnam*132, cmp*8, rec*132
integer :: mou2, k, kkk, L, minp, mout
mou2 = 0
do k = 1,3
kkk = 0
if (k == 1) fnam = 'zuid'
if (k == 2) fnam = 'west'
if (k == 3) fnam = 'noord'
L = len_trim(fnam)
call oldfil (minp, fnam(1:L)//'rand_new10')
call newfil (mout, fnam(1:L)//'.pli')
write(mout,'(a)') 'bl01'
if (k == 1) write(mout,'(a)') ' 23 2 '
if (k == 2) write(mout,'(a)') ' 85 2 '
if (k == 3) write(mout,'(a)') ' 99 2 '
8 continue
read(minp,'(a)',end = 999) rec
read (rec,*) cmp,y,x,d,d,amp,phas
if (cmp == 'Q1') then
if (mou2>0) call doclose(mou2)
write(mout, *) x, y
kkk = kkk + 1
write(fnam(l+1:l+1) , '(a)' ) '_'
write(fnam(l+2:l+5) , '(i4.4)') kkk
call newfil (mou2, fnam(1:L+5)//'.cmp')
write(mou2,'(a)') '* COLUMNN=3'
write(mou2,'(a)') '* COLUMN1=Period (min) or Astronomical Componentname'
write(mou2,'(a)') '* COLUMN2=Amplitude (m)'
write(mou2,'(a)') '* COLUMN3=Phase (deg)'
endif
if (cmp == 'PHI1') cmp = 'FI1'
if (cmp == 'LAMBDA2') cmp = 'LABDA2'
if (cmp == 'RHO1') cmp = 'RO1'
write(mou2,'(a,2f14.6)') cmp, 0.01d0*amp, phas
goto 8
999 call doclose(minp)
call doclose(mout)
call doclose(mou2); mou2 = 0
enddo
end subroutine csmfinebnds2unstruc
subroutine readset(kk,mbca, a)
implicit none
integer :: kk
character (len = 132) :: a(100)
character (len = 132) :: rec
integer :: k, mbca
do k = 1,kk
read(mbca,'(a)') a(k)
enddo
end subroutine readset
subroutine writeset(kk,fnam,nr,a)
implicit none
integer :: kk, nr
character (len = 132) :: a(100)
character (len = 132) :: rec
character*(*) fnam
integer :: l, mout, k
L = index(fnam,'_')
write(fnam(L+1:L+4), '(i4.4)' ) nr
call newfil(mout, fnam)
write(mout,'(a)') '*'//a(1)
do k = 2,kk
! call correctiefile(a(k))
write(mout,'(a)') a(k)
enddo
call doclose(mout)
end subroutine writeset
subroutine correctiefile(a)
implicit none
character*(*) a
double precision :: am, ph
character*8 cmp
read (a,'(a)') cmp
read (a(8:),*) am, ph
if ( index(cmp,'O1') .ne. 0 ) then
am = am*1.100d0 ; ph = ph - 10d0
else if ( index(cmp,'K1') .ne. 0 ) then
am = am*1.050d0 ; ph = ph - 5d0
else if ( index(cmp,'P1') .ne. 0 ) then
am = am*1.050d0 ; ph = ph - 0d0
else if ( index(cmp,'N2') .ne. 0 ) then
am = am*1.000d0 ; ph = ph - 5d0
else if ( index(cmp,'M2') .ne. 0 ) then
am = am*1.150d0 ; ph = ph - 5d0
else if ( index(cmp,'S2') .ne. 0 ) then
am = am*1.100d0 ; ph = ph - 0d0
else if ( index(cmp,'L2') .ne. 0 ) then
am = am*1.000d0 ; ph = ph - 20d0
else if ( index(cmp,'K2') .ne. 0 ) then
am = am*1.100d0 ; ph = ph - 0d0
endif
a = ' '
write(a,*) cmp, am, ph
end subroutine correctiefile
subroutine bndpoint2pol(m,n)
use m_polygon
use m_grid
implicit none
integer :: m, n
double precision :: xce, yce, xbb, ybb
integer :: mu,nu,md,nd
if (ijyes(m,n) == 0) then
mu = m + 1 ; nu = n + 1 ; md = m - 1 ; nd = n - 1
if (m <= mc .and. n > 1 .and. n < nc+1) then
if (ijyes(mu,n)==1) then ! linkerrand
npl = npl + 1
xce = 0.25d0*( xc(mu,n) + xc(mu,nd) + xc(m,n) + xc(m,nd) )
xbb = 0.50d0*( xc(m,n) + xc(m,nd ) )
xpl(npl) = 1.1d0*xbb - 0.1d0*xce
yce = 0.25d0*( yc(mu,n) + yc(mu,nd) + yc(m,n) + yc(m,nd) )
ybb = 0.50d0*( yc(m,n) + yc(m,nd ) )
ypl(npl) = 1.1d0*ybb - 0.1d0*yce
endif
endif
if (n <= nc .and. m > 1 .and. m < mc+1) then
if (ijyes(m,nu)==1) then ! onderrand
npl = npl + 1
xce = 0.25d0*( xc(m,nu) + xc(md,nu ) + xc(m,n) + xc(md,n) )
xbb = 0.50d0*( xc(m,n) + xc(md,n) )
xpl(npl) = 1.1d0*xbb - 0.1d0*xce
yce = 0.25d0*( yc(m,nu) + yc(md,nu ) + yc(m,n) + yc(md,n) )
ybb = 0.50d0*( yc(m,n) + yc(md,n) )
ypl(npl) = 1.1d0*ybb - 0.1d0*yce
endif
endif
if (m >= 2 .and. n > 1 .and. n < nc+1 ) then
if (ijyes(md,n)==1) then ! rechterrand
npl = npl + 1
xce = 0.25d0*( xc(md-1,nd) + xc(md-1,n) + xc(m-1,nd) + xc(m-1,n) )
xbb = 0.50d0*( xc(m-1,n) + xc(m-1,nd) )
xpl(npl) = 1.1d0*xbb - 0.1d0*xce
yce = 0.25d0*( yc(md-1,nd) + yc(md-1,n) + yc(m-1,nd) + yc(m-1,n) )
ybb = 0.50d0*( yc(m-1,n) + yc(m-1,nd) )
ypl(npl) = 1.1d0*ybb - 0.1d0*yce
endif
endif
if (n >= 2 .and. m > 1 .and. m < mc+1 ) then
if (ijyes(m,nd)==1) then ! bovenrand
npl = npl + 1
xce = 0.25d0*( xc(md,nd-1) + xc(md,n-1) + xc(m,nd-1) + xc(m,n-1) )
xbb = 0.50d0*( xc(m,n-1) + xc(md,n-1) )
xpl(npl) = 1.1d0*xbb - 0.1d0*xce
yce = 0.25d0*( yc(md,nd-1) + yc(md,n-1) + yc(m,nd-1) + yc(m,n-1) )
ybb = 0.50d0*( yc(m,n-1) + yc(md,n-1) )
ypl(npl) = 1.1d0*ybb - 0.1d0*yce
endif
endif
endif
end subroutine bndpoint2pol
!> read from rfg grid file
SUBROUTINE ECRREA(X,MMAX,NMAX,MC,NC,MRGF,HALF)
use m_missing
implicit none
character dummy*10, REC*132
! LEES RGF
integer, intent(in) :: MMAX, NMAX !< array sizes
integer, intent(in) :: mc, nc !< grid size
integer, intent(in) :: mrgf !< grid-file unit number
double precision, intent(in) :: half !< progress bar length, 0:half, 0.5:full
double precision :: X(MMAX,NMAX)
double precision :: af
integer :: i,j
DO J=1,NC
IF (HALF > -1D0) THEN
AF = HALF + 0.5d0*dble(J)/dble(NC)
CALL READYY('Reading Grid File',AF)
ENDIF
READ(MRGF,*,err=777,end=999) dummy,dummy, (X(I,J),I=1,MC)
ENDDO
RETURN
777 BACKSPACE (MRGF)
BACKSPACE (MRGF)
DO J=1,NC
IF (HALF > -1D0) THEN
AF = HALF + 0.5d0*dble(J)/dble(NC)
CALL READYY('Reading Grid File',AF)
ENDIF
READ(MRGF,'(10X5F12.0)',err=888,END=999) (X(I,J),I=1,MC)
ENDDO
! where (x == 0d0) x = dxymis
RETURN
888 BACKSPACE (MRGF)
READ(MRGF,'(A)') REC
CALL QNREADERROR('Reading Grid Coordinates but Getting',REC,MRGF)
RETURN
999 BACKSPACE (MRGF)
READ(MRGF,'(A)') REC
CALL QNEOFERROR(MRGF)
RETURN
END SUBROUTINE ECRREA
SUBROUTINE REAMDD( MMDD, RD1,MC,NC,JA)
implicit none
integer :: mmdd, mc, nc, ja
DOUBLE PRECISION :: RD1(MC,NC)
integer :: m, n
double precision :: af
CHARACTER REC*132
CALL READYY('Reading md-Dept File',0d0)
5 CONTINUE
READ(MMDD,'(A)',END = 999) REC
IF (REC(1:1) .EQ. '*') GOTO 5
BACKSPACE(MMDD)
DO 10 N = 1, NC
AF = dble(N) / dble(NC)
CALL READYY('Reading md-Dept File',AF)
READ(MMDD,*,END = 999,ERR = 888) (RD1(M,N),M = 1,MC)
10 CONTINUE
CALL READYY('Reading md-Dept File',-1d0)
CALL DOCLOSE (MMDD)
JA = 1
RETURN
999 CONTINUE
CALL QNEOFERROR(MMDD)
CALL READYY('Reading md-Dept File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
RETURN
888 CALL QNREADERROR('Reading, DD Depth File With Wrong Dimensions', ' ', MMDD)
CALL READYY('Reading md-Dept File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
END SUBROUTINE REAMDD
SUBROUTINE REABOT( MMDD, JA)
USE M_GRID
implicit none
integer :: mmdd, ja, m1, n1, m2, n2, L1, L2, L3, L4, L5
integer :: m, n
double precision :: af
CHARACTER REC*132
CALL READYY('Reading SIMONA *.bottom File',0d0)
5 CONTINUE
READ(MMDD,'(A)',END = 777) REC
IF (REC(1:3) .ne. 'BOX') THEN
GOTO 5
ELSE
L1 = INDEX(REC, '=(')
READ (REC(L1+2:), *) M1
L2 = L1 + INDEX(REC(L1:), ',')
L3 = INDEX(REC(:), ';') -1
READ (REC(L2:L3), *) N1
L3 = INDEX(REC, ';' )
READ (REC(L3+1:), *) M2
L4 = L3 + INDEX(REC(L3:), ',')
L5 = INDEX(REC, ')') - 1
READ (REC(L4:L5), *) N2
ENDIF
DO 10 M = M1,M2
AF = dble(M) / dble(MC)
CALL READYY('Reading SIMONA *.bottom File',AF)
READ(MMDD,'(A)',END = 777) REC
BACKSPACE(MMDD)
READ(MMDD,*,END = 999,ERR = 888) (ZC(M,N),N = N1, N2)
10 CONTINUE
GOTO 5
777 CALL READYY('Reading SIMONA *.bottom File',-1d0)
CALL DOCLOSE (MMDD)
JA = 1
RETURN
999 CONTINUE
CALL QNEOFERROR(MMDD)
CALL READYY('Reading SIMONA *.bottom File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
RETURN
888 CALL QNREADERROR('Reading ERROR SIMONA bottom File With Wrong Dimensions', ' ', MMDD)
CALL READYY('Reading *.bottom File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
END SUBROUTINE REABOT
SUBROUTINE REAweir( MMDD, JA)
use m_missing
use m_fixedweirs
USE M_GRID
implicit none
integer :: mmdd, ja, m1, n1, m2, n2, L1, L2, L3, L4, L5
integer :: m, n, MOUT
double precision :: af, hu, hv, Du1, Du2, Dv1, Dv2
CHARACTER REC*132
JA = 0
CALL NEWFIL(MOUT, 'WEIRS.POL')
5 CONTINUE
READ(MMDD,'(A)',END = 777) REC
IF ( index(rec,'#') ==0) THEN
READ (REC(2:), *, ERR=999) M, N, HU, Du1, Du2, HV, Dv1, Dv2
IF (HU > 0) THEN
WRITE(MOUT,*) XC(M,N ) , YC(M,N ), HU, DU1, DU2
WRITE(MOUT,*) XC(M,N-1) , YC(M,N-1), HU, DU1, DU2
WRITE(MOUT,*) DMISS, DMISS, DMISS
ENDIF
IF (HV > 0) THEN
WRITE(MOUT,*) XC(M ,N) , YC(M ,N), HV, DV1, DV2
WRITE(MOUT,*) XC(M-1,N) , YC(M-1,N), HV, DV1, DV2
WRITE(MOUT,*) DMISS, DMISS, DMISS
ENDIF
ENDIF
GOTO 5
777 CALL DOCLOSE (MMDD)
CALL DOCLOSE (MOUT)
JA = 1
RETURN
999 CONTINUE
CALL QNEOFERROR(MMDD)
CALL READYY('Reading SIMONA *.bottom File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
RETURN
888 CALL QNREADERROR('Reading ERROR SIMONA WEIR File', REC, MMDD)
CALL DOCLOSE (MMDD)
JA = 0
END SUBROUTINE REAWEIR
SUBROUTINE REAcrs( MMDD, JA)
USE M_GRID
use m_missing
implicit none
integer :: mmdd, ja, m1, n1, m2, n2, MH, NH , NR2
integer :: m, n, MOUT
double precision :: af, hu, hv, d
CHARACTER REC*132
JA = 0
NR2 = 2
CALL NEWFIL(MOUT, 'sections_crs.pli')
5 CONTINUE
READ(MMDD,'(A)',END = 777) REC
IF ( index(rec,'#') ==0) THEN
READ (REC(21:), *, ERR=999) M1, N1, M2, N2
IF (M1 > M2) THEN
MH = M2; M2 = M1; M1 = MH
ENDIF
IF (N1 > N2) THEN
NH = N2; N2 = N1; N1 = NH
ENDIF
! WRITE(MOUT,'(A )') REC(1:20)
IF (M1 == M2) THEN
WRITE(MOUT,'(A )') REC(1:20)
WRITE(MOUT, '(2I8)') N2-N1+2, NR2
DO N = N1-1,N2
WRITE (MOUT,*) XC(M1,N), YC(M1,N)
ENDDO
ENDIF
IF (N1 == N2) THEN
if (m1 == m2) then
WRITE(MOUT,'(A )') REC(1:20)//'b'
else
WRITE(MOUT,'(A )') REC(1:20)
endif
WRITE(MOUT, '(2I8)') M2-M1+2, NR2
DO M = M1-1,M2
WRITE (MOUT,*) XC(M,N1), YC(M,N1)
ENDDO
ENDIF
ENDIF
GOTO 5
777 CALL DOCLOSE (MMDD)
CALL DOCLOSE (MOUT)
JA = 1
RETURN
999 CONTINUE
CALL QNEOFERROR(MMDD)
CALL READYY('Reading SIMONA *.bottom File',-1d0)
CALL DOCLOSE (MMDD)
JA = 0
RETURN
888 CALL QNREADERROR('Reading ERROR SIMONA WEIR File', REC, MMDD)
CALL DOCLOSE (MMDD)
JA = 0
END SUBROUTINE REAcrs
SUBROUTINE SCHERM()
use m_netw
use m_flowgeom
use m_grid
use unstruc_messages
implicit none
integer :: i
integer :: maxlin
PARAMETER (MAXLIN = 11)
integer :: nlevel
COMMON /HELPNOW/ WRDKEY,NLEVEL
CHARACTER TEX(MAXLIN)*70,WRDKEY*40
!
TEX(1) = 'ACTUAL AND MAXIMUM DIMENSIONS OF DATA '
TEX(2) = '****************************************************************'
TEX(3) = 'DATA TYPE : ACTUAL MAXIMUM'
TEX(4) = 'NUMBER OF NETNODES : '
TEX(5) = 'NUMBER OF NETLINKS : '
TEX(6) = 'MAXIMUM NUMBER OF LINKS PER NODE : '
TEX(7) = 'land boundary : '
TEX(8) = 'POLYGON : '
TEX(9) = 'NUMBER OF FLOW CELLS : '
TEX(10)= 'NUMBER OF FLOW LINKS : '
TEX(11)= 'Grid m,n dimensions : '
!
WRITE(TEX(4)(44:51),'(I8)') NUMK
WRITE(TEX(5)(44:51),'(I8)') NUML
! WRITE(TEX(6)(44:51),'(I8)')
WRITE(TEX(7)(44:51),'(I8)') MXLAN
WRITE(TEX(8)(44:51),'(I8)') NPL
WRITE(TEX(9) (44:51),'(I8)') NDX
WRITE(TEX(10)(44:51),'(I8)') LNX
WRITE(TEX(11)(44:51),'(I8)') mc
WRITE(TEX(4)(57:64),'(I8)') KMAX
WRITE(TEX(5)(57:64),'(I8)') LMAX
WRITE(TEX(6)(57:64),'(I8)') KNX
WRITE(TEX(7)(57:64),'(I8)') MAXLAN
WRITE(TEX(8)(57:64),'(I8)') MAXPOL
WRITE(TEX(9) (57:64),'(I8)') NDX
WRITE(TEX(10)(57:64),'(I8)') LNX
WRITE(TEX(11)(57:64),'(I8)') nc
!
WRITE(msgbuf,'(A)'); call msg_flush()
DO I = 1,MAXLIN
WRITE(msgbuf,'(A)') TEX(I); call msg_flush()
ENDDO
WRDKEY = 'ACTUAL AND MAXIMUM DIMENSIONS OF DATA'
NLEVEL = 2
CALL HISTOR()
RETURN
END SUBROUTINE SCHERM
!
Subroutine plusabs_flow(numchoice)
use m_flow
use m_flowgeom
implicit none
integer :: numchoice, k, kk, kb, kt
! locals
integer :: key
if (ndx == 0 .or. lnx == 0) then
call qnerror('First reinitialise flow model, current dimensions are 0',' ',' ')
return
endif
if (numchoice == 1) then
call plusabsd(xz,yz,yz,ndx,key,s1); s1=max(s1,bl)
else if (numchoice == 2) then
if (.not. allocated (sa1) ) then
CALL qnerror('first reinitialise with jasal=1',' ',' ')
return
endif
call plusabsd(xz,yz,yz,ndx,key,sa1)
if (kmx > 0) then
do kk = 1,ndx
call getkbotktop(kk,kb,kt)
do k = kb,kt
sa1(k) = sa1(kk)
enddo
enddo
endif
salmax = maxval(sa1)
else if (numchoice == 3) then
if (ibedlevtyp == 1) then
call plusabsd(xz,yz,yz,ndx,key,bl)
else if (ibedlevtyp == 2) then
call plusabsd(xu,yu,yu,lnx,key,blu)
else
CALL qnerror('Specifying cell bottom levels bl (ibedlevtyp=1) or flow link bottom levels blu (ibedlevtyp=2)',' ',' ')
CALL qnerror('Change parameter ibedlevtyp in Various, Change Geometry Parameters',' ',' ')
return
endif
call setbobs()
s1 = max(s1,bl)
endif
End subroutine plusabs_flow
Subroutine sethigherorderadvectionvelocities()
use m_flowgeom
use m_flow
use m_flowtimes
implicit none
integer :: L, LL, k1, k2, k, ku, kd, kku, ku2, is, ip, Lb, Lt, kkua, kkub
double precision :: half, sl1, sl2, sl3, cf, ucxku, ucyku, ds1, ds2, ds, ql, qds, ds1x, ds1y, ds2x, ds2y
double precision, external :: dslim
if (limtypmom < 1 ) return
if (kmx == 0) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L, LL, k1, k2, k, kd, is, half, ip, kku, ku, ku2) &
!$OMP PRIVATE(sl1, sl2, sl3, cf, ucxku, ucyku, ds1x, ds1y, ds2x, ds2y, ds, ql, qds )
do L = 1,lnx ! upwind (supq) + limited high order (dsq)
LL = L
if (qa(LL) .ne. 0d0) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (qa(LL) > 0) then
! -> ds1 ds2
k = k1 ; kd = k2 ; is = 1 ; half = acl(LL) ; ip = 0 ! -> ku k kd
else
! <- ds2 ds1
k = k2 ; kd = k1 ; is = -1 ; half = 1d0-acl(LL) ; ip = 3 ! <- kd k ku
endif
if (hs(ln(1,LL)) < Chkadvd .or. hs(ln(2,LL)) < Chkadvd) cycle
if (limtypmom == 6) then
ds1x = -ducdx(k)*is
ds1y = -ducdy(k)*is
else
kku = klnup(1+ip,LL) ; if (kku == 0) cycle
ku = abs(kku)
if (kku < 0) then
ucxku = ucx(ku)
ucyku = ucy(ku)
else
ku2 = iabs(klnup(2+ip,LL)) ; if ( ku2 == 0) cycle
sl1 = slnup(1+ip,LL) ; sl2 = slnup(2+ip,LL)
ucxku = ucx(ku)*sl1 + ucx(ku2)*sl2
ucyku = ucy(ku)*sl1 + ucy(ku2)*sl2
endif
sl3 = slnup(3+ip,LL)
ds1x = (ucx(k) - ucxku)*sl3
ds1y = (ucy(k) - ucyku)*sl3
endif
cf = dts*abs(u1(L))*dxi(LL) ! cflj(L) !cfli(k ) ! cflj(L)
cf = half*max( 0d0,1d0-cf )
ds2x = ucx(kd) - ucx(k)
ds2y = ucy(kd) - ucy(k)
if (abs(ds2x) > eps10 .and. abs(ds1x) > eps10) then
ds = cf*dslim(ds1x, ds2x, limtypmom) ! no cf, see belanger
if (abs(ds) > eps10) then
ucxu(L) = ucxu(L) + ds
endif
endif
if (abs(ds2y) > eps10 .and. abs(ds1y) > eps10) then
ds = cf*dslim(ds1y, ds2y, limtypmom) ! no cf, see belanger
if (abs(ds) > eps10) then
ucyu(L) = ucyu(L) + ds
endif
endif
endif ! qa.ne.0
enddo ! horizontal
!$OMP END PARALLEL DO
else
do LL = 1,lnx ! upwind (supq) + limited high order (dsq)
if (qa(LL) .ne. 0d0) then
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (qa(L) > 0) then
! -> ds1 ds2
k = k1 ; kd = k2 ; is = 1 ; half = acl(LL) ; ip = 0 ! -> ku k kd
else
! <- ds2 ds1
k = k2 ; kd = k1 ; is = -1 ; half = 1d0-acl(LL) ; ip = 3 ! <- kd k ku
endif
if (hs(ln(1,LL)) < Chkadvd .or. hs(ln(2,LL)) < Chkadvd) cycle
if (limtypmom == 6) then
ds1x = -ducdx(k)*is
ds1y = -ducdy(k)*is
else
kku = klnup(1+ip,LL) ; if (kku == 0) cycle ; kkua = abs(kku)
ku = kbot(kkua) + kmxn(kkua) - ( Lb + kmxL(LL) - L) ; if (ku < kbot(kkua) .or. ku > ktop(kkua) ) cycle
if (kku < 0) then
ucxku = ucx(ku)
ucyku = ucy(ku)
else
kkub = iabs( klnup(2+ip,LL) )
ku2 = kbot(kkub) + kmxn(kkub) - ( Lb + kmxL(LL) - L) ; if (ku2 < kbot(kkub) .or. ku2 > ktop(kkub) ) cycle
sl1 = slnup(1+ip,LL) ; sl2 = slnup(2+ip,LL)
ucxku = ucx(ku)*sl1 + ucx(ku2)*sl2
ucyku = ucy(ku)*sl1 + ucy(ku2)*sl2
endif
sl3 = slnup(3+ip,LL)
ds1x = (ucx(k) - ucxku)*sl3
ds1y = (ucy(k) - ucyku)*sl3
endif
cf = dts*abs(u1(L))*dxi(LL) ! cflj(L) !cfli(k ) ! cflj(L)
cf = half*max( 0d0,1d0-cf )
ds2x = ucx(kd) - ucx(k)
ds2y = ucy(kd) - ucy(k)
if (abs(ds2x) > eps10 .and. abs(ds1x) > eps10) then
ds = cf*dslim(ds1x, ds2x, limtypmom)
if (abs(ds) > eps10) then
ucxu(L) = ucxu(L) + ds
endif
endif
if (abs(ds2y) > eps10 .and. abs(ds1y) > eps10) then
ds = cf*dslim(ds1y, ds2y, limtypmom)
if (abs(ds) > eps10) then
ucyu(L) = ucyu(L) + ds
endif
endif
enddo ! vertical
endif
enddo ! horizontal
endif ! kmx
End subroutine sethigherorderadvectionvelocities
subroutine transport() ! transport for now, advect salinity and add
! high order limited terms to uqcx, uqcy
use m_flowgeom
use m_flow
use m_flowtimes
use m_ship
use m_sediment
use m_netw, only : xk,yk,zk
use m_flowtimes
use m_physcoef, only : idensform, difmolsal
use m_partitioninfo
use m_timer
use m_missing
use unstruc_display, only: jaGUI
use unstruc_messages
implicit none
integer :: L, k, ku, kd, k1, k2, kb, ierr, n, ntmx, it, jupwsal, jupq, itmax, jaimplorg, java
integer :: L1, L2, Li, ip, is, maxit = 100, limtyp, kl1, kl2, kl2s, kku
integer :: jalim2D, nx, k3, k4
double precision :: ds1, ds2, ds, sak, saku, teku, half, cf, tetaj2i, vv, tetav1, cadv, difsalw, diftemw, difsedw
double precision :: qst, qstu, qstd, qds, ql, qh, epssa, sasum, sasum0=0, diff, baroc, barocup, dif, dift, difs, ho
double precision :: ucxku, ucyku, s1ku, sl1, sl2, sl3, fi, qb, wsemx, dgrlay, dtvi, hsk, xx,yy,dmorfax, dv, aa
double precision, allocatable, save :: dsq(:), pp(:), pm(:), qp(:), qm(:), alf(:) ! todo kuzmin limiting jalim2D==1
double precision, external :: upwsalslope, upwsal, rminmod
double precision, external :: dslim, setrho, dlimitercentral
integer :: j, kj, kdj, kuj, kl1j, kl2j, kbj, kij, ki, jastep, kk, kb1, kb2, n1, n2, kkua, kkub, ku2
integer :: LL, Lb, Lt, kt, km, ivert, ja, m, LL1, LL2, jachange
double precision :: sedku(mxgr) !< upper slope sed value , dimension = mxgr
double precision :: flx (mxgr) !< sed erosion flux (kg/s) , dimension = mxgr
double precision :: seq (mxgr) !< sed equilibrium transport rate (kg/m/s) , dimension = mxgr
double precision :: wse (mxgr) !< effective fall velocity (m/s) , dimension = mxgr, ws*crefa=wse*seq
double precision :: cpuorg(3), cpunew(3), adv, adv1, hordif, qsk, qsa
double precision :: a(kmxx), b(kmxx), c(kmxx), d(kmxx), e(kmxx)
double precision :: ta(kmxx),tb(kmxx),tc(kmxx),td(kmxx),te(kmxx)
double precision :: sa(kmxx),sb(kmxx),sc(kmxx),sd(kmxx),se(kmxx)
double precision, allocatable :: sa00(:), vold(:), cch(:), ccv(:), diagn(:) ! help arrays scalar transport
double precision :: dq(kmxx), samiobnd, samerr2, dsadn
double precision :: dfac1, dfac2, src, viL, diuspL, qdsL
integer :: ierror, k3D, noadvection = 0
double precision, allocatable :: skmx(:)
if ( stm_included .and. jased.ne.0 .and. jatransportmodule.eq.0 ) then
call mess(LEVEL_FATAL, 'use transport module')
end if
if (jasal == 0) then
limtypsa = 0 ; maxitverticalforestersal = 0
endif
if (jatem == 0) then
limtypTM = 0 ; maxitverticalforestertem = 0
endif
if (jased == 0) then
limtypsed = 0
endif
if (iadvec == 0) then
limtypmom = 0
endif
limtyp = max(Limtypsa, limtyptm, limtypsed) ! check if limiter need be applied
if (jasal == 0 .and. jatem == 0 .and. jased == 0 .and. jatransportmodule == 0 ) return ! no salinity, or sediment, no higher orders
if (jasal > 0) then
do k = 1,nbnds ! set 1D or 3D sal boundary conditions
LL = kbndS(3,k)
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
kb = ln(1,L) ; ki = ln(2,L)
if (q1(L) > 0) then
kk = kmxd*(k-1)+L-Lb+1
sa1(kb) = zbnds(kk) ! inflow
salmax = max( salmax, sa1(kb) )
else
sa1(kb) = sa1(ki) ! outflow
endif
enddo
enddo
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IMPIREDUCE)
call reduce_double_max(salmax)
if ( jatimer.eq.1 ) call stoptimer(IMPIREDUCE)
end if
endif
if (jatem > 0) then
do k = 1,nbndtm ! set 1D or 3D temp boundary conditions
LL = kbndTM(3,k)
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
kb = ln(1,L) ; ki = ln(2,L)
if (q1(L) > 0) then
kk = kmxd*(k-1)+L-Lb+1
tem1(kb) = zbndTM(kk) ! inflow
else
tem1(kb) = tem1(ki) ! outflow
endif
enddo
enddo
! tem1 = tem1 + 50d0 ! tkelvn
endif
if (jased > 0 .and. jased.le.3) then
do k = 1,nbndz ! set equilibrium boundary conditions for open flow bnds, types z and u
kb = kbndz(1,k)
ki = kbndz(2,k)
L = kbndz(3,k)
if (jaceneqtr == 1) then
call getequilibriumtransportrates(ki, seq, wse, mxgr, hsk) ! get based on cellcentre
else
call getequilibriumtransportrates2(L, kbndz(6,k), kbndz(7,k), seq, wse, mxgr, hsk, 0) ! get based on 2 netnodes
endif
do j = 1,mxgr
if (q1(L) > 0) then
sed(j,kb) = seq(j) ! inflow , equilibrium boundary condition
else
sed(j,kb) = sed(j,ki) ! outflow
bl(kb) = bl(ki) ! copy internal bottom level to outflow bnd level
if (jaceneqtr == 1) then
grainlay(j,kb) = grainlay(j,ki) ! only for plotting
endif
endif
enddo
enddo
do k = 1,nbndu ! set equilibrium boundary conditions for open flow bnds, types z and u
kb = kbndu(1,k)
ki = kbndu(2,k)
L = kbndu(3,k)
if (jaceneqtr == 1) then
call getequilibriumtransportrates(ki, seq, wse, mxgr, hsk) !
else
call getequilibriumtransportrates2(L, kbndu(6,k), kbndu(7,k), seq, wse, mxgr, hsk, 1) ! get based on 2 netnodes
endif
do j = 1,mxgr
if (q1(L) > 0) then
sed(j,kb) = seq(j) ! inflow , equilibrium boundary condition
!sed(j,ki) = seq(j) ! inflow , equilibrium boundary condition
else
sed(j,kb) = sed(j,ki) ! outflow
bl(kb) = bl(ki) ! copy internal bottom level to outflow bnd level
if (jaceneqtr == 1) then
grainlay(j,kb) = grainlay(j,ki)
endif
endif
enddo
enddo
do k = 1,nbndsd ! set prescribed sediment boundary conditions
kb = kbndSd(1,k)
ki = kbndSd(2,k)
L = kbndSd(3,k)
do j = 1,mxgr
if (q1(L) > 0) then
sed(j,kb) = zbndsd(k) ! inflow , todo, check vectormax over grainsizes if boundaryprescribed, else
endif
enddo
enddo
if (dmorfac > 0 .and. time1 >= tstart_user + TMorfspinup) then
jamorf = 1
endif
dvolbot = 0d0
endif
if (limtypsa == 6) then
dsadx = 0d0; dsady = 0d0
do LL = 1,lnx
Lb = Lbot(LL) ; Lt = Lb - 1 + kmxL(LL)
do L = Lb, Lt
k1 = ln(1,L)
k2 = ln(2,L)
dsadn = dxi(LL)*( sa1(k2) - sa1(k1) )
dsadx(k1) = dsadx(k1) + wcx1(LL)*dsadn
dsady(k1) = dsady(k1) + wcy1(LL)*dsadn
dsadx(k2) = dsadx(k2) + wcx2(LL)*dsadn
dsady(k2) = dsady(k2) + wcy2(LL)*dsadn
enddo
enddo
endif
! begin DEBUG
if ( jatransportmodule.eq.1 ) then
goto 1234
endif
! end DEBUG
if (jasal > 0) then
supq = 0d0 ; qsho = 0d0
endif
if (jatem > 0) then
tupq = 0d0 ; qtho = 0d0
endif
if (jased > 0) then
sdupq = 0d0
endif
jalim2D = 3 ! 2D limiting
if (jalim2D > 0) then
if (.not. allocated(pp) ) then
allocate ( pp(ndkx) , stat = ierr)
call aerr('pp(ndkx)', ierr, lnkx+ndkx )
endif
if (jalim2D <= 2) then
if (.not. allocated(pm) ) then
allocate ( dsq(ndx), pm(ndx), qp(ndx), qm(ndx), alf(lnx) , stat = ierr)
call aerr('dsq(ndx), pm(ndx), qp(ndx), qm(ndx), alf(lnx)' , ierr, 6*ndx)
endif
dsq = 0d0
endif
endif
do LL = 1,lnx ! upwind (supq) + limited high order (dsq)
if (q1(LL) .ne. 0d0) then
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0) then
! -> ds1 ds2
k = k1 ; kd = k2 ; is = 1 ; half = acl(LL) ; ip = 0 ! -> ku k kd
else
! <- ds2 ds1
k = k2 ; kd = k1 ; is = -1 ; half = 1d0-acl(LL) ; ip = 3 ! <- kd k ku
endif
ql = is*q1(L)
if (jasal > 0) then
supq(kd) = supq(kd) + ql*sa1(k)
supq(k ) = supq(k ) - ql*sa1(k)
endif
if (jatem > 0) then
tupq(kd) = tupq(kd) + ql*tem1(k)
tupq(k ) = tupq(k ) - ql*tem1(k)
endif
if (jased > 0) then
do j = 1,mxgr ! grainsize loop
sdupq(j,kd) = sdupq(j,kd) + ql*sed(j,k)
sdupq(j,k ) = sdupq(j,k ) - ql*sed(j,k)
enddo
endif
if (limtyp > 0 ) then ! .and. L <= lnxi) then
if (hs(ln(1,LL)) < Chkadvd .or. hs(ln(2,LL)) < Chkadvd) cycle
kku = klnup(1+ip,LL) ; if (kku == 0) cycle ; kkua = abs(kku)
if (kmx > 0) then
ku = kbot(kkua) + kmxn(kkua) - ( Lb + kmxL(LL) - L) ; if (ku < kbot(kkua) .or. ku > ktop(kkua) ) cycle
else
ku = abs(kku)
endif
if (kku < 0) then
if (limtypsa > 0) then
saku = sa1(ku)
endif
if (limtyptm > 0) then
teku = tem1(ku)
endif
if (limtypsed > 0) then
do j = 1,mxgr ! grainsize loop
sedku(j) = sed(j,ku)
enddo
endif
else
kkub = iabs( klnup(2+ip,LL) )
if (kmx > 0) then
ku2 = kbot(kkub) + kmxn(kkub) - ( Lb + kmxL(LL) - L) ; if (ku2 < kbot(kkub) .or. ku2 > ktop(kkub) ) cycle
else
ku2 = kkub
endif
sl1 = slnup(1+ip,LL) ; sl2 = slnup(2+ip,LL)
if (limtypsa > 0) then
saku = sa1(ku)*sl1 + sa1(ku2)*sl2
endif
if (limtyptm > 0) then
teku = tem1(ku)*sl1 + tem1(ku2)*sl2
endif
if (limtypsed > 0) then
do j = 1,mxgr ! grainsize loop
sedku(j) = sed(j,ku)*sl1 + sed(j,ku2)*sl2
enddo
endif
endif
sl3 = slnup(3+ip,LL)
cf = dts*abs(u1(L))*dxi(LL) ! cflj(L) !cfli(k ) ! cflj(L)
cf = half*max( 0d0,1d0-cf )
if (limtypsa > 0) then ! set high order term for salinity
! if (min(sa1(kd), sa1(k), saku) > 1d-3 .and. max(sa1(kd), sa1(k), saku) < salmax -1d-3) then ! lower order near top
if ( .true. ) then ! lower order near top
ds2 = sa1(kd) - sa1(k) ! ds1 = voorlopende slope, ds2 = eigen slope
ds1 = (sa1(k) - saku )*sl3
IF (LL == 28580) THEN
DS1 = 1D0*ds1
ENDIF
if (abs(ds2) > eps10 .and. abs(ds1) > eps10) then
if (Limtypsa == 7) then
ds = 0.5d0*ds2 ! central only for cursusdemo
else if (Limtypsa == 6) then
ds1 = is*(dsadx(k)*csu(LL) + dsady(k)*snu(LL))
ds = cf*dlimitercentral(ds1, ds2, limtypsa)
else
ds = cf*dslim(ds1, ds2, limtypsa)
endif
if (abs(ds) > eps10) then
qsho(L) = ds*ql
endif
endif
! plotlin(L) = qds
endif
endif
if (limtyptm > 0) then ! set high order term for temperature
ds2 = tem1(kd) - tem1(k) ! ds1 = voorlopende slope, ds2 = eigen slope
ds1 = (tem1(k) - teku )*sl3
if (abs(ds2) > eps10 .and. abs(ds1) > eps10) then
ds = cf*dslim(ds1, ds2, limtypsa)
if (abs(ds) > eps10) then
qtho(L) = ds*ql
endif
endif
endif
if (limtypsed > 0) then ! set high order term for sediment, transport limiter equal to that for salinity , = limtypsal
do j = 1,mxgr ! grainsize loop
ds2 = sed(j,kd) - sed(j,k) ! ds1 = voorlopende slope, ds2 = eigen slope
ds1 = (sed(j,k) - sedku(j) )*sl3
if (abs(ds2) > eps10 .and. abs(ds1) > eps10) then
ds = cf*dslim(ds1, ds2, limtypsed)
if (abs(ds) > eps10) then
qds = ds*ql
sdupq(j,kd) = sdupq(j,kd) + qds
sdupq(j,k ) = sdupq(j,k ) - qds
endif
! plotlin(L) = qds
endif
enddo
endif
endif
enddo ! vertical
endif
enddo ! horizontal
nrimptran = 0
if (jasal > 0 .and. nrimptran > 0) then
if (.not. allocated(sa00) ) then
allocate ( sa00(ndkx), cch(lnkx) )
endif
cfli = 0d0 ; cflj = 0d0 ; tetaj = 0d0
do L = 1,lnx ! set courant j for downwind i, add j's for i
if (q1(L) .ne. 0d0) then
k1 = ln(1,L) ; k2 = ln(2,L)
if ( q1(L) > 0 .and. vol0(k2) > 0d0) then
cflj(L) = dts*q1(L)/vol0(k2)
cfli(k2) = cfli(k2) + cflj(L)
else if (q1(L) < 0 .and. vol0(k1) > 0d0) then
cflj(L) = -dts*q1(L)/vol0(k1)
cfli(k1) = cfli(k1) + cflj(L)
endif
endif
enddo
do k = 1,ndx
if (cfli(k) > 1) nrimptran = nrimptran + 1
enddo
if (nrimptran > 0) then
do L = 1,lnx ! set tetaj as tetai upwind cell
tetaj(L) = 0d0
if (q1(L) .ne. 0d0) then
k1 = ln(1,L) ; k2 = ln(2,L)
if ( q1(L) > 0) then
tetaj(L) = max(0d0, 1d0 - 1d0/cfli(k1) )
else if (q1(L) < 0) then
tetaj(L) = max(0d0, 1d0 - 1d0/cfli(k2) )
endif
endif
enddo
endif
sa00 = sa1 / max( 1d0, cfli ) ! normalise with bbk
do L = 1,lnx ! set up ccn, normalise with bbk
k1 = ln(1,L) ; k2 = ln(2,L)
if ( q1(L) > 0) then
cch(L) = cflj(L)*tetaj(L) / max( 1d0, cfli(k2) ) ! L komt binnen voor k2
else if (q1(L) < 0) then
cch(L) = cflj(L)*tetaj(L) / max( 1d0, cfli(k1) )
else
cch(L) = 0d0
endif
enddo
epssa = 1d9
do it = 1,maxit
sa0 = sa1
sa1 = sa00
do L = 1,lnx
if ( cch(L) > 0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
if ( q1(L) > 0) then
sa1(k2) = sa1(k2) + sa0(k1)*cch(L)
else if (q1(L) < 0) then
sa1(k1) = sa1(k1) + sa0(k2)*cch(L)
endif
endif
enddo
epssa = maxval(dabs(sa0-sa1))
if (epssa < eps10) exit
enddo
endif
if (limtypsa > 0 .and. jalim2D > 0) then ! prepare for Kuzmin 2D limiting (comp and applied math 2008)
if (jalim2D == 1) then
pp = 0 ; pm = 0 ; qp = 0 ; qm = 0 ;alf = 1d0
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0d0) then
pp(k2) = pp(k2) + max( 0d0, alf(L)* qsho(L) ) ! set upwind pp, see 4.83
pm(k2) = pm(k2) + min( 0d0, alf(L)* qsho(L) ) !
qp(k1) = qp(k1) + max( 0d0, q1(L)*(sa1(k2)-sa1(k1)) ) ! set downwind qq
qm(k1) = qm(k1) + min( 0d0, q1(L)*(sa1(k2)-sa1(k1)) ) !
else
pp(k1) = pp(k1) + max( 0d0, -alf(L)* qsho(L) ) ! set upwind pp
pm(k1) = pm(k1) + min( 0d0, -alf(L)* qsho(L) ) !
qp(k2) = qp(k2) + max( 0d0, -q1(L)*(sa1(k1)-sa1(k2)) ) ! set downwind qq
qm(k2) = qm(k2) + min( 0d0, -q1(L)*(sa1(k1)-sa1(k2)) ) !
endif
enddo
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L) ; aa = 1d0
if (qsho(L) > 0d0) then
if (pp(k1) .ne. 0d0 .and. qp(k1) .ne. 0d0) then
aa = qp(k1) / pp(k1)
endif
else if (qsho(L) < 0d0 ) then
if (pm(k2) .ne. 0d0 .and. qm(k2) .ne. 0d0) then
aa = qm(k2) / pm(k2)
endif
endif
if (aa > 0d0) then
if ( aa < 1d0) then
alf(L) = aa
endif
else
alf(L) = 1d0
endif
enddo
else if (jalim2D == 2) then
pp = supq ; pm = 0d0 ; qp = -1d3 ; qm = 1d3
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0d0) then
kd = k2 ; k = k1 ; is = 1d0
else
kd = k1 ; k = k2 ; is = -1d0
endif
pp(kd) = pp(kd) + qsho(L)
pm(k ) = pm(k ) + qsho(L)
qp(kd) = max(qp(kd), sa1(k )) ! min and max of neighbours
qm(kd) = min(qm(kd), sa1(k ))
qp(k ) = max(qp(k ), sa1(kd))
qm(k ) = min(qm(k ), sa1(kd))
enddo
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0d0) then ! limit outflow only: check the upwind cell
k = k1
else
k = k2
endif
aa = 1d0
if (pp(k) > 0) then
if (pm(k) > 0) then
if (sa1(k) > qp(k) ) then ! local max
aa = pp(k) / pm(k)
endif
endif
else if (pp(k) < 0) then
if (pm(k) < 0) then
if ( sa1(k) < qm(k) ) then ! local min
aa = pp(k) / pm(k)
endif
endif
endif
if (aa < 0d0) then
aa = 0d0
else if (aa > 1d0) then
aa = 1d0
endif
alf(L) = aa
enddo
else if (jalim2D == 3) then ! testing to see if ho increases max - min, if so, switch off ho
pp = supq
do LL = 1,lnx
if (q1(LL) .ne. 0) then
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0) then
is = 1
else
is = -1
endif
pp(k2) = pp(k2) + qsho(L)*is
pp(k1) = pp(k1) - qsho(L)*is
enddo
endif
enddo
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,k,kb,kt,aa,n,L)
do kk = 1,ndx
if (kfs(kk) == 0) cycle
call getkbotktop(kk,kb,kt)
do k = kb,kt
if (vol1(k) > 0d0) then
aa = sa1(k) + dts*pp(k)/vol1(k)
if ( aa < 0d0 .or. aa > salmax ) then
do n = 1,nd(kk)%lnx
L = iabs( nd(kk)%ln(n) )
qsho(L) = 0d0
enddo
endif
endif
enddo
enddo
!$OMP END PARALLEL DO
endif
do LL = 1,lnx
if (q1(LL) .ne. 0d0) then
call getLbotLtop(LL,Lb,Lt)
do L = Lb, Lt
k1 = ln(1,L) ; k2 = ln(2,L)
if (q1(L) > 0) then
is = 1
else
is = -1
endif
if (qsho(L) .ne. 0d0) then
supq(k2) = supq(k2) + qsho(L)*is
supq(k1) = supq(k1) - qsho(L)*is
endif
if (limtyptm > 0) then
if (qtho(L) .ne. 0d0) then
tupq(k2) = tupq(k2) + qtho(L)*is
tupq(k1) = tupq(k1) - qtho(L)*is
endif
endif
!if (limtypsd > 0) then
! if (qtho(L) .ne. 0d0) then
! sdupq(k2) = sdupq(k2) + qsdho(L)*is
! sdupq(k1) = sdupq(k1) - qsdho(L)*is
! endif
!endif
enddo
endif
enddo
! plotlin = alf
endif
if (jasal > 0 .or. jatem > 0) then
if (jasal > 0) then
sam0 = sam1
sam0tot = sam1tot
sam1tot = 0d0
endif
if (dicouv >= 0d0 ) then ! horizontal diffusion
do LL = 1,lnx
if (hu(LL) > 0d0) then
!n1 = ln(1,LL) ; n2 = ln(2,LL)
!dfac1 = 1d0/dble(nd(n1)%lnx)
!dfac2 = 1d0/dble(nd(n2)%lnx)
! safe for triangles, quads and pentagons, but not for hexahedrons:
dfac1 = 0.2d0
dfac2 = 0.2d0
call getLbotLtop(LL,Lb,Lt)
if (jadiusp == 1) then
diuspL = diusp(LL)
else
diuspL = dicouv
endif
do L = Lb,Lt
k1 = ln(1,L) ; k2 = ln(2,L)
viL = max(0d0, viu(L))
qds = (sigsali*viL + diuspl)*dxi(LL)*au(L)
qds = min( qds, dfac1*vol1(k1)/dts - sqi(k1) , dfac2*vol1(k2)/dts - sqi(k2) ) ! zie Borsboom sobek note
qds = max( 0d0, qds)
if (jasal > 0) then
if (jacreep == 0) then
ds2 = sa1(k2) - sa1(k1)
else
ds2 = dsalL(L)
endif
qsa = qds*ds2
supq(k2) = supq(k2) - qsa
supq(k1) = supq(k1) + qsa
endif
if (jatem > 0) then
if (jacreep == 0) then
ds2 = tem1(k2) - tem1(k1)
else
ds2 = dtemL(L)
endif
qsa = qds*ds2
tupq(k2) = tupq(k2) - qsa
tupq(k1) = tupq(k1) + qsa
endif
if (jased > 0) then
do j = 1,mxgr
ds2 = sed(j,k2) - sed(j,k1)
qsa = qds*ds2
sdupq(j,k2) = sdupq(j,k2) - qsa
sdupq(j,k1) = sdupq(j,k1) + qsa
enddo
endif
enddo
endif
enddo
endif
! UPDATE SALT BY ADDING SALT FLUXES
if (kmx == 0) then ! 2D
!$OMP PARALLEL DO &
!$OMP PRIVATE(k,src)
do k = 1,ndxi
if ( vol1(k) > eps4 ) then
if (jasal > 0) then
src = 0d0 ; if (jasalsrc == 1) src = salsrc(k)
sa1(k) = sa1(k) + dts*(supq(k) - sa1(k)*sq(k) + src ) / vol1(k)
endif
if (jatem > 0) then
tem1(k) = tem1(k) + dts*(tupq(k) - tem1(k)*sq(k) + heatsrc(k) ) / vol1(k)
endif
if (jased > 0) then
do j = 1,mxgr
sed(j,k) = sed(j,k) + dts*(sdupq(j,k) - sed(j,k)*sq(k) ) / vol1(k)
enddo
endif
endif
enddo
!$OMP END PARALLEL DO
if (jampi > 0) then
! update sa1
if (jasal > 0) then
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
call update_ghosts(ITYPE_Sall, 1, Ndx, sa1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
endif
if (jatem > 0) then
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
call update_ghosts(ITYPE_Sall, 1, Ndx, tem1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
endif
end if
else ! 3D
tetav1 = 1d0-tetav
!$xOMP PARALLEL DO &
!$xOMP PRIVATE(kk,kb,kt,km,ku,kd,qst,qstd,qstu,ho,dif,a,b,c,d,e,java,n,adv,adv1,cf,ds1,ds2,m,ja,src) &
!$xOMP REDUCTION(+:sam1tot)
do kk = 1,ndxi
if (kfs(kk) == 0) cycle
call getkbotktop(kk,kb,kt)
!if ( kt < kb ) cycle
!if ( vol1(kb) < eps10 ) cycle
km = kt - kb + 1
difsalw = 0d0 ; diftemw = 0d0 ; difsedw = 0d0
if (dicoww >= 0d0 .and. hs(kk) > epshsdif) then
if (jasal > 0) difsalw = dicoww + difmolsal
if (jatem > 0) diftemw = dicoww + difmoltem
if (jased > 0) difsedw = dicoww + 0d0 ! difmolsed
endif
if (javasal == 1 .or. javasal == 2 ) then ! vertical explicit
do k = kb, kt - 1
if (qw(k) > 0) then ! ku = upwind
ku = k ; kd = k+1 ; qst = qw(k) ! from k to k+1
else
ku = k+1 ; kd = k ; qst = -qw(k) ! from k+1 to k
endif
qstd = qst*(sa1(ku) ) ! -sa1(kd)) ! incoming - self
qstu = qstd ! 0d0
if (javasal > 1) then
ho = qst*(sa1(kd)-sa1(ku))*0.5d0
qstd = qstd + ho ! ho
qstu = qstu + ho ! ho
endif
if (difsalw > 0d0) then
dif = (sigsali*vicwws(k) + difsalw)*(sa1(ku) - sa1(kd) )*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) )
qstd = qstd + dif ; qstu = qstu + dif
endif
supq(kd) = supq(kd) + qstd
supq(ku) = supq(ku) - qstu
enddo
do k = kb,kt
if (vol1(k) > 0d0 ) then
src = 0d0 ; if (jasalsrc == 1) src = salsrc(k)
sa1(k) = sa1(k) + dts*(supq(k) - sa1(k)*sq(k) + src ) / vol1(k)
endif
enddo
else if (javasal >= 3) then ! vertical implicit
java = javasal
if (java >= 5) then ! Forrester alternative: profile upwind if negative stratification
java = 4
if (hs(kk) < chkadvd) then
java = 3
else
do k = kb+1, kt
if (sa1(k) > sa1(k-1) ) then
java = 3
exit
endif
enddo
endif
endif
if (jasal > 0) then
a(1:km) = 0d0 ; b(1:km) = 1d0 ; c(1:km) = 0d0
src = 0d0 ; if (jasalsrc == 1) src = salsrc(kb)
d(1) = sa1(kb) + dts*(supq(kb) - sa1(kb) *sq(kb) + src ) / vol1(kb) ! put sa0 in d
endif
if (jatem > 0) then
ta(1:km) = 0d0 ; tb(1:km) = 1d0 ; tc(1:km) = 0d0
src = heatsrc(kb)
td(1) = tem1(kb) + dts*(tupq(kb) - tem1(kb)*sq(kb) + src ) / vol1(kb) ! put sa0 in d
! BEGIN DEBUG
! td(1) = tem1(kb) + dts*src / vol1(kb) ! put sa0 in d
! END DEBUG
endif
if (jased > 0) then
sa(1:km) = 0d0 ; sb(1:km) = 1d0 ; sc(1:km) = 0d0
src = 0d0 ! sedsrc(kk)
do j = 1,mxgr ! grainsize loop
sd(1) = sed(j,kb) + dts*(sdupq(j,kb) - sed(j,kb)*sq(kb) + src ) / vol1(kb) ! put sa0 in d
enddo
endif
if (java == 3) then ! upwind implicit
do k = kb, kt - 1
n = k - kb + 1
if (difsalw > 0d0) then
dif = dts*(sigsali*vicwws(k) + difsalw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
dif = 0d0
endif
if (diftemw > 0d0) then
dift = dts*(sigtemi*vicwws(k) + diftemw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
dift = 0d0
endif
if (difsedw > 0d0) then
difs = dts*(sigsedi*vicwws(k) + difsedw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
difs = 0d0
endif
if (qw(k) > 0) then
adv1 = dts*qw(k) ; adv = 0d0 ! m3
else if (qw(k) < 0) then
adv = -dts*qw(k) ; adv1 = 0d0
else
adv = 0d0 ; adv1 = 0d0
endif
if (jasal > 0) then
b(n+1) = b(n+1) + ( dif + adv *tetav) / vol1(k+1)
a(n+1) = a(n+1) - ( dif + adv1*tetav) / vol1(k+1)
b(n ) = b(n ) + ( dif + adv1*tetav) / vol1(k )
c(n ) = c(n ) - ( dif + adv *tetav) / vol1(k )
endif
if (jatem > 0) then
tb(n+1) = tb(n+1) + ( dift + adv *tetav) / vol1(k+1)
ta(n+1) = ta(n+1) - ( dift + adv1*tetav) / vol1(k+1)
tb(n ) = tb(n ) + ( dift + adv1*tetav) / vol1(k )
tc(n ) = tc(n ) - ( dift + adv *tetav) / vol1(k )
endif
if (jased > 0) then
sb(n+1) = sb(n+1) + ( difs + adv *tetav) / vol1(k+1)
sa(n+1) = sa(n+1) - ( difs + adv1*tetav) / vol1(k+1)
sb(n ) = sb(n ) + ( difs + adv1*tetav) / vol1(k )
sc(n ) = sc(n ) - ( difs + adv *tetav) / vol1(k )
endif
if (jasal > 0) then
src = 0d0 ; if (jasalsrc == 1) src = salsrc(k+1)
d(n+1) = sa1(k+1) + dts*( supq(k+1) - sa1(k+1)*sq(k+1) + src) / vol1(k+1) ! horizontal explicit, org allinout
if (tetav .ne. 1d0) then
d(n+1) = d(n+1) - tetav1*( sa1(k+1)*adv - sa1(k) *adv1 ) / vol1(k+1)
d(n ) = d(n ) - tetav1*( sa1(k )*adv1 - sa1(k+1)*adv ) / vol1(k )
endif
endif
if (jatem > 0) then
src = heatsrc(k+1)
td(n+1) = tem1(k+1) + dts*( tupq(k+1) - tem1(k+1)*sq(k+1) + src ) / vol1(k+1)
if (tetav .ne. 1d0) then
td(n+1) = td(n+1) - tetav1*( tem1(k+1)*adv - tem1(k) *adv1 ) / vol1(k+1)
td(n ) = td(n ) - tetav1*( tem1(k )*adv1 - tem1(k+1)*adv ) / vol1(k )
endif
endif
if (jased > 0) then
do j = 1,mxgr ! grainsize loop
src = 0d0 ! sedsrc(k+1)
sd(n+1) = sed(j,k+1) + dts*( sdupq(j,k+1) - sed(j,k+1)*sq(k+1) + src ) / vol1(k+1)
if (tetav .ne. 1d0) then
sd(n+1) = td(n+1) - tetav1*( sed(j,k+1)*adv - sed(j,k) *adv1 ) / vol1(k+1)
sd(n ) = td(n ) - tetav1*( sed(j,k )*adv1 - sed(j,k+1)*adv ) / vol1(k )
endif
enddo
endif
! b(k+1):+adv / vol1(k+1) a(k+1):-adv1 / vol1(k+1)
! d(n+1) = d(n+1) - sa0(k+1)*adv / vol1(k+1) + sa0(k) *adv1 / vol1(k+1) ! allinout explicit:
! d(n ) = d(n ) - sa0(k )*adv1 / vol1(k) + sa0(k+1)*adv / vol1(k )
! b(k ):+adv1 / vol1(k) c(k) :-adv / vol1(k )
enddo
else if (java == 4) then ! central implicit
do k = kb, kt - 1
n = k - kb + 1
if (difsalw > 0d0) then
dif = dts*(sigsali*vicwws(k) + difsalw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
dif = 0d0
endif
if (diftemw > 0d0) then
dift = dts*(sigtemi*vicwws(k) + diftemw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
dift = 0d0
endif
if (difsedw > 0d0) then
difs = dts*(sigsedi*vicwws(k) + difsedw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
else
difs = 0d0
endif
adv = 0.5d0*dts*qw(k)*tetav
! BEGIN DEBUG
! adv = 0d0
! dift = 0d0
! dift = dts*(diftemw)*ba(kk) / ( 0.5d0*(zws(k+1) - zws(k-1)) ) ! m3
! END DEBUG
if (jasal > 0) then
b(n+1) = b(n+1) + (dif - adv) / vol1(k+1)
a(n+1) = a(n+1) - (dif + adv) / vol1(k+1)
b(n ) = b(n ) + (dif + adv) / vol1(k)
c(n ) = c(n ) - (dif - adv) / vol1(k)
endif
if (jatem > 0) then
tb(n+1) = tb(n+1) + ( dift - adv ) / vol1(k+1)
ta(n+1) = ta(n+1) - ( dift + adv ) / vol1(k+1)
tb(n ) = tb(n ) + ( dift + adv ) / vol1(k )
tc(n ) = tc(n ) - ( dift - adv ) / vol1(k )
endif
if (jased > 0) then
sb(n+1) = sb(n+1) + ( difs - adv ) / vol1(k+1)
sa(n+1) = sa(n+1) - ( difs + adv ) / vol1(k+1)
sb(n ) = sb(n ) + ( difs + adv ) / vol1(k )
sc(n ) = sc(n ) - ( difs - adv ) / vol1(k )
endif
if (jasal > 0) then
src = 0d0 ; if (jasalsrc == 1) src = salsrc(k+1)
d(n+1) = sa1(k+1) + dts*( supq(k+1) - sa1(k+1)*sq(k+1) + src ) / vol1(k+1)
if (tetav .ne. 1d0) then
adv = 0.5d0*dts*qw(k)*tetav1*(sa1(k) + sa1(k+1))
d(n+1) = d(n+1) + adv/vol1(k+1)
d(n ) = d(n ) - adv/vol1(k)
endif
endif
if (jatem > 0) then
src = heatsrc(k+1)
td(n+1) = tem1(k+1) + dts*( tupq(k+1) - tem1(k+1)*sq(k+1) + src ) / vol1(k+1)
if (tetav .ne. 1d0) then
adv = 0.5d0*dts*qw(k)*tetav1*(tem1(k) + tem1(k+1))
td(n+1) = td(n+1) + adv/vol1(k+1)
td(n ) = td(n ) - adv/vol1(k)
endif
endif
if (jased > 0) then
src = 0d0 ! sedsrc(k+1)
sd(n+1) = sed(1,k+1) + dts*( supq(k+1) - sed(1,k+1)*sq(k+1) + src ) / vol1(k+1)
if (tetav .ne. 1d0) then
adv = 0.5d0*dts*qw(k)*tetav1*(sed(1,k) + sed(1,k+1))
sd(n+1) = sd(n+1) + adv/vol1(k+1)
sd(n ) = sd(n ) - adv/vol1(k)
endif
endif
enddo
endif
!do k = kb, kt check
! n = k - kb + 1
! sa1(k) = d(n)
! if (n > 1) then
! sa1(k) = sa1(k) - a(n)*sa0(k-1)
! endif
! if (n < km) then
! sa1(k) = sa1(k) - c(n)*sa0(k+1)
! endif
!
! sa1(k) = sa1(k) / ( b(n) -1 )
!enddo
if (jasal > 0) then
call tridag(a,b,c,d,e,sa1(kb:kt),km)
endif
if (jatem > 0) then
call tridag(ta,tb,tc,td,e,tem1(kb:kt),km)
endif
if (jased > 0) then
do j = 1,mxgr
call tridag(sa,sb,sc,sd,e,sed(j,kb:kt),km)
enddo
endif
endif
if (maxitverticalforestersal > 0) then
a(1:km) = sa1(kb:kt)
do m = 1, maxitverticalforestersal
d(1:km) = a(1:km)
ja = 0
do k = kb, kt - 1
n = k - kb + 1
dif = d(n+1) - d(n)
if (dif > eps6 .or. d(n) < 0d0 .or. d(n+1) < 0d0 .or. d(n) > salmax .or. d(n+1) > salmax) then
if ( vol1(k) > eps10 .and. vol1(k+1) > eps10 ) then
ja = 1
dif = 0.1666666666667d0*dif*(vol1(k+1) + vol1(k))
a(n) = a(n) + dif / vol1(k)
a(n+1) = a(n+1) - dif / vol1(k+1)
else
dif = 0d0
endif
endif
enddo
if (ja == 0) then
exit
endif
if (n > 80) then
! write(*,*) 'forester n>80'
endif
enddo
sa1(kb:kt) = a(1:km)
do k = kt+1 , kb + kmxn(kk) - 1
sa1(k) = sa1(kt)
enddo
endif
if (maxitverticalforestertem > 0) then
a(1:km) = tem1(kb:kt)
do m = 1, maxitverticalforestertem
d(1:km) = a(1:km)
ja = 0
do k = kb, kt - 1
n = k - kb + 1
dif = d(n+1) - d(n)
if (dif < eps6 .or. d(n) < 0d0 .or. d(n+1) < 0d0 ) then
if ( vol1(k) > eps10 .and. vol1(k+1) > eps10 ) then
ja = 1
dif = 0.1666666666667d0*dif*(vol1(k+1) + vol1(k))
a(n) = a(n) + dif / vol1(k)
a(n+1) = a(n+1) - dif / vol1(k+1)
else
dif = 0d0
endif
endif
enddo
if (ja == 0) then
exit
endif
if (n > 80) then
! write(*,*) 'forester n>80'
endif
enddo
tem1(kb:kt) = a(1:km)
do k = kt+1 , kb + kmxn(kk) - 1
tem1(k) = tem1(kt)
enddo
endif
end do
!$xOMP END PARALLEL DO
if ( jampi.eq.1 ) then
! update sa1
if ( jatimer.eq.1 ) call starttimer(IUPDSALL)
if (jasal > 0) then
call update_ghosts(ITYPE_Sall3D, 1, Ndkx, sa1, ierror)
endif
if (jatem > 0) then
call update_ghosts(ITYPE_Sall3D, 1, Ndkx, tem1, ierror)
endif
if ( jatimer.eq.1 ) call stoptimer(IUPDSALL)
end if
endif ! 3D
! begin DEBUG
1234 continue
if ( jatransportmodule.eq.1 ) then
if ( jasal.gt.0 ) then
sam0 = sam1
sam0tot = sam1tot
end if
call apply_tracer_bc()
call update_constituents(0) ! do all constituents
if ( jasal.gt.0 ) then
sam1tot = 0d0
end if
end if
! end DEBUG
! compute salt error
if ( kmx.eq.0 ) then
if ( jasal.gt.0 ) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(k) &
!$OMP REDUCTION(+:sam1tot)
do k = 1,ndxi
if ( vol1(k) > 0 ) then
rho(k) = setrho(k)
sam1(k) = sa1(k)*vol1(k) ! mass balance
sam1tot = sam1tot + sam1(k) ! mass balance
same(k) = sam1(k) - sam0(k) - dts*supq(k) ! mass balance
endif
enddo
!$OMP END PARALLEL DO
end if
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,kb,kt,km,ku,kd,qst,qstd,qstu,ho,dif,a,b,c,d,e,java,n,adv,adv1,cf,ds1,ds2,m,ja) &
!$OMP REDUCTION(+:sam1tot)
do kk = 1,ndxi
call getkbotktop(kk,kb,kt)
if ( kt < kb ) cycle
if ( vol1(kb) < eps10 ) cycle
km = kt - kb + 1
do k = kb,kt
if ( jasal.gt.0 ) then
sam1(k) = sa1(k)*vol1(k) ! mass balance
sam1tot = sam1tot + sam1(k) ! mass balance
same(k) = sam1(k) - sam0(k) - dts*( supq(k) + qin(k)*salsrc(k) ) ! mass balance
end if
rho(k) = setrho(k)
enddo
do k = kt+1 , kb + kmxn(kk) - 1
rho(k) = rho(kt)
enddo
enddo
!$OMP END PARALLEL DO
! propagate rho
if (jabaroctimeint == 5) then ! rho advection
dts = 0.5d0*dts
if (jarhoxu == 1) then
rho0 = rho
endif
call update_constituents(1) ! do rho only
dts = 2.0d0*dts
endif
endif ! 3D
if ( jasal.gt.0 ) then
if (sam1ini < 0) then
sam1ini = sam1tot
sam0tot = sam1tot
endif
saminbnd = 0d0 ; samoutbnd = 0d0
do LL = lnxi + 1, lnx ! copy on outflow
call getLbotLtop(LL,Lb,Lt)
if (Lt < Lb) then
cycle
endif
do L = Lb, Lt
kb = ln(1,L) ; ki = ln(2,L)
if (q1(L) > 0) then
saminbnd = saminbnd + q1(L)*sa1(kb)*dts ! mass in
else
samoutbnd = samoutbnd - ( q1(L)*sa1(ki)+qsho(L) ) *dts ! mass out
endif
enddo
enddo
samerr = sam1tot - sam0tot - saminbnd + samoutbnd
end if
endif
if (jatem > 0d0) then
! tem1 = tem1 - 50d0 ! tkelvn
endif
if (jased > 0 .and. jased.le.3) then
dmorfax = max(1d0,dmorfac)
if ( jaceneqtr == 1) then ! original cell centre equilibriumtransport approach
if (dmorfac > 0d0) then
blinc = 0d0
endif
jastep = 1 ! 1 = first hor. transport, then limiting
!$OMP PARALLEL DO &
!$OMP PRIVATE(k,flx,seq,wse,hsk,dtvi,wsemx,j,qb,kj,dgrlay)
do k = 1,ndxi
if (vol1(k) > 0d0) then
flx = 0d0
call getequilibriumtransportrates(k, seq, wse, mxgr, hsk) ! get per flowcell and store in small array seq
dtvi = dts/vol1(k)
wsemx = 0.45d0*vol1(k) / ( ba(k)*dts )
do j = 1,mxgr
if ( Wse(j) > wsemx) then
Wse(j) = wsemx
endif
qb = Wse(j)*ba(k) ! (m3/s)
if (jastep == 0) then
flx(j) = qb*( seq(j) - sed(j,k) ) ! (m3/s).(kg/m3) = kg/s , positive = erosion
sed(j,k) = sed(j,k) + dtvi*(sdupq(j,k) + flx(j) ) ! horizontal + vertical transport
else
sed(j,k) = sed(j,k) + dtvi*(sdupq(j,k) ) ! horizontal transport
flx(j) = qb*( seq(j) - sed(j,k) ) ! (m3/s).(kg/m3) = kg/s , positive = erosion
sed(j,k) = sed(j,k) + dtvi*( + flx(j) ) ! vertical transport
endif
dgrlay = - dts*dmorfax*flx(j) / (rhosed(j)*ba(k)*rhobulkrhosed) ! (s)*( )* (kg/s) * (m3 / kg) / m2 = (m)
if (jamorf == 1) then
grainlay(j,k) = grainlay(j,k) + dgrlay
blinc(k) = blinc(k) + dgrlay
dvolbot = dvolbot + dgrlay*ba(k)
endif
enddo
else
sed( :, k ) = 0d0
endif
enddo
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO &
!$OMP PRIVATE(k,j,dtvi)
do k = 1,ndxi
if (vol1(k) > 0d0) then ! horizontal transport over flow nodes
dtvi = dts/vol1(k)
do j = 1,mxgr
sed(j,k) = sed(j,k) + dtvi*(sdupq(j,k) - sed(j,k)*sq(k) ) ! horizontal transport
enddo
else
sed(:, k) = 0d0
endif
enddo
!$OMP END PARALLEL DO
sedi = 0d0
!$OMP PARALLEL DO &
!$OMP PRIVATE(kk,flx, seq, wse, hsk,n,k,dtvi,wsemx,j,qb,dgrlay)
do kk = 1,mxban
flx = 0d0
call getequilibriumtransportrates(kk, seq, wse, mxgr, hsk) ! get per netnode and store in small array seq
n = nban(1,kk) ! net node
k = nban(2,kk) ! flow node
if ( vol1(k) > 0 .and. hsk > 0) then
dtvi = dts/vol1(k) ! (s/m3)
wsemx = 0.45d0*vol1(k) / ( ba(k)*dts ) ! (m/s) was 0.45
do j = 1,mxgr
if ( Wse(j) > wsemx) then
Wse(j) = wsemx
endif
qb = Wse(j) * banf(kk) ! (m3/s)
flx(j) = qb*( seq(j) - sed(j,k) ) ! (m3/s).(kg/m3) = kg/s , positive = erosion
! if (zk(n) > skmx(n) ) then ! no flux if net point above max surrouding waterlevels
! flx(j) = max( 0d0, flx(j) )
! endif
sedi(j,k) = sedi(j,k) + dtvi*flx(j) ! vertical transport (s/m3)*(kg/s) = (kg/m3)
dgrlay = - dts*dmorfax*flx(j) / (rhosed(j)*ban(n)*rhobulkrhosed) ! (s)*( )* (kg/s) * (m3 / kg) * (1/m2) = m
if (jamorf == 1) then
grainlay(j,n) = grainlay(j,n) + dgrlay
zk(n) = zk(n) + dgrlay
dvolbot = dvolbot + banf(kk)*dgrlay
endif
enddo
endif
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL DO &
!$OMP PRIVATE(k,j)
do k = 1,ndxi
do j = 1,mxgr
sed(j,k) = max(0d0, sed(j,k) + sedi(j,k) )
enddo
enddo
!$OMP END PARALLEL DO
endif ! jacenterfluxes
endif ! jased
do LL = lnxi + 1, lnx ! copy on outflow
call getLbotLtop(LL,Lb,Lt)
if (Lt < Lb) then
cycle
endif
do L = Lb, Lt
if (q1(L) < 0) then
kb = ln(1,L) ; ki = ln(2,L)
if (jasal > 0) then
sa1(kb) = sa1(ki)
endif
if (jatem > 0) then
tem1(kb) = tem1(ki)
endif
if (jased > 0) then
do j = 1,mxgr
sed(j,kb) = sed(j,ki)
enddo
endif
endif
enddo
enddo
end subroutine transport
subroutine addbaroclinicpressure()
use m_flowgeom
use m_flow
implicit none
integer :: L,LL,Lb,Lt,k1,k2
double precision, external :: hordiflimited
double precision :: hordif,baroc,barocup
!$OMP PARALLEL DO &
!$OMP PRIVATE(LL,Lb,Lt)
do LL = 1,lnxi
if (hu(LL) == 0d0) cycle
call getLbotLtop(LL,Lb,Lt)
if (Lt < Lb) then
cycle
endif
call addbaroc(LL,Lb,Lt)
enddo
!$OMP END PARALLEL DO
end subroutine addbaroclinicpressure
subroutine addbaroc(LL,Lb,Lt)
use m_flowgeom
use m_flow
implicit none
integer :: LL,Lb,Lt
double precision :: gradpu(kmxx), rhovol(kmxx), dz1(kmxx), dz2(kmxx)
double precision :: z1u,z1d,z2u,z2d, p1u,p1d,p2u,p2d, r1u,r1d,r2u,r2d, dz3, d2
double precision :: barotr, barocl, alf1,alf2,alf3,gr1,gr2,gr3, zh, hdx, fzu1, fzd1, fzu2, fzd2, dzz, dxx
integer :: k1, k2, L
! rho = rhomean
! do L = Lb, Lt
! k1 = ln(1,L)
! rho(k1) = rhomean + 0.5d0*(zws(k1) + zws(k1-1))
! k2 = ln(2,L)
! rho(k2) = rhomean + 0.5d0*(zws(k2) + zws(k2-1))
! enddo
if (kmx == 0) then
k1 = ln(1,LL) ; k2 = ln(2,LL)
barocl = ag*( rho(k1) - rho(k2) )*hu(LL)*dxi(LL) / ( ( rho(k2) + rho(k1) ) )
adve(LL) = adve(LL) - barocL
return
endif
if (zws(ln(1,Lt)) - zws(ln(1,Lb)-1) < epshs) return
if (zws(ln(2,Lt)) - zws(ln(2,Lb)-1) < epshs) return
do L = Lb, Lt
k1 = ln(1,L)
dz1(L-Lb+1) = max(1d-6, zws(k1) - zws(k1-1) )
enddo
do L = Lb, Lt
k2 = ln(2,L)
dz2(L-Lb+1) = max(1d-6, zws(k2) - zws(k2-1) )
enddo
k1 = ln(1,Lt) ; k2 = ln(2,Lt)
if (Lt > Lb) then
d2 = (dz1(Lt-Lb+1) + dz1(Lt-Lb) )
fzu1 = dz1(Lt-Lb+1) / d2 ; fzd1 = 1d0 - fzu1
d2 = (dz2(Lt-Lb+1) + dz2(Lt-Lb) )
fzu2 = dz2(Lt-Lb+1) / d2 ; fzd2 = 1d0 - fzu2
if (jabaroctimeint == 2) then ! extrapolate rho at n+0.5
r1d = (2d0-fzu1)*(1.5d0*rho(k1) - 0.5d0*rho0(k1)) - fzd1*(1.5d0*rho(k1-1) - 0.5d0*rho0(k1-1)) - rhomean
r2d = (2d0-fzu2)*(1.5d0*rho(k2) - 0.5d0*rho0(k2)) - fzd2*(1.5d0*rho(k2-1) - 0.5d0*rho0(k2-1)) - rhomean
else
r1d = (2d0-fzu1)*rho(k1) - fzd1*rho(k1-1) - rhomean
r2d = (2d0-fzu2)*rho(k2) - fzd2*rho(k2-1) - rhomean
endif
! r1d = 1.5d0*rho(k1) - 0.5d0*rho(k1-1) - rhomean
! r2d = 1.5d0*rho(k2) - 0.5d0*rho(k2-1) - rhomean
else
if (jabaroctimeint == 2 ) then ! extrapolate rho at n+0.5
r1d = 1.5d0*rho(k1) - 0.5d0*rho0(k1) - rhomean
r2d = 1.5d0*rho(k2) - 0.5d0*rho0(k2) - rhomean
else
r1d = rho(k1) - rhomean
r2d = rho(k2) - rhomean
endif
endif
z1d = zws(k1) ; z2d = zws(k2)
p1d = 0d0 ; p2d = 0d0
! barotr = ag*(z2d - z1d) / dx(LL)
! r1d = abs(z1d) ; r2d = abs(z2d) ! forced horizontal
gradpu(1:Lt-Lb+1) = 0d0
rhovol(1:Lt-Lb+1) = 0d0
dxx = dx(LL)
hdx = 0.5d0*dxx
do L = Lt, Lb, -1
k1 = ln(1,L) ; k2 = ln(2,L) !
z1u = z1d ; z2u = z2d
r1u = r1d ; r2u = r2d
p1u = p1d ; p2u = p2d
z1d = zws(k1-1) ; z2d = zws(k2-1)
if (L > Lb) then
fzu1 = dz1(L-Lb+1) / (dz1(L-Lb+1) + dz1(L-Lb) ) ; fzd1 = 1d0 - fzu1
fzu2 = dz2(L-Lb+1) / (dz2(L-Lb+1) + dz2(L-Lb) ) ; fzd2 = 1d0 - fzu2
if (jabaroctimeint == 2 ) then ! extrapolate rho at n+0.5
r1d = fzu1*(1.5d0*rho(k1)-0.5d0*rho0(k1)) + fzd1*(1.5d0*rho(k1-1)-0.5d0*rho0(k1-1)) - rhomean
r2d = fzu2*(1.5d0*rho(k2)-0.5d0*rho0(k2)) + fzd2*(1.5d0*rho(k2-1)-0.5d0*rho0(k2-1)) - rhomean
else
r1d = fzu1*rho(k1) + fzd1*rho(k1-1) - rhomean
r2d = fzu2*rho(k2) + fzd2*rho(k2-1) - rhomean
endif
else
if (Lt > Lb) then
fzu1 = dz1(L-Lb+2) / (dz1(L-Lb+1) + dz1(L-Lb+2) ) ; fzd1 = 1d0 - fzu1
fzu2 = dz2(L-Lb+2) / (dz2(L-Lb+1) + dz2(L-Lb+2) ) ; fzd2 = 1d0 - fzu2
if (jabaroctimeint == 2 ) then ! extrapolate rho at n+0.5
r1d = (2d0-fzd1)*(1.5d0*rho(k1)-0.5d0*rho0(k1)) - fzu1*(1.5d0*rho(k1+1)-0.5d0*rho0(k1+1)) - rhomean
r2d = (2d0-fzd2)*(1.5d0*rho(k2)-0.5d0*rho0(k2)) - fzu2*(1.5d0*rho(k2+1)-0.5d0*rho0(k2+1)) - rhomean
else
r1d = (2d0-fzd1)*rho(k1) - fzu1*rho(k1+1) - rhomean
r2d = (2d0-fzd2)*rho(k2) - fzu2*rho(k2+1) - rhomean
endif
else
if (jabaroctimeint == 2 ) then ! extrapolate rho at n+0.5
r1d = 1.5d0*rho(k1) -0.5d0*rho0(k1) - rhomean
r2d = 1.5d0*rho(k2) -0.5d0*rho0(k2) - rhomean
else
r1d = rho(k1) - rhomean
r2d = rho(k2) - rhomean
endif
endif
endif
if (dz1(L-Lb+1) + dz2(L-Lb+1) < 1d-10) then
rhovol(L-Lb+1) = 1d-10 ; cycle
else
rhovol(L-Lb+1) = rhovol(L-Lb+1) + dz1(L-Lb+1) *( rhomean+0.5d0*(r1u+r1d) )*hdx ! left interface Mass
rhovol(L-Lb+1) = rhovol(L-Lb+1) + dz2(L-Lb+1) *( rhomean+0.5d0*(r2u+r2d) )*hdx ! right interface
if (jarhoxu > 0) rhou(L) = rhovol(L-Lb+1) / ( (dz1(L-Lb+1)+dz2(L-Lb+1))*hdx )
endif
dzz = dz1(L-Lb+1)
alf1 = r1d - r1u
p1d = p1u + r1u*dzz + 0.50*alf1*dzz
gr1 = p1u*dzz + 0.5d0*r1u*dzz*dzz + alf1*dzz*dzz/6d0 ! your left wall
dzz = dz2(L-Lb+1)
alf2 = r2d - r2u
p2d = p2u + r2u*dzz + 0.50*alf1*dzz
gr2 = p2u*dzz + 0.5d0*r2u*dzz*dzz + alf2*dzz*dzz/6d0 ! your right wall
dz3 = z2d - z1d
alf3 = r1d - r2d
gr3 = p2d*dz3 + 0.5d0*r2d*dz3*dz3 + alf3*dz3*dz3/6d0 ! your own floor
gradpu(L-Lb+1) = gradpu(L-Lb+1) + gr1 - gr2 - gr3
if (L > Lb ) then
gradpu(L-Lb) = gradpu(L-Lb) + gr3 ! ceiling of ff# downstairs neighbours
endif
enddo
do L = Lt, Lb, -1
if (rhovol(L-Lb+1) > 0d0) then
barocl = ag*gradpu(L-Lb+1)/rhovol(L-Lb+1) ! + barotr
if (jabaroctimeint == 3) then ! Adams bashford
adve(L) = adve(L) - 1.5d0*barocl + 0.5d0*dpbdx0(L)
dpbdx0(L) = barocL
else
adve(L) = adve(L) - barocl
endif
endif
enddo
end subroutine addbaroc
double precision function hordiflimited(LL,L,rho_,nx) ! used to compute a strict horizontal gradient see vkester,stelling 1994
use m_flow
use m_flowgeom
implicit none
integer :: L,LL,nx
double precision, intent (in) :: rho_(nx)
integer :: k1,k2,k2u,k1u,n1,n2,kb1,kb2,kt1,kt2
double precision :: alfu, rho1, rho2, drho1, drho2, drho3, drho4
k1 = ln(1,L)
k2 = ln(2,L)
k2u = k2
n2 = ln(2,LL) ; kb2 = kbot(n2); kt2 = ktop(n2)
if (zws(k1) < zws(k2) .and. k2u > kb2) then
do while ( zws(k2u-1) > zws(k1) .and. k2u > kb2)
k2u = k2u - 1
enddo
alfu = zws(k1) - zws(k2u-1) / ( zws(k2u) - zws(k2u-1) )
rho2 = alfu*rho_(k2u) + (1d0-alfu)*rho_(k2u-1)
else if (zws(k1) > zws(k2) .and. k2u < kt2 ) then
do while ( zws(k2u) < zws(k1) .and. k2u < kt2)
k2u = k2u + 1
enddo
alfu = zws(k1) - zws(k2u-1) / ( zws(k2u) - zws(k2u-1) )
rho2 = alfu*rho_(k2u) + (1d0-alfu)*rho_(k2u-1)
else
rho2 = rho(k2)
endif
k1u = k1
n1 = ln(1,LL) ; kb1 = kbot(n1); kt1 = ktop(n1)
if (zws(k2) < zws(k1) .and. k1u > kb1) then
do while ( zws(k1u-1) > zws(k2) .and. k1u > kb1)
k1u = k1u - 1
enddo
alfu = zws(k2) - zws(k1u-1) / ( zws(k1u) - zws(k1u-1) )
rho1 = alfu*rho_(k1u) + (1d0-alfu)*rho_(k1u-1)
else if (zws(k2) > zws(k1) .and. k1u < kt1 ) then
do while ( zws(k1u) < zws(k2) .and. k1u < kt1)
k1u = k1u + 1
enddo
alfu = zws(k2) - zws(k1u-1) / ( zws(k1u) - zws(k1u-1) )
rho1 = alfu*rho_(k1u) + (1d0-alfu)*rho_(k1u-1)
else
rho1 = rho_(k1)
endif
drho1 = rho2 - rho_(k1)
drho2 = rho_(k2) - rho1
if (limiterhordif == 1) then ! minmod
if (drho1*drho2 <= 0) then
hordiflimited = 0d0
else if ( abs(drho1) < abs(drho2) ) then
hordiflimited = drho1
else
hordiflimited = drho2
endif
elseif (limiterhordif == 2) then ! monotonized central
drho3 = rho_(k2) - rho_(k1)
drho4 = 0.5d0*(drho1 + drho2)
if (drho1*drho2 <= 0) then
hordiflimited = 0d0
else if ( abs(drho4) < abs(drho3) ) then
hordiflimited = drho4
else if ( min(abs(drho1),abs(drho2)) < abs(drho3) .and. abs(drho3) < max(abs(drho1),abs(drho2)) ) then
hordiflimited = drho3
else if (drho1 > 0d0) then
hordiflimited = min( abs(drho1),abs(drho2) )
else
hordiflimited = -min( abs(drho1),abs(drho2) )
endif
endif
end function hordiflimited
subroutine inidensconstants()
use m_physcoef
implicit none
double precision :: temp
temp = backgroundwatertemperature
cp0 = 5890.0d0 + 38.00d0*temp - 0.3750d0*temp*temp
clam = 1779.5d0 + 11.25d0*temp - 0.0745d0*temp*temp
clam0 = 3.8d0 + 0.01d0*temp
end subroutine inidensconstants
double precision function rho_Eckart(k)
! use m_physcoef
use m_flow, only : sa1, tem1, jasal, jatem , backgroundsalinity , backgroundwatertemperature, zws
implicit none
integer :: k
double precision :: cp1, clam1, temp2, saL, temp, dum
double precision :: cp0, clam0, clam, alph0
if (jasal > 0) then
saL = max(0d0, sa1(k))
else
saL = backgroundsalinity
endif
if (jatem > 0) then
temp = max(0d0, tem1(k))
else
temp = backgroundwatertemperature
endif
temp2 = temp*temp
cp0 = 5890.0d0 + 38.00d0*temp - 0.3750d0*temp2
clam = 1779.5d0 + 11.25d0*temp - 0.0745d0*temp2
clam0 = 3.8d0 + 0.01d0*temp
cp1 = cp0 + 3.0d0*saL
clam1 = clam - clam0*saL
rho_Eckart = 1000.0d0*cp1/(0.698d0*cp1+clam1) ! alph0
! rho_Eckart = 1000.0d0* ( cp1/(alph0*cp1+clam1) - 1d0)
! rho_Eckart = abs( 0.5d0*(zws(k)+zws(k-1)) )
! rho_Eckart = 0.7d0*saL + 1000d0
end function rho_Eckart
double precision function setrho(k)
use m_physcoef
use m_flow
implicit none
integer :: k
double precision :: rho_Eckart
if (idensform == 0) then ! Uniform density
setrho = rhomean
else if (abs(idensform) == 1) then ! Carl Henry Eckhart, 1958
setrho = rho_Eckart(k)
else if (abs(idensform) == 2) then ! Unesco
!setrho = rho_Unesco(k)
else if (abs(idensform) == 3) then ! Baroclinic instability
setrho = 1025d0 + 0.78d0*(sa1(k) - 33.73d0)
endif
if (jased > 0) then
endif
setrho = min(setrho, 1250d0) ! check overshoots at thin water layers
setrho = max(setrho, 990d0) !
end function setrho
subroutine getequilibriumtransportrates2(L, kb1, kb2, seq, wse, mx, hsk, jamin) ! get equilibrium transportrateconc seq based on bans associated with bndlink L
use m_netw
use m_flowgeom
use m_sediment
implicit none
integer :: L, kb1, kb2, mx, jamin ! Linknr, left and right ban nr, mxgr,
double precision :: seq(mx) , seq2(mx) ! seq(kg/m3)
double precision :: wse(mx) ! effective fall velocity (m/s)
double precision :: hsk ! waterdepth, flowcell or ban
integer :: k1, k2, kk, n, j
if (kb1 == 0) then ! if bans unknown, first find them
k1 = lncn(1,L) ; k2 = lncn(2,L)
do kk = 1,mxban
n = nban(1,kk) ! net node
if (kb1 == 0) then
if (n == k1) kb1 = kk
endif
if (kb2 == 0) then
if (n == k2) kb2 = kk
endif
if (kb1 .ne. 0 .and. kb2 .ne. 0) then
exit
endif
enddo
endif
call getequilibriumtransportrates(kb1, seq , wse, mx, hsk)
call getequilibriumtransportrates(kb2, seq2, wse, mx, hsk)
if (jamin == 1) then
do j = 1,mxgr
seq(j) = min( seq(j), seq2(j) )
enddo
else
do j = 1,mxgr
seq(j) = max( seq(j), seq2(j) )
enddo
endif
end subroutine getequilibriumtransportrates2
subroutine getequilibriumtransportrates(kk, seq, wse, mx, hsk) ! get them for flowcell kk or ban kk
use m_flowgeom
use m_flow
use m_netw
use m_sediment
implicit none
integer, intent (in) :: kk,mx ! flowcell kk or ban kk
double precision, intent (out) :: seq(mx) ! seq(kg/m3)
double precision, intent (out) :: wse(mx) ! effective fall velocity (m/s)
double precision, intent (out) :: hsk ! waterdepth, flowcell or ban
double precision :: cfsk, cz, taucur, flx ! ,taubmx (Turned off by Bas)
double precision :: ucr, ueff, Twave, Uwave, Ucur, Ucrc, Ucrw, Pmob, beta, D50h, sbeq
double precision :: aref, Tmob, crefa, sseq, ustar, ustar2, rouse,sqcf,dj1,dj2,z0k,dks,hdune=0
double precision :: qsseq,garciaeinstein, effic, bav, caver, botsu, qsseqcheck, eincheck, eincheck2
double precision :: qssevr84 ,vr84rel, deltaa, seqbed
double precision :: blmin, blmax, hpr,dzz,wu2,wid,ar,hyr, zbu
double precision :: erodable, sumlay, hseqb, aa , dmorfacL, dh, ustar2swart, astar, fw, qeng, cf
integer :: j, kj, n, k, kg, nn, n1, L, jabanhydrad = 0
double precision, external :: dbdistance
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
seq = 0d0 ; flx = 0d0
if (jaceneqtr == 1) then
k = kk
if (ibedlevtyp == 1 .or. ibedlevtyp == 6) then ! tile type
hsk = s1(k) - bl(k)
else ! u-netwnodes / conv type
hsk = 0d0 ; nn = 0
do n = 1, netcell(k)%n
n1 = netcell(k)%nod(n)
dh = max(0d0, s1(k)-zk(n1))
if (dh > 0d0) then
nn = nn + 1
hsk = hsk + dh
endif
enddo
if (nn > 0) then
hsk = hsk / nn
endif
endif
else
n = nban(1,kk) ! net node
k = nban(2,kk) ! flow node
hsk = 0d0
if (jabanhydrad == 1) then ! Hydraulic radius for this ban
wu2 = dbdistance( xz(k), yz(k), xk(n), yk(n) )
L = nban(3,kk)
zbu = 9d9
if (L > 0) then
zbu = 0.5d0*( bob(1,L) + bob(2,L) )
endif
L = nban(4,kk)
if (L > 0) then
zbu = 0.5d0*( bob(1,L) + bob(2,L) ) + zbu
zbu = 0.5d0*zbu
endif
if (s1(k) > zbu) then
hpr = s1(k) - zbu
dzz = zk(n) - zbu
call widarhyr(hpr,dzz,wu2,wid,ar,hyr)
hsk = hyr
endif
else
hsk = s1(k) - zk(n) ! todo make netnode oriented waterlevel
endif
endif
if (hsk < epshs) then ! local waterdepth (m)
return
endif
call getczz0(hsk, frcuni, ifrctypuni, cz, z0k) ! get roughness as specified in hydrodynamics
sqcf = sag/cz ! sqrt(g)/C ( )
! or whatever comes out of the roughness predictor, and van Rijn takes z0 = 3D90
dks = 30d0*z0k ! nikuradse roughness (m)
if (dks > 0.5d0*hsk) then !0.2
return
endif
hdune = 0d0 ! half duneheight (m)
wse = ws
if (jaceneqtr == 1) then
ucur = sqrt(ucx(k)*ucx(k) + ucy(k)*ucy(k) ) ! ! current (transport) velocity (m/s)
else
ucur = sqrt(ucnx(n)*ucnx(n) + ucny(n)*ucny(n) )
endif
if (jased == 3) then ! Engelund:
cf = sqcf*sqcf
qeng = 0.05d0*cf*sqcf*(ucur**5)/ (D50(1)*(rhodelta(1)*ag)**2 ) ! (m2/s)
sseq = qeng / ( max(ucur,1d-2)*hsk ) ! ( ) dimensionless equilibrium 2D transport suspended sediment concentration
sseq = alfasus*sseq
seq(1) = rhosed(1)*sseq ! equilibrium transport concentration bed + suspended (kg/m3)
wse(1) = wse(1)*crefcav
else
ueff = ucur ; beta = 1d0 ; twave = 0d0 !
ustar2swart = sqcf*sqcf*Ueff*Ueff
if (jawave > 0 .and. ueff > 0d0) then
if (twav(k) > 1d-2) then
twave = twav(k)
uwave = uorb(k) ! (m/s) for jased == 2, tauwav contains uorb
beta = ucur / ( ucur + uwave ) ! ( )
Ueff = Ueff + 0.4d0*uwave ! (m/s) SvR 2007
if (MxgrKrone > 0) then
astar = twave*uwave/z0wav ! wave (skin) friction factor (Swart) and drag coefficient
if (astar > 296d0) then ! 30*pi*pi
fw = 0.00251*exp(14.1/(astar**0.19))
else
fw = 0.3d0
endif
ustar2swart = ustar2swart + 0.5d0*fw*uwave*uwave ! Swart
endif
endif
endif
ustar = sqcf * Ueff ; ustar2 = ustar*ustar
do j = 1,mxgr ! loop over grainsizes
if (j <= MxgrKrone) then ! following Krone/Swart
if (ustar2swart > Ustcre2(j)) then ! eroderen
Tmob = (ustar2swart - Ustcre2(j) ) / Ustcre2(j) ! ( ) dimensionless mobility parameter
flx = erosionpar(j)*Tmob ! kg/(m2s)
endif
seq(j) = flx / ws(j) ! equilibrium sediment concentration
else ! soulsby van rijn 2007 ASCE,
!Ucr=Accr(j)*log(12.d0*hsk/dks) ! 3d0*D90(j)) ! (2007a (12) )
!Ucr=Accr(j)*log(hsk/(ee*z0k)) / vonkar
Ucr=Accr(j)/sqcf
if (Twave > 0) then
Ucrw = Awcr(j)*Twave**Bwcr(j) ! = 0.24d0*(rhodelta*ag)**0.66d0*D50**0.33d0
Ucr = beta*Ucr + (1d0-beta)*Ucrw ! (m/s)
endif
if (isusandorbed >= 2) then
Pmob = (Ueff - Ucr) / sqsgd50(j) ! ( ) dimensionless mobility parameter
sbeq = 0d0
if (Pmob > 0 ) then
Pmob = Pmob**1.5d0 ! ( ) dimensionless mobility, old power was 2.4d0
D50h = ( D50(j)/ hsk )**1.2d0 ! ( )
sbeq = 0.015d0*D50h*Pmob ! ( ) dimensionless equilibrium bedload concentration, formula 12 , so bed load transport =
! qb = u.h.sbeq.rhosed ( (m/s) . m . ( ). (kg/m3) ) = ( kg/(sm) ), old alfa was .005
seq(j) = sbeq*rhosed(j) ! equilibrium concentration (kg/m3)
endif
endif
! reference height is max of (nikuradse and half dune height) (m)
aref = max(dks,hdune) ! vRijns book page 7.65 (line 6)
aref = max(aref,0.01d0*hsk) ! vRijns book page 7.64 (line 3)
aref = min(aref,0.25d0*hsk) ! check, always < .25 waterdepth
! vrijns book pag 8.50 r 3 ????
Tmob = (Ueff*Ueff - Ucr*Ucr)/ (Ucr*Ucr) ! Mobility parameter T ( )
if (Tmob > 0d0) then
rouse = ws(j)/(vonkar*ustar)
crefa = 0.015d0*(D50(j)/aref)*(Tmob**1.5d0)*Dstar03(j) ! dimensionless reference concentration ( ), (book vRijn 1993, (7.3.31) )
!crefa = min(crefa, 0.65d0) ! max ref concentration ( ) or (book Garcia 2008, (2-226) )
!crefa = min(crefa, 0.15d0)
crefa = min(crefa, 0.05d0) ! vRijns book ?
call check_einstein_garcia2(aref,hsk,z0k,rouse, eincheck2) ! numerical check einstein integrals, now used as vertical integrator anyway
!qssevr84 = 0.012d0*Ueff*D50(j)*Pmob**2.4d0*Dstar(j)**-0.6d0 ! boek vanrijn (7.3.46), or 2007b
qsseq = eincheck2*crefa*ustar/vonkar ! (conclusion : inaccuracy of einstein_garcia is about 10-20 )
!qsseq = qssevr84
sseq = qsseq/ ( max(ucur,1d-2)*hsk ) ! ( ) dimensionless equilibrium 2D transport suspended sediment concentration
! call checksuspended_transport()
seq(j)= seq(j) + rhosed(j)*sseq ! equilibrium transport concentration bed + suspended (kg/m3)
wse(j)= ws(j)*crefa/(sseq+sbeq) ! effective 2Dh fall velocity er (m/s)*( )
endif
endif
enddo
endif ! !jased 1, 2
sumlay = 0d0 ! check bed material
if (jaceneqtr == 1) then
kg = k
else
kg = n
endif
sumlay = 0d0 ! check bed material
do j = 1,mxgr
sumlay = sumlay + grainlay(j,kg)
enddo
dmorfacL = max(1d0,dmorfac)
if (sumlay == 0d0) then
seq(1:mxgr) = 0d0
else
do j = 1,mxgr
seq(j) = seq(j)*grainlay(j,kg)/sumlay ! normed with erodable fraction (kg/m3)
seqbed = rhosed(j)*grainlay(j,kg)*rhobulkrhosed / (hsk*dmorfacL) ! concentration if all bed material was suspended (kg/m3)
if (grainlay(j,kg) < dks ) then ! limiting below roughness thickness
seqbed = seqbed*grainlay(j,kg)/dks
endif
if (seq(j) > seqbed) then
seq(j) = seqbed
endif
enddo
endif
end subroutine getequilibriumtransportrates
subroutine setgrainsizes() ! for all fractions:
USE M_SEDIMENT
use m_physcoef, only : ag, rhomean, vonkar, backgroundwatertemperature
use MessageHandling
implicit none
integer :: m, j
double precision :: Ucr, sster, c1, c2, wster, wschk, taucr, taucr1, thetcr, pclay=0d0, fcr=1d0
double precision :: a = 2.414d-5, b = 247.8d0, c= 140d0, TempK, s
TempK = 273d0 + backgroundwatertemperature
vismol = A*10**( B / (TempK-C) ) / rhomean
vismol = 4.d0/(20.d0 + backgroundwatertemperature)*1d-5 ! Van rijn, 1993
if (allocated (D90) ) then
deallocate(D90, rhodelta, sqsgd50, dstar, dstar03, Accr, Awcr)
endif
if (mxgr == 0) return
m = mxgr
allocate (D90(m), rhodelta(m), sqsgd50(m), dstar(m), dstar03(m), Accr(m), Awcr(m))
D90 = 2d0*D50
rhodelta = (rhosed-rhomean) / rhomean ! rhodelta = (s-1), s=rhosed/rhomean
sqsgd50 = sqrt( rhodelta*ag*D50)
dstar = D50*( rhodelta*ag/(vismol*vismol) )** (1d0/3d0)
dstar03 = dstar**(-0.3d0)
do j = 1,mxgr
call fdster(dstar(j),taucr,thetcr,pclay,ag,d50(j),rhosed(j),rhomean,FCR) ! vanRijn Tr2004
ACCR(J) = sqsgd50(j)*sqrt(thetcr)
Awcr(j) = D50wa(j)*(rhodelta(j)*ag)**D50wb(j)*D50(j)**D50wc(j)
Sster = D50(J)/(4*vismol)*sqsgd50(J)
c1 = 1.06d0*tanh(0.064d0*Sster*exp(-7.5d0/Sster**2))
c2 = 0.22d0*tanh(2.34d0*Sster**(-1.18d0)*exp(-0.0064d0*Sster**2))
wster = c1+c2*Sster
Ws(j) = wster*sqsgd50(j) ! van Rijn
Wschk = 16.17d0*D50(j)*D50(j)/(1.80d-5 + sqrt(12.12*D50(j)**3) ) ! Ferguson,Church 2006) Wikipedia sand fall velocity
call mess(LEVEL_INFO,' Backgroundwatertemperature (degC) ', real(Backgroundwatertemperature) )
call mess(LEVEL_INFO,' Vismol (m2/s) ', real(Vismol) )
call mess(LEVEL_INFO,' Fraction diameter D50 (m) ', real(D50(j)) )
call mess(LEVEL_INFO,' Fraction diameter Dstar ( ) ', real(Dstar(j)) )
call mess(LEVEL_INFO,' Settling velocity Ws vR (m/s) ', real(Ws(j)) )
call mess(LEVEL_INFO,' Settling velocity Ws F,C (m/s) ', real(Wschk) )
call mess(LEVEL_INFO,' Setting time h=5(m) (days) ', real(5d0/(ws(j)*24*3600) ) )
call mess(LEVEL_INFO,' Rhosed (kg/m3) ', real(rhosed(j)) )
Ucr = Accr(j)*log(4.d0*1d0/D90(j))
call mess(LEVEL_INFO,' Ucrc h=1 (m) (m/s) ', real(UCr) )
Ucr = Accr(j)*log(4.d0*5d0/D90(j))
call mess(LEVEL_INFO,' Ucrc h=5 (m) (m/s) ', real(UCr) )
Ucr = Accr(j)*log(4.d0*20d0/D90(j))
call mess(LEVEL_INFO,' Ucrc h=20 (m) (m/s) ', real(UCr) )
enddo
end subroutine setgrainsizes
subroutine fdster(dster,taucr,thetcr,pclay,g,d50,rhos,rhow,FCR)
IMPLICIT NONE
double precision :: dster,taucr,thetcr,pclay,g,d50,rhos,rhow,FCR
double precision :: dsand, dsilt,cmaxs,fch1,cmax,fpack,fclay
IF(DSTER.LE.1.)THETCR=.24 ! this line added by hk and svdp
IF(DSTER.LE.4.)THETCR=0.115/(DSTER)**0.5
IF(4. .LT.DSTER.AND.DSTER.LE.10.)THETCR=.14*DSTER**(-.64)
IF(10..LT.DSTER.AND.DSTER.LE.20.)THETCR=.04*DSTER**(-.1 )
IF(20..LT.DSTER.AND.DSTER.LE.150.)THETCR=.013*DSTER**(.29 )
IF(DSTER.GT.150.)THETCR=.055
!Soulsby gives one single formula
!THETCR=(0.24/DSTER)+0.055*(1.0-exp(-0.02*DSTER))
dsand=0.000062
dsilt=0.000032
cmaxs=0.65
fch1=(dsand/d50)**1.5
cmax=(d50/dsand)*cmaxs
!cmaxs=maximum bed concentration in case of sandy bottom (=0.65)
if(cmax.lt.0.05)cmax=0.05
if(cmax.gt.cmaxs)cmax=cmaxs
fpack=cmax/cmaxs
if(fch1.lt.1.)fch1=1.
if(fpack.gt.1.)fpack=1.
fclay=1.
if(pclay.ge.0.)fclay=(1.+Pclay)**3.
! if(pclay.ge.0..and.d50.ge.dsand)fclay=(1.+Pclay)**3.
if(fclay.ge.2.)fclay=2.
thetcr=FCR*fpack*fch1*fclay*THETCR
TAUCR=(RHOS-RHOW)*G*D50*THETCR
end
subroutine checksuspended_transport()
implicit none
double precision :: cfsk, cz, taucur, hsk ! ,taubmx (Turned off by Bas)
double precision :: ucr, ueff, Twav, Uwav, Ucur, Ucrc, Ucrw, Pmob, beta, D50h, sbeq, sster, wster, ws
double precision :: aref, Tmob, crefa, sseq, ustar, rouse,sqcf,dj1,dj2,z0k,dks, hdune, qssevr84h
double precision :: qsseq,garciaeinstein, effic, bav, caver, botsu, qsseqcheck, eincheck, eincheck2, qssevr84 ,vr84rel
double precision :: blmin, blmax, D50, D90, dstar, ag, sag, vonkar, ee, rhomean, rhosed, sqsgd50, temp, vismol,c1,c2
double precision :: Accr, D5085, Awcr, s095, rhodelta, wschk, ff, hf, df, qsseqrel, D50a, hska, g, deltaa
integer :: k, j, kj, n, i, kk, mout, nx = 4
ag = 9.81d0
sag = sqrt(ag)
vonkar = 0.41d0
ee = exp(1d0)
ucur = 1d0 ! depth avaraged flow velocity
ueff = ucur ! effective velocity, possibly plus wave contribution
call newfil(mout, 'rvrcheck.xyz')
write(mout,* ) ' Depth , D50 , Refcon , Qsc Numerical, Qsc vR84_D50 ' ! QscNumerical/Refcon, Tau'
hska = 1.5d0
ff = 1.3d0
hf = 1d0 / ( hska*ff**(nx-1) )
D50a = 0.000062d0
df = 1d0 / ( D50a*ff**(nx-1) )
do i = 1,nx
!D50 = D50a*ff**(i-1)
if (i == 1) D50 = 0.000062
if (i == 2) D50 = 0.0002
if (i == 3) D50 = 0.0006
if (i == 4) D50 = 0.002
do j = 1, nx
! hsk = hska*ff**(j-1)
if (j == 1) hsk = 1d0
if (j == 2) hsk = 5d0
if (j == 3) hsk = 20d0
if (j == 4) hsk = 40d0
d90 = 2d0*d50 ! grainsize
dks = 3d0*d90 ! nikuradse
z0k = dks/30d0 ! z0
sqcf = vonkar / log(hsk / (ee*z0k) ) ! sqrt(g)/C ( )
ustar = sqcf*Ucur ! ustar
hdune = 0d0
aref = max(dks,hdune) ! reference height is max of (nikuradse and half dune height) (m)
rhosed = 2650d0 ; rhomean = 1000d0
rhodelta = (rhosed-rhomean) / rhomean ! rhodelta = (s-1), s=rhosed/rhomean
sqsgd50 = sqrt( rhodelta*ag*D50)
Temp = 20d0
vismol = 4.d0/(20.d0+Temp)*1d-5 ! Van rijn, 1993
Sster = D50/(4*vismol)*sqsgd50
c1 = 1.06d0*tanh(0.064d0*Sster*exp(-7.5d0/Sster**2))
c2 = 0.22d0*tanh(2.34d0*Sster**(-1.18d0)*exp(-0.0064d0*Sster**2))
wster = c1+c2*Sster
ws = wster*sqsgd50
dstar = D50*( rhodelta/(vismol*vismol) )** (1d0/3d0)
Wschk = 16.17d0*D50*D50/(1.80d-5 + sqrt(12.12*D50*D50*D50) ) ! Ferguson,Church 2006) Wikipedia sand fall velocity
if(D50<=0.0005d0) then ! calculate treshold velocity Ucr, formula (12)
Accr = 0.19d0*D50**0.1d0
else ! if(D50<0.05d0) then ! Dano see what happens with coarse material
Accr = 8.50d0*D50**0.6d0
endif
Ucr = Accr*log10(4.d0*hsk/D90)
Pmob = (Ueff - Ucr)/Ucr
Tmob = (Ueff*Ueff - Ucr*Ucr)/ (Ucr*Ucr) ! Mobility parameter T ( )
if (Tmob > 0d0) then
rouse = ws/(vonkar*ustar)
!deltaa = aref/hsk
!call einstein_garcia(deltaa,rouse,dj1,dj2) ! einstein integrals following garcia 2008
!garciaeinstein = dj1*log(hsk/z0k) + dj2 ! garcia 2008(2-219) ( )
!garciaeinstein = max(0d0,garciaeinstein)
crefa = 0.015d0*(D50/aref)*(Tmob**1.5d0)/(Dstar**0.3d0) ! dimensionless reference concentration ( ), (book vRijn 1993, (7.3.31) )
if (crefa > 0.65d0) then
crefa = 0.65d0 ! max ref concentration ( ) or (book Garcia 2008, (2-226) )
endif
!qsseq = (crefa*ustar*hsk/vonkar)*garciaeinstein ! equilibrium suspended transport, ( ). (m/s) . (m) = ( m2/s) )
!sseq = qsseq/ ( max(ucur,1d-2)*hsk ) ! ( ) dimensionless equilibrium suspended sediment concentration
call check_einstein_garcia(aref,hsk,z0k,rouse, eincheck) ! numerical check einstein integrals slow, height is already in eincheck
call check_einstein_garcia2(aref,hsk,z0k,rouse, eincheck2) ! numerical check einstein integrals fast, height is already in eincheck
qsseqcheck = (crefa*ustar/vonkar)*eincheck ! (conclusion : inaccuracy of einstein_garcia is about 10-20 % => improve if have time )
qssevr84 = 0.012d0*Ucur*D50*Pmob**2.4d0*Dstar**(-0.6d0) ! boek vanrijn (7.3.46), or 2007b
write(mout,'(7F12.8)') hsk, D50, crefa, qsseqcheck, qssevr84 !, qsseqcheck/ crefa, rhomean*ustar**2
!vr84rel = qssevr84 / qsseqcheck
!qsseqrel = qsseq / qsseqcheck
!caver = crefa*dj1 ! just checking
!if (caver > 0) then
! effic = qsseq / (caver*ucur*hsk) ! just checking
! bav = crefa / caver ! just checking
! botsu = sbeq / sseq ! just checking
!endif
endif
enddo
enddo
call doclose(mout)
end subroutine checksuspended_transport
subroutine tauwavefetch() ! fetchlength and fetchdepth based significant wave height and period
use m_sediment ! based on Hurdle, Stive formulae
use m_netw ! tauwave based on Swart
use m_flowgeom ! taubmx = taucur + tauwave, as in Delwaq
use m_flow
use m_sferic
use m_waves, only: fetch, nwf, fetdp, uorb, twav
use m_missing
USE M_OBSERVATIONS
implicit none
double precision :: U10, fetchL, fetchd, hsig, tsig, tlim, rl, rl0
double precision :: dir, uwin, vwin, prin, cs, sn, fetc, fetd, xn, yn, sumw, www , dsk2
double precision :: SL,SM,XCR,YCR,CRP, alfa1, alfa2, wdep, xzk, yzk, dist, distmin, celsiz
integer :: k, L, kk, kkk, k1, k2, kup, n, ndone, ierr, nup, nupf, jacros, nw1, nw2, nodenum, knw = 5
INTEGER :: NDIR, NWND, NSTAT, MOUT, ndoneprevcycle, kkmin
double precision, allocatable :: xzav(:), yzav(:)
double precision, external :: dbdistance
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
if ( .not. allocated (fetch) .or. size (fetch,2) .ne. ndx) then
nwf = 13
if ( allocated (fetch) ) deallocate (fetch)
allocate ( fetch(nwf, ndx) , stat = ierr)
call aerr('fetch(nwf, ndx)', ierr , ndx*nwf) ; fetch = dmiss
if ( allocated (fetdp) ) deallocate (fetdp)
allocate ( fetdp(nwf, ndx) , stat = ierr)
call aerr('fetdp(nwf, ndx)', ierr , ndx*nwf) ; fetdp = dmiss
allocate ( xzav(ndx) , stat=ierr)
call aerr('xzav(ndx)', ierr , ndx) ; xzav = 0d0
allocate ( yzav(ndx) , stat=ierr)
call aerr('yzav(ndx)', ierr , ndx) ; yzav = 0d0
do k = 1,ndx2d
do kkk = 1,netcell(k)%n
xzav(k) = xzav(k) + xk( netcell(k)%nod(kkk) )
yzav(k) = yzav(k) + yk( netcell(k)%nod(kkk) )
enddo
xzav(k) = xzav(k) / netcell(k)%n
yzav(k) = yzav(k) / netcell(k)%n
enddo
do n = 1, nwf
dir = twopi *real (n-1) / real(nwf-1)
uwin = cos(dir) ; vwin = sin(dir)
ndone = 0
do k = 1,ndx2d
kkmin = 0 ; distmin = 1d10; celsiz = 0d0
do kk = 1,netcell(k)%n
L = netcell(k)%lin(kk)
k1 = netcell(k)%nod(kk)
if (kk == netcell(k)%n) then
k2 = netcell(k)%nod(1)
else
k2 = netcell(k)%nod(kk+1)
endif
wdep = s1(k) - min(zk(k1),zk(k2))
celsiz = max(celsiz, dbdistance(xk(k1), yk(k1), xk(k2), yk(k2) ) )
if (lnn(L) == 1 .or. wdep < 0.5d0) then ! link shallow or closed => start fetch here
call normalout(xk(k1), yk(k1), xk(k2), yk(k2), xn, yn)
prin = uwin*xn + vwin*yn
if ( prin < 0d0 ) then ! if upwind
crp = 0d0
CALL CROSS(Xk(k1),Yk(k1),Xk(k2),Yk(k2),Xzav(k),Yzav(k),Xzav(k)-1d4*uwin,Yzav(k)-1d4*vwin, &
JACROS,SL,SM,XCR,YCR,CRP)
dist = dbdistance(xzav(k), yzav(k), xcr, ycr)
if (dist < distmin) then
distmin = dist ; kkmin = kk ! closest upwind edge e
endif
endif
endif
enddo
if (kkmin > 0) then
fetch(n,k) = min(distmin, celsiz)
fetdp(n,k) = max( hs(k), .1d0)
ndone = ndone + 1
endif
enddo
do while ( ndone < ndx2d)
ndoneprevcycle = ndone
do k = 1,ndx2d
if (fetch(n,k) .eq. dmiss) then
kup = 0 ; fetc = 0; fetd = 0; sumw = 0; nup = 0; nupf = 0
do kk = 1,nd(k)%lnx
L = iabs( nd(k)%ln(kk) )
k2 = ln(1,L) ; if (k2 == k) k2 = ln(2,L)
if ( kcs(k2) == 2 ) then ! internal
prin = uwin*(xzav(k)-xzav(k2)) + vwin*(yzav(k)-yzav(k2))
dsk2 = dbdistance(xzav(k2), yzav(k2), xzav(k), yzav(k))
cs = prin/dsk2
if (cs > 0) then ! internal upwind points
nup = nup + 1
if (fetch(n,k2) .ne. dmiss) then ! do not look at open boundaries
nupf = nupf + 1
sn = sqrt( 1d0 - cs*cs)
! www = (1d0-sn)/dsk2 ! first attempt
www = (cs + 0.05d0*sn)*wu(L)/dsk2 ! some diffusion
fetc = fetc + www*(fetch(n,k2) + prin)
fetd = fetd + www*(fetch(n,k2) + prin)*max(.1d0, 0.8d0*fetdp(n,k2) + 0.2d0*(s1(k)-bl(k)) )
sumw = sumw + www
endif
endif
endif
enddo
if (nup == nupf .and. sumw > 0d0) then
fetch(n,k) = fetc/sumw
fetdp(n,k) = fetd/ ( sumw*fetch(n,k) )
ndone = ndone + 1
! plotlin(k) = fetch(n,k)
! if (mod (k,100) == 0)WRITE(*,*) k, NDONE, N, NDX
endif
endif
enddo
if (ndoneprevcycle == ndone) then
write(*,*) 'fetch network connectivity problem'
return
endif
enddo
enddo
! CALL NEWFIL(MOUT, 'WINDROSE.TXT')
deallocate(xzav,yzav)
! plotlin(1:ndx2d) = fetch(1,1:ndx2d)
endif
do k = 1,ndx2d
uorb(k) = 0 ; Twav(k) = 0d0
if ( hs(k) < 0.01d0 ) then
cycle
endif
L = IABS(ND(K)%LN(1) ) ! het is maar voor wind
U10 = SQRT( WX(L)*WX(L) + WY(L)*WY(L) )
IF (U10 .LT. 1) cycle
DIR = ATAN2(WY(L), WX(L))
IF (DIR < 0D0) DIR = DIR + TWOPI
!DO NSTAT = 1,3
! K = KOBS(NSTAT)
! WRITE(MOUT,*) K, NAMOBS(NSTAT)
! DO NWND = 6,21,3
! U10 = DBLE(NWND)
! DO NDIR = 0,360,15
! DIR = DBLE(270 - NDIR)
! IF (DIR <0) DIR = DIR + 360
! DIR = DIR*DG2RD
dir = dir/twopi
if (dir >= 1d0) dir = 0d0
NW1 = DIR*(nwf-1) + 1
NW2 = NW1 + 1
alfa2 = (nwf-1)*( dir - dble(nw1-1) / dble(nwf-1) )
alfa1 = 1d0 - alfa2
fetchL = alfa1*fetch(nw1,k) + alfa2*fetch(nw2,k)
fetchD = alfa1*fetdp(nw1,k) + alfa2*fetdp(nw2,k)
if (jawave == 1) then
call hurdlestive (U10, fetchL, fetchD, Hsig, Tsig)
else if (jawave == 2) then
call ian_young_pt(U10, fetchL, fetchD, Hsig, Tsig)
endif
Twav(k) = Tsig
call tauwave(Hsig, Tsig, hs(k), Uorb(k), k)
! WRITE(MOUT,*) NDIR, HSIG, TSIG, NWND
! ENDDO
! ENDDO
! ENDDO
! tlim = 65.9*fs**0.6666667d0 ! alternatively, compute limited fetch given limited duration
! tlim = tlim*ua/ag
if (NDRAW(28) == 35) then
plotlin(k) = fetchL
else if (NDRAW(28) == 36) then
plotlin(k) = fetchD
else if (NDRAW(28) == 37) then
plotlin(k) = Hsig
else if (NDRAW(28) == 38) then
plotlin(k) = Tsig
else if (NDRAW(28) == 39) then
! plotlin(k) = Taucur
else if (NDRAW(28) == 40) then
plotlin(k) = uorb(k)
endif
enddo
end subroutine tauwavefetch
subroutine tauwave(Hsig, Tsig, Depth, Uorbi, k)
use m_sediment
use m_sferic
use m_flow, only: plotlin, rhog, rhomean, jased
use m_sediment
implicit none
double precision :: Hsig, Tsig, Depth, uorbi, Tauw
integer :: k, jatauw = 2
double precision :: hk, sh2hk,hksh2,rn,asg,ew,sxx,syy,dtau,shs, h2k, cc, cg, omeg, ustokesbas
double precision :: dsk2, rk, astar, fw
double precision, external :: tanhsafe, sinhsafe, sinhsafei
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
call getwavenr(depth,tsig,rk)
hsig = min( hsig,0.4d0*depth )
shs = sinhsafei(rk*depth)
uorbi = pi*hsig*shs/tsig !omeg*(0.5*hsig)
if (jatauw == 1) then ! tauwav = tauw following Swart
endif ! Soulsby v Rijn use Uorb
return
if (ndraw(28) >= 35) then
plotlin(k) = 0d0
endif
if (ndraw(28) > 40) then
omeg = twopi/tsig ! omega
cc = omeg/rk ! fase velocity
hk = rk*depth ! kh
sh2hk = sinhsafei(2d0*hk) ! 1/sinh(2hk)
hksh2 = hk*sh2hk ! kh/sinh(2kh)
rn = 0.5d0 + hksh2 ! cg/c
cg = cc*rn ! group velocity
asg = 0.5d0*hsig ! significant wave amplitude
ew = 0.5d0*rhog*asg*asg ! wave energy
ustokesbas = 0.5d0*cc*rk*asg*asg ! Stokes drift
Sxx = ew*(0.5d0 + 2d0*hksh2) ! radiation stress in wave dir
Syy = ew*hksh2 ! radiation stress perpendicular to wave dir
endif
end subroutine tauwave
subroutine hurdlestive(U10,fetchL,fetchD,Hsig,Tsig)
use m_physcoef
IMPLICIT NONE
double precision :: U10,fetchL,fetchD,Hsig,Tsig
double precision :: rt, ua,fs,ds,aa1,aa2,aa3,aa4
double precision, external :: tanhsafe
rt = 1.1d0 ! temperature and density dependent
ua = 0.71d0*(rt*U10)**1.23 ! reference wind speed
fs = ag * fetchl / ua**2 ! dimensieloze strijklengte
ds = ag * fetchd / ua**2 ! dimensieloze diepte
aa1 = 0.60d0 *ds**0.750d0 ! formulae from : Coastal stabilisation, R. Silvester, J.R.C. Shu, 2.35 en 2.36
! taken from Hurdle, Stive 1989 , RESULTS SEEM VERY SIMILAR TO THOSE OF DELWAQ CODE ABOVE
aa3 = 4.3d-5*fs/tanhsafe(aa1)**2
hsig = 0.25d0*tanhsafe(aa1)*tanhsafe(aa3)**0.5000000d0
hsig = hsig*ua*ua/ag
aa2 = 0.76d0 *ds**0.375d0
aa4 = 4.1d-5*fs/tanhsafe(aa2)**3
tsig = 8.30d0*tanhsafe(aa2)*tanhsafe(aa4)**0.3333333d0
tsig = tsig*ua/ag
end subroutine hurdlestive
SUBROUTINE ian_young_pt(U10,x,d,Hsig,Tsig)
use m_physcoef
IMPLICIT NONE
double precision , INTENT(IN) :: d,U10,x
double precision , INTENT(OUT) :: Hsig, Tsig
double precision :: E,fp
double precision :: delta, XX, A1, B1, epsilon, nu, A2, B2, ta1, ta2
double precision, external :: tanhsafe
XX=ag*x/U10**2 ! non-dim fetch
delta=ag*d/U10**2 ! non-dim depth
! calculate nondimensional energy
B1=3.13e-3*XX**0.57
A1=0.493*delta**0.75
ta1=tanhsafe(A1)
epsilon=3.64e-3*(tA1*tanhsafe(B1/ta1))**1.74
! calculate nondimensional frequency
B2=5.215e-4*XX**0.73
A2=0.331*delta**1.01
ta2=tanhsafe(A2)
nu=0.133*(tA2*tanhsafe(B2/tA2))**(-0.37);
E =U10**4*epsilon/ag**2 ! total energy from non-dim energy
Hsig=4*SQRT(E) ! significant wave height
fp=nu*ag/U10 ! peak freq from non-dim freq, Hz
Tsig=1d0/fp
END SUBROUTINE ian_young_pt
double precision function tanhsafe(a)
implicit none
double precision :: a
if (a < 9d0) then
tanhsafe = tanh(a)
else
tanhsafe = 1d0
endif
end function
double precision function sinhsafe(a)
implicit none
double precision :: a
if (a < 9d0) then
sinhsafe = sinh(a)
else
sinhsafe = 0.5d0*exp(a)
endif
end function
double precision function coshsafe(a)
implicit none
double precision :: a
if (a < 9d0) then
coshsafe = cosh(a)
else
coshsafe = 0.5d0*exp(a)
endif
end function
double precision function sinhsafei(a) ! inverse
implicit none
double precision :: a
if (a < 9d0) then
sinhsafei = 1d0/sinh(a)
else
sinhsafei = 0d0
endif
end function
double precision function coshsafei(a) !inverse
implicit none
double precision :: a
if (a < 9d0) then
coshsafei = 1d0/cosh(a)
else
coshsafei = 0d0
endif
end function
subroutine getwavenr(h, T, k)
use m_sferic
use m_physcoef
implicit none
! get wavenr from waterdepth and period, see d3d doc
double precision, parameter :: a1 = 5.060219360721177D-01, a2 = 2.663457535068147D-01, &
a3 = 1.108728659243231D-01, a4 = 4.197392043833136D-02, &
a5 = 8.670877524768146D-03, a6 = 4.890806291366061D-03, &
b1 = 1.727544632667079D-01, b2 = 1.191224998569728D-01, &
b3 = 4.165097693766726D-02, b4 = 8.674993032204639D-03
double precision , intent(in) :: h ! Waterheight
double precision , intent(in) :: t ! Period
double precision , intent(out) :: k ! Approximation of wave lenght
double precision :: den ! Denominator
double precision :: kd ! Double value for K
double precision :: num ! Numerator
double precision :: ome2 ! Omega
ome2 = ( (twopi/T)**2 )*h/ag
num = 1.0D0 + ome2*(a1 + ome2*(a2 + ome2*(a3 + ome2*(a4 + ome2*(a5 + ome2*a6)))))
den = 1.0D0 + ome2*(b1 + ome2*(b2 + ome2*(b3 + ome2*(b4 + ome2*a6))))
k = sqrt(ome2*num/den)/ h
end subroutine getwavenr
subroutine setupwslopes() ! set upwind slope pointers and weightfactors
! TODO: 1D upwind slope pointers (gewoon de vorige)
use m_flowgeom
use m_flow, only : plotlin
use m_alloc
implicit none
integer :: L, k12, k2
double precision :: dxn, dyn, rmin, xc, yc, dxu, dyu, r, rli
integer :: k,kk,LL,ku,kd,ja, ku2, nn, jacros
double precision :: xzup, yzup, dxx, dyy, rfr, sum, slnupmax, dxk, dis, xn, yn, sl, sm, crp, xcr, ycr, dxl
double precision, allocatable :: xzu(:), yzu(:) ! temparrs for triangulations
double precision, allocatable :: zz(:), zzu(:), wfn(:,:)
integer , allocatable :: indxn(:,:) , kcz(:), kcuu(:)
integer :: jdla, ierr, n, NLNUPMAX
double precision :: rn (6)
integer :: kun(6), nri(6)
double precision, external :: getdx, getdy
if (allocated (klnup) ) then
deallocate (klnup, slnup)
endif
allocate ( klnup(6,lnx) , stat=ierr ); klnup = 0
call aerr( 'klnup(6,lnx)', ierr, lnx )
allocate ( slnup(6,lnx) , stat=ierr ); slnup = 0d0
call aerr( 'slnup(6,lnx)', ierr, lnx )
do L = 1, lnx
dxn = -csu(L) ; dyn = -snu(L) ! normal vector in upwind dir
do k12 = 1,2
rmin = 0
k = ln(k12,L)
kd = ln(2,L) ; if (k12 == 2) kd = ln(1,L)
! SPvdP: (xzup, yzup) not used here
xzup = 2d0*xz(k) - xz(kd) ! upwind position for which cell centre interpolated values
yzup = 2d0*yz(k) - yz(kd) ! need be found
if (k12 == 2) then
dxn = -dxn; dyn = -dyn
endif
n = 0
do kk = 1,nd(k)%lnx ! first try to find 1 point that is sufficiently close to link line
LL = iabs(nd(k)%ln(kk)) ! use this 1 point if it is less than e.g. 0.1dx away from xzup
if (LL .gt. lnx1D .and. LL .ne. L) then !
ku = ln(1,LL)
if (ku == k) ku = ln(2,LL)
dxx = getdx( xz(k), yz(k), xz(ku), yz(ku) )
dyy = getdy( xz(k), yz(k), xz(ku), yz(ku) )
dxu = dxx*dxi(LL)
dyu = dyy*dxi(LL)
r = dxu*dxn + dyu*dyn
if (r > 0) then ! points upwind
n = n + 1
call dlinedis2(xz(ku), yz(ku), xz(k), yz(k), xz(kd), yz(kd), ja, dis, xn, yn, sl)
rn(n) = dis
kun(n) = ku
endif
endif
enddo
if (n > 0) then
nri(1) = 1
if (n > 1) call indexx(n,rn,nri) ! sorted in closeness to linkline
nn = 1
ku = kun(nri(nn))
rfr = rn(nri(nn)) * dxi(L)
! if (n == 1 .or. rfr < 0.1d0) then ! if only 1 link attached or upwind point sufficiently close
if ( rfr < 0.1d0) then ! if only 1 link attached or upwind point sufficiently close
klnup(1+3*(k12-1),L) = -ku ! flag for single value weighting
dxx = getdx( xz(k), yz(k), xz(ku), yz(ku) )
dyy = getdy( xz(k), yz(k), xz(ku), yz(ku) )
dxk = sqrt(dxx*dxx + dyy*dyy)
dxl = dx(L)
slnup(3+3*(k12-1),L) = dxl/dxk ! slope weigths in 3 or 6
if (L > lnx1D) then ! switch of when intersecting fixed weir flagged by iadv type 6 or 8
do kk = 1,nd(k)%lnx !
LL = iabs(nd(k)%ln(kk)) ! see testcase transport harbour
k2 = ln(1,LL) + ln(2,LL) - k
if (k2 == ku) then
if (iadv(LL) == 6 .or. iadv(LL) == 8) then
klnup(1+3*(k12-1),L) = 0
endif
endif
enddo
endif
cycle
endif
jacros = 0
if (n >= 2) then
nn = 2
ku2 = kun(nri(nn)) ! can we interpolate in ku and ku2?
call dcross (xz(kd), yz(kd), xz(k), yz(k), xz(ku), yz(ku), xz(ku2), yz(ku2),JACROS,SL,SM,XCR,YCR,CRP)
if (sl < 1.2) jacros = 0 ! int point too close to xz(k)
endif
if (n >= 3 .and. jacros == 0) then
nn = 3
ku2 = kun(nri(nn))
call dcross (xz(kd), yz(kd), xz(k), yz(k), xz(ku), yz(ku), xz(ku2), yz(ku2),JACROS,SL,SM,XCR,YCR,CRP)
if (sl < 1.2) jacros = 0 ! int point too close to xz(k)
endif
if (n >= 4 .and. jacros == 0) then
nn = 4
ku2 = kun(nri(nn))
call dcross (xz(kd), yz(kd), xz(k), yz(k), xz(ku), yz(ku), xz(ku2), yz(ku2),JACROS,SL,SM,XCR,YCR,CRP)
if (sl < 1.2) jacros = 0 ! int point too close to xz(k)
endif
if (jacros == 1) then
if (L > lnx1D) then ! switch of when intersecting fixed weir flagged by iadv type 6 or 8
do kk = 1,nd(k)%lnx !
LL = iabs(nd(k)%ln(kk)) ! see testcase transport harbour
k2 = ln(1,LL) + ln(2,LL) - k
if (k2 == ku .or. k2 == ku2) then
if (iadv(LL) == 6 .or. iadv(LL) == 8) then
ku = 0; ku2 = 0
endif
endif
enddo
endif
klnup(2+3*(k12-1),L) = ku2
slnup(2+3*(k12-1),L) = sm
klnup(1+3*(k12-1),L) = ku
slnup(1+3*(k12-1),L) = 1d0 - sm
dxx = getdx(xz(k), yz(k), xcr, ycr )
dyy = getdy(xz(k), yz(k), xcr, ycr )
dxk = sqrt(dxx*dxx + dyy*dyy)
dxl = dx(L)
slnup(3+3*(k12-1),L) = dxL/dxk ! slope weigths in 3 or 6
if (size(nd(k)%x) == 3 .or. size(nd(kd)%x) == 3) then ! flag links connected to triangle on either side as negative through klnup(2,*)
klnup(2+3*(k12-1),L) = -iabs( klnup(2+3*(k12-1),L) ) ! for maxlimontris
endif
endif
endif
enddo
!plotlin(L) = klnup(2,L)
enddo
return
allocate ( xzu(lnx), yzu(lnx), zzu(lnx), kcuu(lnx), indxn(3,lnx), wfn(3,lnx) , stat=ierr)
call aerr('xzu(lnx), yzu(lnx), zzu(lnx), kcuu(lnx), indxn(3,lnx), wfn(3,lnx)', ierr, 9*lnx)
allocate ( zz(ndx), kcz(ndx) , stat=ierr ) ; zz= 0 ; kcz = 1
call aerr('zz(ndx), kcz(ndx)', ierr, 2*ndx )
do k12 = 1,2
kcuu = 0 ; xzu = 0 ; yzu = 0 ; zzu = 0
do L = 1,lnx
xzup = 2d0*xz( ln(1,L) ) - xz( ln(2,L) ) ! upwind position for which cell centre interpolated values
yzup = 2d0*yz( ln(1,L) ) - yz( ln(2,L) ) ! need be found
if (k12 == 2) then
dxn = -dxn ; dyn = -dyn
xzup = 2d0*xz( ln(2,L) ) - xz( ln(1,L) )
yzup = 2d0*yz( ln(2,L) ) - yz( ln(1,L) )
endif
xzu(L) = xzup + 0.1d0 ; yzu(L) = yzup + 0.1d0 ; kcuu(L) = 1
enddo
jdla = 1
indxn = 0
wfn = 0
call triint( xz , yz , zz, kcz , ndx, &
xzu , yzu , zzu, kcuu, 1, lnx, jdla, indxn, wfn )
do L = 1,lnx
if (klnup(1+3*(k12-1),L) == 0) then
slnupmax = 0 ; nlnupmax = 0
do n = 1,3
klnup(n+3*(k12-1),L) = indxn(n,L)
slnup(n+3*(k12-1),L) = wfn(n,L)
sum = sum + slnup(n+3*(k12-1),L)
if (slnup(n+3*(k12-1),L) > slnupmax ) then
slnupmax = slnup(n+3*(k12-1),L)
nlnupmax = n
endif
sum = sum - slnupmax
enddo
do n = 1,3
if (n == nlnupmax) then
slnup(n+3*(k12-1),L) = 1 - sum
endif
enddo
endif
enddo
enddo
deallocate ( xzu, yzu, zzu, kcuu, indxn, wfn)
deallocate ( zz, kcz )
end subroutine setupwslopes
double precision function dslim(d1,d2,limtyp)
implicit none
double precision d1, d2 ! voorslope, naslope
integer limtyp
double precision :: dminmod, dvanleer, dkoren,dcentral,dcminmod
double precision :: rminmod,rvanleer,rkoren,rcentral
double precision :: dlimiter,dlimitercentral
if (limtyp .eq. 0) then
dslim = 0
else if (limtyp .eq. 1) then ! codering guus, met voorslope
dslim = d1*dminmod(d1,d2)
else if (limtyp .eq. 2) then ! codering guus, met voorslope
dslim = d1*dvanleer(d1,d2)
else if (limtyp .eq. 3) then ! codering guus, met voorslope
dslim = d1*dkoren(d1,d2)
else if (limtyp .eq. 4) then ! monotonized central no division
dslim = dcentral(d1,d2)
else if (limtyp .eq. 5) then ! monotonized central Sander with division
dslim = dlimiter(d1,d2,limtyp)
else if (limtyp .eq. 6) then ! monotonized central Sander with division, upwind slope ds1 at central cel
dslim = dlimitercentral(d1,d2,limtyp)
else if (limtyp .eq. 11) then ! standaard codering
dslim = d2*dminmod(d1,d2)
else if (limtyp .eq. 12) then ! standaard codering
dslim = d2*dvanleer(d1,d2)
else if (limtyp .eq. 13) then ! standaard codering
dslim = d2*dkoren(d1,d2)
else if (limtyp .eq. 14) then ! monotonized central, == 4
dslim = dcentral(d2,d1)
else if (limtyp .eq. 15) then ! minmod central
dslim = dcminmod(d2,d1)
else if (limtyp .eq. 20) then ! leftbiased
dslim = d1
else if (limtyp .eq. 21) then ! central
dslim = d2
endif
return
end function dslim
double precision function dkoren(d1,d2) ! nog naar kijken
implicit none
double precision d1, d2, r
if (d1*d2 > 0d0) Then
r=d2/d1
dkoren=max(0d0,min(r+r,min((1d0+r+r)/3d0,2d0)))
else
dkoren=0d0
endif
return
end function dkoren
double precision function dvanleer(d1,d2) ! twee maal vergroot vanwege acl
implicit none
double precision d1, d2
if (d1*d2 > 0d0) then
dvanleer = 2d0*d2/(d1+d2)
else
dvanleer = 0d0
endif
return
end function dvanleer
double precision function dminmod(d1,d2) ! twee maal vergroot vanwege acl
implicit none
double precision d1, d2
if (d1*d2 > 0d0) then
dminmod =min(1d0,d2/d1)
else
dminmod =0d0
endif
return
end function dminmod
double precision function dcentral(d1,d2) ! twee maal vergroot vanwege acl
implicit none
double precision d1, d2, dcminmod
if (d1*d2 > 0d0) then
dcentral = dcminmod( (d1+d2)*0.5d0 , dcminmod( 2d0*d1, 2d0*d2) )
else
dcentral = 0d0
endif
return
end function dcentral
double precision function dcminmod(d1,d2) ! basic minmod definition
implicit none
double precision d1, d2
if (d1*d2 > 0) then
if (abs(d1) < abs(d2)) then
dcminmod = d1
else
dcminmod = d2
endif
else
dcminmod = 0d0
endif
return
end function dcminmod
double precision function rslim(d1,d2,limtyp)
implicit none
double precision :: d1, d2
double precision :: rminmod,rvanleer,rkoren,rcentral
integer :: limtyp
if (limtyp .eq. 0) then
rslim = 0
else if (limtyp .eq. 1) then ! codering guus, met voorloper
rslim = d1*rminmod(d1,d2)
else if (limtyp .eq. 2) then ! codering guus, met voorloper
rslim = d1*rvanleer(d1,d2)
else if (limtyp .eq. 3) then ! codering guus, met voorloper
rslim = d1*rkoren(d1,d2)
else if (limtyp .eq. 4) then ! monotonized central
rslim = rcentral(d1,d2)
endif
return
end function rslim
double precision function rkoren(sl1,sl2) ! nog naar kijken
implicit none
double precision :: sl1, sl2
double precision :: r
if (sl1*sl2.GT.0d0) Then
r=sl2/sl1
rkoren=max(0d0,min(r+r,min((1d0+r+r)/3d0,2d0)))
else
rkoren=0d0
endif
return
end function rkoren
double precision function rvanleer(sl1,sl2) ! twee maal vergroot vanwege acl
implicit none
double precision :: sl1, sl2
if (sl1*sl2.GT.1.0d-2) then
rvanleer=2*sl2/(sl1+sl2)
else
rvanleer=0d0
endif
return
end function rvanleer
double precision function rminmod(sl1,sl2) ! twee maal vergroot vanwege acl
implicit none
double precision :: sl1, sl2
if (sl1*sl2.GT.0d0) then
rminmod=min(1d0,sl2/sl1)
else
rminmod=0d0
endif
return
end function rminmod
double precision function rcentral(sl1,sl2) ! twee maal vergroot vanwege acl
implicit none
double precision :: sl1, sl2
double precision :: tminmod
if (sl1*sl2.GT.0d0) then
rcentral=tminmod( (sl1+sl2)*0.5d0 , tminmod( 2*sl1, 2*sl2) )
else
rcentral=0d0
endif
return
end function rcentral
double precision function tminmod(sl1,sl2) ! basic minmod definition
implicit none
double precision :: sl1, sl2
if (sl1*sl2 > 0) then
if (abs(sl1) < abs(sl2)) then
tminmod = sl1
else
tminmod = sl2
endif
else
tminmod = 0d0
endif
return
end function tminmod
double precision function sminmod(sl1,sl2)
implicit none
double precision :: sl1, sl2
double precision :: r
r = sl1/sl2
sminmod = max(0d0,min(1d0,r))
return
end function sminmod
double precision function svanleer(sl1,sl2)
implicit none
double precision :: sl1, sl2
double precision :: r
r = sl1/sl2
svanleer = (r + abs(r))/(1d0 + r)
return
end function svanleer
double precision function skoren(sl1,sl2)
implicit none
double precision :: sl1, sl2
double precision :: r
r = sl1/sl2
skoren = max(0d0,min(r+r,min((1d0+r+r)/3d0,2d0)))
return
end function skoren
double precision function upwsalslope(L,k,ds2) ! k is upwind cell for link L, find slope upwind of k
use m_flowgeom ! limit upwind slopes for all inflowing links
use m_flow
implicit none
integer :: L, k
double precision :: ds2
integer :: kk,ku,LL,LLL,jap
double precision :: ds1
double precision, external :: dcminmod
upwsalslope = -1d9
if (ds2 < 0) upwsalslope = 1d9
jap = -1
if (ln(1,L) == k) jap = 1
do kk = 1,nd(k)%lnx
LLL= nd(k)%ln(kk)
LL = iabs(LLL)
if (LL .ne. L .and. q1(LL)*LLL > 0) then
ku = ln(1,LL)
if (ku == k) ku = ln(2,LL)
ds1 = (sa0(k) - sa0(ku))*jap
if (ds2 > 0) then
upwsalslope = dcminmod(ds1,ds2)
else if (ds2 < 0) then
upwsalslope = dcminmod(ds1,ds2)
endif
endif
enddo
end function upwsalslope
double precision function upwsal(L,k12) ! upwind salinity
use m_flowgeom
use m_flow
implicit none
integer :: L, k12
double precision :: cl, sl, rl, ql, qls
integer :: k, kk, LL, LLL, ku
cl = csu(L) ; sl = snu(L)
if (k12 == 2) then
cl = -cl ; sl = -sl
endif
k = ln(k12,L)
ql = 0
qls = 0
do kk = 1,nd(k)%lnx
LL = nd(k)%ln(kk)
LLL = iabs(LL)
ku = ln(1,LLL)
if (ku == k) ku = ln(2,LLL)
rl = cl*csu(LLL) + sl*snu(LLL)
if (LL > 0 .and. q1(LLL) > 0) then
if (rl > 0) then
ql = ql + rl*q1(LLL)
qls = qls + rl*q1(LLL)*sa0(ku)
endif
else if (LL < 0 .and. q1(LLL) < 0) then
if (rl < 0) then
ql = ql + rl*q1(LLL)
qls = qls + rl*q1(LLL)*sa0(ku)
endif
endif
enddo
if (ql > 0) then
upwsal = qls/ql
else
upwsal = sa0(k)
endif
end function upwsal
subroutine checkspeed(rr)
use unstruc_messages
implicit none
double precision :: mult0, mult1, mult, divt0, divt1, divt
double precision :: t, ti, r, rr, rrm, rrd
integer :: k, key
call klok(mult0)
do k = 1,10000
t = 1d0*k - 1d0*k + 1.5155155d0
ti = 1d0/t
r = 0
rrm = 0
do key = 1,1000000
r = r + 1d0
rr = r*ti
rrm = rrm + rr ! remove this line and both loops will have identical perf on compaq visual
enddo
enddo
call klok(mult1)
call klok(divt0)
do k = 1,10000
t = 1d0*k - 1d0*k + 1.5155155d0
ti = 1d0/t
r = 0
rrd = 0
do key = 1,1000000
r = r + 1d0
rr = r/t
rrd = rrd + rr
enddo
enddo
call klok(divt1)
mult = mult1-mult0
divt = divt1-divt0
write(msgbuf,*) 'mult ', mult
call msg_flush()
write(msgbuf,*) 'divt ', divt
call msg_flush()
write(msgbuf,*) 'divt/mult ', divt/mult
call msg_flush()
write(msgbuf,*) 'rrm, rrd, rrd-rrm ', rrm, rrd, rrd-rrm
call msg_flush()
end subroutine checkspeed
subroutine carrier( ndx, time1)
implicit none
double precision :: time1
integer :: ndx
double precision :: J0(100),J1(100),A1(100),A3(100), ahh
double precision :: h0, T0, s, etinbr,dc,tol,etabr,etain,a,a2
double precision :: omega,sg,osg,osg2,rl0,c,dt,t,uold,u,x,xster,hh,uu,xx
double precision :: pi, g
integer :: ic1,ic2,nt,ic,iter,it
double precision :: bessj0,bessj1
common /signal/ ahh
!open(1,file='carrier.inp')
!open(2,file='carrier.out')
!open(3,file='carrier.env')
!open(4,file='carrier.u')
!open(5,file='carrier.tx')
h0 = 5
T0 = 32
s = .04
etinbr = 0.5d0 ! eta in /eta br
dc = .09906
ic1 = 1
ic2 = 100
nt = 21
tol = .0001
pi=4.*atan(1.)
g=9.81d0
etabr=1./sqrt(128.)/(pi**3)*s**2.5d0*T0**2.5d0*g**1.25d0*h0**(-.25)
etain=etinbr*etabr
A=etain*pi/sqrt(.125*s*T0*sqrt(g/h0))
! write(*,*)' eta in = ',etain
! write(*,*)' A/ eta in = ',A/etain
! write(*,*)' eta br = ',etabr
! write(*,*)' etain/etabr= ',etain/etabr
omega=2.*pi/T0
sg=s*g
osg=omega/sg
osg2=2.*osg
rl0 = T0*sqrt(sg)
do ic=ic1,ic2
C=ic*dc
J0(ic)=BESSj0(osg2*C)
J1(ic)=BESSj1(osg2*C)
A1(ic)=A*g/C*J1(ic)
enddo
A2=osg
dt=T0/(Nt-1)
t=-dt
t = time1
it = 1
! do it=1,Nt
! t=t+dt
A3(it)=omega*t
do ic=ic1,ic2
C=ic*dc
do iter=1,100
uold=u
u=A1(ic)*cos(A2*u-A3(it))
if(abs(uold-u).lt.tol) exit
enddo
x=.5*u*u/sg+C*C/sg-A/s*J0(ic)*sin(A2*u-A3(it))
xster=x*4./(sg*T0*T0)
hh = (C*C/g-s*x)/A
uu = u/(A*omega/s)
xx = 125d0 - x/2
ahh = a*hh
if (ic == ic1) then
call movabs(xx,ahh)
else
call lnabs(xx,ahh)
endif
! write(2,'(2f10.4)')xster,(C*C/g-s*x)/A
! write(3,'(2f10.4)')xster,(A/pi*sqrt(.5*s*T0*g/C))/A
! write(4,'(2f10.4)')xster,u/(A*omega/s)
! if (ic.eq.ic1) write(5,'(2f10.4)')t,x
enddo
! enddo
end subroutine carrier
double precision FUNCTION BESSJ0(X)
implicit none
double precision :: X
double precision :: Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5,R6,S1,S2,S3,S4,S5,S6
DATA P1,P2,P3,P4,P5/1.D0,-.1098628627D-2,.2734510407D-4, &
-.2073370639D-5,.2093887211D-6/, Q1,Q2,Q3,Q4,Q5/-.1562499995D-1, &
.1430488765D-3,-.6911147651D-5,.7621095161D-6,-.934945152D-7/
DATA R1,R2,R3,R4,R5,R6/57568490574.D0,-13362590354.D0,651619640.7D0, &
-11214424.18D0,77392.33017D0,-184.9052456D0/, &
S1,S2,S3,S4,S5,S6/57568490411.D0,1029532985.D0, &
9494680.718D0,59272.64853D0,267.8532712D0,1.D0/
double precision :: ax, z, xx
IF(ABS(X).LT.8d0)THEN
Y=X**2
BESSJ0=(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))) /(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))))
ELSE
AX=ABS(X)
Z=8./AX
Y=Z**2
XX=AX-.785398164
BESSJ0=SQRT(.636619772d0/AX)*(COS(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y*P5))))-Z*SIN(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))))
ENDIF
RETURN
END FUNCTION BESSJ0
double precision FUNCTION BESSJ1(X)
implicit none
double precision :: x
double precision :: Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5,R6,S1,S2,S3,S4,S5,S6
DATA R1,R2,R3,R4,R5,R6/72362614232.D0,-7895059235.D0,242396853.1D0, &
-2972611.439D0,15704.48260D0,-30.16036606D0/, &
S1,S2,S3,S4,S5,S6/144725228442.D0,2300535178.D0, &
18583304.74D0,99447.43394D0,376.9991397D0,1.D0/
DATA P1,P2,P3,P4,P5/1.D0,.183105D-2,-.3516396496D-4,.2457520174D-5, &
-.240337019D-6/, Q1,Q2,Q3,Q4,Q5/.04687499995D0,-.2002690873D-3, &
.8449199096D-5,-.88228987D-6,.105787412D-6/
double precision :: ax, z, xx
IF(ABS(X).LT.8d0)THEN
Y=X**2
BESSJ1=X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))) /(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))))
ELSE
AX=ABS(X)
Z=8./AX
Y=Z**2
XX=AX-2.356194491d0
BESSJ1=SQRT(.636619772/AX)*(COS(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y*P5))))- &
Z*SIN(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))))) *SIGN(1.d0,X)
ENDIF
RETURN
END FUNCTION BESSJ1
subroutine belanger()
use m_physcoef
use m_flowexternalforcings
use m_flowgeom, only : xz, bl, dxi, ln
use m_flow , only : s1, iadvec
implicit none
double precision :: chezy,cf,h0,h1,x0,x1,q,u,constant,bot,a,x,hav,slope,h,h3,hc,hc3,he,he3
integer :: k , kb
integer, parameter :: mmax = 100000 , num = 200
double precision, allocatable :: xx(:), ss(:), uu(:)
allocate ( xx(0:mmax), ss(0:mmax), uu(0:mmax) )
x0 = 0d0 ! left
kb = kbndz(1,1)
x1 = xz(kb) ! right
bot = bl(kb)
h1 = s1(kb) - bot ! exact right
h0 = 20d0 ! geschat left
slope = abs ( ( bl(ln(1,3)) - bl(ln(2,3)) ) * dxi(3) )
! slope = 1d-4
hav = 0.5*(h0+h1)
call getcz(hav, frcuni, ifrctypuni, Chezy)
cf = ag/Chezy**2
q = 1500d0/50d0
hc3 = q*q/ag
hc = hc3**0.333333333d0
constant = 0.25d0*h1**4 - h1*hc**3 + x1*cf*hc**3
call movabs(x1, h1+bot )
x = x1 ; h = h1
xx(mmax) = x1 ; ss(mmax) = h1 + bot
if (slope == 0d0 ) then ! analytic
do k = 1, -num
a = 1d0 - dble(k-1) / dble(num-1)
h = h0*(1d0-a) + h1*a
x = ( constant - 0.25d0*h**4 + h*hc**3 ) / ( cf * hc**3 )
if (x > x0) then
call lnabs(x, h+bot )
endif
enddo
else
he3 = cf*hc3/slope
endif
do k = mmax-1, 0 , -1
x = x - 1d0
h3 = h**3
if (slope == 0d0 ) then
if (iadvec == 0) then
h = h + (cf*hc**3)/h3 ! - hc**3)
else
h = h + (cf*hc**3)/(h3 - hc3)
endif
else
h = h - slope*(h3-he3)/(h3 - hc3)
endif
bot = bot + slope
call lnabs(x, h + bot )
xx(k) = x; ss(k) = h+bot
enddo
call compareanalytic(ss,uu,xx,mmax)
end subroutine belanger
subroutine drybed(time)
implicit none
double precision :: time, xm, xmx, h0, dxw
integer, parameter :: mmax = 601 ! 3000
double precision:: s(0:mmax),u(0:mmax),xx(0:mmax)
double precision :: g, t, cw, xl, xr,sa,ua, x
integer :: m
g = 9.81 ! 10.0
t = time
h0 = 2
cw = sqrt(9.81*h0)
dxw = 100.
xl = -cw*t
xr = t*2*cw
xmx = -9999
do m=2, 600 ! ndx
xm = m*dxw - 50 ! xz(m)
x = xm - 300*dxw
if (x.gt.xl.and.x.lt.xr) then
sa=(((2*cw-x/t)/3.0)**2)/g
ua=2*(cw+x/t)/3.0
xmx = max (xmx, xm)
else if (x.lt.xl) then
sa=h0
ua=0.0
else
sa=0.0
ua=0.0
endif
s(m) = sa ; u(m) = ua; xx(m) = xm
if (m == 2) then
call movabs(xm,sa)
else
call lnabs(xm,sa)
endif
enddo
call movabs(xmx,0.1d0*h0)
call lnabs(xmx,0.2d0*h0)
call compareanalytic(s,u,xx,mmax)
end subroutine drybed
subroutine wetbed(time)
use m_flowparameters
implicit none
integer, parameter :: mmax = 601 ! 3000
double precision:: s(0:mmax),u(0:mmax),x(0:mmax)
double precision :: time, dxw, xc
double precision :: g, t, dt, xd, x0, xu, h1,h0,eps, c1, c0, u20, z0, c20, &
aa, ab, ac, ad, ba, bb, bc, bd, ca, cb, cc, cd, dd, d1, d2, d3, dz, &
dc2, du2, z, c2, h2, u2, xm, c, si1
integer :: itmax, mc, i,iter, m, n
!c
!c initialise
!c
g=9.81
t=time
dt=1.0
xd=0.0
x0=0.0
xu=0.0
dxw=100.0
h1=2.0
h0=0.0000000001
h0=hwetbed
itmax=3600
itmax=1
eps=1.0e-6
mc = 301
xc = (mc-1)*dxw
do i=0,mmax
x(i)=(i-0.5)*dxw - xc
enddo
do i=0,mmax
if (x(i).lt.0.0) then
s(i)=h1
else
s(i)=h0
endif
u(i)=0.0
enddo
!c
!c initialise
!c
c1=sqrt(g*h1)
c0=sqrt(g*h0)
u20=c0
z0=c0
c20=c0
iter=0
10 continue
iter=iter+1
!c
!c Newton iteration for correct coefficients of exact solution
!c
aa=2*z0-u20
ab=-c20
ac=-z0
ad=0.5*c0**2+u20*z0-z0**2+0.5*(c20)**2
ba=-c20**2+c0**2
bb=2*c20*u20-2*c20*z0
bc=c20**2
bd=-c20**2*u20+c20**2*z0-c0**2*z0
ca=0.0
cb=2.0
cc=1.0
cd=2*c1-u20-2*c20
dd=aa*(bb*cc-bc*cb)-ab*(ba*cc-bc*ca)+ac*(ba*cb-bb*ca)
d1=ad*(bb*cc-bc*cb)-ab*(bd*cc-bc*cd)+ac*(bd*cb-bb*cd)
d2=aa*(bd*cc-bc*cd)-ad*(ba*cc-bc*ca)+ac*(ba*cd-bd*ca)
d3=aa*(bb*cd-bd*cb)-ab*(ba*cd-bd*ca)+ad*(ba*cb-bb*ca)
dz=d1/dd
dc2=d2/dd
du2=d3/dd
z0=z0+dz
c20=c20+dc2
u20=u20+du2
if (abs(dz).gt.eps) goto 10
if (abs(dc2).gt.eps) goto 10
if (abs(du2).gt.eps) goto 10
!c
!c correct shock speeds (z, c2 and u2) are found
!c
z=z0
c2=c20
h2=c2**2/g
u2=u20
! WRITE(*,*) 'H2, Z, U2', H2, Z, U2
! do itime=1,itmax
! t=t+dt
!c
!c determination of various zones with different solutions
!c
xd=-c1*t
xm=(u2-c2)*t
xu=z*t
do i=0,mmax
if (x(i).lt.xd) then
u(i)=0.0
s(i)=h1
else if (x(i).ge.xd.and.x(i).lt.xm) then
c=(2*c1-x(i)/t)/3.0
s(i)=c**2/g
u(i)=2.0/3.0*(c1+x(i)/t)
else if (x(i).ge.xm.and.x(i).lt.xu) then
u(i)=2.0/3.0*(c1+xm/t)
s(i)=h2
else if (x(i).ge.xu) then
u(i)=0.0
s(i)=h0
endif
enddo
! enddo
! open(unit=33,file='wetbed.prn')
do m=2,mmax
if (m == 2) then
call movabs(x(m)+xc, s(m))
else
call lnabs(x(m)+xc, s(m))
endif
enddo
do m=2,0 ! mmax-1
if (m == 2) then
call movabs(x(m)+xc, 0.1d0*U(m))
else
call lnabs(x(m)+xc, 0.1d0*U(m))
endif
enddo
! write (33,'(3e15.4)') x(m)+xc, s(m), u(m)
! call htext(dble(h2), dble(xu+xc), dble(h2) )
x = x + xc
call compareanalytic(s,u,x,mmax)
end subroutine wetbed
subroutine compareanalytic(s,u,x,mmax)
use m_flowgeom
use m_flow
implicit none
integer :: mmax
double precision :: s(0:mmax),u(0:mmax),x(0:mmax)
double precision :: alf, dif, si, aa
integer :: n, i, ii
logical :: inview
call statisticsnewstep()
call setcol(221)
do n = 1,ndx
if (.not. inview( xz(n), yz(n) ) ) cycle
i = 0
do ii = 1, mmax-1
if ( x(ii) <= xz(n) .and. xz(n) < x(ii+1) ) then
i = ii
exit
endif
enddo
!i = (xz(n) + 0.5*dxw) / dxw
if ( i > 2 .and. i < mmax-1 ) then
alf = (xz(n) - x(i) ) / ( x(i+1) - x(i) )
if (alf < 0d0 .or. alf > 1d0) then
si = 0
else
si = (1-alf)*s(i) + alf*s(i+1)
dif = abs(s1(n) - si)
call statisticsonemorepoint(dif)
! call ptabs(xz(n), bl(n) + 100d0*dif)
endif
endif
enddo
call statisticsfinalise()
end subroutine compareanalytic
subroutine weirexact()
use unstruc_colors
implicit none
integer, parameter :: mx = 32
double precision :: dp(mx), s1(mx), s0(mx), u1(mx), u0(mx), q1(mx), q0(mx), se(mx), ue(mx), xe(mx), wh
integer :: m, m0, m1
double precision :: g, hexact, uexact, zexact, energy, z0, z1, z2, h0, h1, h2, &
fh0, fh1, fh2, fhx, zx, sem, uem, test0, he2, he1, test1, h00
integer :: mmax
do m = 1,mx
xe(m) = 5 + (m-1)*10
enddo
mmax = mx-1
m0 = 14
m1 = 14
wh = 1.0
dp = wh ; dp(m0:m1) = 0.0
q0 = 1.71
s1(mx) = 0.0
g=9.81
hexact=(q0(1)**2/g)**(1.0/3.0)
uexact=sqrt(g*hexact)
zexact=hexact-minval(dp)
energy=0.5*uexact**2+g*zexact
! energy=0.5*u1(1)*u1(1) + g*s1(1)
z0=zexact
z1=zexact+3.0
h00=dp(1)+z0
h1=dp(1)+z1
fh0=0.5*(q0(1)/h00)**2+g*z0-energy
fh1=0.5*(q0(1)/h1)**2+g*z1-energy
z0=0.5
z1=zexact+1.0
z2=0.5*(z0+z1)
do m=1,mmax
if (m>=m0.and.m<=m1) then
se(m)=zexact
ue(m)=uexact
else
if (m>=m1) then
z0=-dp(m)-0.1
z1=z1+0.0001
else
z0=zexact
z1=zexact+0.0001
endif
do
h1=dp(m)+z1
h0=dp(m)+z0
fh1=0.5*(q0(1)/h1)**2+g*z1-energy
fh0=0.5*(q0(1)/h0)**2+g*z0-energy
if (fh1*fh0<0.0) then
if (fh0>0.0) then
fhx=fh0
zx=z0
fh0=fh1
z0=z1
z1=zx
fh1=fhx
endif
exit
endif
z1=z1+0.0001
z0=z0+0.0001
enddo
10 z2=0.5*(z0+z1)
h2=dp(m)+z2
fh2=0.5*(q0(1)/h2)**2+g*z2-energy
if (fh2<0.0) then
z0=z2
fh0=fh2
else
z1=z2
fh1=fh2
endif
if (abs(fh2)>1.0d-6) goto 10
se(m)=z2
if (dp(m)+z2<0.0) then
write(*,*) m,dp(m)+z2
stop
endif
ue(m)=q1(m)/(dp(m)+se(m))
endif
enddo
se(m1+1)=0.5*(se(m1)+se(m1+2))
sem=s1(mmax+1)
uem=q1(1)/(sem+dp(mmax+1))
ue(mmax+1)=uem
se(mmax+1)=sem
h2=sem+dp(mmax+1)
h1=se(mmax)+dp(mmax)
energy=0.5*ue(mmax+1)**2+g*sem
test0=0.5*g*h1*h2*(h1+h2)-q1(1)**2
m=mmax+1
do
m=m-1
z1=sem+0.1
z0=z1-0.001
do
h1=dp(m)+z1
h0=dp(m)+z0
fh1=0.5*(q0(1)/h1)**2+g*z1-energy
fh0=0.5*(q0(1)/h0)**2+g*z0-energy
if (fh1*fh0<0.0) then
if (fh0>0.0) then
fhx=fh0
zx=z0
fh0=fh1
z0=z1
z1=zx
fh1=fhx
endif
exit
endif
z1=z1-0.001
z0=z0-0.001
enddo
do
z2=0.5*(z0+z1)
h2=dp(m)+z2
fh2=0.5*(q0(1)/h2)**2+g*z2-energy
if (fh2<0.0) then
z0=z2
fh0=fh2
else
z1=z2
fh1=fh2
endif
if (abs(fh2)<1.0d-5) exit
enddo
sem=z2
uem=q1(1)/(dp(m)+se(m))
he2=dp(m)+sem
he1=dp(m)+se(m)
test1=g*0.5*he1*he2*(he1+he2)-q1(1)**2
if (test1*test0>0.and.m>m1) then
se(m)=sem
ue(m)=uem
cycle
else
exit
endif
enddo
call setcol(NCOLANA)
call movabs(xe(1), se(1)+wh)
do m=2,mx
call lnabs(xe(m), se(m) + wh)
enddo
return
end subroutine weirexact
subroutine weirtheory(zupstream,zdownstream,crestheight,zcrestperfect,zminsub,zcrest, &
qweir,uupstream,ucrest,udownstream,regime, qfree, gateheight)
implicit none
double precision :: zupstream,zdownstream,crestheight,zcrestperfect,zminsub,zcrest,&
qweir,uupstream,ucrest,udownstream, qfree, gateheight
double precision :: pi, g, d, z1, h1, p, q, cosfi,fi, zc1, zc2, zc3, &
res1, res2, res3, z2, z2critical,h2, u1, u2, u3, qd, ff, z3, z3critical, &
h3, fz2, z3inp, z2a, fz2a, z2b, fz2b, z2c, fz2c, za, zb, fa, fb, zc, fc, &
fr1, fr2, fr3
character(len=*) :: regime
! input variables:
! zupstream : upstream water level
! zdownstream : downstream water level
! crestheight : crestheight
! outputvariables :
! zcrestperfect : waterlevel on crest for critical flow
! zminsub : minimum down stream waterlevel for submerged flow
! zcrest : waterlevel on crest
! qweir : discharge/m
! uupstream : upstream velocity
! ucrest : velocity on crest
! udownstream : downstream velocity :
! open(5,file='weirtheory.dia')
qweir = 0 ; uupstream = 0 ; ucrest = 0; udownstream = 0
regime = 'subcritical'
if (zupstream < zdownstream) return
pi=4.0d0*atan(1.0d0)
g=9.81d0
d=crestheight
z1=zupstream
h1=z1+d
! compute critical depth on crest by solving: z^3-3*h1^z+2*h1^2*zupstream=0
! equation is solved analytically method of Gardano
p=3.0d0*(h1**2)
q=2.0d0*(h1**2)*z1
cosfi=z1/h1
fi=acos(cosfi)
zc1=-2.0d0*h1*cos(fi/3.0d0)
zc2=-2.0d0*h1*cos(fi/3.0d0+2.0d0*pi/3.0d0)
zc3=-2.0d0*h1*cos(-fi/3.0d0+2.0d0*pi/3.0d0)
if (zc3 < 0) return
! write(5,'(3e14.5)') zc1,zc2,zc3
res1=zc1**3-p*zc1+q
res2=zc2**3-p*zc2+q
res3=zc3**3-p*zc3+q
! write(5,'(3d14.5)') res1,res2,res3
z2=zc3
z2critical=z2
h2=z2+d
u2=sqrt(g*z2)
qd=z2*u2
qfree = qd
! compute maximum down stream water level for perfect weir or minimum water level for submerged weir
! for this the equation F=q^2/h3+0.5*g*h3^2 is solved analytically with Gardano
ff=qd*u2+0.5d0*g*h2*h2
p=2.0d0*ff/g
q=2.0d0*qd**2/g
cosfi=0.5*q/sqrt((p/3.0d0)**3)
cosfi=max(-1d0,min(cosfi,1d0))
fi=acos(cosfi)
zc1=-2.0d0*sqrt(p/3.0d0)*cos(fi/3.0d0)
zc2=-2.0d0*sqrt(p/3.0d0)*cos(fi/3.0d0+2.0d0*pi/3.0d0)
zc3=-2.0d0*sqrt(p/3.0d0)*cos(-fi/3.0d0+2.0d0*pi/3.0d0)
!write(5,'(3e14.5)') zc1-d,zc2-d,zc3-d
res1=zc1**3-p*zc1+q
res2=zc2**3-p*zc2+q
res3=zc3**3-p*zc3+q
!write(5,'(3d14.5)') res1,res2,res3
z3=zc2-d
z3critical=z3
zminsub=z3
zcrestperfect=z2critical
h3=d+z3
fz2=4.0d0*(z2-z1)*h1**2*z2*(h3-z2)-(h3**2-h2**2)*(z2**2-h1**2)*h3
!write(5,'(d15.5)') fz2
! compute subcritical weir by solving:
! 4.0d0*(z2-z1)*h1**2*z2*(h3-z2)-(h3**2-h2**2)*(z2**2-h1**2)*h3=0
z3inp=zdownstream
if (z3inp1.0d-10)
if (fa*fc<0) then
zb=zc
fb=fc
zc=0.5*(za+zb)
z2=zc
h2=zc+d
fc=4.0d0*(z2-z1)*h1**2*z2*(h3-z2)-(h3**2-h2**2)*(z2**2-h1**2)*h3
else if (fb*fc<0) then
za=zc
fa=fc
zc=0.5*(za+zb)
z2=zc
h2=zc+d
fc=4.0d0*(z2-z1)*h1**2*z2*(h3-z2)-(h3**2-h2**2)*(z2**2-h1**2)*h3
endif
enddo
! write(5,'('' water levels:'',3d15.5)') z1,z2,z3
h1=z1+d
h2=z2 ! +d
h3=z3+d
qd=sqrt((2.0d0*g*(z2-z1)*h1**2*z2**2)/(z2**2-h1**2))
! qdb=sqrt(0.5d0*g*(h3**2-h2**2)*z2*h3/(h3-z2))
! write(5,'('' discharge/m:'',d15.5)') qd
u1=qd/h1;u2=qd/h2;u3=qd/h3
! write(5,'('' velocities:'',3d15.5)') u1,u2,u3
fr1=u1/sqrt(g*h1);fr2=u2/sqrt(g*h2);fr3=u3/sqrt(g*h3)
! write(5,'('' Froude numbers:'',3d15.5)') fr1,fr2,fr3
zcrest=z2
qweir=qd
uupstream=u1
ucrest=u2
udownstream=u3
return
end subroutine weirtheory
subroutine findqorifice12(gateheight,crestheight,h1,h2,q,hg,regime,num,qcrit) ! bepaal q en hg waterstand links = h1, rechts= h2
implicit none
double precision :: gateheight ! gate height above crest
double precision :: crestheight ! crest height above bed
double precision :: h1 ! upstream waterheight above crest
double precision :: q ! flux m3/s (out)
double precision :: h2 ! pressure height above crest after gate (out)
double precision :: hg ! vena contracta height above crest after gate (out)
double precision :: qcrit ! critical discharge m2/s (out)
character(len=*) :: regime ! (out)
double precision :: g, dh, qmax, hkmin,ha,hb,qa,qb,ha0,qa0,hb0,qb0,qc,hc,a,d, qda, qdb, qdc, hga, hgb, hgc
integer :: num, k, kk, nummin
double precision :: coeffs(5), ccx(4), cc, alfa = 0.02d0, qf,hgf,h2f,qer,qermin
double precision :: aa, bb
g = 9.81 ! h1 = waterhoogte bovenstrooms
h2 = min(h2,h1-0.0001) ! hg = gateheight * contractie = effectieve keeldoorsnee
d = crestheight
a = gateheight
h1 = max(h1, 0.00010)
h2 = max(h2, 0.00001)
hg = gateheight*0.5d0 ! lower boundary
hg = max(hg , 0.0001)
if (gateheight >= h1) then ! gate above water
q = 11111d0
regime = 'gate above water'
return
else if (gateheight < 0.001) then
q = 0d0
regime = 'gate closed, a<0.001 '
return
endif
qcrit = sqrt( 2d0*g*(h1-hg) / (hg**-2-h1**(-1)) )
ha = hg ; hb = h2
call qorifdif12(ha,d,a,h1,h2,qda)
call qorifdif12(hb,d,a,h1,h2,qdb)
num = 0 ; qdc = 1d9
do while ( abs(qdc) > 1d-6 .and. abs(qda-qdb) > 1d-6 .and. num < 50 )
num = num + 1
hc = ha - qda*(ha-hb)/(qda-qdb) ! regula falsi
hc = max(hc,hg)
hc = min(hc,h2)
call qorifdif12(hc,d,a,h1,h2,qdc)
if (qda*qdc > 0) then
ha = hc ; qda = qdc
else if (qdb*qdc > 0) then
hb = hc ; qdb = qdc
endif
enddo
hg = hc
call getq3(hg,d,a,h1,h2,q)
return
do k = 1, 10
a = 0.1d0*dble(k)*h1
aa = 2d0*(h1-a)
bb = -2d0*h1**2
cc = a*h1*h1
hgb = (-bb + sqrt(bb*bb -4d0*aa*cc))/ (2d0*aa)
hgc = (-bb - sqrt(bb*bb -4d0*aa*cc))/ (2d0*aa)
hgb = hgb / h1
hgc = hgc / h1
enddo
end subroutine findqorifice12
subroutine findqorifice(gateheight,crestheight,h1,h3,q,h2,hg,regime,num,qcrit) ! bepaal q en hoogte h2 achter schuif, waterstand links = h1, rechts= h4, schuif = a, alles tov bodem
implicit none
double precision :: gateheight ! gate height above crest
double precision :: crestheight ! crest height above bed
double precision :: h1 ! upstream waterheight above crest
double precision :: h3 ! downstream waterheight above crest
double precision :: q ! flux m3/s (out)
double precision :: h2 ! pressure height above crest after gate (out)
double precision :: hg ! vena contracta height above crest after gate (out)
double precision :: qcrit ! critical discharge m2/s (out)
character(len=*) :: regime ! (out)
double precision :: g, dh, qmax, hkmin,ha,hb,qa,qb,ha0,qa0,hb0,qb0,qc,hc,a,d, qda, qdb, qdc, hga, hgb, hgc
integer :: num, k, kk, nummin
double precision :: coeffs(5), ccx(4), cc, alfa = 0.02d0, qf,hgf,h2f,qer,qermin
g = 9.81 ! h1 = waterhoogte bovenstrooms
h3 = min(h3,h1-0.0001) ! hg = gateheight * contractie = effectieve keeldoorsnee
d = crestheight
a = gateheight
h1 = max(h1, 0.0001)
h3 = max(h3, 0.00001)
h2 = h3
qermin = 1d9
hg = gateheight*0.5d0 ! lower boundary
hg = max(hg , 0.0001)
if (gateheight >= h1) then ! gate above water
q = 11111d0
regime = 'gate above water'
return
else if (gateheight < 0.001) then
q = 0d0
regime = 'gate closed, a<0.001 '
return
endif
qcrit = sqrt( 2d0*g*(h1-hg) / (hg**-2-h1**(-2)) )
if (h3 < 0.60*h1) then
regime = 'free gate flow '
q = qcrit
return
endif
do k = 1, 50
ha = hg ; hb = h3 ; hgc = hg
call qorifdif(hg,d,h1,h3,ha,qda)
call qorifdif(hg,d,h1,h3,hb,qdb)
num = 0 ; qdc = 1d9
do while ( abs(qdc) > 1d-6 .and. abs(qda-qdb) > 1d-6 .and. num < 50 )
num = num + 1
! if (ha >= h2) then
! regime = 'free weir flow' ; return
! endif
hc = ha - qda*(ha-hb)/(qda-qdb) ! regula falsi
hc = max(hc,hg)
hc = min(hc,h3)
call qorifdif(hg,d,h1,h3,hc,qdc)
if (qda*qdc > 0) then
ha = hc ; qda = qdc
else if (qdb*qdc > 0) then
hb = hc ; qdb = qdc
endif
enddo
h2 = hc
call getq1(hg,d,h1,h2,qa)
call getq2(hg,d,h2,h3,qb)
call getq3(hg,d,a,h1,h2,qc)
q = 0.5d0*(qa+qb)
qer = abs(q-qc)
if (qer < qermin) then
qermin = qer ; qf = q ; hgf = hg ; h2f = h2; nummin = num
endif
hg = hg + 0.01d0*a
regime = 'submerged gate flow '
enddo
h2 = h2f
hg = hgf
q = qf
num = nummin
end subroutine findqorifice
subroutine gethg(q,a,h1,h2,hg)
implicit none
double precision :: q,a,h1,h2,hg, g = 9.81d0
hg = h1*q**2 / (q**2 - g*a**h1*(h2-h1) )
end subroutine gethg
subroutine getq1(hg,d,h1,h2,q) ! energiebehoud bovenstrooms
implicit none ! bepaal q gegeven hg,h1,h2
double precision :: hg, d, h1, h2, q
double precision :: g, t, r, tr
g = 9.81d0
t = 2d0*g*(h1-h2)
r = 1d0/hg**2 - 1d0/(h1+d)**2
tr = t/r
if (tr .gt. 0) then
q = sqrt(tr)
else
q = h1*sqrt(g*h1)
endif
end subroutine getq1
subroutine getq2(hg,d,h2,h3,q) ! momentumbehoud benedenstrooms
implicit none ! bepaal q gegeven a,h2,h3
double precision :: hg,d,h2,h3,q
double precision :: g, t, r, tr
g = 9.81d0
t = 0.5d0*g*(h3**2 - h2**2)
r = 1d0/hg - 1d0/h3
tr = t/r
q = sqrt(tr)
end subroutine getq2
subroutine getq3(hg,d,a,h1,h2,q) ! momentumbehoud bovenstrooms
implicit none ! bepaal q gegeven a,hg,h1,h2
double precision :: hg,d,a,h1,h2,q
double precision :: g, t, r, tr, h2d
g = 9.81d0
t = g*a*(h2 - h1)
r = 1.0/h1 - 1d0/hg
tr = t/r
q = sqrt(tr)
end subroutine getq3
subroutine qorifdif(hg,d,h1,h3,h2,qd)
implicit none
double precision :: hg, d, h1, h3, h2, qd
double precision :: ql, qr
call getq1(hg,d,h1,h2,ql)
call getq2(hg,d,h2,h3,qr)
qd = ql-qr
end
subroutine qorifdif12(hg,d,a,h1,h2,qd)
implicit none
double precision :: hg,d,a,h1,h2,qd
double precision :: ql, qr
call getq1(hg,d,h1,h2,ql)
call getq3(hg,d,a,h1,h2,qr)
qd = ql-qr
end
subroutine interpdivers(naar)
use m_netw
USE M_FLOWGEOM
use m_flow
use m_samples
use m_flowparameters
USE M_INTERPOLATIONSETTINGS
use m_missing
use m_grid
use m_kdtree2
implicit none
double precision, external :: dbdistance
DOUBLE PRECISION, ALLOCATABLE :: XX(:,:), YY(:,:)
DOUBLE PRECISION, ALLOCATABLE :: XXX(:), YYY(:)
INTEGER , ALLOCATABLE :: NNN (:)
integer :: naar, N,NN,L,LK,K,KK, N6, mnx, md,mu, n1,n2
integer :: i, ierror
integer :: jdla, jakdtree = 1
double precision :: xn, yn, dist
if (NAAR == 1 .AND. ndx == 0) then
call qnerror('First reinitialise flow model, current dimensions are 0',' ',' ')
return
endif
if ( ( (naar.eq.1) .and. (interpolationtype.ne.1) ) .or. &
( (naar.eq.2) .and. (interpolationtype.eq.2) ) .or. &
( (naar.eq.3) .and. (interpolationtype.ne.1) ) ) then
if ( jakdtree.eq.1 ) then
! initialize kdtree
call build_kdtree(treeglob, Ns,xs,ys, ierror)
if ( ierror.ne.0 ) then
! disable kdtree
call delete_kdtree2(treeglob)
jakdtree = 0
end if
end if
end if
if (naar == 2 .and. interpolationtype == 2) then
call findcells(0)
endif
! get sample permutation array (increasing x-coordinate order)
if ( IPSTAT.ne.IPSTAT_OK ) then
call tidysamples(xs,ys,zs,ipsam,NS,MXSAM,MYSAM)
call get_samples_boundingbox()
IPSTAT = IPSTAT_OK
end if
JDLA = 1
if (naar == 1) then
if (ibedlevtyp == 1) then
IF (INTERPOLATIONTYPE == 1) THEN
CALL triinterp2(XZ,YZ,BL,NDX,JDLA) ! to flownodes bl, tiledepth approach
ELSE
N6 = MAXVAL(NETCELL%N)
ALLOCATE( XX(N6,NDX), YY(N6,NDX), NNN(NDX) )
DO N = 1,NDX
NNN(N) = NETCELL(N)%N
DO NN = 1, NNN(N)
XX(NN,N) = XK(NETCELL(N)%NOD(NN))
YY(NN,N) = YK(NETCELL(N)%NOD(NN))
ENDDO
ENDDO
call averaging2(1,NS,XS,YS,ZS,IPSAM,XZ,YZ,BL,NDX,XX,YY,N6,NNN,jakdtree)
DEALLOCATE(XX,YY,NNN)
ENDIF
else if (ibedlevtyp == 2) then ! to flowlinks bottomlevel blu will be phased out
if (INTERPOLATIONTYPE == 1) THEN
CALL triinterp2(Xu,Yu,Blu,LNX,JDLA)
else
N6 = 4
ALLOCATE( XX(N6,lnx), YY(N6,lnx), NNN(lnx) )
do L = 1,lnx
xx(1,L) = xz(ln(1,L)) ; yy(1,L) = yz(ln(1,L))
xx(3,L) = xz(ln(2,L)) ; yy(3,L) = yz(ln(2,L))
Lk = ln2lne(L)
xx(2,L) = xk(kn(1,Lk)) ; yy(2,L) = yk(kn(1,Lk))
xx(4,L) = xk(kn(2,Lk)) ; yy(4,L) = yk(kn(2,Lk))
enddo
nnn = 4 ! array nnn
call averaging2(1,NS,XS,YS,ZS,IPSAM,Xu,Yu,BLu,lnx,XX,YY,N6,NNN,jakdtree)
DEALLOCATE(XX,YY,NNN)
endif
endif
else if (naar == 2) then ! to network ZK
if (INTERPOLATIONTYPE == 1) THEN
CALL triinterp2(Xk,Yk,Zk,Numk,JDLA)
ELSE IF (INTERPOLATIONTYPE == 2) THEN
n6 = 2*maxval(nmk) ! 2: safe upper bound
ALLOCATE( XX(N6,NUMK), YY(N6,NUMK), NNN(NUMK), xxx(N6), yyy(N6) )
do K = 1,NUMK
! get the celllist
call make_dual_cell(k, n6, rcel, xxx, yyy, nnn(k))
do i=1,nnn(k)
xx(i,k) = xxx(i)
yy(i,k) = yyy(i)
enddo
enddo
call averaging2(1,NS,XS,YS,ZS,IPSAM,XK,YK,ZK,NUMK,XX,YY,N6,NNN,jakdtree)
DEALLOCATE(XX,YY,xxx,yyy,NNN)
ELSE IF (INTERPOLATIONTYPE == 3 ) THEN
call sam2net_curvi(numk,xk,yk,zk)
ENDIF
else if (naar == 3) then ! to waterlevels S1
s1 = dmiss
if (INTERPOLATIONTYPE == 1) THEN
CALL triinterp2(Xz,Yz,s1,Ndx,JDLA)
ELSE
N6 = 6
ALLOCATE( XX(N6,Ndx), YY(N6,Ndx), NNN(Ndx) )
do K = 1,Ndx
NN = nd(k)%lnx
XX(1:nn,K) = nd(k)%x
yy(1:nn,K) = nd(k)%y
nnn(K) = NN ! array nnn
enddo
call averaging2(1,NS,XS,YS,ZS,IPSAM,Xz,Yz,s1,Ndx,XX,YY,N6,NNN,jakdtree)
DEALLOCATE(XX,YY,NNN)
ENDIF
do k = 1,ndx
if (s1(k) == dmiss) then
s1(k) = bl(k)
endif
s1(k) = max(s1(k), bl(k))
enddo
else if (naar == 4) then ! to curvilinear grid ZC
mnx = mmax*nmax
IF (INTERPOLATIONTYPE == 1) THEN
CALL triinterp2(Xc,Yc,Zc,mnx,JDLA)
ELSE
N6 = 4
ALLOCATE( XX(N6,mnx), YY(N6,mnx), NNN(mnx) )
DEALLOCATE(XX,YY,NNN)
!k = 0
!do n = 1,nc
! do m = 1,mc
! md = max(1 ,m-1); nd = max(1, n-1)
! mu = min(mc,m+1); nu = min(nc,n+1)
! k = k + 1
! XX(1,K) = 0.25*(
!
call qnerror('not implemented yet',' ',' ')
return
ENDIF
endif
if ( jakdtree.eq.1 ) then
call delete_kdtree2(treeglob)
end if
END subroutine interpdivers
subroutine pixcount(xs,ys,zs,jatel)
USE M_FLOWGEOM
implicit none
double precision :: xs, ys, zs
integer :: jatel
double precision :: xmn, xmx, ymn, ymx
integer :: nn, k, in
integer, allocatable, save :: itel(:)
double precision, allocatable, save :: ztel(:)
if (jatel == 1) then
if (.not. allocated (itel) ) then
allocate(itel(ndx), ztel(ndx) ) ; itel = 0 ; ztel = 0
endif
do k = 1,ndx
xmn = minval(nd(k)%x) ; xmx = maxval(nd(k)%x)
ymn = minval(nd(k)%y) ; ymx = maxval(nd(k)%y)
if (xs <= xmx .and. xs >= xmn .and. ys <= ymx .and. ys >= ymn ) then
nn = size(nd(k)%x)
call PINPOK(Xs, Ys, Nn, nd(k)%x, nd(k)%y, IN)
if (IN == 1) then
itel(k) = itel(k) + 1
ztel(k) = ztel(k) + zs
return
endif
endif
enddo
else
do k = 1,ndx
if (itel(k) .ne. 0) then
bl(k) = ztel(k) / dble( itel(k) )
endif
enddo
if (allocated(itel) ) deallocate (itel, ztel)
endif
end subroutine pixcount
subroutine wriblu(mout) ! write bottom level u points
USE M_FLOWGEOM
implicit none
integer :: mout, L
write(mout,'(A,I12)') 'NR of FLOWlinks = ', lnx
do L = 1,lnx
write(mout,* ) xu(L), yu(L), blu(L)
enddo
call doclose(mout)
end subroutine wriblu
subroutine reablu(mout) ! read bottom level u points
USE M_FLOWGEOM
implicit none
integer :: mout
character(len=256) :: rec
integer :: L, L1
integer :: lnxr
double precision :: rd
read(mout,'(a)') rec
L1 = index(rec,'=') + 1
read (rec(L1:), *, err = 888) lnxr
if (lnxr .ne. lnx) then
call doclose(mout)
call qnerror('nr of flowlinks read .ne. nr of flowlinks', ' ',' ')
return
endif
do L = 1,lnx
read(mout,* ) rd, rd, blu(L)
enddo
call doclose(mout)
call setbobs()
return
888 call qnreaderror('trying to read nr of flowlinks but getting',rec,mout)
call doclose(mout)
end subroutine reablu
subroutine wribl(mout) ! write bottom level
USE M_FLOWGEOM
implicit none
integer :: mout, k
write(mout,'(A,I12)') 'NR of internal FLOWCELLS = ', ndxi
do k = 1,ndxi
write(mout,* ) xz(k), yz(k), bl(k)
enddo
call doclose(mout)
end subroutine wribl
subroutine reabl(mout) ! read bottom level
use m_flowgeom
use M_samples
use m_missing
implicit none
integer :: mout
character(len=256) :: rec
integer :: K, L1
integer :: ndxr
double precision :: rd
CALL reasam(mout,0)
bl = dmiss
call interpdivers(1)
call delsam(-1) ! deallocate
return
888 call qnreaderror('trying to read nr of internal flow nodes but getting',rec,mout)
call doclose(mout)
end subroutine reabl
subroutine setbathymetryfromextfile() ! setbottomlevels() ! check presence of old cell centre bottom level file
use timespace_data
use timespace
use unstruc_model
use m_flowgeom
use m_flow
use m_netw ! only : xk, yk, zk
implicit none
logical :: jawel
integer :: mxyb, ja, method
character(len=256) :: filename
! character(len=1) :: operand
! double precision :: transformcoef(25) !< Transform coefficients a+b*x
inquire(file = md_xybfile, exist=jawel)
jawel = jawel .and. (len_trim(md_xybfile) > 0) ! strange behavior on some Linux systems if file name is empty, but reported exist=.true.
if (jawel) then ! set tegeldiepte optie als bl file aanwezig
call oldfil(mxyb,md_xybfile)
call reabl(mxyb)
endif
if (mext > 0) then
ja = 1
do while (ja .eq. 1) ! read *.ext file
call delpol() ! ook jammer dan
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. qid == 'bathymetry') then
call mess(LEVEL_INFO, 'setting bathymetry from file '''//trim(filename)//'''.')
success = timespaceinitialfield(xk, yk, zk, numk, filename, filetype, method, operand, transformcoef, ibedlevtyp) ! zie meteo module
endif
enddo
rewind (mext)
endif
end subroutine setbathymetryfromextfile ! setbottomlevels
subroutine setbobs() ! and set blu, weigthed depth at u point
use m_netw
use m_flowgeom
use m_flow
use m_missing
implicit none
integer L, k1, k2, n1, n2, LK, n, k, k3, LL, kk, Ls
double precision :: bl1, bl2, blv, bln, zn1, zn2, zn3, wn, alf, banow, xnow, ynow
! First, prepare bed levels at pressure points:
if (ibedlevmode == BLMODE_D3D) then
! DPSOPT=MAX equivalent: deepest zk/corner point
do k = 1,ndx2d
bl(k) = huge(1d0)
do kk = 1,netcell(k)%n
zn1 = zk(netcell(k)%nod(kk)) ; if (zn1 == dmiss) zn1 = zkuni
bl(k) = min(bl(k), zn1)
enddo
enddo
else
! Default: BLMODE_DFM, tiles or velocity point based, use ibedlevtyp only
if (ibedlevtyp > 1 .and. ibedlevtyp .le. 5) then
bl = 1d30
else if (ibedlevtyp == 6) then ! quick and dirty flownodes tile depth like taken from netnodes, to be able to at least run netnode zk defined models
do k = 1,ndx2d
bl(k) = 0d0
do kk = 1,netcell(k)%n
bl(k) = bl(k) + zk(netcell(k)%nod(kk))
enddo
bl(k) = bl(k) / netcell(k)%n
enddo
endif
end if
do L = lnx1D+1, lnx
n1 = ln(1,L) ; n2 = ln(2,L)
if (ibedlevtyp == 1 .or. ibedlevtyp == 6) then ! tegeldieptes celcentra
bl1 = bl(n1)
bl2 = bl(n2)
bob(1,L) = max( bl1, bl2 )
bob(2,L) = bob(1,L)
else if (ibedlevtyp == 2) then ! rechtstreeks op u punten interpoleren,
k1 = ln(1,L) ; k2 = ln(2,L) ! haal waarde uit blu, gedefinieerd op xu,yu
blv = blu(L)
bob(1,L) = blv
bob(2,L) = blv
if (ibedlevmode == BLMODE_DFM) then
bl(n1) = min(bl(n1) , blv)
bl(n2) = min(bl(n2) , blv)
end if
else if (ibedlevtyp >= 3 .or. ibedlevtyp <= 5) then ! dieptes uit netnodes zk
k1 = lncn(1,L) ; k2 = lncn(2,L)
zn1 = zk(k1) ; if (zn1 == dmiss) zn1 = zkuni
zn2 = zk(k2) ; if (zn2 == dmiss) zn2 = zkuni
if (jaconveyance2D >= 1) then ! left rigth
blv = min(zn1,zn2)
bob(1,L) = zn1
bob(2,L) = zn2
else if (ibedlevtyp == 3) then ! mean
blv = 0.5d0*( zn1 + zn2 )
bob(1,L) = blv
bob(2,L) = blv
else if (ibedlevtyp == 4) then ! min
blv = min( zn1, zn2 )
bob(1,L) = blv
bob(2,L) = blv
else if (ibedlevtyp == 5) then ! max
blv = max( zn1, zn2 )
bob(1,L) = blv
bob(2,L) = blv
endif
if (allocated(ibot)) then ! Local override of bottomleveltype
if (ibot(L) == 4) then
blv = min(zn1,zn2) ! local override min
bob(1,L) = blv
bob(2,L) = blv
else if (ibot(L) == 5) then ! local override max
blv = max(zn1,zn2)
bob(1,L) = blv
bob(2,L) = blv
endif
end if
! When in DFM mode (not D3D mode), get bed level from velocity point depth.
if (ibedlevmode == BLMODE_DFM) then
bl(n1) = min(bl(n1) , blv)
bl(n2) = min(bl(n2) , blv)
end if
endif
blu(L) = min(bob(1,L), bob(2,L) )
enddo
if (jaembed1D >= 2) then
n = 0
do k = 1,ndxi
if (kcs(k) == 21) then
n = n + 1
endif
enddo
if (allocated(kembed) ) then
deallocate(kembed, dbl21)
endif
allocate(kembed(n), dbl21(n) )
n = 0
do k = 1,ndxi
if (kcs(k) == 21) then
n = n + 1; kembed(n) = k; dbl21(n) = bl(k)
endif
enddo
numembed = n
endif
do L = 1,lnx1D ! 1D
n1 = ln(1,L) ; n2 = ln(2,L) ! flow ref
k1 = lncn(1,L) ; k2 = lncn(2,L) ! net ref
zn1 = zk(k1) ; if (zn1 == dmiss) zn1 = zkuni
zn2 = zk(k2) ; if (zn2 == dmiss) zn2 = zkuni
if ( kcu(L) == 1) then
blv = 0.5d0*( zn1 + zn2 ) ! same as 2D, based on network, but now in flow link dir. In 2D this is net link dir
bob(1,L) = blv
bob(2,L) = blv
bl(n1) = min(bl(n1) , blv)
bl(n2) = min(bl(n2) , blv)
else if (kcu(L) == 3) then
if (kcs(n1) == 21) blv = bl(n1)
if (kcs(n2) == 21) blv = bl(n2)
bob(1,L) = blv
bob(2,L) = blv
bl(n1) = min(bl(n1) , blv)
bl(n2) = min(bl(n2) , blv)
else if (kcu(L) == 4) then ! left rigth
blv = min(zn1,zn2)
bob(1,L) = zn1
bob(2,L) = zn2
bl(n1) = min(bl(n1) , blv)
bl(n2) = min(bl(n2) , blv)
endif
enddo
if (jaembed1D > 0) then
do n = 1,numembed
dbl21(n) = dbl21(n) - bl(kembed(n) )
enddo
endif
do k = 1,ndx !losse punten die geen waarde kregen
if (bl(k) == 1d30) then
bl(k) = zkuni
endif
enddo
do L = lnxi+1, lnx ! randjes copieren
n1 = ln(1,L) ; n2 = ln(2,L)
bl(n1) = bl(n2)
if (jaconveyance2D >= 1) then
aif(n1) = aif(n2) ! ook voor skewness
endif
if (kcu(L) == -1) then ! 1D randjes extrapoleren voor 1D straight channel convecyance testcase
k1 = lncn(1,L) ; k2 = lncn(2,L)
do k = 1,nd(n2)%lnx
LL = iabs(nd(n2)%ln(k))
if (kcu(LL) == 1) then
if (nd(n2)%ln(k) < 0) k3 = lncn(2,LL)
if (nd(n2)%ln(k) > 0) k3 = lncn(1,LL)
endif
!zn1 = 1.5d0*zk(k2) - 0.5d0*zk(k3)
! SPvdP: previous expression is problematic when zk(k2) and/or zk(k3) have missing values
zn2 = zk(k2) ; if (zn2 == dmiss) zn2 = zkuni
zn3 = zk(k3) ; if (zn3 == dmiss) zn3 = zkuni
zn1 = 1.5d0*zn2 - 0.5d0*zn3 ! note: actual locations of cells centers not taken into account
bob(1,L) = zn1
bob(2,L) = zn1
bl(n1) = min(bl(n1) , zn1)
bl(n2) = min(bl(n2) , zn1)
enddo
else if (jaconveyance2D < 1) then
if (ibedlevtyp == 1 .or. ibedlevtyp == 6) then
bob(1,L) = bl(n1) ! uniform bobs only for tiledepths
bob(2,L) = bl(n1)
endif
endif
enddo
if (blmeanbelow .ne. -999d0) then
do n = 1,ndx2D
wn = 0d0; bln = 0d0
do LL = 1,nd(n)%lnx
Ls = nd(n)%ln(LL); L = iabs(Ls)
bln = bln + wu(L)*0.5d0*( bob(1,L) + bob(2,L) )
wn = wn + wu(L)
enddo
if (wn > 0d0) then
bln = bln/wn
alf = min (1d0, ( blminabove - bln ) / ( blminabove-blmeanbelow ) )
if (alf > 0d0) then
bl(n) = alf*bln + (1d0-alf)*bl(n)
endif
endif
enddo
endif
end subroutine setbobs
subroutine correctblforzlayerpoints()
use m_netw
use m_flowgeom
use m_flow
use m_missing
implicit none
integer :: n,nlayb,nrlay
if ( kmx.eq.0 ) return
if (Layertype == 2) then ! z only
do n = 1,ndx
call getzlayerindices(n,nlayb,nrlay)
if ( zslay(nlayb-1,1) < bl(n) ) then
bl(n) = zslay(nlayb-1,1)
endif
enddo
else if (Layertype == 3) then ! mix : first do sigma and z
! do n = 1,ndx
! Ldn = laydefnr(n)
! if (Ldn > 0) then
! kb = kbot(n)
! zws(kb-1) = bl(n)
! if (Laytyp(Ldn) == 1) then ! sigma
! h0 = s1(n) - bl(n)
! do k = 1, kmxn(n) - 1
! zws(kb + k - 1) = bl(n) + h0*zslay(k,Ldn)
! enddo
! ktop(n) = kb + kmxn(n) - 1
! zws(ktop(n)) = s1(n)
! else if (Laytyp(Ldn) == 2) then ! z
!
! ktx = kb + kmxn(n) - 1
! call getzlayerindices(n,nlayb,nrlay)
! toplayminthick = 0.5d0*( zslay(2,1) - zslay(1,1) )
! do k = kb, ktx
! kk = k - kb + nlayb
! zkk = zslay(kk,Ldn)
! if (zkk < s1(n) - toplayminthick .and. k < ktx ) then
! zws(k) = zkk
! else
! zws(k) = s1(n)
! ktop(n) = k
! if (ktx > k) then
! zws (k+1:ktx) = zws(k)
! endif
! exit
! endif
! enddo
!
! endif
!
! endif
! enddo
endif
end subroutine correctblforzlayerpoints
!> Sets the bob values on the flow links that are overridden by a fixed weir.
!! This is based on the interpolated pliz values from the fixed weir definition.
subroutine setbobs_fixedweirs()
use m_flowgeom
use m_fixedweirs
implicit none
integer :: i, ip, iL, Lf
double precision :: alpha, zc
if ( nfxw == 0 ) return
do i = 1,nfxw
do iL=1,fxw(i)%lnx
Lf = abs(fxw(i)%ln(iL))
ip = fxw(i)%indexp(iL)
alpha = fxw(i)%wfp(iL)
zc = alpha * fxw(i)%zp(ip) + (1d0-alpha)*fxw(i)%zp(ip+1)
bob(1,Lf) = max( zc,bob(1,Lf) ) ; bob(2,Lf) = max( zc,bob(2,Lf) )
end do
end do
end subroutine setbobs_fixedweirs
subroutine othercell(k1,L,k2)
USE M_FLOWGEOM
implicit none
integer :: k1,k2,L
if (ln(1,L) == k1) k2 = ln(2,L)
if (ln(2,L) == k1) k2 = ln(1,L)
end subroutine othercell
subroutine solve_jacobi() ! uses both s0 and s1
use m_flow ! when entering this subroutine, s1=s0, u1=u0, etc
use m_flowgeom
use m_flowtimes
use m_jacobi
implicit none
double precision :: ds ! max error
integer :: L, n, k1, k2
call klok(cpusol(1))
do n = 1,ndx
if (kfs(n) == 1) then
bbi(n) = 1d0/bb(n)
db(n) = dd(n)*bbi(n)
endif
enddo
ds = 1e10 ! some big nr
itsol = 0
do while (ds > epsjac) ! Jacobi
do n = 1,ndx
if (kfs(n) == 1) then
s1(n) = db(n) ! For explicit points db = s0, so this does won't hurt
endif
enddo
do L = 1,lnx
if (tetaf(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
if (kcs(k1) > 0) then ! later remove this check (and make boundary override)
s1(k1) = s1(k1) + tetaf(L)*s0(k2)*bbi(k1)
endif
if (kcs(k2) > 0) then
s1(k2) = s1(k2) + tetaf(L)*s0(k1)*bbi(k2) ! use s0 and update of s0 below because of link-oriented Jacobi
endif
endif
enddo
if (jsolpos == 1) s1 = max(s1,bl) !
ds = maxval( dabs(s1-s0) )
s0 = s1 ! TODO: AvD: (NEVER CALLED! SO NOT A PROBLEM) if single time step is being restarted, then this line will have overwritten some of the old s0 values.
itsol = itsol + 1
if (itsol == itmxjac) exit
enddo
call klok(cpusol(2)) ; cpusol(3) = cpusol(3) + cpusol(2) - cpusol(1)
end subroutine solve_jacobi
subroutine setkfs() ! set kfs
use m_flow
use m_flowgeom
use m_flowtimes
implicit none
integer :: i, L, LL
integer :: n, kb, ki
kfs = 0
if (ivariableteta<=1) then ! fully implicit and teta=constant
do L=1,lnx ! implicit points
if (hu(L)> 0) then
kfs(ln(1,L))=1
kfs(ln(2,L))=1
endif
enddo
else ! set kfs ic. teta; 0=not, 1 =impl, 2 = expl
do L=1,lnx ! explicit points
if (hu(L)> 0) then
if (teta(L) == 0) then
kfs(ln(1,L))=2
kfs(ln(2,L))=2
else if (teta(L) > 0) then
kfs(ln(1,L))=1 ! todo: or bnd, randjes ook altijd impliciet
kfs(ln(2,L))=1
endif
endif
enddo
endif
! water-level Neumann boundaries: add boundary cells whose corresponding internal cell is wet (but boundary face is inactive)
do n=1,nbndz
kb = kbndz(1,n)
ki = kbndz(2,n)
if ( kfs(ki).eq.1 ) then
kfs(kb) = 1
end if
end do
! velocity boundaries: Neumann water-level boundaries are applied
do n=1,nbndu
kb = kbndu(1,n)
ki = kbndu(2,n)
if ( kfs(ki).eq.1 ) then
kfs(kb) = 1
end if
end do
end subroutine setkfs
subroutine setship()
use m_netw
use m_flowgeom
use m_flow
use m_flowtimes
use m_missing
use m_sferic
use m_ship
use m_physcoef
implicit none
integer :: L, k, k1,k2, kk, LL, n, num, ierr, nav
double precision :: xu1,xu2,yu1,yu2,sx1,sx2,sy1,sy2,alf,alfy,eps
double precision :: rela, dpx, dpy, fxx, fyy, frac, yf, yf2, corr, dvL, dp
double precision :: sxr, syr, sxr2, syr2, css, sns, dss, prp, prop, volprop, prptot, volu, frb, a
double precision :: frc,uxsh,uysh,uxw,uyw,uxd,uyd,umods,uud, uush, uushd, friL, frix, friy, frim, phi
double precision :: FX, FY, XM, YM, armx, army, shvol, roeri, stuwc, stuwn, frixi, friyi, frimi, frcL
double precision :: cb, chez, rman, s0shipav
if (nshiptxy == 0) return
prptot = 0
if (time0 == 0d0) then
shb(1) = 60d0/2d0 - 0.1d0
shL(1) = 360d0/2d0
shd(1) = 17d0
xmx = maxval(xk (1:numk) ) - 20d0 ! domain extent, run on ground 20 m prior to land water border
xmn = minval(xk (1:numk) ) + 20d0
ymx = maxval(yk (1:numk) ) - 20d0
ymn = minval(yk (1:numk) ) + 20d0
javiusp = 1
if (.not. allocated (viusp) ) then
allocate ( viusp(lnx) , stat=ierr ); viusp = 0d0
endif
shu = 0d0
shv = 0d0
sho = 0d0
fricx = 0d0; fricy = 0d0 ; fricm = 0d0
fx2 = 0d0; fy2 = 0d0 ; fm2 = 0d0
shx(1) = xmn + 0.6d0*(xmx-xmn) ! 5850.
shy(1) = ymn + 0.3d0*(ymx-ymn) ! 450.
shi(1) = pi
fstuw = 0d0 ; froer = 0d0
stuwmx = 120d0*rhog
roermx = 1d0
stuw(1) = 0d0*stuwmx(1) ! in ship direction
roer(1) = 0 ! easy on the helm now
! cb = deadw / rhomean*shL*shb*shd*4d0 ) ! mass
shu(1) = 0d0
shv(1) = 0d0
sho(1) = 0d0 ! twopi/(60d0*10d0)
if (nshiptxy == 2) then
shx(2) = xmn + 0.3d0*(xmx-xmn) ! 3300.
shy(2) = ymn + 0.7d0*(ymx-ymn) ! 580.
shi(2) = 0d0 ! pi
stuw(2) = 0d0
roer(2) = 0
shb(2) = 32.2d0/2d0 - 0.1d0
shL(2) = 278d0/2d0
shd(2) = 15d0
endif
call readshipdef()
deadwi = deadw*(4d0*shb**2 + 4d0*shL**2)/12d0 ! intertia vertical rotation axis
return
endif
if (icontroltyp(1) >= 4) then
call getshipcontrol() ! arrows + 5 = first ship qawsd = second ship
endif
zsp = 0d0 ; viusp = 0d0
do n = 1, nshiptxy
stuw(n) = fstuw(n)*stuwmx(n) ! arrays
roer(n) = froer(n)*roermx(n)
if (stuw(n) >= 0d0) then
roeri = 0.5d0*roer(n)
stuwc = cos(roer(n))
else
roeri = 0.06d0 ! wheel effect especially in reverse => 6 degree dev to port => left turning screw
stuwc = 0.6d0 ! less efficient in reverse
endif
css = cos(shi(n) + roeri) ; sns = sin(shi(n) + roeri)
stuwn = stuwc*stuw(n)
stuwx(n) = stuwn*css ; stuwy(n) = stuwn*sns ; stuwm(n) = 0.8d0*shL(n)*stuwn*sin(-roeri)
if (icontroltyp(n) == 1 .or. icontroltyp(n) == 2) then ! position from txy file
if (iniship > 0) then
shu(n) = ( xyship(2*(n-1)+1) - shx(n) ) /dts
shv(n) = ( xyship(2*(n-1)+2) - shy(n) ) /dts
rela = exp(-dts/(10d0*Trelax) ) ! time relax for force
if ( .not. (shv(n) == 0 .and. shu(n) == 0) ) then
phi = atan2( shv(n), shu(n) )
if (phi - shi(n) >= pi) phi = phi - twopi
if (phi - shi(n) <=-pi) phi = phi + twopi
shi(n) = (1d0-rela)*phi + rela*shi(n)
endif
endif
shx(n) = xyship(2*(n-1)+1)
shy(n) = xyship(2*(n-1)+2)
else
if (icontroltyp(n) == 3) then ! velocity from txy file
shu(n) = xyship(2*(n-1)+1) ! * 3.34D0/3.14D0
shv(n) = xyship(2*(n-1)+2)
else if( icontroltyp(n) == 4 .or. icontroltyp(n) == 5) then ! velocity computed from forces
a = (fx2(n) + fricxe(n) + stuwx(n) + fextx(n)) / deadw(n)
shu(n) = (shu(n) + a*dts)/(1D0 + dts*fricxi(n)/deadw(n) )
a = (fy2(n) + fricye(n) + stuwy(n) + fexty(n)) / deadw(n)
shv(n) = (shv(n) + a*dts)/(1D0 + dts*fricyi(n)/deadw(n) )
if (icontroltyp(n) == 4) then ! also compute gyring, rotation vertical axis
a = (fm2(n) + fricme(n) + stuwm(n) + fextm(n)) / deadwi(n)
sho(n) = (sho(n) + a*dts)/(1D0 + dts*fricmi(n)/deadwi(n) )
endif
endif
shx(n) = shx(n) + shu(n)*dts
shy(n) = shy(n) + shv(n)*dts
shi(n) = shi(n) + sho(n)*dts
endif
enddo
if (icontroltyp(1) > 1) then
call afhouwendammit()
endif
do n = 1, nshiptxy
css = cos(shi(n)) ; sns = sin(shi(n))
if (icontroltyp(n) == 1) then ! body force method for prescribed position sluice doors just blocking flow etc
do L = 1,lnx
syr = (yu(L) - shy(n))*css - (xu(L) - shx(n))*sns
sxr = (xu(L) - shx(n))*css + (yu(L) - shy(n))*sns
yf = 1d0 ! - ( 0.1d0*abs( syr ) / shb(n) )
if ( syr > -shb(n) .and. syr < shb(n) .and. &
sxr > -shL(n)*yf .and. sxr < shL(n)*yf ) then
advi(L) = advi(L) + eps
endif
enddo
else ! moving pressurefield
checkdw(n) = 0d0
s0shipav = 0d0; nav = 0
do k = 1,ndx
syr = (yz(k) - shy(n))*css - (xz(k) - shx(n))*sns
sxr = (xz(k) - shx(n))*css + (yz(k) - shy(n))*sns
yf = 1d0 - ( 0.1d0*abs( syr ) / shb(n) )
if ( syr > -shb(n) .and. syr < shb(n) .and. &
sxr > -shL(n)*yf .and. sxr < shL(n)*yf ) then
alf = 1d0
dss = abs( sxr) / (shL(n)*yf) ; frb = 0.40d0 ! 0.25d0
if (dss > frb) then
alf = 0.5d0*( cos(pi*(dss-frb)/(1d0-frb)) + 1d0)
endif
alfy = 1d0
dss = abs(syr) / shb(n)
if (icontroltyp(n) < 4 ) then
frb = max(0.2d0, 0.8d0*alf)
else
frb = 0.6d0 ! relax man
endif
if (dss > frb) then
alfy = 0.5d0*( cos(pi*(dss-frb)/(1d0-frb)) + 1d0)
endif
if (zsp(k) == 0d0) then
zsp(k) = shd(n)*alf*alfy ! 17d0
checkdw(n) = checkdw(n) + zsp(k) * ba(k)
else
zsp(k) = 0.5d0*(zsp(k) + shd(n)*alf*alfy)
endif
if (iniship == 0 .and. japressurehull > 0) then
s0(k) = s0(k) - zsp(k) ; s1(k) = s0(k)
endif
endif
enddo
endif
enddo
do n = 1, nshiptxy
css = cos(shi(n)) ; sns = sin(shi(n))
if (icontroltyp(n) > 1) then
volprop = 0d0 ; prop = 0.5d0*shb(n); prptot = 0d0
do L = 1,lnx ! establish propellor volume to later distribute stuw
k1 = ln(1,L) ; k2 = ln(2,L)
syr = (yz(k1) - shy(n))*css - (xz(k1) - shx(n))*sns
sxr = (xz(k1) - shx(n))*css + (yz(k1) - shy(n))*sns
syr2 = (yz(k2) - shy(n))*css - (xz(k2) - shx(n))*sns
sxr2 = (xz(k2) - shx(n))*css + (yz(k2) - shy(n))*sns
yf = 1d0 - ( 0.1d0*abs( syr ) / shb(n) )
yf2 = 1d0 - ( 0.1d0*abs( syr2) / shb(n) )
if ( syr > -shb(n) .and. syr < shb(n) .and. &
sxr > -shL(n)*yf .and. sxr < shL(n)*yf .or. &
syr2 > -shb(n) .and. syr2 < shb(n) .and. &
sxr2 > -shL(n)*yf2 .and. sxr2 < shL(n)*yf2 ) then
prp = 0d0
sxr = 0.5d0*(sxr + sxr2)
syr = 0.5d0*(syr + syr2)
dss = sqrt( (-0.8*shL(n) - sxr)**2 + syr**2)
if (dss < prop) then
dss = dss/prop
prp = 0.5d0*( cos(pi*dss) + 1d0)
prptot = prptot + abs(csu(L))*prp
endif
endif
enddo
fricx (n)= 0d0 ; fricy (n) = 0d0 ; fricm (n) = 0d0
fricxe(n) = 0d0 ; fricye(n) = 0d0 ; fricme(n) = 0d0
fricxi(n) = 0d0 ; fricyi(n) = 0d0 ; fricmi(n) = 0d0
do L = 1,lnx ! impose ship by pressure field
k1 = ln(1,L) ; k2 = ln(2,L)
syr = (yz(k1) - shy(n))*css - (xz(k1) - shx(n))*sns
sxr = (xz(k1) - shx(n))*css + (yz(k1) - shy(n))*sns
syr2 = (yz(k2) - shy(n))*css - (xz(k2) - shx(n))*sns
sxr2 = (xz(k2) - shx(n))*css + (yz(k2) - shy(n))*sns
yf = 1d0 - ( 0.1d0*abs( syr ) / shb(n) )
yf2 = 1d0 - ( 0.1d0*abs( syr2) / shb(n) )
if ( syr > -shb(n) .and. syr < shb(n) .and. &
sxr > -shL(n)*yf .and. sxr < shL(n)*yf .or. &
syr2 > -shb(n) .and. syr2 < shb(n) .and. &
sxr2 > -shL(n)*yf2 .and. sxr2 < shL(n)*yf2 ) then
alf = 1d0
do kk = 1,nd(k1)%lnx ! set eddy viscosity = 1 at ship
LL = iabs( nd(k1)%ln(kk) )
viusp(LL) = vicuship
enddo
do kk = 1,nd(k2)%lnx
LL = iabs( nd(k2)%ln(kk) )
viusp(LL) = vicuship
enddo
if (japrop == 1) then
prp = 0d0 ; prop = 0.5d0*shb(n) ! add propellor
sxr = 0.5d0*(sxr + sxr2)
syr = 0.5d0*(syr + syr2)
dss = sqrt( (-0.8*shL(n) - sxr)**2 + syr**2)
if (dss < prop) then
dss = dss/prop
prp = 0.5d0*( cos(pi*dss) + 1d0)
endif
if (prp > 0d0) then
volu = acl(L)*vol1(k1) + (1d0-acl(L))*vol1(k2)
adve(L) = adve(L) + (prp/prptot)*(stuwx(n)*csu(L)+stuwy(n)*snu(L))*ag / (rhog*volu) ! normalised propellor
endif !
endif
if (jafric == 1) then ! add hull friction
rman = 0.015*(57.+17.+17.)/57. ! friction coefficient
chez = ( huvli(L)**(-0.1666d0) ) / rman ! ship manning
frc = ag / (chez*chez) ! g/C2
frc = Cfskin*(shb(n)+shd(n)) / shb(n)
uxsh = shu(n) - sho(n)*(yu(L) - shy(n)) ! ship velocity x,y
uysh = shv(n) + sho(n)*(xu(L) - shx(n))
uxw = 0.5d0*(ucx(k1)+ucx(k2)) ! water velocity x,y
uyw = 0.5d0*(ucy(k1)+ucy(k2))
uxd = uxsh - uxw ! velocity difference
uyd = uysh - uyw
umods = sqrt( uxd*uxd + uyd*uyd ) ! friction velocity
uud = uxd*csu(L) + uyd*snu(L) ! component in (L)
friL = frc*umods*uud
! adve(L) = adve(L) - friL*huvli(L) ! add skin friction explicit
uush = uxsh*csu(L) + uysh*snu(L)
uushd = uush - u1(L)
adve(L) = adve(L) - frc*huvli(L)*umods*uushd ! add skin friction implicit
advi(L) = advi(L) + frc*huvli(L)*umods ! add skin friction
frcL = frc*umods*dx(L)*wu(L)*rhomean
frix = -uxd*frcL ! = -(shu(n) - sho(n)*(yu(L) - shy(n)) - uxw)*frcL ! force on ship
friy = -uyd*frcL ! = -(shv(n) + sho(n)*(xu(L) - shx(n)) - uxw)*frcL
frim = friy*(xu(L) - shx(n)) - frix*(yu(L) - shy(n))
fricx(n) = fricx(n) + frix
fricy(n) = fricy(n) + friy
fricm(n) = fricm(n) + frim
fricxe(n) = fricx(n)
fricye(n) = fricy(n)
fricme(n) = fricm(n)
if (jashfricimpl == 1) then ! implicit
! frix = -uxd*frcL = -(shu(n) - sho(n)*(yu(L) - shy(n)) - uxw)*frcL ! force on ship
! friy = -uyd*frcL = -(shv(n) + sho(n)*(xu(L) - shx(n)) - uxw)*frcL
!frix = -(shu(n) - sho(n)*(yu(L) - shy(n)) - uxw)*frcL ! force on ship
!friy = -(shv(n) + sho(n)*(xu(L) - shx(n)) - uxw)*frcL
!frim = -(shv(n) + sho(n)*(xu(L) - shx(n)) - uxw)*frcL*(xu(L) - shx(n)) - &
! -(shu(n) - sho(n)*(yu(L) - shy(n)) - uxw)*frcL*(yu(L) - shy(n))
frix = -(0d0 - sho(n)*(yu(L) - shy(n)) - uxw)*frcL ! force on ship explicit part
friy = -(0d0 + sho(n)*(xu(L) - shx(n)) - uxw)*frcL
frim = -(shv(n) + 0d0*(xu(L) - shx(n)) - uxw)*frcL*(xu(L) - shx(n)) - &
! TODO, double check this one 2 - after each other is not defined in fortran....
(-(shu(n) - 0d0*(yu(L) - shy(n)) - uxw)*frcL*(yu(L) - shy(n)))
frixi = frcL ! force on ship implicit part
friyi = frcL
frimi = (xu(L) - shx(n))*frcL*(xu(L) - shx(n)) + &
(yu(L) - shy(n))*frcL*(yu(L) - shy(n))
fricxe(n) = fricxe(n) + frix
fricye(n) = fricye(n) + friy
fricme(n) = fricme(n) + frim
fricxi(n) = fricxi(n) + frixi
fricyi(n) = fricyi(n) + friyi
fricmi(n) = fricmi(n) + frimi
endif
endif
endif
enddo
endif
enddo
if ( japressurehull >= 0) then
rela = exp(-dts/Trelax) ! time relax for force
do n = 1,nshiptxy ! compute pressure force
fx = 0d0 ; fy = 0d0; xm = 0d0; ym = 0d0; shvol = 0d0
if (icontroltyp(n) < 4 .AND. checkdw(n) > 0D0) then
corr = 1d-3*deadw(n)/checkdw(n)
else
corr = 1d0 ! no correction
endif
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
css = cos(shi(n)) ; sns = sin(shi(n))
syr = (yz(k1) - shy(n))*css - (xz(k1) - shx(n))*sns
sxr = (xz(k1) - shx(n))*css + (yz(k1) - shy(n))*sns
syr2 = (yz(k2) - shy(n))*css - (xz(k2) - shx(n))*sns
sxr2 = (xz(k2) - shx(n))*css + (yz(k2) - shy(n))*sns
yf = 1d0 - ( 0.1d0*abs( syr ) / shb(n) )
yf2 = 1d0 - ( 0.1d0*abs( syr2) / shb(n) )
if ( syr > -shb(n) .and. syr < shb(n) .and. &
sxr > -shL(n)*yf .and. sxr < shL(n)*yf .or. &
syr2 > -shb(n) .and. syr2 < shb(n) .and. &
sxr2 > -shL(n)*yf2 .and. sxr2 < shL(n)*yf2 ) then
dp = -rhog*(s1(k2) - s1(k1) ) ! /dx(L) !
dvL = 0.5d0*(zsp(k1) + zsp(k2) )*wu(L) ! *dx(L) !
shvol = shvol + dvl
dpx = dp*csu(L)
fxx = dpx*dvl*corr
fx = fx + fxx
xm = xm - fxx*(yu(L) - shy(n) )
dpy = dp*snu(L)
fyy = dpy*dvl*corr
fy = fy + fyy
ym = ym + fyy*(xu(L) - shx(n) )
endif
enddo
if (fx .ne. 0) armx = xm/fx
if (fy .ne. 0) army = ym/fy
fx2(n) = (1d0-rela)*fx2(n) + rela*fx
fy2(n) = (1d0-rela)*fy2(n) + rela*fy
fm2(n) = (1d0-rela)*fm2(n) + rela*(ym + xm)
enddo
endif
iniship = 1
if (japressurehull >= 0) then
adve0 = adve
endif
end subroutine setship
subroutine setpressurehull()
use m_ship
use m_flowgeom
use m_flow
implicit none
integer :: L, k1, k2
double precision :: r1,r2
if (nshiptxy == 0) return
if (japressurehull == 1 .and. iniship == 1) then
r2 = alfahull
r1 = 1d0 + r2
do L = 1,Lnx
k1 = ln(1,L) ; k2 = ln(2,L)
if (zsp(k1) .ne. 0d0 .or. zsp(k2) .ne. 0d0) then
! adve(L) = adve0(L) + ag*( zsp(k2) - zsp(k1) )*dxi(L) ! impose ship hull just staticly
adve(L) = adve0(L) + ag*( r1*zsp(k2) + r2*s1(k2) - r1*zsp(k1) - r2*s1(k1) )*dxi(L) ! impose ship hull
endif
enddo
endif
end subroutine setpressurehull
subroutine checkpressurehull()
use m_ship
use m_flowgeom
use m_flow
implicit none
integer :: k
double precision :: difmx
if (nshiptxy == 0) return
if (japressurehull == 1 .and. iniship == 1) then
difmx = 0d0
do k = 1,ndx
if (zsp(k) .ne. 0d0) then
if (abs( zsp(k) + s1(k) ) > 0.01d0) then
difmx = max(difmx, abs (zsp(k) + s1(k) ) )
endif
endif
enddo
endif
end subroutine checkpressurehull
subroutine readshipdef()
use m_sferic
use m_ship
use unstruc_model
implicit none
integer :: minp, ja, n, nn, ic
logical jawel
inquire (file = trim(md_ident)//'.shd', exist = jawel)
if (jawel) then
call oldfil(minp, trim(md_ident)//'.shd')
call zoekinteger (minp, 'JAPRESSUREHULL' , japressurehull, ja)
call zoekinteger (minp, 'JAFRIC' , jafric, ja)
call zoekinteger (minp, 'JAPROP' , japrop, ja)
call zoekinteger (minp, 'JASHFRICIMPL' , jashfricimpl,ja)
call zoekdouble (minp, 'TRELAX' , Trelax,ja)
call zoekdouble (minp, 'CFSKIN' , Cfskin,ja)
call zoekdouble (minp, 'ALFAHULL' , alfahull,ja)
call zoekinteger (minp, 'ITHULLMX' , ithullmx, ja)
rewind (minp)
do N = 1,nshiptxy
call zoekinteger (minp, 'NSHIPN' , nn , ja)
call zoekinteger (minp, 'ICONTROLTYP', icontroltyp(n) , ja)
call zoekdouble (minp, 'SHL' , shL(n) , ja) ; if (ja == 1) shL(n)= 0.5d0*shL(n) ! shiplenght on input, then half length
call zoekdouble (minp, 'SHB' , shB(n) , ja) ; if (ja == 1) shB(n)= 0.5d0*shB(n) ! idem width
call zoekdouble (minp, 'SHD' , shd(n) , ja)
call zoekdouble (minp, 'DEADW' , deadw(n) , ja) ; if (ja == 1) deadw(n) = 1000d0*deadw(n) !kg
call zoekdouble (minp, 'POWERMX' , powermx(n) , ja) ; if (ja == 1) powermx(n) = 1000d0*0.75d0*powermx(n) ! conversion hp to kw
call zoekdouble (minp, 'SPEEDMX' , speedmx(n) , ja) ; if (ja == 1) speedmx(n) = 0.514444d0*speedmx(n) ! conversion knots to m/s
if (ja == 1 .and. speedmx(n) .ne. 0d0) then
stuwmx(n) = 0.65d0*powermx(n)/speedmx(n) ! propellor efficiency 0.65
endif
call zoekdouble (minp, 'FSTUW' , fstuw(n) , ja)
call zoekdouble (minp, 'FROER' , froer(n) , ja)
call zoekdouble (minp, 'SHX' , shx(n) , ja)
call zoekdouble (minp, 'SHY' , shy(n) , ja)
call zoekdouble (minp, 'SHI' , shi(n) , ja) ; if (ja == 1) shi(n) = shi(n)*dg2rd
call zoekdouble (minp, 'SHU' , shu(n) , ja)
call zoekdouble (minp, 'SHV' , shv(n) , ja)
call zoekdouble (minp, 'SHO' , sho(n) , ja)
if (ja == 1 .and. sho(n) .ne. 0d0) then
sho(n) = twopi/sho(n)
endif
enddo
endif
end subroutine readshipdef
subroutine afhouwendammit()
use m_ship
implicit none
integer :: n, i, j
double precision :: sx1, sy1, sx2, sy2, eas, easm, frc
! kinetic e = potential e
! 0.5*m*u*u = 0.5*eas*dx*dx, u = 5m/s, dx = 10 m indeuking => eas = deadw potential energy = kinetic energy
! 0.5*m*u*u = 0.5*frc*u*dx frc = mu/dx friction labour = kinetic energy
do n = 1,nshiptxy
eas = 0.25d0*deadw(n) ; easm = 0.5d0*eas
frc = 0.5d0*deadw(n)
fextx(n) = 0d0 ; fexty(n) = 0d0 ; fextm(n) = 0d0
sx1 = 0.9d0; sy1 = 0d0
call shipcoor(n,sx1,sy1,sx2,sy2) ! midvoor
call inkade(sx2,sy2,i,j)
if (i == 1) then
fextx(n) = fextx(n) + eas*(xmx - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmx - sx2)*(sy2 - shy(n))
endif
if (i == -1) then
fextx(n) = fextx(n) + eas*(xmn - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmn - sx2)*(sy2 - shy(n))
endif
if (j == 1) then
fexty(n) = fexty(n) + eas*(ymx - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymx - sy2)*(sx2 - shx(n))
endif
if (j == -1) then
fexty(n) = fexty(n) + eas*(ymn - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymn - sy2)*(sx2 - shx(n))
endif
sx1 = 0.9d0; sy1 = 1d0
call shipcoor(n,sx1,sy1,sx2,sy2) ! linksvoor
call inkade(sx2,sy2,i,j)
if (i == 1) then
fextx(n) = fextx(n) + eas*(xmx - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmx - sx2)*(sy2 - shy(n))
endif
if (i == -1) then
fextx(n) = fextx(n) + eas*(xmn - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmn - sx2)*(sy2 - shy(n))
endif
if (j == 1) then
fexty(n) = fexty(n) + eas*(ymx - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymx - sy2)*(sx2 - shx(n))
endif
if (j == -1) then
fexty(n) = fexty(n) + eas*(ymn - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymn - sy2)*(sx2 - shx(n))
endif
sx1 = 0.9d0; sy1 = -1d0
call shipcoor(n,sx1,sy1,sx2,sy2) ! rechtsvoor
call inkade(sx2,sy2,i,j)
if (i == 1) then
fextx(n) = fextx(n) + eas*(xmx - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmx - sx2)*(sy2 - shy(n))
endif
if (i == -1) then
fextx(n) = fextx(n) + eas*(xmn - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmn - sx2)*(sy2 - shy(n))
endif
if (j == 1) then
fexty(n) = fexty(n) + eas*(ymx - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymx - sy2)*(sx2 - shx(n))
endif
if (j == -1) then
fexty(n) = fexty(n) + eas*(ymn - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymn - sy2)*(sx2 - shx(n))
endif
sx1 = -1d0; sy1 = 1d0
call shipcoor(n,sx1,sy1,sx2,sy2) ! linksachter
call inkade(sx2,sy2,i,j)
if (i == 1) then
fextx(n) = fextx(n) + eas*(xmx - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmx - sx2)*(sy2 - shy(n))
endif
if (i == -1) then
fextx(n) = fextx(n) + eas*(xmn - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmn - sx2)*(sy2 - shy(n))
endif
if (j == 1) then
fexty(n) = fexty(n) + eas*(ymx - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymx - sy2)*(sx2 - shx(n))
endif
if (j == -1) then
fexty(n) = fexty(n) + eas*(ymn - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymn - sy2)*(sx2 - shx(n))
endif
sx1 = -1d0; sy1 = -1d0
call shipcoor(n,sx1,sy1,sx2,sy2) ! rechtsachter
call inkade(sx2,sy2,i,j)
if (i == 1) then
fextx(n) = fextx(n) + eas*(xmx - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmx - sx2)*(sy2 - shy(n))
endif
if (i == -1) then
fextx(n) = fextx(n) + eas*(xmn - sx2)
fricxi(n) = fricxi(n) + frc
fextm(n) = fextm(n) - easm*(xmn - sx2)*(sy2 - shy(n))
endif
if (j == 1) then
fexty(n) = fexty(n) + eas*(ymx - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymx - sy2)*(sx2 - shx(n))
endif
if (j == -1) then
fexty(n) = fexty(n) + eas*(ymn - sy2)
fricyi(n) = fricyi(n) + frc
fextm(n) = fextm(n) + easm*(ymn - sy2)*(sx2 - shx(n))
endif
enddo
end subroutine afhouwendammit
subroutine inkade(sx2,sy2,i,j)
use m_ship
implicit none
integer :: i, j
double precision :: sx2, sy2
i = 0 ; j = 0
if (sx2 > xmx) i = 1
if (sx2 < xmn) i = -1
if (sy2 > ymx) j = 1
if (sy2 < ymn) j = -1
if (i .ne. 0 .or. j .ne. 0) then
i = i + 1 ; i = i-1
endif
end subroutine inkade
subroutine furu() ! set fu, ru and kfs
use m_flow ! substitue u1 and q1
use m_flowgeom
use m_flowtimes
use m_alloc
use m_partitioninfo
use m_xbeach_data, only: ust, vst, urms, swave, Lwave
use m_sediment
use unstruc_channel_flow
use m_structure
use m_general_structure
implicit none
integer :: L, Lf, n, k1, k2, kb, LL, k, itu1, Lb, Lt
integer :: kfu, istru
double precision :: bui, cu, du, gdxi, ds, riep, as, gdxids
double precision :: slopec, hup, u1L, v2, frL, u1L0, rhof, zbndun, bdmwrp, bdmwrs
double precision :: qk0, qk1, dzb, hdzb, z00 !
double precision :: as1, as2, qtotal, s_on_crest, width
double precision :: twot = 2d0/3d0
logical :: firstiter, jarea
type(t_structure), pointer :: pstru
integer :: np, L1 ! pumpstuff
double precision :: ap, qp, vp ! pumpstuff
double precision :: cfuhi3D ! for bed friction
integer :: ierr
call klok(cpufuru(1))
if (kmx < 1) then ! original 2D coding
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2,slopec,hup,gdxi,cu,du,ds,u1L,v2,itu1,frL,bui,u1L0)
do L = 1,lnx
if (hu(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
slopec = 0d0
if (L > lnx1D) then
if (jaSlopedr > 0) then ! 2D droplosses at ridge points and at 2D/1D2D couplings
if (iadv(L) == 8) then
hup = s0(k2) - ( min(bob(1,L), bob(2,L) ) + twot*hu(L) )
if (hup < 0) then
slopec = hup
else
hup = s0(k1) - ( min( bob(1,L), bob(2,L) ) + twot*hu(L) )
if (hup < 0) then
slopec = -hup
endif
endif
endif
endif
else if (iadv(L) == -8) then
hup = s0(k2) - ( min(bob(1,L), bob(2,L) ) + twot*hu(L) )
if (hup < 0) then
slopec = hup
else
hup = s0(k1) - ( min( bob(1,L), bob(2,L) ) + twot*hu(L) )
if (hup < 0) then
slopec = -hup
endif
endif
endif
gdxi = ag *dxi(L)
cu = gdxi*teta(L)
du = dti*u0(L) - adve(L) + gdxi*slopec
ds = s0(k2) - s0(k1)
if (teta(L) /= 1d0) then
du = du - (1d0-teta(L))*gdxi*ds
endif
u1L = u0(L)
if (jaconveyance2D >=3 .or. L <= lnx1D ) then
v2 = 0d0
else
v2 = v(L)*v(L)
endif
if (jafrculin > 0) then
advi(L) = advi(L) + frculin(L)/hu(L)
endif
itu1 = 0
10 continue
if (jawave == 3) then ! Delft3D-Wave Stokes-drift correction
! First trial SvdP, AM : frL = cfu(L)*sqrt((u1L-ustokes(L))**2 + (v(L)-vstokes(L))**2 )
! Bas : frL = taubpu(L)/hu(L)
! Quadratic Stokes corr: frL = ypar(L)*(cfu(L)+cfwavhi(L))*sqrt((u1L-ustokes(L))**2 + (v(L)-vstokes(L))**2 )
! D3D: Compare with taubsu computation (taubot.f90) and usage (cucnp.f90/uzd.f90)
! A3M:ok for c01-validation_3.1.6: frL = ypar(L)*(cfuhi(L)+cfwavhi(L))*wavmu(L)/hu(L)
frL = ypar(L)*(cfuhi(L)+cfwavhi(L)) * sqrt((u1L-ustokes(L))**2 + (v(L)-vstokes(L))**2)
!bdmwrs = frL * wavmu(L)
!bdmwrp = frL * hu(L)
! Bed shear due to flow and waves:
! A3M:ok for c01-validation_3.1.6: du = du + frL * sqrt((u1L-ustokes(L))**2 + (v(L)-vstokes(L))**2)
du = du + frL*wavmu(L)*huvli(L)
!du = du + bdmwrs - bdmwrp * sqrt(u1L**2 + v(L)**2)
else if ( jawave.eq.4 .and. swave.eq.1 ) then ! JRE: XBeach Stokes-drift correction
frL = cfuhi(L)*sqrt((u1L-ust(L))**2 + (v(L)-vst(L))**2 + (1.16d0*urms(L))**2)
du = du + frL*ust(L)
else if ( ifxedweirfrictscheme > 0) then
if (iadv(L) == 21) then
call fixedweirfriction2D(L,k1,k2,frL)
else
frL = cfuhi(L)*sqrt(u1L*u1L + v2) ! g / (H.C.C) = (g.K.K) / (A.A) travels in cfu
endif
else
frL = cfuhi(L)*sqrt(u1L*u1L + v2) ! g / (H.C.C) = (g.K.K) / (A.A) travels in cfu
endif
bui = 1d0 / ( dti + advi(L) + frL )
fu(L) = cu*bui
ru(L) = du*bui
u1L0 = u1L
u1L = ru(L) - fu(L)*ds
itu1 = itu1 + 1
if (huvli(L) > 1d0 .and. itu1 < 4 .and. abs( u1L-u1L0 ) > 1d-2 ) then ! less than 1 m deep
goto 10
endif
endif
enddo
!$OMP END PARALLEL DO ! todo check difference
do np = 1,npumpsg ! loop over pump signals, sethu
qp = qpump(np)
ap = 0d0
vp = 0d0
do n = L1pumpsg(np), L2pumpsg(np)
k1 = kpump(1,n)
L1 = kpump(3,n)
L = iabs(L1)
hu(L) = 0d0; au(L) = 0d0
fu(L) = 0d0; ru(L) = 0d0
if (hs(k1) > 1d-2) then
hu(L) = 1d0
au(L) = 1d0
ap = ap + au(L)
vp = vp + vol1(k1)
endif
enddo
if (qp > 0.5d0*vp/dts) then
qp = 0.5d0*vp/dts
endif
if (ap > 0d0) then
do n = L1pumpsg(np), L2pumpsg(np)
k1 = kpump(1,n)
if (hs(k1) > 1d-2) then
L1 = kpump(3,n)
L = iabs(L1)
fu(L) = 0d0
if (L1 > 0) then
ru(L) = qp/ap
else
ru(L) = -qp/ap
endif
endif
enddo
endif
enddo
do istru = 1, network%sts%count
if (network%sts%struct(istru)%ST_TYPE == ST_GENERAL_ST) then
pstru => network%sts%struct(istru)
L = pstru%link_number
Lf = abs(L)
k1 = pstru%left_calc_point
k2 = pstru%right_calc_point
firstiter = .true.
jarea = .false.
as1 = wu(Lf)*(s1(k1)-bob(1,Lf))
as2 = wu(Lf)*(s1(k2)-bob(2,Lf))
qtotal = q1(Lf)
call computeGeneralStructure(pstru%generalst, fu(Lf), ru(Lf), s_on_crest, &
au(Lf), as1, as2, width, kfu, s1(k1), s1(k2), s1(k1), s1(k2), q1(Lf), & !s00(k1), s00(k2), q1(Lf), & ! TODO: find proper s00 or s2 iterand
q1(Lf), qtotal, u1(Lf), u0(Lf), dx(Lf), dts, firstiter, jarea, flowdir = (L>0))
else
! NOT supported error
endif
enddo
else ! 3D
call update_verticalprofiles()
endif
do n = 1, nbndu ! boundaries at u points
LL = kbndu(3,n)
call getLbotLtop(LL,Lb,Lt)
zbndun = zbndu(n)
if (alfsmo < 1d0) then
zbndun = alfsmo*zbndun ! i.c. smoothing, start from 0
endif
if (Lt > Lb) then
u1(LL) = zbndun
call getustbcfuhi( LL,LL,ustb(LL),cfuhi(LL),hdzb, z00, cfuhi3D) ! call with Lb = LL => layer integral profile
advi(LL) = advi(LL) + cfuhi3D
qk0 = 0d0
endif
do L = Lb,Lt
fu(L) = 0d0
ru(L) = zbndun
if (Lt > Lb) then
dzb = hu(L) + c9of1*z00
qk1 = hu(L)*ustb(LL)*(log(dzb/z00)-1d0) / vonkar ! integral flux till level k
ru(L) = (qk1 - qk0) / ( hu(L) - hu(L-1) )
if (zbndu(n) < 0d0) ru(L) = -1d0*ru(L)
qk0 = qk1
endif
if (kbndu(4,n) == 5) then ! JRE, to do: Riemann boundary
! kb = kbndu(1,n)
! k2 = kbndu(2,n)
! riep = s0(k2)*sqrt(ag*huvli(L))
! ru(L) = ru(L) - riep
! as = 0.5d0*sqrt(ag*huvli(L))
!! fu(L) = as
!! ru(L) = -2d0*as*s0(kb) ! -2d0*sqrt(ag/huvli(L)) +2d0*sqrt(ag*5d0)
endif
enddo
enddo
call furusobekstructures()
if ( jawave.eq.3 ) then
! add wave-induced mass fluxes on boundaries
do L=Lnxi+1,Lnx
ru(L) = ru(L) + wavmubnd(L)
end do
end if
! BEGIN DEBUG
if ( jampi.eq.1 ) then
! call update_ghosts(ITYPE_U,1,Lnx,fu,ierr)
! call update_ghosts(ITYPE_U,1,Lnx,ru,ierr)
! call diff_ghosts(ITYPE_U,dxi)
! call diff_ghosts(ITYPE_Sall,ucx)
endif
! END DEBUG
call klok(cpufuru(2)) ; cpufuru(3) = cpufuru(3) + cpufuru(2) - cpufuru(1)
end subroutine furu
subroutine s1ini() ! links in continuity eq.
use m_flow
use m_flowgeom
use m_flowtimes
use m_reduce
implicit none
integer :: L, k1, k2, k, kb, n, LL, kk, kt
double precision :: aufu, auru, tetau
double precision :: zb, dir, ds, qhs, hsk, buitje, qk
buitje = 0.013d0/300d0 ! 13 mm in 5 minutes
bb = 0 ; ccr = 0 ; dd = 0
if (jagrw > 0 .or. numsrc > 0) then
jaqin = 1
endif
if (jatem > 0) then
if (jatem > 1) then
heatsrc = heatsrc0 ! heatsrc0 established in heatu at interval usertimestep
else
heatsrc = 0d0 ! just prior to setsorsin that may add to heatsrc
endif
endif
if (jaqin > 0) then ! sources and sinks through meteo
qin = 0d0
if (jarain > 0) then
qin(1:ndx) = rain*ba*1d-3/(24d0*3600d0) ! mm/day => m3/s
endif
if (kmx > 0 .and. jarain > 0 ) then
do k = 1,ndxi
kt = ktop(k)
qin(kt) = qin(kt) + qin(k)
enddo
endif
if (jagrw > 0) then
call grwflowexpl() ! add grw-flow exchange to the qin array
endif
if (numsrc > 0) then
call setsorsin() ! add sources and sinks
endif
qincel = 0d0 ; qoutcel = 0d0; qinrain = 0d0
do k = 1,ndxi
if (qin(k) > 0d0) then
hsk = s0(k) - bl(k)
if (kfs(k) == 0) then ! niet in matrix => expliciet vullen
s1(k) = s0(k) + dts*qin(k)/ba(k) !
else
dd(k) = qin(k)
endif
qinrain = qinrain + qin(k) ! rain and groundwater now lumped
else if (qin(k) < 0d0) then
hsk = s0(k) - bl(k)
ds = -dts*qin(k)/ba(k) ! altijd minder dan daling bij niet-lin volumes
if (kfs(k) == 0) then ! niet in matrix
if (ds < hsk) then ! er is genoeg
s1(k) = s1(k) - ds
else ! leeg
s1(k) = bl(k) ; ds = hsk
endif
qin(k) = -ds*ba(k)/dts
else if (ds < 0.3d0*hsk) then ! er is royaal => matrix rechterlid
dd(k) = qin(k)
else if (hsk > epshu) then ! er is voldoende => impliciet
qhs = qin(k) / hsk
bb(k) = -qhs
dd(k) = -qhs * ( bl(k) - 0d0 )
qin(k) = 0.30d0 * qin(k) ! 0.3: schatting v/h impliciet weggehaalde deel
else ! er is te weinig
dd(k) = 0 ; qin(k) = 0 ! => wachten tot kfs=0 en expliciet scheppen
endif
qouteva = qouteva - qin(k) ! evap is negative rainfall
else
dd(k) = 0
endif
qincel = qincel + qin(k)
enddo
endif
if (kmx < 1) then ! original 2D coding
do L = 1,lnx
if (hu(L) > 0) then
tetau = teta(L)*au(L)
aufu = tetau*fu(L)
k1 = ln(1,L); k2 = ln(2,L)
bb(k1) = bb(k1) + aufu
bb(k2) = bb(k2) + aufu
ccr(Lv2(L)) = ccr(Lv2(L)) - aufu
auru = tetau*ru(L) + (1d0 - teta(L))* au(L)*u0(L) ! q1(L)
dd(k1) = dd(k1) - auru
dd(k2) = dd(k2) + auru
endif
enddo
!
else
do LL = 1,lnx
if (hu(LL) > 0) then
k1 = ln(1,LL) ; k2 = ln(2,LL)
do L = Lbot(LL), Ltop(LL)
if (hu(L) > 0) then
tetau = teta(LL)*au(L)
aufu = tetau*fu(L)
bb(k1) = bb(k1) + aufu
bb(k2) = bb(k2) + aufu
ccr(Lv2(LL)) = ccr(Lv2(LL)) - aufu
auru = tetau*ru(L) + (1d0 - teta(LL))*au(L)*u0(L) ! q1(L)
dd(k1) = dd(k1) - auru
dd(k2) = dd(k2) + auru
endif
enddo
endif
enddo
endif
if (nonlin > 0) then
ccrsav = ccr
endif
end subroutine s1ini
subroutine s1nod() ! nodes in continuity eq
use m_flow
use m_flowgeom
use m_flowtimes
use m_reduce
use m_partitioninfo
use m_missing
use m_alloc
use m_sobekdfm
implicit none
integer :: n
integer :: kb , k2 , L, k, LL, LS, itpbn
integer :: kbk, k2k, Lk
double precision :: dtiba, hh, zb, dir, dtgh, alf
integer :: i, ierr
!bbr = bb + dti*a1 !m2/s
!ddr = dd + dti*a1*s1 !m3/s
! BEGIN DEBUG
!if ( jampi.eq.1 ) then
! call reduce_dt()
! call update_ghosts(ITYPE_Sall, Ndx, s1, ierr)
! call update_ghosts(ITYPE_Sall, Ndx, a1, ierr)
! call update_ghosts(ITYPE_Sall, Ndx, vol0, ierr)
! call update_ghosts(ITYPE_Sall, Ndx, vol1, ierr)
! call update_ghosts(ITYPE_U, 1, Lnx, fu, ierr)
! call update_ghosts(ITYPE_U, 1, Lnx, ru, ierr)
!end if
! END DEBUG
!! remove entries for 1d2d nodes in bb, dd and ccr
! do n = 1, nbnd1d2d ! 1D2D boundaries
! kb = kbnd1d2d(1,n)
! k2 = kbnd1d2d(2,n)
! L = kbnd1d2d(3,n)
! bb(k2) = bb(k2) -bb(kb)
! dd(k2) = dd(k2) + dd(kb)
! bb(kb) = 0d0
! dd(kb) = 0d0
! ccr(lv2(L)) = 0d0
! end do
!$OMP PARALLEL DO &
!$OMP PRIVATE(n,dtiba)
do n = 1,ndx ! Waterlevels, = s1ini
dtiba = dti*a1(n) !
bbr(n) = bb(n) + dtiba ! need it also for kfs.ne.1 at the boundaries (for parallel runs, see partition_setkfs)
if (kfs(n) == 1) then ! only for implicit points
if (nonlin == 1) then
ddr(n) = dd(n) + dtiba*s1(n) !
ddr(n) = ddr(n) + dti*( vol0(n) - vol1(n) )
else
ddr(n) = dd(n) + dtiba*s0(n) ! Use s0 for the linear solver. Normally s0 = s1, however in
! iterative couplings this might not be the case (e.g. 1d2d
! SOBEK D-FlowFM coupling
endif
endif ! then also setback s1 !
enddo
!$OMP END PARALLEL DO
do n = 1, nbndz ! overrides for waterlevel boundaries
kb = kbndz(1,n)
k2 = kbndz(2,n)
L = kbndz(3,n)
itpbn = kbndz(4,n)
! bbr(kb) = 1d0
if ( itpbn == 1) then ! waterlevelbnd
zb = zbndz(n)
if (alfsmo < 1d0) then
zb = alfsmo*zb + (1d0-alfsmo)*zbndz0(n)
endif
else if (itpbn == 2) then ! neumannbnd, positive specified slope leads to inflow
!zb = s1(k2) + zbndz(n)*dx(L)
zb = -zbndz(n)*dx(L)*ccr(Lv2(L)) ! right-hand side
else if (itpbn == 5) then ! Riemannbnd
hh = max(epshs, 0.5d0*( hs(kb) + hs(k2) ) )
zb = 2d0*zbndz(n) - zbndz0(n) - sqrt(hh/ag)*u1(L)
else if (itpbn == 6) then ! outflowbnd
if (u0(L) > 0d0) then
zb = s1(k2)
else
hh = max(epshs, 0.5d0*( hs(kb) + hs(k2) ) )
dtgh = dts*( sqrt(ag*hh) )
zb = s1(kb) - dtgh*( dxi(L)*( s1(kb) - s1(k2) ) - zbndz(n) ) ! verder testen
endif
else if (itpbn == 7) then ! qhbnd
zb = zbndz(n)
if (alfsmo < 1d0) then
zb = alfsmo*zb + (1d0-alfsmo)*zbndz0(n)
endif
endif
if ( itpbn.ne.2 ) then
! Dirichlet boundary condition
if (japatm > 0 .and. PavBnd > 0) then
zb = zb - ( patm(kb) - PavBnd )/(ag*rhomean)
endif
zb = max( zb, bl(kb) + 1d-3 )
ddr(kb) = bbr(kb)*zb
ddr(k2) = ddr(k2) - ccr(Lv2(L)) * zb ! met link(L) in s1ini
ccr(Lv2(L)) = 0d0
else
! Neumann boundary condition
if ( ccr(Lv2(L)).eq.0d0 ) then ! internal cell is wet, but boundary face is inactive (see setkfs)
ccr(Lv2(L)) = -bbr(kb)
bbr(k2) = bbr(k2) + bbr(kb)
end if
bbr(kb) = -ccr(Lv2(L))
ddr(kb) = -zbndz(n)*dx(L)*ccr(Lv2(L)) ! double for safety
end if
enddo
do n = 1, nbndu ! velocity boundaries
kb = kbndu(1,n)
k2 = kbndu(2,n)
L = kbndu(3,n)
! bbr(kb) = 1d0
! ddr(kb) = s1(k2)
! SPvdP: apply Neumann conditions to water level at velocity boundaries
ccr(Lv2(L)) = -bbr(k2) ! some non-zero value
bbr(k2) = bbr(k2) - ccr(Lv2(L))
bbr(kb) = -ccr(Lv2(L)) ! should not be zero
ddr(kb) = 0d0
enddo
if (nbnd1d2d > 0) then
call compute_1d2d_boundaries()
endif
! update overlapping ghost-parts of matrix
if ( jampi.eq.1 .and. jaoverlap.eq.1 ) then
call update_matrix(ierr)
end if
end subroutine s1nod
! update overlapping ghost-parts of matrix
subroutine update_matrix(ierror)
! use m_flow
use m_flowgeom
use m_reduce
use m_partitioninfo
use m_alloc
implicit none
integer, intent(out) :: ierror ! error (1) or not (0)
integer :: i, k, L
ierror = 0
! allocate if necessary
call realloc(workmatbd, (/2, Ndx/), keepExisting=.true., fill=0d0)
call realloc(workmatc, Lnx, keepExisting=.true., fill=0d0)
! fill work arrays
do i=1,numsend_sall
k=isendlist_sall(i)
workmatbd(1,k) = bbr(k)
workmatbd(2,k) = ddr(k)
end do
do i=1,numsend_u
L=isendlist_u(i)
workmatc(L) = ccr(Lv2(L))
end do
! update work arrays
call update_ghosts(ITYPE_SALL,2,Ndx,workmatbd,ierror)
call update_ghosts(ITYPE_U,1,Lnx,workmatc,ierror)
! copy from work array
do i=1,numghost_sall
k=ighostlist_sall(i)
bbr(k) = workmatbd(1,k)
ddr(k) = workmatbd(2,k)
end do
do i=1,numghost_u
L=ighostlist_u(i)
ccr(Lv2(L)) = workmatc(L)
end do
return
end subroutine update_matrix
!> apply Dirichlet conditions to non-overlapping ghost cells (i.e. effectively remove from the system)
subroutine apply_ghost_bc(ierror)
use m_flow
use m_flowgeom
use m_reduce
use m_partitioninfo
use m_alloc
implicit none
integer, intent(out) :: ierror ! error (1) or not (0)
integer :: i, k, kother, L, LL
do i=1,nghostlist_snonoverlap(ndomains-1)
k = ighostlist_snonoverlap(i)
do LL=1,nd(k)%lnx
L = iabs(nd(k)%ln(LL))
kother = ln(1,L)+ln(2,L)-k
ddr(kother) = ddr(kother)-ccr(Lv2(L))*s1(k)
ccr(Lv2(L)) = 0
ddr(k) = ddr(k)-ccr(Lv2(L))*s1(k)
end do
end do
ierror = 0
return
end subroutine apply_ghost_bc
subroutine grwflowexpl() ! groundwater flow explicit
use m_flowgeom
use m_flow
use m_flowtimes
implicit none
integer :: k1, k2, L, k
double precision :: z1, z2, hunsat, fac, qgrw, h2f, fc, conduct, dum, h_upw
if (jagrw == 1) then ! simple drainage model, just absorb some rain
do k = 1,ndxi
if (sgrw1(k) < bl(k)) then
sgrw1(k) = sgrw1(k) + qin(k)*dts/ba(k) ! results in increase of sgrw
qin(k) = 0d0
endif
enddo
else
sgrw0 = sgrw1
! Conductivity = 1d-3
do L = 1,Lnxi
k1 = ln(1,L) ; k2 = ln(2,L)
hunsat = bl(k1) - sgrw0(k1)
fac = min ( 1d0, max(0d0, hunsat / h_transfer ) ) ! 0 at bed, 1 at sgrw
z1 = sgrw1(k1)*fac + s1(k1)*(1d0-fac)
pgrw(k1) = z1
hunsat = bl(k2) - sgrw0(k2)
fac = min ( 1d0, max(0d0, hunsat / h_transfer ) )
z2 = sgrw1(k2)*fac + s1(k2)*(1d0-fac)
pgrw(k2) = z2
! h_upw = h_aquiferuni ! constant
if (z1 > z2) then
h_upw = sgrw1(k1) - ( bl(k1) - h_aquiferuni )
else
h_upw = sgrw1(k2) - ( bl(k2) - h_aquiferuni )
endif
h_upw = max(0d0, h_upw) ! var thickness
Qgrw = Conductivity*h_upw*wu(L)*(z1 - z2)*dxi(L)*dts ! (m3/s)*s
sgrw1(k1) = sgrw1(k1) - Qgrw*bai(k1)
sgrw1(k2) = sgrw1(k2) + Qgrw*bai(k2)
enddo
do k = 1,ndxi
hunsat = bl(k) - sgrw1(k)
h2f = porosgrw*ba(k)/dts
if (hunsat <= 0) then ! groundwater above bed => transfer to open water
sgrw1(k) = sgrw1(k) + hunsat ! decrease sgrw to bedlevel
qin(k) = qin(k) - hunsat*h2f ! results in positive qin
else ! groundwater below bed => seepage from open water
fc = min ( 1d0, max(0d0, ( sgrw1(k)+h_capillair - bl(k) ) / h_capillair ) )
Conduct = Conductivity*(fc + unsatfac*(1-fc) ) ! lineair weight sat - unsat over capillair zone
fac = min ( 1d0, max(0d0, ( hunsat / h_transfer ) ) ) ! 0 at bed, 1 at sgrw
Qgrw = fac*Conduct*h_aquiferuni*(s1(k) - bl(k)) ! Darcy in vertical m3/s
qin(k) = qin(k) - Qgrw ! negative qin
sgrw1(k) = sgrw1(k) + Qgrw/h2f ! results in increase of sgrw
endif
enddo
do k = ndxi +1, ndx ! copy bnd values
sgrw1(k) = s1(k)
pgrw(k) = s1(k)
enddo
endif
end subroutine grwflowexpl
subroutine addsorsin(filename, area, ierr)
use m_flowexternalforcings
use m_polygon
use m_flow
use m_missing
use unstruc_messages
use m_missing
use dfm_error
implicit none
character (len=*), intent(in) :: filename
double precision, intent(in) :: area
integer, intent(out) :: ierr
integer :: minp, k, kk, kb, kt, kk2, n1, n2, i
character (len=40) :: tmpname
ierr = DFM_NOERR
call oldfil(minp, filename)
call reapol(minp, 0)
if (npl == 0) return
numsrc = numsrc + 1
call reallocsrc(numsrc)
! Strip off trailing file extension .pli
n2 = index(filename,'.', .true.) - 1
if (n2 < 0) then
n2 = len_trim(filename)
end if
! Strip off leading path /dir/name/bnd/
n1 = index(filename(1:n2),'\', .true.) ! Win
if (n1 == 0) then
n1 = index(filename(1:n2),'/', .true.) ! Or try UX
end if
! Store sink/source name for waq
srcname(numsrc) = filename(n1+1:n2)
! call inflowcell(xpl(npl), ypl(npl), kk2) ! TO: Source
tmpname = filename(n1+1:n2) // ' source'
call find_flownode(1,xpl(npl),ypl(npl),tmpname,kk2,0,0)
! Support point source/sinks in a single cell if polyline has just one point (npl==1)
if (npl == 1) then
kk = 0 ! Only keep the source-side (kk2), and disable momentum discharge
if (area /= dmiss .and. area /= 0d0) then
! User specified an area for momentum discharge, but that does not apply to POINT sources.
write (msgbuf, '(a,a,a,f8.2,a)') 'Source-sink for ''', trim(filename), ''' is a POINT-source. Nonzero area was specified: ', area, ', but area will be ignored (no momentum discharge).'
call warn_flush()
end if
arsrc (numsrc) = 0d0
else ! Default: linked source-sink, with polyline npl >= 2
! call inflowcell(xpl(1) , ypl(1) , kk) ! FROM: sink
tmpname = filename(n1+1:n2) // ' sink'
call find_flownode(1,xpl(1),ypl(1),tmpname,kk,0,0)
if (kk.ne.0 .or. kk2.ne.0) then
arsrc (numsrc) = area
endif
end if
if (kk == 0 .and. kk2 == 0) then
write (msgbuf, '(a,a)') 'Source+sink is outside model area for ', trim(filename)
call warn_flush()
ierr = DFM_NOERR
goto 8888
endif
ksrc(1,numsrc) = kk
zsrc(1,numsrc) = zpl(1)
ksrc(4,numsrc) = kk2
zsrc(2,numsrc) = zpl(npl)
if (kk > 0) then
if ( allocated(dzL) ) then
if (dzL(1) .ne. dmiss) then
zsrc2(1,numsrc) = dzL(1)
endif
endif
! Determine angle (sin/cos) of 'from' link (=first segment of polyline)
if (npl > 1) then
call normalin (xpl(1), ypl(1), xpl(2), ypl(2), cssrc(1,numsrc), snsrc(1,numsrc) )
end if
do i = 1,numsrc-1
if ( kk == ksrc(1,i) .or. kk == ksrc(4,i) ) then
write (msgbuf, '(3a)') 'sorsin 2D coincide : ', trim (srcname(numsrc)), trim(srcname(i)) ; call warn_flush()
endif
enddo
endif
if (kk2 > 0) then
if ( allocated(dzL) ) then
if (dzL(npl) .ne. dmiss) then
zsrc2(2,numsrc) = dzL(npl)
endif
endif
! Determine angle (sin/cos) of 'to' link (=first segment of polyline)
if (npl > 1) then
call normalin (xpl(npl-1), ypl(npl-1), xpl(npl), ypl(npl), cssrc(2,numsrc), snsrc(2,numsrc) )
endif
do i = 1,numsrc-1
if ( kk2 == ksrc(1,i) .or. kk2 == ksrc(4,i) ) then
write (msgbuf, '(3a)') 'sorsin 2D coincide : ', trim (srcname(numsrc)), trim(srcname(i)) ; call warn_flush()
endif
enddo
endif
8888 continue
end subroutine addsorsin
!> Compute and set source and sink values for the 'intake-outfall' structures.
subroutine setsorsin() ! links in continuity eq.
use m_flow
use m_flowgeom
use m_flowtimes
use MessageHandling
use m_partitioninfo
implicit none
integer :: n, ierr, kk, k, kb, kt, k2, kk2, kb2
double precision :: qsrck
if (jasalsrc > 0) then ! also just prior to setsorsin
salsrc = 0d0
endif
srsn = 0d0
do n = 1,numsrc
kk = ksrc(1,n) ! 2D pressure cell nr, From side, 0 = out of all, -1 = in other domain, > 0, own domain
kk2 = ksrc(4,n) ! 2D pressure cell nr, To side, 0 = out of all, -1 = in other domain, > 0, own domain
qsrc(n) = qstss(3*(n-1) + 1)
if ( kk > 0) then ! FROM point
if (kmx > 0) then
call getkbotktop(kk,kb,kt)
do k = kb, kt
if ( zws(k) > zsrc(1,n) .or. k == kt ) then
exit
endif
enddo
else
k = kk ! in 2D, volume cell nr = pressure cell nr
endif
ksrc(2,n) = k ! store kb of src
ksrc(3,n) = k ! kt = kb
if (qsrc(n) > 0) then ! Reduce if flux pos
do k = ksrc(2,n) , kt
srsn(1,n) = srsn(1,n) + vol1(k)
if (jasal > 0) srsn(2,n) = srsn(2,n) + sa1(k)*vol1(k)
if (jatem > 0) srsn(3,n) = srsn(3,n) + tem1(k)*vol1(k)
ksrc(3,n) = k
if ( cflmx*srsn(1,n) / dts > abs(qsrc(n)) ) then
exit
endif
enddo
if ( srsn(1,n) > 0d0 ) then
if (jasal > 0) srsn(2,n) = srsn(2,n) / srsn(1,n)
if (jatem > 0) srsn(3,n) = srsn(3,n) / srsn(1,n)
endif
do k = ksrc(2,n), ksrc(3,n)
if (jasal > 0) sa1(k) = srsn(2,n)
if (jatem > 0) tem1(k) = srsn(3,n)
enddo
endif
endif
if ( kk2 > 0 ) then ! TO point
if (kmx > 0) then
call getkbotktop(kk2,kb,kt)
do k = kb, kt
if ( zws(k) > zsrc(2,n) .or. k == kt ) then
exit
endif
enddo
else
k = kk2 ! in 2D, volume cell nr = pressure cell nr
endif
ksrc(5,n) = k
ksrc(6,n) = k
if ( qsrc(n) < 0 ) then ! Reduce if flux neg
do k = ksrc(5,n) , kt
srsn(4,n) = srsn(4,n) + vol1(k)
if (jasal > 0) srsn(5,n) = srsn(5,n) + sa1(k)*vol1(k)
if (jatem > 0) srsn(6,n) = srsn(6,n) + tem1(k)*vol1(k)
ksrc(6,n) = k
if ( cflmx*srsn(4,n) / dts > abs(qsrc(n)) ) then
exit
endif
enddo
if ( srsn(4,n) > 0d0 ) then
if (jasal > 0) srsn(5,n) = srsn(5,n) / srsn(4,n)
if (jatem > 0) srsn(6,n) = srsn(6,n) / srsn(4,n)
endif
do k = ksrc(5,n), ksrc(6,n)
if (jasal > 0) sa1(k) = srsn(5,n)
if (jatem > 0) tem1(k) = srsn(6,n)
enddo
endif
endif
enddo
if (jampi > 0) then
call reduce_srsn(numsrc, srsn)
endif
jamess = 0
do n = 1,numsrc
qsrc (n) = qstss(3*(n-1) + 1)
sasrc(n) = qstss(3*(n-1) + 2)
tmsrc(n) = qstss(3*(n-1) + 3)
kk = ksrc(1,n) ! 2D pressure cell nr
qsrck = qsrc(n)
if (kk .ne. 0 .and. qsrck > 0) then ! FROM
if ( cflmx*srsn(1,n) / dts < abs(qsrck) ) then
qsrck = cflmx*srsn(1,n) / dts ; jamess(n) = 1
endif
endif
kk2 = ksrc(4,n) ! 2D pressure cell nr
if (kk2 .ne. 0 .and. qsrck < 0) then ! TO
if ( cflmx*srsn(4,n) / dts < abs(qsrck) ) then
qsrck = - cflmx*srsn(4,n) / dts ; jamess(n) = 2
endif
endif
qsrc(n) = qsrck
if (kk*kk2 .ne. 0) then ! Coupled stuff
if (qsrck > 0) then ! FROM k to k2
if (jasal > 0) sasrc(n) = sasrc(n) + srsn(2,n)
if (jatem > 0) tmsrc(n) = tmsrc(n) + srsn(3,n)
else if (qsrck < 0) then ! FROM k2 to k
if (jasal > 0) sasrc(n) = sasrc(n) + srsn(5,n)
if (jatem > 0) tmsrc(n) = tmsrc(n) + srsn(6,n)
endif
endif
if (kk > 0) then ! FROM Point
k = ksrc(2,n)
if (kmx > 0) qin(k) = qin(k) - qsrck
qin(kk) = qin(kk) - qsrck ! add to 2D pressure cell nr
if (qsrck > 0) then ! FROM k to k2
if (jasal > 0) salsrc(k) = salsrc (k) - qsrck*sa1 (k)
if (jatem > 0) heatsrc(k) = heatsrc(k) - qsrck*tem1(k)
else if (qsrck < 0) then ! FROM k2 to k
if (jasal > 0) salsrc(k) = salsrc (k) - qsrck*sasrc(n)
if (jatem > 0) heatsrc(k) = heatsrc(k) - qsrck*tmsrc(n)
endif
endif
if (kk2 > 0) then ! TO Point
k = ksrc(5,n)
if (kmx > 0) qin(k) = qin(k) + qsrck
qin(kk2) = qin(kk2) + qsrck ! add to 2D pressure cell nr
if (qsrck > 0) then
if (jasal > 0) salsrc (k) = salsrc (k) + qsrck*sasrc(n)
if (jatem > 0) heatsrc(k) = heatsrc(k) + qsrck*tmsrc(n)
else if (qsrck < 0) then
if (jasal > 0) salsrc (k) = salsrc (k) + qsrck*sa1 (k)
if (jatem > 0) heatsrc(k) = heatsrc(k) + qsrck*tem1(k)
endif
endif
enddo
do n = 1,numsrc
if (jamess(n) == 1) then
write(msgbuf, *) 'Extraction flux larger than cell volume at point 1 of : ', trim( srcname(n) )
call mess(LEVEL_INFO, msgbuf)
else if (jamess(n) == 2) then
write(msgbuf, *) 'Extraction flux larger than cell volume at point 2 of : ', trim( srcname(n) )
call mess(LEVEL_INFO, msgbuf)
endif
enddo
end subroutine setsorsin
subroutine reallocsrc(n)
use m_flowexternalforcings
use m_alloc
use m_missing
implicit none
integer :: n
call realloc (ksrc , (/ 6,n /), keepexisting=.true., fill=0 )
call realloc (qsrc , n, keepExisting = .true., fill=0d0)
call realloc (tmsrc, n, keepExisting = .true., fill=0d0)
call realloc (sasrc, n, keepExisting = .true., fill=0d0)
call realloc (arsrc, n, keepExisting = .true., fill=0d0)
call realloc (cssrc, (/ 2,n /), keepExisting = .true.)
call realloc (snsrc, (/ 2,n /), keepExisting = .true.)
call realloc (zsrc , (/ 2,n /), keepExisting = .true.)
call realloc (zsrc2, (/ 2,n /), keepExisting = .true.) ; zsrc2 = dmiss
call realloc (srsn , (/ 6,n /), keepExisting = .true.)
call realloc (jamess, n, keepExisting = .true.)
call realloc (kdss , 3*n, keepExisting = .true., fill=1)
call realloc (qstss, 3*n, keepExisting = .true., fill=0d0)
call realloc (srcname, n, keepExisting = .true., fill=' ')
end subroutine reallocsrc
subroutine u1q1()
use m_flow ! substitute u1 and q1
use m_flowgeom
use m_flowtimes
use m_partitioninfo
use m_timer
implicit none
integer :: L, k1, k2, LL, k, n, nn, km, n1, n2, Ld, kb, kt, ks, Lb, Lt, kmxLL
double precision :: qt, zws0k
double precision :: accur = 1e-30, wb, ac1, ac2, dsL, sqiuh, qwb, qsigma
double precision :: qwave
integer :: ierror
squ = 0d0 ; sqi = 0d0 ; qinbnd = 0d0 ; qoutbnd = 0d0
u1 = 0d0 ; q1 = 0d0 ; qa = 0d0
if (kmx < 1) then ! original 2D coding ! 1D2D
if ( jampi.eq.0 ) then
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2)
do L = 1,lnx
if (hu(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
u1(L) = ru(L) - fu(L)*( s1(k2) - s1(k1) )
q1(L) = au(L)*( teta(L)*u1(L) + (1d0-teta(L))*u0(L) )
qa(L) = au(L)*u1(L)
endif
enddo
!$OMP END PARALLEL DO
else
! parallel: compute u1, update u1, compute remaining variables
! compute u1
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2)
do L=1,Lnx
if ( hu(L).gt.0 ) then
k1 = ln(1,L)
k2 = ln(2,L)
u1(L) = ru(L) - fu(L)*( s1(k2) - s1(k1) )
end if
end do
!$OMP END PARALLEL DO
! update u1
if ( jatimer.eq.1 ) call starttimer(IUPDU)
call update_ghosts(ITYPE_U, 1, Lnx, u1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDU)
! compute q1 and qa
!$OMP PARALLEL DO &
!$OMP PRIVATE(L,k1,k2)
do L=1,Lnx
if ( hu(L).gt.0 ) then
k1 = ln(1,L)
k2 = ln(2,L)
q1(L) = au(L)*( teta(L)*u1(L) + (1d0-teta(L))*u0(L) )
qa(L) = au(L)*u1(L)
end if
end do
!$OMP END PARALLEL DO
end if ! jampi
if (jaqaisq1 == 1) then ! tetaad
qa = q1
endif
do L = 1,lnx
if (q1(L) > 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k1) = squ(k1) + q1(L)
sqi(k2) = sqi(k2) + q1(L)
else if (q1(L) < 0) then
k1 = ln(1,L) ; k2 = ln(2,L)
squ(k2) = squ(k2) - q1(L)
sqi(k1) = sqi(k1) - q1(L)
endif
enddo
sqa = 0d0
do L=1,Lnx
if ( hu(L).gt.0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
sqa(k2) = sqa(k2) - qa(L)
sqa(k1) = sqa(k1) + qa(L)
endif
enddo
if (iadvec == 40) then
voldhu = 0d0
do L = 1,lnx
if (q1(L) > 0) then
k1 = ln(1,L)
voldhu(k1) = voldhu(k1) + q1(L)*hu(L)
else if (q1(L) < 0) then
k2 = ln(2,L)
voldhu(k2) = voldhu(k2) - q1(L)*hu(L)
endif
enddo
do k = 1, ndxi
if (squ(k) > 0d0) then
voldhu(k) = ba(k)*voldhu(k) / squ(k)
else
voldhu(k) = vol1(k)
endif
enddo
voldhu(ndxi+1:ndx) = vol1(ndxi+1:ndx)
endif
if (jaqin > 0) then
do k = 1, ndxi
if (qin(k) > 0d0) then
sqi(k) = sqi(k) + qin(k)
else
squ(k) = squ(k) - qin(k)
endif
enddo
endif
if ( itstep.eq.4 ) then ! explicit time-step
sqwave = 0d0
do L=1,Lnx
k1 = ln(1,L); k2 = ln(2,L)
qwave = 2d0*sqrt(hu(L)*ag)*Au(L) ! 2d0: safety
sqwave(k1) = sqwave(k1) + max(q1(L)+qwave,0d0)
sqwave(k2) = sqwave(k2) - min(q1(L)-qwave,0d0)
end do
end if
do L = lnxi+1,lnx
if ( jampi.ne.0 ) then
! do not include boundaries in the ghost region
if ( idomain(ln(2,L)).ne.my_rank ) then
cycle
end if
end if
if (q1(L) > 0) then
qinbnd = qinbnd + q1(L)
else
qoutbnd = qoutbnd - q1(L)
endif
enddo
else ! 3D
do LL = 1,lnx
k1 = ln(1,LL) ; k2 = ln(2,LL)
dsL = ( s1(k2) - s1(k1) )
Lb = Lbot(LL) ; Lt = Ltop(LL) ; kmxLL = kmxL(LL)
if ( hu(LL) > 0d0 ) then
do L = Lb, Lt
u1(L) = ru(L) - fu(L)*dsL
enddo
do L = Lt+1, Lb + kmxLL - 1 ! copy top inactive part of column == utop
u1(L) = u1(Lt)
enddo
endif
enddo
if ( jampi.eq.1 ) then
! update u1
if ( jatimer.eq.1 ) call starttimer(IUPDU)
! call update_ghosts(ITYPE_U, 1, Lnx, u1, ierror)
call update_ghosts(ITYPE_U3D, 1, Lnkx, u1, ierror)
if ( jatimer.eq.1 ) call stoptimer(IUPDU)
end if
do LL = 1,lnx
n1 = ln(1,LL) ; n2 = ln(2,LL)
q1(LL) = 0d0 ; u1(LL) = 0d0 ; au(LL) = 0d0
Lb = Lbot(LL) ; Lt = Ltop(LL)
do L = Lb, Lt ! flux update after velocity update
if (au(L) > 0d0) then
q1(L) = au(L)*( teta(LL)*u1(L) + (1d0-teta(LL))*u0(L) )
qa(L) = au(L)*u1(L)
q1(LL) = q1(LL) + q1(L) ! depth integrated result
qa(LL) = qa(LL) + qa(L) ! depth integrated result
au(LL) = au(LL) + au(L)
k1 = ln(1,L)
k2 = ln(2,L)
if (q1(L) > 0) then
squ(k1) = squ(k1) + q1(L)
sqi(k2) = sqi(k2) + q1(L)
squ(n1) = squ(n1) + q1(L)
sqi(n2) = sqi(n2) + q1(L)
else
sqi(k1) = sqi(k1) - q1(L)
squ(k2) = squ(k2) - q1(L)
sqi(n1) = sqi(n1) - q1(L)
squ(n2) = squ(n2) - q1(L)
endif
endif
enddo
if (au(LL) > 0d0 ) then ! depth averaged velocity
u1(LL) = q1(LL) / au(LL)
endif
enddo
sqa = 0d0
do LL=1,Lnx
Lb = Lbot(LL) ; Lt = Ltop(LL)
do L = Lb, Lt
if ( hu(L).gt.0 ) then
k1 = ln0(1,L) ; k2 = ln0(2,L)
sqa(k2) = sqa(k2) - qa(L)
sqa(k1) = sqa(k1) + qa(L)
endif
enddo
enddo
if (jarhoxu > 0) then
sqa = sqa*rho
endif
if (ja_timestep_auto == 3 .or. ja_timestep_auto == 4) then ! 2D timestep
squ2d = squ
if (ja_timestep_auto == 4) then
squ2d = squ2d + sqi
endif
endif
do LL = Lnxi+1, Lnx
if (q1(LL) > 0) then
qinbnd = qinbnd + q1(LL)
else
qoutbnd = qoutbnd - q1(LL)
endif
enddo
do nn = ndxi,1,-1 ! close vertical fluxes
kb = kbot(nn)
kt = ktop(nn)
if (a1(nn) > 0) then
do k = kb, kb + kmxn(nn) - 1
if ( k <= kt ) then
if (jaqin > 0) then
if (qin(k) > 0d0) then
sqi(k) = sqi(k) + qin(k)
else
squ(k) = squ(k) - qin(k)
endif
endif
km = k-1
if (k == kb) then
wb = 0d0 ; qwb = 0d0
else
wb = ww1(km) ; qwb = qw(km)
endif
sqiuh = sqi(k) - squ(k)
qw (k) = qwb + sqiuh
ww1(k) = wb + sqiuh / a1(nn)
! BEGIN DEBUG
! ww1(k) = min(max(ww1(k),-1d0), 1d0)
! qw(k) = ww1(k) * a1(nn)
! END DEBUG
else
qw(k) = 0d0
ww1(k) = 0d0
endif
enddo
else
qw (kb:kt) = 0d0
ww1(kb:kt) = 0d0
endif
do k = kb, kt
if (k == kt) then
zws0k = zws0(ktop0(nn))
else
zws0k = zws0(k)
endif
qsigma = a1(nn)*(zws(k) - zws0k)/dts
qw(k) = qw(k) - qsigma
if (qw(k) > 0) then
squ(k) = squ(k) + qw(k)
if (k < kt) then
sqi(k+1) = sqi(k+1) + qw(k)
endif
else
sqi(k) = sqi(k) - qw(k)
if (k < kt) then
squ(k+1) = squ(k+1) - qw(k)
endif
endif
enddo
enddo
endif
call update_waqfluxes()
sq = sqi-squ ! arrays
end subroutine u1q1
subroutine a1vol1tot()
use m_flowgeom
use m_flow
use m_partitioninfo
implicit none
integer :: k
if ( jampi.ne.1 ) then
a1tot = sum(a1 (1:ndxi))
vol1tot = sum(vol1(1:ndxi))
else
a1tot = 0d0
vol1tot = 0d0
do k=1,Ndxi
if ( idomain(k).eq.my_rank ) then
a1tot = a1tot + a1(k)
vol1tot = vol1tot + vol1(k)
end if
end do
!a1tot = sum(a1 (1:ndxi), mask=idomain(1:Ndxi).eq.my_rank)
!vol1tot = sum(vol1(1:ndxi), mask=idomain(1:Ndxi).eq.my_rank)
! begin debug
! call reduce_double_sum(vol1tot)
! end debug
end if
! begin debug
! if ( my_rank.eq.0 ) write(6,*) 'vol1tot =', vol1tot
! end debug
end subroutine a1vol1tot
subroutine flow_f0isf1() ! Todo: make pointer stucture and reset pointers
use m_flowgeom
use m_flow
use m_flowtimes
use m_partitioninfo
use m_sediment
use m_strucs
use m_sobekdfm , only: nbnd1d2d, kbnd1d2d
implicit none
integer :: ierror, k,kk,kb,kt, Lf, i
integer :: ndraw
COMMON /DRAWTHIS/ NDRAW(40)
call a1vol1tot()
! TODO: UNST-904: sum only across *own* cells
! if ( idomain(n).ne.my_rank ) cycle
! UNST-904: AND, create some reduce_bal() subroutine
hsaver = 0d0
if (a1tot .ne. 0) then
hsaver = vol1tot / a1tot
endif
! basis spul
vinbnd = qinbnd *dts ! do *dts here to avoid inconsistencies
voutbnd = qoutbnd *dts
vincel = qincel *dts ! do *dts here to avoid inconsistencies
voutcel = qoutcel *dts
volerr = vol1tot - vol0tot - vinbnd + voutbnd - vincel + voutcel
vinbndcum = vinbndcum + vinbnd
voutbndcum = voutbndcum + voutbnd
vincelcum = vincelcum + vincel
voutcelcum = voutcelcum + voutcel
volerrcum = volerrcum + volerr
if (jamorf == 1) then
volerrcum = volerrcum + dvolbot
endif
if (jahisbal > 0) then
! extra
vinrain = qinrain *dts
vouteva = qouteva *dts
vinlat = qinlat *dts
voutlat = qoutlat *dts
vinsoil = qinsoil *dts
voutsoil = qoutsoil*dts
vinsrc = qinsrc *dts
voutsrc = qoutsrc *dts
qinsrc = 0d0
qoutsrc = 0d0
do i = 1,numsrc
qinsrc = qinsrc + max( 0d0, qsrc(i) )
qoutsrc = qoutsrc - min( 0d0, qsrc(i) )
enddo
qinsrc = qinsrc * dts
qoutsrc = qoutsrc * dts
! Time-summed cumulative volumes (nowhere used)
vinraincum = vinraincum + vinrain
voutevacum = voutevacum + vouteva
vinlatcum = vinlatcum + vinlat
voutlatcum = voutlatcum + voutlat
vinsoilcum = vinsoilcum + vinsoil
voutsoilcum = voutsoilcum + voutsoil
vinsrccum = vinsrccum + vinsrc
voutsrccum = voutsrccum + voutsrc
! Volume totals at current time (for his output)
volcur(IDX_STOR ) = vol1tot - vol1ini
volcur(IDX_VOLTOT) = vol1tot
volcur(IDX_VOLERR) = volerr
volcur(IDX_BNDIN ) = vinbnd
volcur(IDX_BNDOUT) = voutbnd
volcur(IDX_BNDTOT) = (vinbnd - voutbnd)
volcur(IDX_EXCHIN ) = 0d0
volcur(IDX_EXCHOUT) = 0d0
volcur(IDX_EXCHTOT) = 0d0
do i = 1,nbnd1d2d
Lf = kbnd1d2d(3,i)
volcur(IDX_EXCHTOT) = volcur(IDX_EXCHTOT) + q1(Lf)*dts
if (q1(Lf) > 0) then
volcur(IDX_EXCHIN) = volcur(IDX_EXCHIN) + q1(Lf)*dts
else
volcur(IDX_EXCHOUT) = volcur(IDX_EXCHOUT) - q1(Lf)*dts
endif
end do
volcur(IDX_PARTIP) = vinrain
volcur(IDX_SOUR ) = vinsrc - voutsrc
if( jampi == 1 ) then
call reduce_bal( volcur, MAX_IDX ) ! Nabi
endif
voltot(IDX_STOR) = volcur(IDX_STOR)
voltot(IDX_VOLTOT) = volcur(IDX_VOLTOT)
voltot(IDX_VOLERR) = voltot(IDX_VOLERR) + volcur(IDX_VOLERR)
voltot(IDX_BNDIN ) = voltot(IDX_BNDIN ) + volcur(IDX_BNDIN )
voltot(IDX_BNDOUT) = voltot(IDX_BNDOUT) + volcur(IDX_BNDOUT)
voltot(IDX_BNDTOT) = voltot(IDX_BNDTOT) + volcur(IDX_BNDTOT)
voltot(IDX_EXCHIN) = voltot(IDX_EXCHIN) + volcur(IDX_EXCHIN)
voltot(IDX_EXCHOUT) = voltot(IDX_EXCHOUT) + volcur(IDX_EXCHOUT)
voltot(IDX_EXCHTOT) = voltot(IDX_EXCHTOT) + volcur(IDX_EXCHTOT)
voltot(IDX_PARTIP) = voltot(IDX_PARTIP) + volcur(IDX_PARTIP)
voltot(IDX_SOUR) = voltot(IDX_SOUR) + volcur(IDX_SOUR)
end if
if (NDRAW(28) == 34) then ! Display values at flow nodes: volerror
if (kmx == 0) then
do kk = 1,ndxi
if ( jampi == 1) then
if (idomain(kk).ne.my_rank ) cycle
end if
volerror(kk) = vol1(kk) - vol0(kk) - dts*(sqi(kk) - squ(kk)) ! array transfer
enddo
else
do kk = 1,ndxi
if ( jampi == 1) then
if (idomain(kk).ne.my_rank ) cycle
end if
call getkbotktop(kk,kb,kt)
do k = kb,kt
volerror(k) = vol1(k) - vol0(k) - dts*(sqi(k) - squ(k))
enddo
enddo
endif
end if
vol0 = vol1 ! array
vol0tot = vol1tot ! scalar
a0tot = a1tot
end subroutine flow_f0isf1
! ====================================================================
! ====================================================================
subroutine structure_parameters
use m_flowgeom , only : ln, wu
use m_flow
use m_structures, only: pumpdisch, pumpcapac, cgendisch, gatedisch, cdamdisch, &
gategendisch, weirdisch, jaoldstr, gategenflowh
use m_flowexternalforcings, only: ngenstru
implicit none
integer :: i, n, L, Lf, La, ierr, ntmp, k
double precision :: qtotal, dir, sav, area
do n = 1,npumpsg
qtotal = 0d0
do L = L1pumpsg(n),L2pumpsg(n)
Lf = kpump(3,L)
La = abs( Lf )
qtotal = qtotal + q1(La) * sign(1d0,Lf+0d0)
enddo
pumpdisch(n) = qtotal
enddo
do n = 1,npumpsg
qtotal = 0d0
do L = L1pumpsg(n),L2pumpsg(n)
Lf = kpump(3,L)
La = abs( Lf )
qtotal = qtotal + qpump(n)
enddo
pumpcapac(n) = qtotal
enddo
if( jaoldstr == 1 ) then
ntmp = ncgensg
else
ntmp = ngenstru
endif
do n = 1,ntmp
if (jaoldstr == 1) then
i = n
else
i = genstru2cgen(n)
endif
qtotal = 0d0
do L = L1cgensg(i),L2cgensg(i)
Lf = kcgen(3,L)
La = abs( Lf )
dir = 1d0 ; if( Ln(1,Lf) /= kcgen(1,L) ) dir = -1d0
qtotal = qtotal + q1(La) * dir
enddo
cgendisch(n) = qtotal
enddo
do n = 1,ngatesg
qtotal = 0d0
do L = L1gatesg(n), L2gatesg(n)
Lf = kgate(3,L)
La = abs( Lf )
dir = 1d0 ; if( Ln(1,Lf) /= kgate(1,L) ) dir = -1d0
qtotal = qtotal + q1(La) * dir
enddo
gatedisch(n) = qtotal
enddo
do n = 1,ngategen
i = gate2cgen(n)
qtotal = 0d0
area = 0d0
sav = 0d0
do L = L1cgensg(i), L2cgensg(i)
Lf = kcgen(3,L)
La = abs( Lf )
dir = 1d0 ; if( Ln(1,Lf) /= kcgen(1,L) ) dir = -1d0
qtotal = qtotal + q1(La) * dir
k = kcgen(1,L) ; if( q1(La) < 0d0 ) k = kcgen(2,L)
sav = sav + s1(k) * wu(La)
area = area + wu(La)
enddo
gategendisch(n) = qtotal
sav = sav / area
gategenflowh(n) = min( zcgen(3*i-1)-zcgen(3*i-2), sav-zcgen(3*i-2) )
enddo
do n = 1,ncdamsg
qtotal = 0d0
do L = L1cdamsg(n), L2cdamsg(n)
Lf = kcdam(3,L)
La = abs( Lf )
dir = 1d0 ; if( Ln(1,Lf) /= kcdam(1,L) ) dir = -1d0
qtotal = qtotal + q1(La) * dir
enddo
cdamdisch(n) = qtotal
enddo
do n = 1,nweirgen
i = weir2cgen(n)
qtotal = 0d0
do L = L1cgensg(i),L2cgensg(i)
Lf = kcgen(3,L)
La = abs( Lf )
dir = 1d0 ; if( Ln(1,Lf) /= kcgen(1,L) ) dir = -1d0
qtotal = qtotal + q1(La) * dir
enddo
weirdisch(n) = qtotal
enddo
end subroutine structure_parameters
subroutine reconstructucz(k)
! Perot reconstruction of the vertical velocity, by Willem
use m_flow
use m_flowgeom
use m_flowtimes
implicit none
integer, intent(in) :: k
integer k1, k2 ! flow node counters (ndx)
integer kk, kk1, kk2 ! flow node counter (ndkx)
integer kb, kb1, kb2 ! bottom level flow node counters
integer kt, kt1, kt2 ! top level flow node counters
integer ko ! flow nodeat other side of flow link
integer L, Lidx ! flow link counter (2D)
integer LL ! flow link counter (3D)
integer Lb, Lt ! counter of bottom/top level link
integer Ls ! flow link counter (<0 indicates the flow link starts at the current flow node;
! >0 indicates the flow link ends at the current flow node )
integer ndlnx ! number of neighbouring flow links
double precision dx1, dx2, dz1, dz2
double precision dzL, dzL1, dzL2
double precision zlc, zlc1, zlc2
double precision zlu, dzhu
double precision Lsign, Lsign1, Lsign2
double precision wsigma1, wsigma2 ! interface velocity at lower and upper interface
!
if (k == 0) then
!
! reconstruct ucz for whole domain
!
!initialize for flow nodes
do k1 = 1,ndxi
call getkbotktop(k1,kb,kt)
dzL = zws(kb)-bl(k1);
wsigma2 = (zws(kb) - zws0(kb))/dts
ucz(kb) = (ww1(kb)+wsigma2)*0.5d0*dzL*ba(k1) ! ww1 at bed level = 0
do kk = kb+1, kt
!
dzL = zws(kk)-zws(kk-1);
wsigma1 = (zws(kk-1) - zws0(kk-1))/dts
wsigma2 = (zws(kk) - zws0(kk))/dts
ucz(kk) = - (ww1(kk-1)+wsigma1)*0.5d0*dzL*ba(k1) ! add velocity at surface level (kk-1)
ucz(kk) = ucz(kk) + (ww1(kk) +wsigma2)*0.5d0*dzL*ba(k1) ! add velocity at surface level (kk)
!
end do
end do
!loop over flow links
do L = 1,Lnx
k1 = LN(1,L)
k2 = LN(2,L)
call getkbotktop(k1,kb1,kt1)
call getkbotktop(k2,kb2,kt2)
Lb = Lbot(L);
Lt = Ltop(L);
zLc1 = bl(k1)
zLc2 = bl(k2)
kk1 = kb1
kk2 = kb2
Lsign1 = 1d0
Lsign2 = -1d0
do LL = Lb, Lt
zlu = min( bob(1,L), bob(2,L) ) + hu(LL)*0.5+hu(LL-1)*0.5 ! update flow link elevation
!
! update first flow node
!
dzL1 = zws(kk1)-zws(kk1-1)
zlc1 = zlc1 + 0.5d0*dzL1
dz1 = zlu-zlc1
ucz(kk1) = ucz(kk1) + Lsign1*u1(LL)*wu(L)*(hu(LL)-hu(LL-1))*dz1
!
zlc1 = zlc1 + 0.5d0*dzL1
!
! update second flow node
!
dzL2 = zws(kk2)-zws(kk2-1)
zlc2 = zlc2 + 0.5d0*dzL2
dz2 = zlu-zlc2
ucz(kk2) = ucz(kk2) + Lsign2*u1(LL)*wu(L)*(hu(LL)-hu(LL-1))*dz2
!
zlc2 = zlc2 + 0.5d0*dzL2
!
! update vertical counters
!
kk1 = kk1+1
kk2 = kk2+1
end do
end do
!finalize for flow nodes
do k1 = 1,ndxi
call getkbotktop(k1,kb,kt)
do kk = kb, kt
if (vol1(kk) > 0d0) then
ucz(kk) = ucz(kk)/vol1(kk) ! divide by volume
endif
end do
end do
else
!
! reconstruct ucz for single flow node
!
call getkbotktop(k,kb,kt)
!ucz(kb) = 0.0d0
dzL = zws(kb)-bl(k);
wsigma2 = (zws(kb) - zws0(kb))/dts
ucz(kb) = (ww1(kb)+wsigma2)*0.5d0*dzL*ba(k) ! ww1 at bed level = 0
do kk = kb+1, kt
!
dzL = zws(kk)-zws(kk-1);
wsigma1 = (zws(kk-1) - zws0(kk-1))/dts
wsigma2 = (zws(kk) - zws0(kk))/dts
ucz(kk) = - (ww1(kk-1)+wsigma1)*0.5d0*dzL*ba(k) ! add velocity at surface level (kk-1)
ucz(kk) = ucz(kk) + (ww1(kk) +wsigma2)*0.5d0*dzL*ba(k) ! add velocity at surface level (kk)
!
end do
!get neighbouring flow links
ndlnx = nd(k)%lnx ! number of flowlinks associated with current flow node.
do Lidx = 1,ndlnx
Ls = nd(k)%ln(Lidx) ! link number including its direction (<0 indicates the flow link starts at the current flow node;
! >0 indicates the flow link ends at the current flow node )
L = abs(nd(k)%ln(Lidx)) ! link numbers
if (L == Ls) then ! determine horizontal distance dx1 from flow link to u point
Lsign = -1d0 ! Lsign (velocity directed towards current flow node)
dx1 = dx(L)*(1d0-acl(L)) !
dx2 = acl(L)*dx(L) !
ko = LN(1,L) ! outside associated flow node number
else
Lsign = 1d0 ! Lsign (velocity directed away from current flow node)
dx1 = dx(L)*acl(L) !
dx2 = dx(L)*(1d0-acl(L)) !
ko = LN(2,L) ! outside flow node number
end if
!k2 = LN(2,L) ! second associated flow node number
Lb = Lbot(L) ! --
Lt = Ltop(L)
kk = kb
zlc = bl(k) ! bed level in flow node
dzhu = hu(Lb) ! height of the bottom layer at flow link
do LL = Lb, Lt ! get link numbers in the vertical
dzL = zws(kk)-zws(kk-1);
zlc = zlc + 0.5d0*dzL
!zlu = dx2*bl(k)*dxi(L) + dx1*bl(ko)*dxi(L) + hu(LL)*0.5+hu(LL-1)*0.5 (interpolated bed level at u-point)
zlu = min( bob(1,L), bob(2,L) ) + hu(LL)*0.5+hu(LL-1)*0.5
!
! u_vertical,new = u_vertical,old + Lsign*u_horizontal*width*depth_layer
!
dz1 = zlu-zlc
ucz(kk) = ucz(kk) + Lsign*u1(LL)*wu(L)*(hu(LL)-hu(LL-1))*dz1
!
zlc = zlc + 0.5d0*dzL
kk = kk+1 ! update vertical counter
!
end do
end do
do kk = kb, kt
if (vol1(kk) > 0) then
ucz(kk) = ucz(kk)/vol1(kk) ! divide by volume
endif
end do
end if
end subroutine reconstructucz
! Secondary Flow
subroutine get_curvature ! Find the curvature of the bend, to be used in secondary flow, added by Nabi
use m_flow
use m_flowgeom
use m_netw
implicit none
integer :: k, k2, L, LL, n
double precision :: cofa, cofb, cofc, cofd, cofe, coff, cofg, cofw, cofx, cofy, cofu, cofv, cof0
double precision :: dudx, dudy, dvdx, dvdy
do k = 1,ndx
spirucm(k) = 0d0
if( hs(k) < epshu ) cycle
spirucm(k) = sqrt( ucx(k) * ucx(k) + ucy(k) * ucy(k) )
enddo
do k = 1,ndxi
if( spirucm(k) < 1.0d-3 .or. hs(k) < epshu ) then
spircrv(k) = 0.0d0
cycle
endif
cofa = 0.0d0
cofb = 0.0d0
cofc = 0.0d0
cofd = 0.0d0
cofe = 0.0d0
coff = 0.0d0
cofg = 0.0d0
n = 0
do LL = 1,nd(k)%lnx
L = abs( nd(k)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - k
if( hs(k2) < epshu ) cycle
n = n + 1
cofx = xz(k2) - xz(k)
cofy = yz(k2) - yz(k)
cofu = ucx(k2) - ucx(k)
cofv = ucy(k2) - ucy(k)
cof0 = sqrt( cofx * cofx + cofy * cofy )
cofw = 1.0d0 / cof0
if( cof0 < 1.0d-6 ) cofw = 1.0d6
cofx = cofw * cofx
cofy = cofw * cofy
cofu = cofw * cofu
cofv = cofw * cofv
cofa = cofa + cofx * cofx
cofb = cofb + cofx * cofy
cofc = cofc + cofy * cofy
cofd = cofd + cofu * cofx
cofe = cofe + cofu * cofy
coff = coff + cofv * cofx
cofg = cofg + cofv * cofy
enddo
cof0 = cofa * cofc - cofb * cofb
spircrv(k) = 0.0d0
if( cof0 == 0d0 .or. n < 2 ) cycle
dudx = ( cofd * cofc - cofb * cofe ) / cof0
dudy = ( cofa * cofe - cofd * cofb ) / cof0
dvdx = ( coff * cofc - cofb * cofg ) / cof0
dvdy = ( cofa * cofg - coff * cofb ) / cof0
spircrv(k) = ucx(k) * ucx(k) * dvdx - ucy(k) * ucy(k) * dudy + ucx(k) * ucy(k) * ( dvdy - dudx )
spircrv(k) = - spircrv(k) / spirucm(k)**3
enddo
do k = ndxi+1,ndx ! Boundary condtions as Neumann for the curvature
do LL = 1,nd(k)%lnx
L = abs( nd(k)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - k
spircrv(k2) = spircrv(k)
spirucm(k2) = spirucm(k)
enddo
enddo
end subroutine get_curvature
subroutine get_spiralangle ! Calculated the angle of streamlines generated by spiral flow to be used in bedload sediment transport, added by Nabi
use m_flow
use m_flowgeom
use mathconsts, only: pi_hp
implicit none
integer :: kk
double precision :: cof1, cof2, alfspir, pi
pi = pi_hp
do kk = 1,ndx
cof1 = 0.0d0
cof2 = 0.0d0
if( spirucm(kk) /= 0.0d0 ) then
alfspir = 2.0d0 / vonkar**2 * spirE * ( 1.0d0 - 0.5d0 * sqrt( ag ) / vonkar / czssf(kk) ) !Eq. 11.45 in Delft3D manual
cof1 = ucy(kk) - alfspir * ucx(kk) / spirucm(kk) * spirint(kk)
cof2 = ucx(kk) - alfspir * ucy(kk) / spirucm(kk) * spirint(kk)
endif
if( cof2 == 0.0 ) then
spirang(kk) = pi * 0.5d0 ; if( cof1 < 0.0d0 ) spirang(kk) = - spirang(kk)
else
spirang(kk) = atan( cof1 / cof2 )
if( cof2 < 0.0d0 ) spirang(kk) = spirang(kk) + pi
endif
if( spirang(kk) < 1.5d0 * pi .and. spirang(kk) > pi ) spirang(kk) = spirang(kk) - 2. * pi ! optional line, can be removed
enddo
end subroutine get_spiralangle
subroutine get_spiralforce ! Effect of secondary flow on momentum equations
! This subroutine calculates the forces fx and fy for momentum equations, added by Nabi
use m_flow
use m_flowgeom
implicit none
integer :: k, k1, k2, LL, L, n
double precision :: cofa, cofb, cofc, cofd, cofe, coff, cofg, cofw, cofx, cofy, coftxx, coftxy, coftyy, cof0
double precision :: dtxxdx, dtxxdy, dtxydx, dtxydy
double precision :: betas, beta, alfa
double precision :: fx, fy, fxl
double precision, dimension(ndx) :: ht_xx, ht_xy
ht_xx = 0d0 ; ht_xy = 0d0
do k = 1,ndxi
ht_xx(k) = 0d0
ht_xy(k) = 0d0
if( spirucm(k) < 1.0d-3 ) cycle
alfa = sag / vonkar / czssf(k)
betas = spirbeta * ( 5.0d0 * alfa - 15.6d0 * alfa**2 + 37.5d0 * alfa**3 )
beta = 0d0
if( spirucm(k) /= 0d0 ) beta = betas * spirint(k) / spirucm(k)
ht_xx(k) = -2.0d0 * hs(k) * beta * ucx(k) * ucy(k)
ht_xy(k) = hs(k) * beta * ( ucx(k) * ucx(k) - ucy(k) * ucy(k) )
enddo
do k = ndxi+1,ndx ! Boundary conditions for spiral flow forces
k1 = k
do LL = 1,nd(k1)%lnx
L = abs( nd(k1)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - k1
ht_xx(k2) = ht_xx(k1)
ht_xy(k2) = ht_xy(k1)
enddo
enddo
do k = 1,ndxi
k1 = k
spirfx(k1) = 0d0
spirfy(k1) = 0d0
if( hs(k1) < epshu ) cycle
cofa = 0.0d0
cofb = 0.0d0
cofc = 0.0d0
cofd = 0.0d0
cofe = 0.0d0
coff = 0.0d0
cofg = 0.0d0
n = 0
do LL = 1,nd(k1)%lnx
L = abs( nd(k1)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - k1
if( hs(k2) < epshu ) cycle
n = n + 1
cofx = xz(k2) - xz(k1)
cofy = yz(k2) - yz(k1)
coftxx = ht_xx(k2) - ht_xx(k1)
coftxy = ht_xy(k2) - ht_xy(k1)
cof0 = sqrt( cofx * cofx + cofy * cofy )
cofw = 1.0d0 / cof0
if( cof0 < 1.0d-6 ) cofw = 1.0d6
cofx = cofw * cofx
cofy = cofw * cofy
coftxx = cofw * coftxx
coftxy = cofw * coftxy
cofa = cofa + cofx * cofx
cofb = cofb + cofx * cofy
cofc = cofc + cofy * cofy
cofd = cofd + coftxx * cofx
cofe = cofe + coftxx * cofy
coff = coff + coftxy * cofx
cofg = cofg + coftxy * cofy
enddo
cof0 = cofa * cofc - cofb * cofb
if( cof0 == 0d0 .or. n < 2 ) cycle
dtxxdx = ( cofd * cofc - cofb * cofe ) / cof0
dtxxdy = ( cofa * cofe - cofd * cofb ) / cof0
dtxydx = ( coff * cofc - cofb * cofg ) / cof0
dtxydy = ( cofa * cofg - coff * cofb ) / cof0
spirfx(k1) = ( dtxxdx + dtxydy ) / hs(k1)
spirfy(k1) = ( dtxydx - dtxxdy ) / hs(k1)
enddo
do k = ndxi+1,ndx ! Boundary conditions for spiral flow forces
k1 = k
do LL = 1,nd(k1)%lnx
L = abs( nd(k1)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - k1
spirfx(k2) = spirfx(k1)
spirfy(k2) = spirfy(k1)
enddo
enddo
do L = 1,lnxi ! Mapping forces from global coordinates to local
k1 = ln(1,L) ; k2 = ln(2,L)
fx = acl(L) * spirfx(k1) + ( 1.0d0 - acl(L) ) * spirfx(k2)
fy = acl(L) * spirfy(k1) + ( 1.0d0 - acl(L) ) * spirfy(k2)
fxl = csu(L) * fx + snu(L) * fy
adve(L) = adve(L) - fxl ! Adding the local forces to the momentum equation
enddo
end subroutine get_spiralforce
!> count number of 2D links and 1D endpoints
subroutine count_links(mx1Dend, Nx)
use network_data, only: numL, numL1D, kn, lne, nmk
implicit none
integer, intent(out) :: mx1Dend !< number of 1D endpoints
integer, intent(out) :: Nx !< number of 2D links and 1D endpoints
integer :: k1, k2, L
mx1Dend = 0 ! count MAX nr of 1D endpoints
do L = 1,numl1D
if ( kn(3,L) == 1) then ! zeker weten
k1 = kn(1,L) ; k2 = kn(2,L)
if (nmk(k1) == 1 .and. nmk(k2) == 2 .and. lne(1,L) < 0 .or. &
nmk(k2) == 1 .and. nmk(k1) == 2 .and. lne(2,L) < 0 ) then
mx1Dend = mx1Dend + 1
endif
endif
enddo
Nx = numL + mx1Dend
return
end subroutine count_links
!> make the mirror cells for open boundaries
subroutine make_mirrorcells(Nx, xe, ye, xyen, kce, ke, ierror)
use network_data, only: numL, kn, lne, nmk, xk, yk
implicit none
integer, intent(in) :: Nx !< number of links
double precision, dimension(Nx), intent(out) :: xe, ye !< inner cell center coordinates
double precision, dimension(2,Nx), intent(out) :: xyen !< mirror cell center coordinates
integer, dimension(Nx), intent(inout) :: kce !< flag
integer, dimension(Nx), intent(out) :: ke !< inner cell number
integer, intent(out) :: ierror !< error (1) or not (0)
double precision, dimension(4) :: xx, yy ! (half) mirror cell contour
double precision :: xci, yci, xcb, ycb, xce2, yce2
integer :: ind, k1, k2, k3, k4, L
ierror = 1
do L = 1,numL ! kandidate points and distance tolerance of closed (u) points
k3 = kn(1,L) ; k4 = kn(2,L)
! if ( abs(xk(k3)+11.5d0)+abs(xk(k4)+11.5d0) .lt. 1d-8 ) then
! continue
! end if
if (lne(1,L) == 0 .and. lne(2,L) /= 0 .or. & ! 2D links
lne(1,L) /= 0 .and. lne(2,L) == 0 ) then
ind = lne(1,L)+lne(2,L) ! i.e., the nonzero cell nr.
call mirrorcell( ind, xk(k3), yk(k3), xk(k4), yk(k4), xci, yci, xcb, ycb, xce2, yce2, xx, yy) ! voetje uitsteken tussen xz intern (xci) en xz rand (xcb)
xe(L) = xci
ye(L) = yci
xyen(1,L) = xce2
xyen(2,L) = yce2
kce(L) = 1
ke(L) = ind
else if (kn(3,L) == 1) then ! 1D links
k1 = k3 ; k2 = k4
if (nmk(k1) == 1 .and. nmk(k2) == 2 .and. lne(1,L) < 0 ) then
xe(L) = xk(k1)
ye(L) = yk(k1)
xyen(1,L) = 2d0*xk(k1) - xk(k2)
xyen(2,L) = 2d0*yk(k1) - yk(k2)
kce(L) = 1
ke(L) = -lne(1,L)
else if (nmk(k2) == 1 .and. nmk(k1) == 2 .and. lne(2,L) < 0 ) then
xe(L) = xk(k2)
ye(L) = yk(k2)
xyen(1,L) = 2d0*xk(k2) - xk(k1)
xyen(2,L) = 2d0*yk(k2) - yk(k1)
kce(L) = 1
ke(L) = -lne(2,L)
endif
endif
enddo
ierror = 0
1234 continue
return
end subroutine make_mirrorcells
subroutine convert_externalforcings_file(extfileold)
use properties
use unstruc_messages
use unstruc_version_module
use m_flowexternalforcings, only: qid, filetype, operand, transformcoef
use timespace
implicit none
character(len=*), intent(in) :: extfileold
type(tree_data), pointer :: ext_ptr, q_ptr
character(len=256) :: filename
character(len=20) :: rundat
integer :: L1, L2, istat, method, mextold, mextnew, ja
character(len=64) :: qtype
logical :: jawel
inquire (file = trim(extfileold), exist = jawel)
if (jawel) then
call oldfil(mextold, extfileold)
else
return
end if
call mess(LEVEL_INFO, 'Attempting to convert '''//trim(extfileold)//''' to new format...')
qtype = ' '
ja = 1
call tree_create(trim(extfileold), ext_ptr)
do while (ja .eq. 1) ! read *.ext file
call readprovider(mextold,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja /= 1) then
call mess(LEVEL_WARN, 'Failed to read provider.')
cycle
end if
! value, factor, ifrctyp
L2 = len_trim(qid)
L1 = max(1,L2-2)
if (qid(L1:L2) == 'bnd') then
qtype = 'boundary'
else
select case (qid)
case ('lowergatelevel', 'damlevel', 'pump')
qtype = 'structure'
case ('frictioncoefficient', 'horizontaleddyviscositycoefficient', 'horizontaleddydiffusivitycoefficient', 'advectiontype', &
'ibotlevtype', 'initialwaterlevel', 'initialsalinity', 'initialsalinitytop', &
'initialverticaltemperatureprofile', 'initialverticalsalinityprofile', 'Windstresscoefficient' )
qtype = 'initial'
case ('windx', 'windy', 'windxy', 'rainfall', 'atmosphericpressure')
qtype = 'meteo'
case ('shiptxy', 'movingstationtxy')
qtype = 'misc'
end select
end if
call tree_create_node(ext_ptr, trim(qtype), q_ptr)
call prop_set(q_ptr, '', 'quantity', trim(qid))
call prop_set(q_ptr, '', 'filename', trim(filename))
call prop_set(q_ptr, '', 'filetype', filetype)
call prop_set(q_ptr, '', 'method', method)
call prop_set(q_ptr, '', 'operand', operand)
if (transformcoef(1) /= -999d0) then
call prop_set(q_ptr, '', 'value', transformcoef(1))
end if
if (transformcoef(2) /= -999d0) then
call prop_set(q_ptr, '', 'factor', transformcoef(2))
end if
if (transformcoef(3) /= -999d0) then
call prop_set(q_ptr, '', 'ifrctyp', int(transformcoef(3)))
end if
end do
call doclose(mextold)
L2 = len_trim(extfileold)
L1 = max(1, L2-3)
call newfil(mextnew, extfileold(1:L1-1)//'.converted.ext')
call datum(rundat)
write(mextnew, '(a,a)') '# Converted from old format ext-file: ', trim(extfileold)
write(mextnew, '(a,a)') '# Generated on ', trim(rundat)
write(mextnew, '(a,a)') '# ', trim(unstruc_version_full)
call prop_write_inifile(mextnew, ext_ptr, istat)
call doclose(mextnew)
end subroutine convert_externalforcings_file
!> Adds administration for an open boundary segment, intended
!! for postprocessing.
!!
!! An open boundary section is associated with one polyline
!! and consists of one or more netlink numbers.
subroutine addopenbndsection(nbnd, netlinknrs, plifilename, ibndtype)
use m_alloc
use m_flowexternalforcings
implicit none
integer, intent(in) :: nbnd !< Nr. of net links in this open bnd section.
integer, intent(in) :: netlinknrs(nbnd) !< Net link nrs in this open bnd section (in any order)
character(len=*), intent(in) :: plifilename !< File name of the original boundary condition definition polyline.
integer, intent(in) :: ibndtype !< Type of this boundary section (one of IBNDTP_ZETA, etc...)
integer, external :: get_dirsep
integer :: maxopenbnd, istart, i, n1, n2
if (nbnd <= 0) return
! Start index (-1) of net link numbers for this net boundary section:
if (nopenbndsect >= 1) then
istart = nopenbndlin(nopenbndsect)
else
istart = 0
end if
nopenbndsect = nopenbndsect + 1
maxopenbnd = max(size(nopenbndlin), int(1.2*nopenbndsect)+1, 5)
call realloc(openbndname, maxopenbnd, fill = ' ')
call realloc(openbndfile, maxopenbnd, fill = ' ')
call realloc(openbndtype, maxopenbnd, fill = IBNDTP_UNKNOWN)
call realloc(nopenbndlin, maxopenbnd)
call realloc(openbndlin, istart+nbnd)
! Strip off trailing file extension .pli
n2 = index(plifilename,'.', .true.) - 1
if (n2 < 0) then
n2 = len_trim(plifilename)
end if
! Strip off leading path /dir/name/bnd/
n1 = index(plifilename(1:n2),'\', .true.) ! Win
if (n1 == 0) then
n1 = index(plifilename(1:n2),'/', .true.) ! Or try UX
end if
openbndfile(nopenbndsect) = trim(plifilename)
openbndname(nopenbndsect) = plifilename(N1+1:N2)
openbndtype(nopenbndsect) = ibndtype
do i = 1,nbnd
openbndlin(istart+i) = netlinknrs(i)
end do
nopenbndlin(nopenbndsect) = istart + nbnd
end subroutine addopenbndsection
subroutine addexternalboundarypoints
use m_netw
use m_flow
use m_flowgeom
use unstruc_messages
use m_alloc
use timespace, only: polyindexweight
use m_missing
use m_sobekdfm
implicit none
integer :: i, k, k1, k2, L, Lf, lb, nn, ierr, ja, k3, k4, id, istart, num1d2d, kL, kR, mpliz
double precision :: x0,y0,x1,y1,x2,y2,xn,yn, dis, wL, wR
double precision :: dbdistance
double precision :: rtol, xci, yci, xcb, ycb, xce2, yce2, xx(4), yy(4)
integer, allocatable :: kdum(:)
! Update Mar'15: 1D/2D bnds points/links used to be mixed, now all 1D bnds nodes/links come first,
! followed by 2D bnd.
! So: links: 1..lnx1d..lnxi..lnx1db..lnx
! nodes: 1..ndx2d..ndxi..ndx1db..ndx (notice how 1D bnds nodes go before 2D bnds, while 2D internal go before 1D internal).
Lf = lnxi
k = ndxi
lnx1db = lnxi ! Counter for last 1D boundary link (==lnxi if no 1D bnds)
ndx1db = ndxi ! Counter for last 1D boundary node (==ndxi if no 1D bnds)
do id=1,2 ! 1D and 2D treated after one another
do Lb = 1,nbndz ! add boundary link and update ln array waterlevel bnds
L = kez(Lb)
if ( (id == 1 .and. kn(3,L) .ne. 1) & ! we're in 1D loop, so skip this 2D boundary cell for the moment.
.or. (id == 2 .and. kn(3,L) .eq. 1)) then ! or we're in 2D loop, so skip this 1D boundary cell for the moment.
cycle
end if
k = k + 1
Lf = Lf + 1
if (id == 1) then ! Increment 1D boundary node & link counters
lnx1db = Lf
ndx1db = k
end if
k1 = k ! external point
k2 = iabs(lne(1,L)) ! internal point
ln(1,Lf) = k1
ln(2,Lf) = k2
ln2lne(Lf) = L
lne2ln(L) = Lf ! after this, only closed edges will still have a (negative)
! reference to an inside node
nn = 4
allocate ( nd(k1)%x(nn), nd(k1)%y(nn) , stat=ierr )
call aerr('nd(k1)%x(nn), nd(k1)%y(nn)', ierr, nn*2)
k3 = kn(1,L); k4 = kn(2,L)
if (kn(3,L) .ne. 1) then ! in 2D mirror cell
call mirrorcell( k2, xk(k3), yk(k3), xk(k4), yk(k4), xci, yci, xz(k1), yz(k1), xce2, yce2, nd(k1)%x, nd(k1)%y)
xzw(k1) = xz(k1) ; yzw(k1) = yz(k1)
if (izbndpos == 0) then ! as in D3DFLOW
else if (izbndpos == 1) then ! on network boundary
xz(k1) = 0.5d0*( xk(k3) + xk(k4 ) )
yz(k1) = 0.5d0*( yk(k3) + yk(k4 ) )
else if (izbndpos == 2) then ! on specified boundary polyline
endif
kcu(Lf) = -2
kcs(k1) = -2
else ! in 1D mirror point
if (nmk(k3) == 1 .and. nmk(k4) == 2 .and. lne(1,L) < 0 ) then
if (izbndpos == 0) then ! as in D3DFLOW
xz(k1) = 2d0*xk(k3) - xk(k4)
yz(k1) = 2d0*yk(k3) - yk(k4)
else if (izbndpos == 1) then ! on network boundary
xz(k1) = 1.5d0*xk(k3) - 0.5d0*xk(k4)
yz(k1) = 1.5d0*yk(k3) - 0.5d0*yk(k4)
else if (izbndpos == 2) then ! on specified boundary polyline
endif
ln(2,Lf) = iabs(lne(1,L)) ! this overrides previous k2
kcu(Lf) = -1
kcs(k1) = -1
nd(k1)%x = xz(k1) ; nd(k1)%y = yz(k1) ! todo, naar allocateandset1D nodestuff
else if (nmk(k4) == 1 .and. nmk(k3) == 2 .and. lne(2,L) < 0 ) then
if (izbndpos == 0) then ! as in D3DFLOW
xz(k1) = 2d0*xk(k4) - xk(k3)
yz(k1) = 2d0*yk(k4) - yk(k3)
else if (izbndpos == 1) then ! on network boundary
xz(k1) = 1.5d0*xk(k4) - 0.5d0*xk(k3)
yz(k1) = 1.5d0*yk(k4) - 0.5d0*yk(k3)
else if (izbndpos == 2) then ! on specified boundary polyline
endif
ln(2,Lf) = iabs(lne(2,L))
kcu(Lf) = -1
kcs(k1) = -1
nd(k1)%x = xz(k1) ; nd(k1)%y = yz(k1) ! todo, naar allocateandset1D nodestuff
endif
endif
enddo
enddo ! id=1,2
do id=1,2 ! 1D and 2D treated after one another
do Lb = 1,nbndu ! idem u bnds, duplicatie niet top in elegantie
L = keu(Lb)
if ( (id == 1 .and. kn(3,L) .ne. 1) & ! we're in 1D loop, so skip this 2D boundary cell for the moment.
.or. (id == 2 .and. kn(3,L) .eq. 1)) then ! or we're in 2D loop, so skip this 1D boundary cell for the moment.
cycle
end if
k = k + 1
Lf = Lf + 1
if (id == 1) then ! Increment 1D boundary node & link counters
lnx1db = Lf
ndx1db = k
end if
k1 = k ! external point
k2 = iabs(lne(1,L)) ! internal point
ln(1,Lf) = k1
ln(2,Lf) = k2
ln2lne(Lf) = L
lne2ln(L) = Lf
nn = 4
allocate ( nd(k1)%x(nn), nd(k1)%y(nn) , stat=ierr )
call aerr('nd(k1)%x(nn), nd(k1)%y(nn)', ierr, nn*2)
k3 = kn(1,L); k4 = kn(2,L)
if (kn(3,L) .ne. 1) then ! in 2D mirror cell
call mirrorcell( k2, xk(k3), yk(k3), xk(k4), yk(k4), xci, yci, xz(k1), yz(k1), xce2, yce2, nd(k1)%x, nd(k1)%y)
xzw(k1) = xz(k1) ; yzw(k1) = yz(k1)
kcu(Lf) = -2
kcs(k1) = -2
else ! in 1D mirror point
if (nmk(k3) == 1 .and. nmk(k4) == 2 .and. lne(1,L) < 0 ) then
xz(k1) = 2d0*xk(k3) - xk(k4)
yz(k1) = 2d0*yk(k3) - yk(k4)
ln(2,Lf) = iabs(lne(1,L)) ! this overrides previous k2
kcu(Lf) = -1
kcs(k1) = -1
else if (nmk(k4) == 1 .and. nmk(k3) == 2 .and. lne(2,L) < 0 ) then
xz(k1) = 2d0*xk(k4) - xk(k3)
yz(k1) = 2d0*yk(k4) - yk(k3)
ln(2,Lf) = iabs(lne(2,L))
kcu(Lf) = -1
kcs(k1) = -1
endif
endif
enddo
enddo ! id=1,2
do Lb = 1,nbnd1d2d ! add boundary link and update ln array 1d2dbnds
L = ke1d2d(Lb)
k = k + 1
Lf = Lf + 1
k1 = k ! external point
k2 = iabs(lne(1,L)) ! internal point
ln(1,Lf) = k1
ln(2,Lf) = k2
ln2lne(Lf) = L
lne2ln(L) = Lf ! after this, only closed edges will still have a (negative)
! reference to an inside node
nn = 4
allocate ( nd(k1)%x(nn), nd(k1)%y(nn) , stat=ierr )
call aerr('nd(k1)%x(nn), nd(k1)%y(nn)', ierr, nn*2)
k3 = kn(1,L); k4 = kn(2,L)
if (kn(3,L) .ne. 1) then ! in 2D mirror cell
call mirrorcell( k2, xk(k3), yk(k3), xk(k4), yk(k4), xci, yci, xz(k1), yz(k1), xce2, yce2, nd(k1)%x, nd(k1)%y)
xzw(k1) = xz(k1) ; yzw(k1) = yz(k1)
!xz(k1) = 0.5d0*( xk(k3) + xk(k4 ) )
!yz(k1) = 0.5d0*( yk(k3) + yk(k4 ) )
kcu(Lf) = -2
kcs(k1) = -2
else ! in 1D mirror point
! non-sensible: 1D internal point that accidentally lies on 2DFM -- 1DSOBEK boundary (should not happen)
endif
enddo
write(msgbuf, '(a,i0,a)') 'addexternalboundarypoints: added ', nbnd1d2d, ' bnd points for SOBEK1D-FM2D connections.'
call dbg_flush()
! Special for 1D2D: interpolate zpl crest levels for each open boundary link u-point
if (nbnd1d2d > 0) then
call realloc(zcrest1d2d, nbnd1d2d, keepExisting=.false.)
call savepol()
istart = 0
num1d2d = 0 ! local counter for 1D2D open boundary points (should be identical to ordering inside zbnd1d2d array, etc. If not, programming error!)
do i=1,nopenbndsect
if (openbndtype(i) == IBNDTP_1D2D) then
call oldfil(mpliz, trim(openbndfile(i))) ! The original .pli(z) file as listed in the external forcings file.
call reapol(mpliz, 0)
call realloc(kdum, maxpol, keepExisting=.false.)
kdum = 1 ! Mask all pli points as valid for interpolation: each pli point should have a zpl crest value.
do Lb=istart+1,nopenbndlin(i)
num1d2d = num1d2d + 1
L = openbndlin(Lb) ! Net link
Lf = lne2ln(L) ! Flow link
if (Lf > 0 .and. Lf <= lnx) then
k1 = ln(1,Lf)
k2 = ln(2,Lf)
call polyindexweight(xz(k1), yz(k1), xz(k2), yz(k2), xpl, ypl, kdum, npl, kL, wL, kR, wR)
if (kL > 0 .and. kR > 0) then
if (zpl(kL) == dmiss) then
write(msgbuf, '(a,a,a,i0)') 'Missing crest level for SOBEK1D-FM2D boundary ''', trim(openbndname(i)), ''': missing value found on point #', kL
call err_flush()
elseif (zpl(kR) == dmiss) then
write(msgbuf, '(a,a,a,i0)') 'Missing crest level for SOBEK1D-FM2D boundary ''', trim(openbndname(i)), ''': missing value found on point #', kR
call err_flush()
else
zcrest1d2d(num1d2d) = wL*zpl(kL) + wR*zpl(kR)
end if
else
! Should not happen for any model, only for debugging
write(msgbuf, '(a,a,a,i0)') 'Could not find crest level for SOBEK1D-FM2D boundary ''', trim(openbndname(i)), ''': no overlap found for net link ', L
call err_flush()
end if
else
! Should not happen for any model, only for debugging
write(msgbuf, '(a,a,a,i0)') 'Could not set crest level for SOBEK1D-FM2D boundary ''', trim(openbndname(i)), ''': no flow link found for net link ', L
call err_flush()
end if
end do
call doclose(mpliz)
end if
istart = nopenbndlin(i)
end do
call restorepol()
if (allocated(kdum)) deallocate(kdum)
end if ! nbnd1d2d > 0
end subroutine addexternalboundarypoints
!> Initializes boundaries and meteo for the current model.
!! @return Integer result status (0 if successful)
integer function flow_initexternalforcings() result(iresult) ! This is the general hook-up to wind and boundary conditions
use unstruc_boundaries
use m_alloc
use m_flowexternalforcings
use m_flowparameters
use m_flowtimes ! Two stages: 1 = collect elsets for which data is provided
use m_flowgeom ! 2 = add relations between elsets and their providers
use m_netw
use unstruc_model
use unstruc_messages
use unstruc_files
use timespace
use m_missing
use m_ship
use m_flow, only : frcu, frculin, jafrculin, viusp, javiusp, diusp, jadiusp, vicouv, dicouv, &
ifrcutp, frcuni, ifrctypuni, s1, sa1, tem1, u1, zws, satop, kmx, kmxd, ndkx, kmxn, Cdwusp
use m_observations
use m_alloc
use m_structures
use m_meteo
use m_ec_instance
use m_grw
use m_alloc
use m_sediment
use m_transport
use m_strucs
use dfm_error
use m_sobekdfm
use m_partitioninfo
implicit none
character(len=256) :: filename, sourcemask
integer :: L, Lf, mout, kb, LL, Lb, Lt, ierr, k, k2, ja, method, n1, n2, kbi, Le, n, j, mx, n4, kk, kt, lenqidnam
character (len=256) :: fnam, rec, filename0
character (len=NAMTRACLEN) :: tracnam, qidnam
integer :: minp0, npli, inside, filetype0
integer, allocatable :: ihu(:) ! temp
integer, allocatable :: lnxbnd(:) ! temp
double precision, allocatable :: viuh(:) ! temp
logical :: exist
integer :: numz, numu, numq, numg, numd, numgen, npum, jaifrcutp, jainivel
integer :: numnos, numnot, numnon ! < Nr. of unassociated flow links (not opened due to missing z- or u-boundary)
double precision, allocatable :: xdum(:), ydum(:), xy2dum(:,:)
integer, allocatable :: kdum(:)
double precision, allocatable :: xships(:), yships(:)
integer, allocatable :: kships(:)
double precision, allocatable :: grainlayerthickness(:,:) ! help array grain layer thickness
double precision, allocatable :: sah(:) ! temp
double precision :: fff ! help
double precision, allocatable :: hulp(:,:) ! hulp
double precision, allocatable :: widths(:) ! hulp
double precision, allocatable :: uxini(:), uyini(:) !< optional initial velocity fields on u points in x/y dir.
integer :: iconst, itrac
integer, external :: findname
iresult = DFM_NOERR
success = .true. ! default if no valid providers are present in *.ext file (m_flowexternalforcings::success)
call settimespacerefdat(refdat, julrefdat, Tzone, Timjan)
jainivel = 0 ! no initial velocity field loaded
call initialize_ec_module()
call flow_init_structurecontrol() !(GvdO) should this be here? Separate functionality, separate file, separate subroutine.
if (jatimespace == 0) goto 888 ! Just cleanup and close ext file.
if (allocated(wx)) deallocate(wx,wy) ! wind arrays
if (allocated(pwxwythc)) deallocate(pwxwythc)
if (allocated(ec_pwxwy_x)) deallocate(ec_pwxwy_x)
if (allocated(ec_pwxwy_y)) deallocate(ec_pwxwy_y)
if (allocated(kcw)) deallocate(kcw)
if (allocated(patm)) deallocate(patm)
if (allocated(kbndz)) deallocate(xbndz,ybndz,xy2bndz,zbndz,kbndz,zbndz0)
if (allocated(zkbndz)) deallocate(zkbndz)
if(allocated(lnxbnd)) deallocate(lnxbnd)
allocate(lnxbnd(lnx-lnxi))
n4 = 5 ; if (jased > 0 .and. jaceneqtr == 2) n4 = 2*n4
if (nbndz > 0) then ! now you know the elementsets for the waterlevel bnds
allocate ( xbndz(nbndz), ybndz(nbndz), xy2bndz(2,nbndz), zbndz(nbndz), kbndz(n4,nbndz), zbndz0(nbndz), kdz(nbndz) , stat=ierr )
call aerr('xbndz(nbndz), ybndz(nbndz), xy2bndz(2,nbndz), zbndz(nbndz), kbndz(n4,nbndz), zbndz0(nbndz), kdz(nbndz)', ierr, nbndz*10 )
if (jased > 1 .and. jaceneqtr == 2) then
allocate ( zkbndz(2,nbndz) ,stat= ierr )
call aerr('zkbndz(2,nbndz)',ierr, 2*nbndz )
endif
kbndz = 0 ; kdz = 1
do k = 1, nbndz
L = kez(k)
Lf = lne2ln(L)
kb = ln(1,Lf)
kbi = ln(2,LF)
xbndz(k) = xe(L) ! xz(kb)
ybndz(k) = ye(L) ! yz(kb)
zbndz0(k) = dmiss
xy2bndz(:,k) = xyen(:,L)
kbndz(1,k) = kb
kbndz(2,k) = kbi
kbndz(3,k) = Lf
kbndz(4,k) = itpez(k)
kbndz(5,k) = itpenz(k)
lnxbnd(Lf-lnxi) = itpenz(k)
do n = 1,nd(kbi)%lnx
L = iabs(nd(kbi)%ln(n))
teta(L) = 1d0
enddo
if (iadvec > 0) then
iadv(Lf) = 6 ! piaczek upw
endif
if (jased > 1 .and. jaceneqtr == 2) then
zkbndz(1,k) = zk(lncn(1,Lf) )
zkbndz(2,k) = zk(lncn(2,Lf) )
endif
enddo
do k = 1,nbndz
kbi = kbndz(2,k)
Lf = kbndz(3,k)
do k2 = 1,nd(kbi)%lnx
L = abs(nd(kbi)%ln(k2))
if (L .ne. Lf) then
if (iadvec .ne. 0) then
iadv(L) = 6
endif
endif
enddo
enddo
endif
if (allocated(kbndu)) deallocate( xbndu,ybndu,xy2bndu,zbndu,kbndu)
if (allocated(zkbndu)) deallocate( zkbndu)
if (allocated(zbndu_store)) deallocate(zbndu_store)
if (nbndu > 0) then ! similar for u bnd's
allocate ( xbndu(nbndu), ybndu(nbndu), xy2bndu(2,nbndu), zbndu(nbndu), kbndu(n4,nbndu), kdu(nbndu) , stat=ierr )
call aerr('xbndu(nbndu), ybndu(nbndu), xy2bndu(2,nbndu), zbndu(nbndu), kbndu(n4,nbndu), kdu(nbndu)', ierr, nbndu*10 )
if (jased > 1 .and. jaceneqtr == 2) then
allocate ( zkbndu(2,nbndu) ,stat= ierr )
call aerr('zkbndu(2,nbndu)',ierr, 2*nbndu )
endif
allocate ( zbndu_store(nbndu) , stat=ierr )
call aerr('zbndu_store(nbndu)', ierr, nbndu )
kbndu = 0 ; kdu = 1
do k = 1, nbndu
L = keu(k)
Lf = lne2ln(L)
kb = ln(1,Lf)
kbi = ln(2,Lf)
xbndu(k) = xe(L) ! xz(kb)
ybndu(k) = ye(L) ! yz(kb)
xy2bndu(:,k) = xyen(:,L)
kbndu(1,k) = kb
kbndu(2,k) = kbi
kbndu(3,k) = Lf
kbndu(4,k) = itpeu(k)
kbndu(5,k) = itpenu(k)
lnxbnd(Lf-lnxi) = itpenu(k)
do n = 1,nd(kbi)%lnx
L = iabs(nd(kbi)%ln(n))
teta(L) = 1d0
enddo
iadv(Lf) = -1 ! switch off adv at open u-bnd's
if (jased > 1 .and. jaceneqtr == 2) then
zkbndu(1,k) = zk(lncn(1,Lf) )
zkbndu(2,k) = zk(lncn(2,Lf) )
endif
enddo
endif
if ( allocated (kbnds) ) deallocate( xbnds,ybnds,xy2bnds,zbnds,kbnds)
if (jasal > 0) then
if ( allocated(sigmabnds) ) deallocate(sigmabnds)
if (nbnds > 0) then ! salinity as for waterlevel bnds, but no kcs = -1
numnos = 0
allocate ( xbnds(nbnds), ybnds(nbnds), xy2bnds(2,nbnds), zbnds(kmxd*nbnds), kbnds(5,nbnds), kds(nbnds), stat=ierr )
call aerr('xbnds(nbnds), ybnds(nbnds), xy2bnds(2,nbnds), zbnds(kmxd*nbnds), kbnds(5,nbnds), kds(nbnds)', ierr, nbnds*9 )
if ( kmx.gt.0 ) then ! also allocate 3D-sigma bnd distribution for EC
allocate ( sigmabnds(kmx*nbnds) )
call aerr('sigmabnds(kmx*nbnds)', ierr, kmx*nbnds )
end if
zbnds = DMISS ; kbnds = 0 ; kds = 1
do k = 1, nbnds
L = kes(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbnds(k) = xe(L) ! xz(kb)
ybnds(k) = ye(L) ! yz(kb)
xy2bnds(:,k) = xyen(:,L)
kbnds(1,k) = kb
kbnds(2,k) = kbi
kbnds(3,k) = Lf
kbnds(5,k) = lnxbnd(Lf-lnxi)
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Salinity boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
!nbnds = 0
!jasal = 0
end if
endif
endif
if ( allocated (kbndTM) ) deallocate( xbndTM,ybndTM,xy2bndTM,zbndTM,kbndTM)
if (jatem > 0) then
if ( allocated(sigmabndTM) ) deallocate(sigmabndTM)
if (nbndTM > 0) then ! salinity as for waterlevel bnds, but no kcs = -1
numnos = 0
allocate ( xbndTM(nbndTM), ybndTM(nbndTM), xy2bndTM(2,nbndTM), zbndTM(kmxd*nbndTM), kbndTM(5,nbndTM), kdTM(nbndTM) , stat=ierr )
call aerr('xbndTM(nbndTM), ybndTM(nbndTM), xy2bndTM(2,nbndTM), zbndTM(kmxd*nbndTM), kbndTM(5,nbndTM), kdTM(nbndTM)', ierr, nbndTM*9 )
if ( kmx.gt.0 ) then ! also allocate 3D-sigma bnd distribution for EC
allocate ( sigmabndTM(kmx*nbndTM) , stat=ierr )
call aerr('sigmabndTM(kmx*nbndTM)', ierr, kmx*nbndTM )
end if
zbndTM = DMISS ; kbndTM = 0 ; kdTM = 1
do k = 1, nbndTM
L = keTM(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbndTM(k) = xe(L) ! xz(kb)
ybndTM(k) = ye(L) ! yz(kb)
xy2bndTM(:,k) = xyen(:,L)
kbndTM(1,k) = kb
kbndTM(2,k) = kbi
kbndTM(3,k) = Lf
kbndTM(5,k) = lnxbnd(Lf-lnxi)
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Temperature boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
!nbnds = 0
!jasal = 0
end if
endif
endif
call init_1d2d()
! JRE ================================================================
if (nbndw > 0) then
numnos = 0
jawave = 4
call mess(LEVEL_INFO, 'Enabled wave forcing while reading external forcings.')
if (allocated (kbndw) ) deallocate( xbndw,ybndw,xy2bndw,zbndw,kbndw)
allocate ( xbndw(nbndw), ybndw(nbndw), xy2bndw(2,nbndw), zbndw(ntheta,nbndw), kbndw(4,nbndw), kdw(nbndw) , stat=ierr )
call aerr('xbndw(nbndw), ybndw(nbndw), xy2bndw(2,nbndw), zbndw(ntheta,nbndw), kbndw(4,nbndw), kdw(nbndw)', ierr, nbndw*(9 + ntheta) )
kbndw = 0 ; kdw = 1
do k = 1, nbndw
L = kew(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbndw(k) = xe(L) !xz(kb)
ybndw(k) = ye(L) !yz(kb)
!xbndw(k) = xu(Lf)
!ybndw(k) = yu(Lf)
xy2bndw(:,k) = xyen(:,L)
kbndw(1,k) = kb
kbndw(2,k) = kbi
kbndw(3,k) = Lf
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Wave energy boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
end if
endif
! ========================
if (allocated(kbndsd)) deallocate(xbndsd,ybndsd,xy2bndsd,zbndsd,kbndsd)
if (nbndsd > 0) then ! sediment bnds as for waterlevel bnds, but no kcs = -1
numnos = 0
allocate ( xbndsd(nbndsd), ybndsd(nbndsd), xy2bndsd(2,nbndsd), zbndsd(nbndsd), kbndsd(5,nbndsd), kdsd(nbndsd) , stat=ierr )
call aerr('xbndsd(nbndsd), ybndsd(nbndsd), xy2bndsd(2,nbndsd), zbndsd(nbndsd), kbndsd(5,nbndsd), kdsd(nbndsd)', ierr, nbndsd*9 )
kbndsd = 0 ; kdsd = 1
do k = 1, nbndsd
L = kesd(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbndsd(k) = xe(L) ! xz(kb)
ybndsd(k) = ye(L) ! yz(kb)
xy2bndsd(:,k) = xyen(:,L)
kbndsd(1,k) = kb
kbndsd(2,k) = kbi
kbndsd(3,k) = Lf
kbndsd(5,k) = lnxbnd(Lf-lnxi)
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Sediment boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
!nbndsd = 0
!jased = 0
end if
endif
! tracers
if (nbndtr_all > 0) then ! sediment bnds as for waterlevel bnds, but no kcs = -1
! deallocate
call dealloc_bndarr(bndtr)
! allocate
allocate(bndtr(numtracers))
do itrac=1,numtracers
numnos = 0
call alloc_bnd(nbndtr(itrac), kmx, bndtr(itrac))
do k = 1, nbndtr(itrac)
L = ketr(k,itrac)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
bndtr(itrac)%name = trim(trnames(itrac))
bndtr(itrac)%x(k) = xe(L) ! xz(kb)
bndtr(itrac)%y(k) = ye(L) ! yz(kb)
bndtr(itrac)%xy2(:,k) = xyen(:,L)
bndtr(itrac)%k(1,k) = kb
bndtr(itrac)%k(2,k) = kbi
bndtr(itrac)%k(3,k) = Lf
bndtr(itrac)%k(5,k) = lnxbnd(Lf-lnxi)
endif
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Constituent boundary for '''//trim(bndtr(itrac)%name)//''' (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
! nbndtr(itrac) = 0
! jatr = 0
end if
enddo
end do ! itrac
endif
if (allocated (kbndt) ) deallocate(xbndt, ybndt, xy2bndt, zbndt, kbndt)
if (nbndt > 0) then ! Tangential velocity boundaries as u bnds
numnos = 0
allocate ( xbndt(nbndt), ybndt(nbndt), xy2bndt(2,nbndt), zbndt(nbndt), kbndt(4,nbndt), kdt(nbndt) , stat=ierr )
call aerr('xbndt(nbndt), ybndt(nbndt), xy2bndt(2,nbndt), zbndt(nbndt), kbndt(4,nbndt), kdt(nbndt)', ierr, nbndt*10 )
kbndt = 0 ; kdt= 1
do k = 1, nbndt
L = ket(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbndt(k) = xe(L) ! xz(kb)
ybndt(k) = ye(L) ! yz(kb)
xy2bndt(:,k) = xyen(:,L)
kbndt(1,k) = kb
kbndt(2,k) = kbi
kbndt(3,k) = Lf
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Tangential boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
!nbndt = 0
end if
endif
if (allocated (kbnduxy) ) deallocate( xbnduxy,ybnduxy,xy2bnduxy,zbnduxy,kbnduxy)
if (allocated (sigmabnduxy) ) deallocate(sigmabnduxy)
if (nbnduxy > 0) then ! Tangential velocity boundaries as u bnds
numnos = 0
allocate ( xbnduxy(nbnduxy), ybnduxy(nbnduxy), xy2bnduxy(2,nbnduxy), zbnduxy(2*kmxd*nbnduxy), kbnduxy(4,nbnduxy), kduxy(nbnduxy) , stat=ierr )
call aerr('xbnduxy(nbnduxy), ybnduxy(nbnduxy), xy2bnduxy(2,nbnduxy), zbnduxy(2*kmxd*nbnduxy), kbnduxy(4,nbnduxy), kduxy(nbnduxy)', ierr, nbnduxy*10 )
if ( kmx.gt.0 ) then ! also allocate 3D-sigma bnd distribution for EC
allocate ( sigmabnduxy(kmx*nbnduxy) , stat=ierr )
call aerr('sigmabnduxy(kmx*nbnduxy)', ierr, kmx*nbnduxy )
end if
kbnduxy= 0 ; kduxy= 1
do k = 1, nbnduxy
L = keuxy(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbnduxy(k) = xe(L) ! xz(kb)
ybnduxy(k) = ye(L) ! yz(kb)
xy2bnduxy(:,k) = xyen(:,L)
kbnduxy(1,k) = kb
kbnduxy(2,k) = kbi
kbnduxy(3,k) = Lf
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('UxUy velocity boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
end if
endif
if (allocated (kbndn) ) deallocate( xbndn,ybndn,xy2bndn,zbndn,kbndn)
if (nbndn > 0) then ! Normal velocity boundaries as z bnds
numnos = 0
allocate ( xbndn(nbndn), ybndn(nbndn), xy2bndn(2,nbndn), zbndn(nbndn), kbndn(4,nbndn), kdn(nbndn) , stat=ierr )
call aerr('xbndn(nbndn), ybndn(nbndn), xy2bndn(2,nbndn), zbndn(nbndn), kbndn(4,nbndn), kdn(nbndn)', ierr, nbndn*10 )
kbndn = 0 ; kdn= 1
do k = 1, nbndn
L = ken(k)
Lf = lne2ln(L)
if (Lf <= 0 .or. Lf > lnx) then
numnos = numnos + 1
cycle
end if
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kcs(kb) < 0 ) then ! if already opened by flow bnd's
xbndn(k) = xe(L) ! xz(kb)
ybndn(k) = ye(L) ! yz(kb)
xy2bndn(:,k) = xyen(:,L)
kbndn(1,k) = kb
kbndn(2,k) = kbi
kbndn(3,k) = Lf
iadv(Lf) = 77
endif
enddo
if (numnos > 0) then
rec = ' '
write (rec, '(a,i6,a)') '(', numnos, ' points)'
call qnerror('Normal boundary (partially) unassociated. ', trim(rec), ' Open boundary required.')
iresult = DFM_WRONGINPUT
goto 888
!nbndn = 0
end if
endif
deallocate (xyen, xe, ye, lnxbnd)
if (allocated(xdum )) deallocate(xdum, ydum, kdum, xy2dum)
allocate ( xdum(1), ydum(1), kdum(1), xy2dum(2,1) , stat=ierr)
call aerr('xdum(1), ydum(1), kdum(1), xy2dum ', ierr, 3)
xdum = 1d0 ; ydum = 1d0; kdum = 1; xy2dum = 0d0
if (nshiptxy > 0) then
if (allocated(xships)) deallocate(xships, yships, kships)
allocate ( xships(nshiptxy), yships(nshiptxy), kships(nshiptxy) , stat=ierr)
call aerr('xships(nshiptxy), yships(nshiptxy), kships(nshiptxy)', ierr, 3)
if (allocated(shx) ) deallocate ( xyship, shx, shy, shu, shv, shi, sho, zsp )
allocate ( xyship(2*nshiptxy), shx(nshiptxy), shy(nshiptxy), shu(nshiptxy), shv(nshiptxy), shi(nshiptxy), sho(nshiptxy) , stat= ierr)
call aerr('xyship(2*nshiptxy), shx(nshiptxy), shy(nshiptxy), shu(nshiptxy), shv(nshiptxy), shi(nshiptxy), sho(nshiptxy)', ierr, 4*nshiptxy)
allocate ( zsp(ndx) , stat = ierr )
call aerr ('zsp(ndx)', ierr, ndx )
allocate ( adve0(lnx) , stat = ierr )
call aerr ('adve0(lnx)', ierr, lnx )
iniship = 0 ; nshiptxy = 0 ; shx = 0d0 ; shy = 0d0; xyship = dmiss
endif
if (jased > 0) then
mx = size(grainlay,2)
allocate ( grainlayerthickness (mx,mxgr) , stat=ierr) ; grainlayerthickness = dmiss
else
mxgr = 0
endif
if (len_trim(md_extfile_new) > 0) then
success = initboundaryblocksforcings(md_extfile_new)
if (.not. success) then
iresult = DFM_WRONGINPUT
call mess(LEVEL_WARN, 'Error in external forcings file '''//trim(md_extfile_new)//'''.')
call qnerror('Error occurred while running, please inspect your diagnostic output.',' ', ' ')
goto 888
end if
endif
ja = 1
do while (ja .eq. 1) ! read *.ext file
call delpol() ! ook jammer dan
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja,sourcemask)
if (ja == 1) then
call mess(LEVEL_INFO, 'External Forcing or Initialising '''//trim(qid)//''' from file '''//trim(filename)//'''.')
! Initialize success to be .false.
success = .false.
call get_tracername(qid, tracnam, qidnam)
lenqidnam = len_trim(qidnam)
if (filetype == 7 .and. method == 4) then
method = 5 ! upward compatible fix
endif
kx = 1 ! voorlopig vectormax = 1
if (qid == 'frictioncoefficient') then
success = timespaceinitialfield(xu, yu, frcu, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
if (success) then
do L = 1,lnx
if (frcu(L) .ne. dmiss) then
if (transformcoef(3) == -999d0) then
transformcoef(3) = ifrctypuni
endif
if (operand == 'O') then ! 'O' also specifies friction type
if (int(transformcoef(3)) .ne. ifrctypuni ) then ! type array only must be used if different from uni
ifrcutp(L) = int( transformcoef(3) )
endif
endif
endif
enddo
endif
else if (qid == 'linearfrictioncoefficient') then
jafrculin = 1
success = timespaceinitialfield(xu, yu, frculin, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
else if (qid == 'horizontaleddyviscositycoefficient') then
if (javiusp == 0) then
if (allocated (viusp) ) deallocate(viusp)
allocate ( viusp(lnx) , stat=ierr )
call aerr('viusp(lnx)', ierr, lnx ) ; viusp = dmiss
javiusp = 1
endif
success = timespaceinitialfield(xu, yu, viusp, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
else if (qid == 'horizontaleddydiffusivitycoefficient') then
if (jadiusp == 0) then
if (allocated (diusp) ) deallocate(diusp)
allocate ( diusp(lnx) , stat=ierr )
call aerr('diusp(lnx)', ierr, lnx ) ; diusp = dmiss
jadiusp = 1
endif
success = timespaceinitialfield(xu, yu, diusp, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
else if (qid == 'windstresscoefficient') then
if (jaCdwusp == 0) then
if (allocated (Cdwusp) ) deallocate(Cdwusp)
allocate ( Cdwusp(lnx) , stat=ierr )
call aerr('Cdwusp(lnx)', ierr, lnx ) ; Cdwusp = dmiss
jaCdwusp = 1
endif
iCdtyp = 1 ! only 1 coeff
success = timespaceinitialfield(xu, yu, Cdwusp, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
else if (qid == 'advectiontype') then
success = timespaceinitialfield_int(xu, yu, iadv, lnx, filename, filetype, method, operand, transformcoef) ! zie meteo module
else if (qid == 'ibedlevtype') then ! Local override of bottomleveltype
success = timespaceinitialfield_int(xu, yu, ibot, lnx, filename, filetype, method, operand, transformcoef) ! zie meteo module
else if (qid == 'initialwaterlevel') then
success = timespaceinitialfield(xz, yz, s1, ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
else if (qid == 'initialvelocity') then ! both ucx and ucy component from map file in one QUANTITY
if (filetype /= ncflow) then ! only from our own map files
success = .false.
else
call realloc(uxini, lnx, fill=dmiss)
qid = 'initialvelocityx'
success = timespaceinitialfield(xu, yu, uxini, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
if (success) then
call realloc(uyini, lnx, fill=dmiss)
qid = 'initialvelocityy'
success = timespaceinitialfield(xu, yu, uyini, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
if (success) then
jainivel = 1
end if
end if
end if
else if (qid == 'initialvelocityx') then
call realloc(uxini, lnx, fill=dmiss)
success = timespaceinitialfield(xu, yu, uxini, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
if (success) then
jainivel = 1
end if
else if (qid == 'initialvelocityy') then
call realloc(uyini, lnx, fill=dmiss)
success = timespaceinitialfield(xu, yu, uyini, lnx, filename, filetype, method, operand, transformcoef, 1) ! zie meteo module
if (success) then
jainivel = 1
end if
else if (qid == 'initialunsaturedzonethickness') then
if (allocated (h_unsat) ) deallocate (h_unsat)
allocate (h_unsat(ndx)) ; h_unsat = dmiss
success = timespaceinitialfield(xz, yz, h_unsat, ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
if (success) then
do k = 1,ndx
if (h_unsat(k) == dmiss) then
h_unsat(k) = h_unsatini
else
h_unsat(k) = h_unsat(k) + 1d-4
endif
enddo
endif
else if (qid == '__bathymetry__') then ! this is for the D-Flow FM User interface!!!
success = timespaceinitialfield(xk, yk, zk, numk, filename, filetype, method, operand, transformcoef, 3) ! zie meteo module
else if (qid == 'bathymetry') then ! to suppress error message while actually doing this in geominit
success = .true.
else if (jasal > 0 .and. qid == 'initialsalinity') then
success = timespaceinitialfield(xz, yz, sa1, ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
if (success) then
inisal2D = 1
endif
else if (jasal > 0 .and. qid == 'initialsalinitytop') then
if (.not. allocated(satop) ) then
allocate(satop(ndx)) ; satop = dmiss
endif
success = timespaceinitialfield(xz, yz, satop, ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
if (success) then
inisal2D = 2
endif
else if (jatem > 0 .and. qid == 'initialtemperature') then
success = timespaceinitialfield(xz, yz, tem1, ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
if (success) then
initem2D = 1
endif
else if (jatem > 0 .and. qid == 'initialverticaltemperatureprofile') then
call setinitialverticalprofile(tem1, ndkx, filename) ; success = .true.
else if (jasal > 0 .and. qid == 'initialverticalsalinityprofile') then
call setinitialverticalprofile(sa1 , ndkx, filename) ; success = .true.
else if (qid(1:13) == 'initialtracer') then
call get_tracername(qid, tracnam, qidnam)
call add_tracer(tracnam, iconst) ! or just gets constituents number if tracer already exists
if ( allocated(viuh) ) deallocate(viuh)
allocate(viuh(Ndx))
! copy existing tracer values (if they existed) in temp array
do kk=1,Ndx
call getkbotktop(kk,kb,kt)
do k=kb,kb+kmxn(kk)-1
viuh = constituents(iconst,k)
end do
end do
success = timespaceinitialfield(xz, yz, viuh, Ndx, filename, filetype, method, operand, transformcoef, 2)
if (success) then
do kk = 1,Ndx
if (viuh(kk) .ne. dmiss) then
call getkbotktop(kk,kb,kt)
do k=kb,kb+kmxn(kk)-1
fff = constituents(iconst,k)
call operate(fff, viuh(kk) , operand)
constituents(iconst,k) = fff
end do
endif
enddo
endif
deallocate(viuh)
else if (qid == 'erodablelayerthicknessgrainsize1' .and. mxgr >= 1) then
if (jaceneqtr == 1) then
success = timespaceinitialfield(xz, yz, grainlayerthickness(1,1), ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
else
mx = size(grainlay,2)
success = timespaceinitialfield(xk, yk, grainlayerthickness(1,1), mx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
endif
jagrainlayerthicknessspecified = 1
else if (qid == 'erodablelayerthicknessgrainsize2' .and. mxgr >= 2) then
if (jaceneqtr == 1) then
success = timespaceinitialfield(xz, yz, grainlayerthickness(1,2), ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
else
mx = size(grainlay,2)
success = timespaceinitialfield(xk, yk, grainlayerthickness(1,2), mx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
endif
jagrainlayerthicknessspecified = 1
else if (qid == 'erodablelayerthicknessgrainsize3' .and. mxgr >= 3) then
if (jaceneqtr == 1) then
success = timespaceinitialfield(xz, yz, grainlayerthickness(1,3), ndx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
else
mx = size(grainlay,2)
success = timespaceinitialfield(xk, yk, grainlayerthickness(1,3), mx, filename, filetype, method, operand, transformcoef, 2) ! zie meteo module
endif
jagrainlayerthicknessspecified = 1
else if (qid == 'windx' .or. qid == 'windy' .or. qid == 'windxy') then
if (.not. allocated(wx) ) then
if ( allocated (kcw) ) deallocate(kcw) ; allocate( kcw(lnx) )
allocate ( wx(lnx), wy(lnx), stat=ierr) ; wx = 0 ; wy = 0 ; kcw = 1
call aerr('wx(lnx), wy(lnx)', ierr, 3*lnx)
endif
if (len_trim(sourcemask)>0) then
success = ec_addtimespacerelation(qid, xu(1:lnx), yu(1:lnx), kcw, kx, filename, filetype, method, operand, srcmaskfile=sourcemask)
else
success = ec_addtimespacerelation(qid, xu(1:lnx), yu(1:lnx), kcw, kx, filename, filetype, method, operand)
endif
if (success) jawind = 1
else if (qid == 'airpressure_windx_windy') then
if (.not. allocated(patm) ) then
allocate ( patm(ndx) , stat=ierr) ; patm = 100000d0
call aerr('patm(ndx)', ierr, ndx)
endif
if (.not. allocated(wx) ) then
allocate ( wx(lnx), wy(lnx) , stat=ierr) ; wx = 0d0 ; wy = 0d0
call aerr('wx(lnx), wy(lnx)', ierr, 2*lnx)
endif
if (.not. allocated(ec_pwxwy_x) ) then
allocate ( ec_pwxwy_x(ndx) , ec_pwxwy_y(ndx) , kcw(ndx) , stat=ierr) ; ec_pwxwy_x = 0d0 ; ec_pwxwy_y = 0d0 ; kcw = 1d0
call aerr('ec_pwxwy_x(ndx) , ec_pwxwy_y(ndx) ,kcw(ndx)', ierr, 3*ndx)
endif
if (len_trim(sourcemask)>0) then
success = ec_addtimespacerelation(qid, xz(1:ndx), yz(1:ndx), kcw, kx, filename, filetype, method, operand, srcmaskfile=sourcemask)
else
success = ec_addtimespacerelation(qid, xz(1:ndx), yz(1:ndx), kcw, kx, filename, filetype, method, operand)
endif
if (success) then
jawind = 1 ; japatm = 1
endif
else if (qid == 'humidity_airtemperature_cloudiness') then
! Meteo1
kx = 3
if (allocated (kcw) ) deallocate(kcw) ; allocate( kcw(ndx) ) ; kcw = 1
jatair = 3 ; jarhum = 3 ; jaclou = 3 ; jasol = 2 ! flag all three in one line
success = ec_addtimespacerelation(qid, xz(1:ndx), yz(1:ndx), kcw, kx, filename, filetype, method, operand) ! vectormax=3
else if (qid == 'humidity_airtemperature_cloudiness_solarradiation') then
! Meteo1
kx = 4
if (allocated (kcw) ) deallocate(kcw) ; allocate( kcw(ndx) ) ; kcw = 1
jatair = 3 ; jarhum = 3 ; jaclou = 3 ; jasol = 1 ! flag all four in one line
success = ec_addtimespacerelation(qid, xz(1:ndx), yz(1:ndx), kcw, kx, filename, filetype, method, operand) ! vectormax = 4
else if (qidnam(max(1,lenqidnam-2):lenqidnam) == 'bnd') then ! All-in-one handler for boundary qids
success = addtimespacerelation_boundaries(qid, filename, filetype, method, operand)
else if (qid == 'atmosphericpressure') then
if (.not. allocated(patm) ) then
allocate ( patm(ndx) , stat=ierr) ; patm = 0d0
call aerr('patm(ndx)', ierr, ndx)
endif
success = ec_addtimespacerelation(qid, xz, yz, kcs, kx, filename, filetype, method, operand)
if (success) then
japatm = 1
endif
else if (qid(1:8) == 'rainfall' ) then
if (.not. allocated(rain) ) then
allocate ( rain(ndx) , stat=ierr) ; rain = 0d0
call aerr('rain(ndx)', ierr, ndx)
endif
success = ec_addtimespacerelation(qid, xz, yz, kcs, kx, filename, filetype, method, operand)
if (success) then
jarain = 1
jaqin = 1
endif
else if (jaoldstr > 0 .and. qid == 'gateloweredgelevel' ) then
call selectelset_internal_links( filename, filetype, xz, yz, ln, lnx, keg(ngate+1:numl), numg )
success = .true.
WRITE(msgbuf,'(a,1x,a,i8,a)') trim(qid), trim(filename) , numg, ' nr of gate links' ; call msg_flush()
ngatesg = ngatesg + 1
call realloc(L1gatesg,ngatesg) ; L1gatesg(ngatesg) = ngate + 1
call realloc(L2gatesg,ngatesg) ; L2gatesg(ngatesg) = ngate + numg
ngate = ngate + numg
else if (jaoldstr > 0 .and. qid == 'damlevel' ) then
call selectelset_internal_links( filename, filetype, xz, yz, ln, lnx, ked(ncdam+1:numl), numd )
success = .true.
WRITE(msgbuf,'(a,1x,a,i8,a)') trim(qid), trim(filename) , numd, ' nr of dam level cells' ; call msg_flush()
ncdamsg = ncdamsg + 1
call realloc(L1cdamsg,ncdamsg) ; L1cdamsg(ncdamsg) = ncdam + 1
call realloc(L2cdamsg,ncdamsg) ; L2cdamsg(ncdamsg) = ncdam + numd
ncdam = ncdam + numd
else if (jaoldstr > 0 .and. qid == 'generalstructure' ) then
call selectelset_internal_links( filename, filetype, xz, yz, ln, lnx, kegen(ncgen+1:numl), numgen )
success = .true.
WRITE(msgbuf,'(a,1x,a,i8,a)') trim(qid), trim(filename) , numgen, ' nr of general structure cells' ; call msg_flush()
ncgensg = ncgensg + 1
call realloc(L1cgensg,ncgensg) ; L1cgensg(ncgensg) = ncgen + 1
call realloc(L2cgensg,ncgensg) ; L2cgensg(ncgensg) = ncgen + numgen
ncgen = ncgen + numgen
else if (jaoldstr > 0 .and. (qid == 'pump1D' .or. qid == 'pump') ) then
if (qid == 'pump1D') then
call selectelset_internal_links( filename, filetype, xz, yz, ln, lnx1D, kep(npump+1:numl), npum )
else
call selectelset_internal_links( filename, filetype, xz, yz, ln, lnx, kep(npump+1:numl), npum )
endif
success = .true.
WRITE(msgbuf,'(a,1x,a,i8,a)') trim(qid), trim(filename) , npum, ' nr of pump links' ; call msg_flush()
npumpsg = npumpsg + 1
call realloc(L1pumpsg,npumpsg) ; L1pumpsg(npumpsg) = npump + 1
call realloc(L2pumpsg,npumpsg) ; L2pumpsg(npumpsg) = npump + npum
npump = npump + npum
else if (qid == 'discharge_salinity_temperature_sorsin') then
! 1. Prepare source-sink location (will increment numsrc, and prepare geometric position), based on .pli file (transformcoef(4)=AREA).
call addsorsin(filename, transformcoef(4), ierr )
if (ierr /= DFM_NOERR) then
success = .false.
else
success = .true.
end if
! 2. Time series hookup is done below, once counting of all numsrc is done.
else if (qid == 'shiptxy') then
kx = 2
nshiptxy = nshiptxy + 1
! Converter will put 'x' in array(2*nshiptxy-1) and 'y' in array(2*nshiptxy).
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename, filetype, method, operand, targetIndex = nshiptxy)
else if (qid == 'movingstationtxy') then
kx = 2
rec = ' '
call basename(filename, rec) ! rec now contains the station name.
call addMovingObservation(dmiss, dmiss, rec)
! Converter will put 'x' in array(2*nummovobs-1) and 'y' in array(2*nummovobs).
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename, filetype, method, operand, targetIndex=nummovobs)
else if (trim(qid) == "spiderweb") then
call qnerror(' ', 'Quantity SPIDERWEB must be renamed to airpressure_windx_windy in the ext-file.', ' ')
success = .false.
else if (trim(qid) == "windx_windy_airpressure") then
call qnerror(' ', 'Quantity WINDX_WINDY_AIRPRESSURE must be renamed to airpressure_windx_windy in the ext-file.', ' ')
success = .false.
else
call mess(LEVEL_WARN, 'Reading *.ext forcings file '''//trim(md_extfile)//''', getting unknown QUANTITY '//trim(qid) )
call qnerror('Reading *.ext forcings file '''//trim(md_extfile)//''', ', ' getting unknown QUANTITY ', trim(qid) )
success = .false.
endif
if (.not. success) then
rec = getmeteoerror()
if (len_trim(rec) > 0) then
call mess(LEVEL_WARN, rec)
end if
! We do a direct goto 888 end, so qnerror for GUI is allowed here.
call qnerror('flow_initexternalforcings: Error while initializing quantity: ', qid, 'Check preceding log lines for details.')
iresult = DFM_EXTFORCERROR
goto 888
endif
endif
enddo
if (ngate == 0) ngatesg = 0
if (ncdam == 0) ncdamsg = 0
if (npump == 0) npumpsg = 0
! initialise water level of 1d2d boundary points
if (nbnd1d2d>0) then
call init_1d2d_boundary_points()
endif
if (jaoldstr > 0 .and. ngate > 0) then
if (allocated (kgate) ) deallocate(kgate)
if (allocated (xgate) ) deallocate(xgate)
if (allocated (ygate) ) deallocate(ygate)
if (allocated (zgate) ) deallocate(zgate)
allocate ( xgate(ngatesg), ygate(ngatesg), zgate(ngatesg), xy2gate(2,ngatesg), kgate(3,ngate), kdg(ngatesg) , stat=ierr )
call aerr('xgate(ngatesg), ygate(ngatesg), zgate(ngatesg), xy2gate(2,ngatesg), kgate(3,ngate), kdg(ngatesg)',ierr, ngate*10 )
kgate = 0d0; zgate = 1d10; kdg = 1
if ( allocated(gate_ids) ) deallocate( gate_ids )
allocate( gate_ids(ngatesg) )
do n = 1, ngatesg
do k = L1gatesg(n), L2gatesg(n)
Lf = iabs(keg(k))
kb = ln(1,Lf)
kbi = ln(2,Lf)
kgate(1,k) = kb
kgate(2,k) = kbi
kgate(3,k) = Lf
xgate(n) = xz(kb)
ygate(n) = yz(kb)
xy2gate(1,n) = xz(kbi)
xy2gate(2,n) = yz(kbi)
call setfixedweirscheme3onlink(Lf)
enddo
enddo
ja = 1 ; rewind (mext); kx = 1
ngatesg = 0
do while (ja .eq. 1) ! for gates again postponed read *.ext file
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. qid == 'gateloweredgelevel') then
ngatesg = ngatesg + 1
! Prepare time series relation, if the .pli file has an associated .tim file.
L = index(filename,'.', back=.true.) - 1
filename0 = filename(1:L)//'_0001.tim'
gate_ids(ngatesg) = filename(1:L)
inquire (file = trim(filename0), exist = exist)
if (exist) then
filetype0 = uniform ! uniform=single time series vectormax = 1
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename0, filetype0, method=spaceandtime, operand='O', targetIndex=ngatesg)
end if
endif
enddo
endif
if (jaoldstr > 0 .and. ncdamsg > 0) then
if (allocated (xcdam) ) deallocate( xcdam)
if (allocated (ycdam) ) deallocate( ycdam)
if (allocated (zcdam) ) deallocate( zcdam)
if (allocated (kcdam) ) deallocate( kcdam)
allocate ( xcdam(ncdamsg), ycdam(ncdamsg), zcdam(ncdamsg), xy2cdam(2,ncdamsg), kcdam(3,ncdam), kdd(ncdamsg) , stat=ierr )
call aerr('xcdam(ncdamsg), ycdam(ncdamsg), zcdam(ncdamsg), xy2cdam(2,ncdamsg), kcdam(3,ncdam), kdd(ncdamsg)',ierr, ncdam*10 )
kcdam = 0d0; zcdam = 1d10; kdd = 1
if ( allocated( cdam_ids ) ) deallocate( cdam_ids )
allocate( cdam_ids(ncdamsg) )
do n = 1, ncdamsg
do k = L1cdamsg(n), L2cdamsg(n)
Lf = iabs(ked(k))
kb = ln(1,Lf)
kbi = ln(2,Lf)
kcdam(1,k) = kb
kcdam(2,k) = kbi
kcdam(3,k) = Lf
xcdam(n) = xz(kb)
ycdam(n) = yz(kb)
xy2cdam(1,n) = xz(kbi)
xy2cdam(2,n) = yz(kbi)
!do kk = 1, nd(kb)%lnx ! old: ifixedweirscheme == 1
! L = iabs(nd(kb)%ln(kk))
! iadv(L) = 10
!enddo
call setfixedweirscheme3onlink(Lf)
enddo
enddo
ja = 1 ; rewind (mext); kx = 1
ncdamsg = 0
do while (ja .eq. 1) ! for cdams again postponed read *.ext file
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. qid == 'damlevel') then
ncdamsg = ncdamsg + 1
! Prepare time series relation, if the .pli file has an associated .tim file.
L = index(filename,'.', back=.true.) - 1
filename0 = filename(1:L)//'_0001.tim'
cdam_ids(ncdamsg) = filename(1:L)
inquire (file = trim(filename0), exist = exist)
if (exist) then
filetype0 = uniform ! uniform=single time series vectormax = 1
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename0, filetype0, method=spaceandtime, operand='O', targetIndex=ncdamsg)
end if
! success = ec_addtimespacerelation(qid, xcdam, ycdam, kdd, filename, filetype, method, operand, xy2cdam)
endif
enddo
endif
if (jaoldstr > 0 .and. ncgensg > 0) then
if (allocated (xcgen) ) deallocate( xcgen, ycgen, zcgen)
if (allocated (kcgen) ) deallocate( kcgen) ; kx = 3
allocate ( xcgen(ncgensg), ycgen(ncgensg), zcgen(ncgensg*kx), xy2cgen(2,ncgensg), kcgen(4,ncgen), kdgen(ncgensg) , stat=ierr )
call aerr('xcgen(ncgensg), ycgen(ncgensg), zcgen(ncgensg*kx), xy2cgen(2,ncgensg), kcgen(4,ncgen), kdgen(ncgensg)',ierr, ncgen*10 )
kcgen = 0d0; zcgen = 1d10; kdgen = 1
if (allocated(fusav)) deallocate(fusav)
if (allocated(rusav)) deallocate(rusav)
if (allocated(ausav)) deallocate(ausav)
allocate( Fusav(2,ncgen), Rusav(2,ncgen), Ausav(2,ncgen) , stat = ierr ) ; Fusav = 0d0 ; Rusav = 0d0 ; ausav = 0d0
if ( allocated(cgen_ids) ) deallocate( cgen_ids )
allocate( cgen_ids(ncgensg) )
do n = 1, ncgensg
! Temp array width wu(L) values for all links under a single general structure
call realloc(widths, L2cgensg(n)-L1cgensg(n)+1)
! Here allocate the structure ids for generalstructuyre
do k = L1cgensg(n), L2cgensg(n)
Lf = iabs(kegen(k))
widths(k-L1cgensg(n)+1) = wu(Lf)
kb = ln(1,Lf)
kbi = ln(2,Lf)
if (kegen(k) > 0) then
kcgen(1,k) = kb
kcgen(2,k) = kbi
else
kcgen(1,k) = kbi ! Store point left of the structure in kcgen(1,*) (in this case opposite to flow link, so kcgen(1,k)==ln(2,Lf)
kcgen(2,k) = kb
end if
kcgen(3,k) = Lf
kcgen(4,k) = n ! pointer to general structure signal nr n
xcgen(n) = xz(kb)
ycgen(n) = yz(kb)
xy2cgen(1,n) = xz(kbi)
xy2cgen(2,n) = yz(kbi)
call setfixedweirscheme3onlink(Lf)
iadv(Lf) = 22 ! iadv = general
enddo
enddo
allocate( hulp(25,ncgensg) ) ; hulp = dmiss
ja = 1
rewind (mext)
kx = 3
ncgensg = 0
do while (ja .eq. 1) ! for cgens again postponed read *.ext file
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. qid == 'generalstructure') then
ncgensg = ncgensg + 1
! Prepare time series relation, if the .pli file has an associated .tim file.
L = index(filename,'.', back=.true.) - 1
filename0 = filename(1:L)//'_0001.tim'
cgen_ids(ncgensg) = filename(1:L)
inquire (file = trim(filename0), exist = exist)
if (exist) then
filetype0 = uniform ! uniform=single time series vectormax = kx = 3
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename0, filetype0, method=spaceandtime, operand='O', targetIndex=ncgensg)
end if
!success = ec_addtimespacerelation(qid, xcgen, ycgen, kdgen, filename, filetype, method, operand, xy2cgen, targetIndex=(ncgensg-1)*3+1)
hulp(:,ncgensg) = transformcoef(:)
endif
enddo
if ( allocated(generalstruc) ) deallocate (generalstruc)
allocate (generalstruc(ncgensg) )
if ( allocated(cgen_type) ) deallocate (cgen_type)
allocate (cgen_type(ncgensg) )
cgen_type(1:ncgensg) = ICGENTP_GENSTRU ! We only have true fully parameterized general structures from old ext file
do n = 1, ncgensg
call togeneral(n, hulp(:,n), L2cgensg(n)-L1cgensg(n)+1,widths)
enddo
deallocate( hulp )
deallocate(widths)
endif
if (jaoldstr > 0 .and. npump > 0) then
if (allocated (xpump) ) deallocate( xpump)
if (allocated (ypump) ) deallocate( ypump)
if (allocated (qpump) ) deallocate( qpump)
if (allocated (kpump) ) deallocate( kpump)
allocate ( xpump(npumpsg), ypump(npumpsg), qpump(npumpsg), xy2pump(2,npumpsg), kpump(3,npump), kdp(npumpsg) , stat=ierr )
call aerr('xpump(npumpsg), ypump(npumpsg), qpump(npumpsg), xy2pump(2,npumpsg), kpump(3,npump), kdp(npumpsg)',ierr, npump*10 )
kpump = 0d0; qpump = 0d0; kdp = 1
if ( allocated( pump_ids ) ) deallocate( pump_ids )
allocate( pump_ids(npumpsg) ) ! TODO: names are not stored here yet (they are in init_structure_control, but not for old ext file)
do n = 1, npumpsg
do k = L1pumpsg(n), L2pumpsg(n)
L = kep(k)
Lf = iabs(L)
if (L > 0) then
kb = ln(1,Lf)
kbi = ln(2,Lf)
else
kb = ln(2,Lf)
kbi = ln(1,Lf)
endif
kpump(1,k) = kb
kpump(2,k) = kbi
kpump(3,k) = L ! f
xpump(n) = xz(kb)
ypump(n) = yz(kb)
xy2pump(1,n) = xz(kbi)
xy2pump(2,n) = yz(kbi)
enddo
enddo
ja = 1 ; rewind (mext); kx = 1
do while (ja .eq. 1) ! for pumps again postponed read *.ext file
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. ( qid == 'pump1D' .or. qid == 'pump') ) then
qid = 'pump'
success = ec_addtimespacerelation(qid, xpump, ypump, kdp, kx, filename, filetype, method, operand, xy2pump)
endif
enddo
endif
if (numsrc > 0) then
if (allocated(xdum )) deallocate(xdum, ydum, kdum, xy2dum)
allocate ( xdum(1), ydum(1), kdum(1), stat=ierr) ! Filetype is timeseries: uniform in space.
xdum = 1d0 ; ydum = 1d0; kdum = 1
ja = 1 ; rewind (mext)
kx = 3
! TODO: UNST-537/UNST-190: we now support timeseries, the constant values should come from new format ext file, not from transformcoef
numsrc = 0
do while (ja .eq. 1) ! for sorsin again read *.ext file
call readprovider(mext,qid,filename,filetype,method,operand,transformcoef,ja)
if (ja == 1 .and. qid == 'discharge_salinity_temperature_sorsin') then
numsrc = numsrc + 1
! 2. Prepare time series relation, if the .pli file has an associated .tim file.
L = index(filename,'.', back=.true.) - 1
filename0 = filename(1:L)//'.tim'
inquire (file = trim(filename0), exist = exist)
if (exist) then
filetype0 = uniform ! uniform=single time series vectormax = ..
! Converter will put 'qsrc, sasrc and tmsrc' values in array qstss on positions: (3*numsrc-2), (3*numsrc-1), and (3*numsrc), respectively.
success = ec_addtimespacerelation(qid, xdum, ydum, kdum, kx, filename0, filetype0, method=spaceandtime, operand='O', targetIndex=numsrc)
else
success = .true. ! TODO: now, this is no error, because sorsin values will be handled below as transformcoef. Long term solution: only support timeseries??
endif
endif
enddo
endif
if (loglevel_StdOut == LEVEL_DEBUG) then
call ecInstancePrintState(ecInstancePtr,6)
endif
if (.not. success) then
iresult = DFM_EXTFORCERROR
goto 888
end if
! Cleanup:
888 continue
if (jafrculin == 0) then
deallocate(frculin)
endif
if (allocated(kez)) then ! mext > 0 .or. len_trim(md_extfile_new) > 0) then
deallocate ( kez, keu, kes, ketm, kesd, ket, keuxy, ken, ke1d2d, keg, ked, kep, kegs, kegen, itpez, itpenz, itpeu, itpenu, kew, ketr)
end if
if (mext > 0) then
call doclose(mext) ! close ext file
end if
if (allocated (xdum)) deallocate( xdum, ydum, kdum)
if (allocated (kdz)) deallocate (kdz)
if (allocated (kdu)) deallocate (kdu)
if (allocated (kds)) deallocate (kds)
if (allocated (kdTM)) deallocate (kdTM)
if (allocated (kdw)) deallocate (kdw)
if (allocated (kdsd)) deallocate (kdsd)
! if (allocated (kdtr)) deallocate (kdtr)
if (allocated (kdt)) deallocate (kdt)
if (allocated (kduxy)) deallocate (kduxy)
if (allocated (kdn)) deallocate (kdn)
if (allocated (kdg)) deallocate (kdg)
if (allocated (kdd)) deallocate (kdd)
if (allocated (kdgen)) deallocate (kdgen)
if (allocated (kdp)) deallocate (kdp)
if (allocated (kdss)) deallocate (kdss)
if (allocated (xy2gate) ) deallocate (xy2gate)
if (allocated (xy2cdam) ) deallocate (xy2cdam)
if (allocated (xy2cgen) ) deallocate (xy2cgen)
if (allocated (xy2pump) ) deallocate (xy2pump)
if (allocated (xships) ) deallocate (xships)
if (allocated (yships) ) deallocate (yships)
if (allocated (kships) ) deallocate (kships)
if (allocated (xdum) ) deallocate( xdum, ydum, kdum, xy2dum)
if (jasol == 2) then
if (allocated (qrad) ) deallocate (qrad)
endif
if (mxgr > 0 .and. .not.stm_included) then
do j = 1,mxgr
grainlay(j,:) = uniformerodablethickness(j)
enddo
if (jagrainlayerthicknessspecified == 1) then
do k = 1,size(grainlay,2)
do j = 1,mxgr
if (grainlayerthickness(k,j) .ne. dmiss) then
grainlay(j,k) = grainlayerthickness(k,j)
endif
enddo
enddo
deallocate (grainlayerthickness)
else
endif
endif
if (jawind == 0) then
if (jawave < 3) then
jawave = 0 ! no wind, no waves
call mess(LEVEL_INFO, 'No wind, so waves is switched off ')
endif
if (jatem > 1) then
jatem = 1 ! no wind, no heat model temperature
call mess(LEVEL_INFO, 'No wind ?? => no heat model !')
endif
endif
if (javiusp == 1) then
do L = 1,lnx
if (viusp(L) == dmiss) then
viusp(L) = vicouv
endif
enddo
endif
if (jadiusp == 1) then
do L = 1,lnx
if (diusp(L) == dmiss) then
diusp(L) = dicouv
endif
enddo
endif
if (jainivel == 1) then
do L=1,lnx
if (uxini(L) == dmiss .and. uyini(L) == dmiss) then
cycle
end if
u1(L) = uxini(L)*csu(L) + uyini(L)*snu(L)
if (kmx > 0) then ! Basic 3D initialization: entire water column same horizontal velocities u1.
call getLbotLtop(LL,Lb,Lt)
u1(Lb:Lt) = u1(L)
end if
end do
end if
if (allocated(uxini)) deallocate(uxini)
if (allocated(uyini)) deallocate(uyini)
if ( jampi.eq.1 ) then
! see if one or more discharge boundaries are partioned
call set_japartqbnd()
call mess(LEVEL_WARN,'One or more discharge boundaries are partitioned.')
else
japartqbnd = 0
end if
end function flow_initexternalforcings
subroutine setinitialverticalprofile(yy,ny,filename) ! polyfil
use m_flowgeom
use m_flow
use m_polygon
implicit none
integer :: ny
double precision :: xx(kmxx)
double precision :: yy(ny)
character(*), intent(in) :: filename ! file name for polygonfile
integer :: minp0, n, k, kb, kt, ktx
call oldfil(minp0, filename)
call savepol()
call reapol(minp0, 0)
do n=1,ndxi
call getkbotktop(n,kb,kt)
do k = kb, kt
xx(k-kb+1) = 0.5d0*( zws(k) + zws(k-1) )
enddo
ktx = kt-kb + 1
call lineinterp(xx, yy(kb:), ktx, xpl, ypl, npl)
enddo
call restorepol()
end subroutine setinitialverticalprofile
subroutine lineinterp(xx, yy, ktx, x,y,n)
implicit none
integer :: ktx, n, k, ip
double precision :: xx(ktx), yy(ktx), x(n), y(n)
double precision :: a, b
ip = 1
do k = 1, ktx
do while ( xx(k) > x(ip+1) .and. ip < n-1 )
ip = ip + 1
enddo
if ( xx(k) <= x(ip) ) then
yy(k) = y(ip)
else if ( xx(k) > x(ip) .and. xx(k) <= x(ip+1) ) then
a = ( xx(k) - x(ip) ) / max( 1d-4 , x(ip+1) - x(ip) ) ; b = 1d0 - a
yy(k) = b*y(ip) + a*y(ip+1)
else
yy(k) = y(ip+1)
endif
enddo
end subroutine lineinterp
subroutine lineinterp3(xx, yy, zz, vv, ktx, x,y,z,v,n)
implicit none
integer :: ktx, n, k, ip
double precision :: xx(ktx), yy(ktx), zz(ktx), vv(ktx)
double precision :: x(n) , y(n) , z(n) , v(n)
double precision :: a, b
ip = 1
do k = 1, ktx
do while ( xx(k) > x(ip+1) .and. ip < n-1 )
ip = ip + 1
enddo
if ( xx(k) <= x(ip) ) then
yy(k) = y(ip)
zz(k) = z(ip)
vv(k) = v(ip)
else if ( xx(k) > x(ip) .and. xx(k) <= x(ip+1) ) then
a = ( xx(k) - x(ip) ) / max( 1d-4 , x(ip+1) - x(ip) ) ; b = 1d0 - a
yy(k) = b*y(ip) + a*y(ip+1)
zz(k) = b*z(ip) + a*z(ip+1)
vv(k) = b*v(ip) + a*v(ip+1)
else
yy(k) = y(ip+1)
zz(k) = z(ip+1)
vv(k) = v(ip+1)
endif
enddo
end subroutine lineinterp3
subroutine update_verticalprofiles()
!c************************************************************************
!c
!c D e l f t H y d r a u l i c s - Section M-C-M
!c
!c Module: based on Subroutine tratur in DPM
!c Function: Transport solver tke and epsilon plus vertical momentum exchange u0
!c Method used: Teta method for integration in time.
!c Tke and eps computed at layer interfaces.
!c SANCTUM
!c Date: 13:26 dinsdag 4 augustus 1998
!c Programmer: R.E. Uittenbogaard
!c************************************************************************
!c hk: please communicate all other turbulence, waves, vegetation, internal waves, through tkedis and tkepro arrays
use m_flow
use m_flowgeom
use m_partitioninfo
use m_flowtimes
implicit none
double precision :: tetm1, pransm, pransmi, dz0, dzc1, dzc2, zb1, zb2, tkedisL, tkeproL
double precision :: vicu, vicd, difu, difd, fac, dzdz1, dzdz2, s2, sourtu, sinktu, bet, ybot, rhom, drhodz
double precision :: uave, ustar, zz, sqcf, frcn, cz,z00, uave2, ac1, ac2, dzLw, sqcf3, ustar3, tkebot, tkesur, epsbot, epssur, volu
double precision :: hdzb, hdzs, dtiL, hdz, adv, omega1, omega2, omegu, drhodz1, drhodz2, rhomea, sousin
double precision :: dzu(kmxx), dzw(kmxx), womegu(kmxx)
double precision :: gradk, gradt, grad, gradd, gradu, volki, arLL, qqq
double precision :: cfuhi3D, vicwmax, tkewin, zint, z1, vicwww, alfaT, tke, eps, tttctot
integer :: k, ku, kd, kb, kt, n, kbn, kbn1, kn, knu, kk, kbk, ktk, kku, LL, L, Lb, Lt, kxL, Lu, Lb0, kb0
integer :: k1, k2, k1u, k2u, n1, n2, ifrctyp, ierr, jadrhodz = 1, kup, ierror
if (iturbulencemodel <= 0 .or. kmx == 0) return
if (iadvec == 0) then
javau = 0
endif
if (iturbulencemodel == 1) then ! 1=constant
! vicwwu = vicoww
!$OMP PARALLEL DO &
!$OMP PRIVATE(LL,Lb,Lt,kxL,dzu,L,k,hdzb,z00,ac1,ac2,n1,n2,zb1,zb2,k1,k2,omega1,omega2,volu,womegu)
do LL = 1,lnx
if ( hu(LL) > 0d0 ) then
Lb = Lbot(LL) ! bed layer index
Lt = Ltop(LL) ! surface layer index = surface interface index
kxL = Lt-Lb+1 ! nr of layers
dzu(1) = hu(Lb)
do L = Lb + 1, Lt ! layer thickness at layer center
k = L - Lb + 1
dzu(k) = hu(L) - hu(L-1)
enddo
call getustbcfuhi( LL,Lb,ustb(LL),cfuhi(LL),hdzb, z00, cfuhi3D)
advi(Lb) = advi(Lb)+cfuhi3D
if (javau > 0) then
ac1 = acL(LL) ; ac2 = 1d0-ac1
n1 = ln(1,LL) !; zb1 = zws(kbot(n1)-1)
n2 = ln(2,LL) !; zb2 = zws(kbot(n2)-1)
do L = Lb , Lt-1 ! vertical omega velocity at layer interface u point
k1 = ln(1,L) ; k2 = ln(2,L)
if (n1 > ndxi) then ! for open boundaries only look inside
omega1 = 0d0 ; ac1 = 0d0; ac2 = 1d0
else
omega1 = qw(k1) / a1(n1)
endif
omega2 = qw(k2) / a1(n2)
k = L - Lb + 1
womegu(k) = ac1*omega1 + ac2*omega2
enddo
womegu(Lt-Lb+1) = 0d0 ! top layer : 0
endif
call vertical_profile_u0( dzu, womegu, Lb, Lt, kxL, LL)
endif
enddo
!$OMP END PARALLEL DO
else if (iturbulencemodel == 2) then ! 2=algebraic , just testing 1D flow
!$xOMP PARALLEL DO &
!$xOMP PRIVATE(LL,Lb,Lt,kxL,dzu,frcn,L,k,Cz,z00,sqcf,zz,n1,n2,zb1,zb2,volu)
do LL = 1,lnx
if ( hu(LL) > 0d0 ) then
Lb = Lbot(LL) ! bed layer index
Lt = Ltop(LL) ! surface layer index = surface interface index
kxL = Lt-Lb+1 ! nr of layers
dzu(1) = hu(Lb)
do L = Lb + 1, Lt ! layer thickness at layer center
k = L - Lb + 1
dzu(k) = hu(L) - hu(L-1)
enddo
call getustbcfuhi( LL,Lb,ustb(LL),cfuhi(LL),hdzb, z00, cfuhi3D)
advi(Lb) = advi(Lb)+cfuhi3D
if (javau > 0) then
ac1 = acL(LL) ; ac2 = 1d0-ac1
n1 = ln(1,LL) ; !zb1 = zws(kbot(n1)-1)
n2 = ln(2,LL) ; !zb2 = zws(kbot(n2)-1)
do L = Lb , Lt-1 ! vertical omega velocity at layer interface u point
k1 = ln(1,L) ; k2 = ln(2,L)
if (n1 > ndxi) then ! for open boundaries only look inside
omega1 = 0d0 ; ac1 = 0d0; ac2 = 1d0
else
omega1 = qw(k1) / a1(n1)
endif
omega2 = qw(k2) / a1(n2)
k = L - Lb + 1
womegu(k) = ac1*omega1 + ac2*omega2
enddo
womegu(Lt-Lb+1) = 0d0 ! top layer : 0
endif
vicwwu(Lb-1) = 0d0
do L = Lb, Lt
zz = hu(L)*( 1d0 - hu(L)/ hu(LL) ) ! parabolic
! zz = hu(L)*sqrt( ( 1d0 - hu(L)/ hu(LL) ) ) ! Bakhmetev
vicwwu(L) = zz * ustb(LL) * vonkar
enddo
call vertical_profile_u0( dzu, womegu, Lb, Lt, kxL, LL)
endif
enddo
!$xOMP END PARALLEL DO
else if (iturbulencemodel >= 3) then ! 3=k-epsilon
if (javakeps > 0 ) then ! transport switched on: prepare horizontal advection k and eps
call linkstocenterstwodoubles2(turkinepsws, turkin1, tureps1)
if ( jampi.eq.1 ) then
call update_ghosts(ITYPE_Sall3D, 2, Ndkx, turkinepsws, ierror)
end if
tqcu = 0d0 ; eqcu = 0d0 ; sqcu = 0d0
javatest = 0
if (javatest == 3) then
if (.not. allocated (tttu) ) then
allocate ( tttu(lnkx), ttqc(ndkx), tttc(ndkx) ) ; tttu = 0d0
call getLbotLtop(lnx/2,Lb,Lt)
do L = Lb,Lt
tttu = 1d0
enddo
endif
call linkstocenterstwodoubles(tttc, tttu)
tttctot = 0d0
do n = 1,ndxi
call getkbotktop(n,kb,kt)
do k = kb,kt
tttctot = tttctot + tttc(k)*vol1(k)
enddo
enddo
ttqc = 0d0
endif
do LL = 1,lnx
call getLbotLtop(LL,Lb,Lt)
do L = Lb,Lt-1
k1 = ln(1,L) ; k2 = ln(2,L)
qqq = 0.5d0*(q1(L)+q1(L+1))
if (qqq > 0) then ! set upwind center values on links
tqcu(k2) = tqcu(k2) + qqq*turkinepsws(1,k1)
eqcu(k2) = eqcu(k2) + qqq*turkinepsws(2,k1)
if (javatest == 3) ttqc(k2) = ttqc(k2) + qqq*tttc(k1)
sqcu(k2) = sqcu(k2) + qqq
else if (qqq < 0) then
tqcu(k1) = tqcu(k1) - qqq*turkinepsws(1,k2)
eqcu(k1) = eqcu(k1) - qqq*turkinepsws(2,k2)
if (javatest == 3) ttqc(k1) = ttqc(k1) - qqq*tttc(k2)
sqcu(k1) = sqcu(k1) - qqq
endif
enddo
enddo
endif
tetm1 = 1d0-tetavkeps
pransmi = 1d0 / sigtke ! 1 / Prandtl Schmidt number Tke
dtiL = 1d0 / dtprev ! turbulence transport in current velocity field => do not use new timestep but previous step
!$xOMP PARALLEL DO &
!$xOMP PRIVATE(LL,Lb,Lt,Lb0,kxL,L,k,dzu,dzw,hdzb,z00,tkebot,tkesur) &
!$xOMP PRIVATE(ak,bk,ck,dk,ek,vicu,vicd,dzdz1,dzdz2,difu,difd,Lu,ku) &
!$xOMP PRIVATE(k1,k2,k1u,k2u,drhodz,drhodz1,drhodz2,dzc1,dzc2,bruva,buoflu,dijdij) &
!$xOMP PRIVATE(sourtu,sinktu,tkedisL,ac1,ac2,n1,n2,womegu,omega1,omega2,adv,omegu ) &
!$xOMP PRIVATE(gradd,gradu,gradt,gradk,grad)
do LL = 1,lnx ! all this at velocity points
Lt = Ltop(LL) ! surface layer index = surface interface index
Lb = Lbot(LL) ! bed layer index
Lb0 = Lb - 1 ! bed interface index
if (hu(LL) > 0) then
kxL = Lt-Lb+1 ! nr of layers
do L = Lb, Lt ! layer thickness at layer center (org: Lb + 1)
k = L - Lb + 1
!k1 = ln(1,L) ; k2 = ln(2,L)
!dzu(k) = acl(LL)*(zws(k1)-zws(k1-1)) + (1d0-acl(LL))*(zws(k2)-zws(k2-1))
dzu(k) = hu(L) - hu(L-1)
if (dzu(k) < 1d-10) then
call qnerror('duz(k) < 1d-10',' ',' ')
endif
enddo
do L = Lb , Lt-1 ! layer thickness at layer interface
k = L - Lb + 1
dzw(k) = 0.5d0*( dzu(k) + dzu(k+1) )
enddo
call getustbcfuhi( LL,Lb,ustb(LL),cfuhi(LL),hdzb,z00,cfuhi3D)
advi(Lb) = advi(Lb)+cfuhi3D
tkebot = sqcmukepi * ustb(LL)**2
tkesur = sqcmukepi * ustw(LL)**2
if (ieps == 3) then ! as Delft3D
vicwwu(Lb0) = vonkar*ustb(LL)*z00 ! as Delft3D
endif
turkin0(Lb0:Lt) = turkin1(Lb0:Lt)
tureps0(Lb0:Lt) = tureps1(Lb0:Lt)
ak(0:kxL) = 0.d0 ! Matrix initialisation
bk(0:kxL) = dtiL
ck(0:kxL) = 0.d0
dk(0:kxL) = dtiL*turkin0(Lb0:Lt)
vicu = viskin+0.5d0*(vicwwu(Lb0)+vicwwu(Lb))*pransmi !
do L = Lb, Lt - 1 ! Loop over layer interfaces
Lu = L + 1
vicd = vicu
vicu = viskin + 0.5d0*(vicwwu(L)+vicwwu(Lu))*pransmi
k = L - Lb + 1; ku = k + 1
dzdz1 = dzw(k) * dzu(k)
difd = vicd / dzdz1
dzdz2 = dzw(k) * dzu(ku)
difu = vicu / dzdz2
ak(k) = ak(k) - difd*tetavkeps
bk(k) = bk(k) + (difd + difu)*tetavkeps
ck(k) = ck(k) - difu*tetavkeps
if (tetavkeps .ne. 1d0) then
dk(k) = dk(k) - difu*(turkin0(L ) - turkin0(Lu))*tetm1 &
+ difd*(turkin0(L-1) - turkin0(L ))*tetm1
endif
!c Source and sink terms k turkin
if (idensform > 0 ) then
k1 = ln(1,L) ; k2 = ln(2,L)
k1u = ln(1,Lu) ; k2u = ln(2,Lu)
drhodz = 0d0 ; drhodz1 = 0d0 ; drhodz2 = 0d0
dzc1 = 0.5d0*(zws(k1u) - zws(k1-1) ) ! vertical distance between cell centers on left side
if (dzc1 > 0) then
drhodz1 = ( rho(k1u) - rho(k1) ) / dzc1
endif
dzc2 = 0.5d0*(zws(k2u) - zws(k2-1) ) ! vertical distance between cell centers on right side
if (dzc2 > 0) then
drhodz2 = ( rho(k2u) - rho(k2) ) / dzc2
endif
if (jadrhodz == 1) then
if (drhodz1 == 0) then
drhodz = drhodz2
else if (drhodz2 == 0) then
drhodz = drhodz1
else
drhodz = 0.5d0*( drhodz1 + drhodz2 )
endif
else if (jadrhodz == 2) then
drhodz = min( drhodz1, drhodz2 )
endif
!
bruva (k) = coefn2*drhodz ! N.B., bruva = N**2 / sigrho
buoflu(k) = max(vicwwu(L), vicwminb)*bruva(k)
!c Production, dissipation, and buoyancy term in TKE equation;
!c dissipation and positive buoyancy are split by Newton linearization:
if (bruva(k) > 0d0) then
dk(k) = dk(k) + buoflu(k)
bk(k) = bk(k) + 2d0*buoflu(k) / turkin0(L)
! EdG: make buoyance term in matrix safer
! bk(k) = bk(k) + 2d0*buoflu(k) / max(turkin0(L), 1d-20)
elseif (bruva(k) < 0d0) then
dk(k) = dk(k) - buoflu(k)
endif
endif
!c TKEPRO is the energy transfer flux from Internal Wave energy to
!c Turbulent Kinetic energy and thus a source for the k-equation.
!c TKEDIS is the energy transfer flux from Turbulent Kinetic energy to
!c Internal Wave energy and thus a sink for the k-equation.
! Production, dissipation, and buoyancy term in TKE equation;
! dissipation and positive buoyancy are split by Newton linearization;
! buoyancy only for unstable stratification;
! notice: application of TKE at new time level:
! Addition of production and of dissipation to matrix ;
! observe implicit treatment by Newton linearization.
dijdij(k) = ( ( u1(Lu) - u1(L) ) ** 2 + ( v(Lu) - v(L) ) ** 2 ) / dzw(k)**2
if (jarichardsononoutput > 0) then ! save richardson nr to output
rich(L) = sigrho*bruva(k)/max(1d-8,dijdij(k)) ! sigrho because bruva premultiplied by 1/sigrho
endif
sourtu = max(vicwwu(L),vicwminb)*dijdij(k) ! + tkepro(L)
if (iturbulencemodel == 3) then
sinktu = tureps0(L) / turkin0(L) ! + tkedis(L) / turkin0(L)
bk(k) = bk(k) + sinktu*2d0
dk(k) = dk(k) + sinktu*turkin0(L) + sourtu
else if (iturbulencemodel == 4) then
sinktu = 1d0 / tureps0(L) ! + tkedis(L) / turkin0(L)
bk(k) = bk(k) + sinktu
dk(k) = dk(k) + sourtu
endif
! dk(k) = dk(k) + sourtu - sinktu*turkin0(L)
enddo
! Boundary conditions:
! TKE at free surface
ak(kxL) = 0.d0
bk(kxL) = 1.d0
ck(kxL) = 0.d0
dk(kxL) = tkesur
! TKE at the bed:
ak(0) = 0.d0
bk(0) = 1.d0
ck(0) = 0.d0
dk(0) = tkebot
if (javau > 0 .or. javakeps > 0) then
ac1 = acL(LL) ; ac2 = 1d0-ac1
n1 = ln(1,LL) ; !zb1 = zws(kbot(n1)-1)
n2 = ln(2,LL) ; !zb2 = zws(kbot(n2)-1)
do L = Lb , Lt-1 ! vertical omega velocity at layer interface u point
k1 = ln(1,L) ; k2 = ln(2,L)
if (n1 > ndxi) then ! for open boundaries only look inside
omega1 = 0d0 ; ac1 = 0d0; ac2 = 1d0
else
omega1 = qw(k1) / a1(n1)
endif
omega2 = qw(k2) / a1(n2)
k = L - Lb + 1
womegu(k) = ac1*omega1 + ac2*omega2
! womegu(k) = ( ac1*qw(k1) + ac2*qw(k2) ) / ( ac1*a1(ln(2,LL)) + ac2*a1(ln(2,LL)) )
enddo
womegu(Lt-Lb+1) = 0d0 ! top layer : 0
if (javakeps == 3) then ! Advection of turkin, vertical implicit, horizontal explicit
arLL = ac1*a1(n1) + ac2*a1(n2)
do L = Lb, Lt-1
k = L - Lb + 1
omegu = 0.5d0*womegu(k)
if (k > 1) omegu = omegu + 0.5d0*womegu(k-1) ! Omega at U-point in between layer interfaces
if (omegu > 0d0) then ! omegu(k) lies below interface(k)
adv = omegu / dzw(k) ! omegu(k) > 0 contributes to k
bk(k) = bk(k) + adv
ak(k) = ak(k) - adv
else
if (k > 1) then
adv = -omegu / dzw(k-1)
bk(k-1) = bk(k-1) + adv
ck(k-1) = ck(k-1) - adv
endif
endif
if ( q1(L) + q1(L+1) > 0) then
kup = ln(1,L) ; arLL = a1(n1)
else
kup = ln(2,L) ; arLL = a1(n2)
endif
volki = 1d0 / (dzw(k)*arLL )
dk(k) = dk(k) + tqcu(kup)*volki
bk(k) = bk(k) + sqcu(kup)*volki
! k1 = ln(1,L) ; k2 = ln(2,L)
! volki = 1d0 / (dzw(k)*arLL )
! dk(k) = dk(k) + ( ac1*tqcu(k1) + ac2*tqcu(k2) ) * volki
! bk(k) = bk(k) + ( ac1*sqcu(k1) + ac2*sqcu(k2) ) * volki
enddo
endif
endif
call tridag(ak,bk,ck,dk,ek,turkin1(Lb0:Lt),kxL+1) ! solve k
turkin1(Lb0:Lt) = max(epstke, turkin1(Lb0:Lt) )
!_____________________________________________________________________________________!
pransmi = 1d0 / sigeps ! 1 / Prandtl Schmidt number Eps (=1.3)
ak(0:kxL) = 0.d0 ! Matrix initialization
bk(0:kxL) = dtiL
ck(0:kxL) = 0.d0
dk(0:kxL) = dtiL*tureps0(Lb0:Lt)
! Vertical diffusion; Neumann condition on surface;
! Dirichlet condition on bed ; teta method:
vicu = viskin+0.5d0*(vicwwu(Lb0)+vicwwu(Lb))*pransmi
do L = Lb, Lt - 1
Lu = L + 1
vicd = vicu
vicu = viskin + 0.5d0*(vicwwu(L)+vicwwu(Lu))*pransmi
k = L - Lb + 1; ku = k + 1
dzdz1 = dzw(k) * dzu(k)
difd = vicd / dzdz1
dzdz2 = dzw(k) * dzu(ku)
difu = vicu / dzdz2
ak(k) = ak(k) - difd*tetavkeps
bk(k) = bk(k) + (difd + difu)*tetavkeps
ck(k) = ck(k) - difu*tetavkeps
if (tetavkeps .ne. 1d0) then
dk(k) = dk(k) - difu*(tureps0(L ) - tureps0(Lu))*tetm1 &
+ difd*(tureps0(L-1) - tureps0(L ))*tetm1
endif
if (iturbulencemodel == 3) then !k-eps
!c Source and sink terms epsilon
if (bruva(k) < 0.d0) then
dk(k) = dk(k)-cmukep*c1e*bruva(k)*turkin1(L)
endif
! Similar to the k-equation, in the eps-equation the net IWE to TKE
! transfer rate (TKEPRO-TKEDIS) is added to the eps-production term, but
! split for implicit treatment for avoiding negative epsilon.
sourtu = c1e*cmukep*turkin0(L)*dijdij(k)
tkedisL = 0d0 ! tkedis(L)
sinktu = c2e*(tureps0(L) + tkedisL) / turkin1(L) ! yoeri has here : /turkin0(L)
!c Addition of production and of dissipation to matrix ; epsilon
!c observe implicit treatment by Newton linearization.
bk(k) = bk(k) + sinktu*2d0
dk(k) = dk(k) + sinktu*tureps0(L) + sourtu
! bk(k) = bk(k) + sinktu
! dk(k) = dk(k) + sourtu
! dk(k) = dk(k) - sinktu*tureps0(L) + sourtu
else if (iturbulencemodel == 4) then ! k-tau
if (buoflu(k) < 0.d0) then
dk(k) = dk(k) - c3tuns*buoflu(k)*tureps0(L)*tureps0(L)
else if (buoflu(k) > 0.d0) then
bk(k) = bk(k) + c3tsta*buoflu(k)*tureps0(L)
endif
bk(k) = bk(k) - c1t*cmukep*dijdij(k)*tureps0(L)
dk(k) = dk(k) - c2t
gradd = 0.5d0*(turkin0(L-1)+turkin0(L))*( tureps0(L) -tureps0(L-1) ) / dzu(k) ! The D_tt-term:
gradu = 0.5d0*(turkin0(Lu) +turkin0(L))*( tureps0(Lu)-tureps0(L) ) / dzu(ku)
gradt = pransmi*cmukep*(gradd+gradu)
gradd = 0.5d0*(tureps0(L-1)+tureps0(L))*( turkin0(L) -turkin0(L-1) ) / dzu(k) ! The D_kt-term:
gradu = 0.5d0*(tureps0(Lu) +tureps0(L))*( turkin0(Lu)-turkin0(L) ) / dzu(ku)
gradk = pransmi*cmukep*(gradd+gradu)
grad = gradk - gradt ! D_kt - D_tt
grad = -grad ! This is positive advection, dc/dt + wdc/dz
grad = grad / dzw(k)
if (grad > 0d0) then
bk(k) = bk(k) + grad
ak(k) = ak(k) - grad
else if (gradk < 0d0) then
bk(k) = bk(k) - grad
ck(k) = ck(k) + grad
endif
endif
enddo
if (iturbulencemodel == 3) then ! Boundary conditions EPSILON:
ak(kxL) = -1.d0 ! Flux at the free surface:
bk(kxL) = 1.d0
ck(kxL) = 0.d0
dk(kxL) = 4d0*abs(ustw(LL))**3/ (vonkar*dzu(Lt-Lb+1))
ak(0) = 0.d0 ! at the bed:
bk(0) = 1.d0
ck(0) = -1.d0
if (ustb(LL) > 0) then ! deps/dz = (epsb+1-epsb)/dz = (u*)**3/ ((dz/2+9z0)**2)
dk(0) = dzu(1)*abs(ustb(LL))**3/(vonkar*hdzb*hdzb)
else
dk(0) = 0d0
endif
else if (iturbulencemodel == 4) then ! Boundary conditions tau:
ak(kxL) = 0.d0 ! at the free surface:
bk(kxL) = 1.d0
ck(kxL) = 0.d0
dk(kxL) = 0.d0
ak(0) = 0.d0 ! at the bed:
bk(0) = 1.d0
ck(0) = 0.d0
if (ustb(LL) > 0) then
dk(0) = vonkar*9d0*z00/(max(ustb(LL),eps6)*0.3d0) ! 0.3=sqrt(cmu0), cmu0=cmukep
else
dk(0) = 0d0
endif
endif
if (javakeps == 3) then ! Advection of tureps, vertical implicit, horizontal explicit
do L = Lb, Lt-1
k = L - Lb + 1
omegu = 0.5d0*womegu(k)
if (k > 1) omegu = omegu + 0.5d0*womegu(k-1) ! Omega at U-point in between layer interfaces
if (omegu > 0d0) then
adv = omegu / dzw(k)
bk(k) = bk(k) + adv
ak(k) = ak(k) - adv
else
if (k > 1) then
adv = -omegu / dzw(k-1)
bk(k-1) = bk(k-1) + adv
ck(k-1) = ck(k-1) - adv
endif
endif
if ( q1(L) + q1(L+1) > 0) then
kup = ln(1,L) ; arLL = a1(n1)
else
kup = ln(2,L) ; arLL = a1(n2)
endif
volki = 1d0 / (dzw(k)*arLL )
dk(k) = dk(k) + eqcu(kup)*volki
bk(k) = bk(k) + sqcu(kup)*volki
enddo
endif
call tridag(ak,bk,ck,dk,ek,tureps1(Lb0:Lt),kxL+1) ! solve eps
tureps1(Lb0:Lt) = max(epseps, tureps1(Lb0:Lt) )
if (javatest == 3) then ! test advection
ak(0:kxL) = 0.d0 ! Matrix initialisation
bk(0:kxL) = dtiL
ck(0:kxL) = 0.d0
dk(0:kxL) = dtiL*tttu(Lb0:Lt)
if (javau > 0 .or. javakeps > 0) then
if (javakeps == 3) then ! Advection of tttu, vertical implicit, horizontal explicit
arLL = ac1*a1(n1) + ac2*a1(n2)
do L = Lb, Lt-1
k = L - Lb + 1
omegu = 0.5d0*womegu(k)
if (k > 1) omegu = omegu + 0.5d0*womegu(k-1) ! Omega at U-point in between layer interfaces
if (omegu > 0d0) then ! omegu(k) lies below interface(k)
adv = omegu / dzw(k) ! omegu(k) > 0 contributes to k
bk(k) = bk(k) + adv
ak(k) = ak(k) - adv
else
if (k > 1) then
adv = -omegu / dzw(k-1)
bk(k-1) = bk(k-1) + adv
ck(k-1) = ck(k-1) - adv
endif
endif
if ( q1(L) + q1(L+1) > 0) then
kup = ln(1,L) ; arLL = a1(n1)
else
kup = ln(2,L) ; arLL = a1(n2)
endif
volki = 1d0 / (dzw(k)*arLL )
dk(k) = dk(k) + ttqc(kup)*volki
bk(k) = bk(k) + sqcu(kup)*volki
! k1 = ln(1,L) ; k2 = ln(2,L)
! volki = 1d0 / (dzw(k)*arLL )
! dk(k) = dk(k) + ( ac1*ttqcu(k1) + ac2*ttqcu(k2) ) * volki
! bk(k) = bk(k) + ( ac1*sqcu(k1) + ac2*sqcu(k2) ) * volki
enddo
endif
endif
call tridag(ak,bk,ck,dk,ek,tttu(Lb0:Lt),kxL+1) ! solve tttu
endif ! end test
if (Tspinupturblogprof > 0d0 .and. Time1 < Tstart_user + Tspinupturblogprof ) then
alfaT = (Time1-Tstart_user) / Tspinupturblogprof
tkebot = ustb(LL)**2/sqcmukep
tkewin = ustw(LL)**2/sqcmukep
tkesur = tkewin ! max(tkewin,ustb(LL)**2)
epsbot = cewall*tkebot**1.5d0
epssur = cewall*tkesur**1.5d0
do L = Lb,Lt-1 ! TKE and epsilon at layer interfaces:
zint = hu(L) / hu(LL)
z1 = 1d0 - zint
k1 = ln(1,L) ; k2 = ln(1,L)
tke = tkebot*z1 + tkesur*zint
zz = hu(L)*( 1d0 - hu(L)/ hu(LL) ) ! parabolic
vicwww = zz * max(0.001d0, ustb(LL)) * vonkar
eps = cmukep*tke*tke / vicwww
if (iturbulencemodel == 3) then
turkin1(L) = tke*(1d0-alfaT) + alfaT*turkin1(L)
tureps1(L) = eps*(1d0-alfaT) + alfaT*tureps1(L)
endif
enddo
if (iturbulencemodel == 3) then
tke = tkesur
turkin1(Lt) = tke*(1d0-alfaT) + alfaT*turkin1(Lt)
eps = epssur / ( hu(Lt) - hu(Lt-1) )
tureps1(Lt) = eps*(1d0-alfaT) + alfaT*tureps1(Lt)
tke = tkebot
turkin1(Lb-1) = tke*(1d0-alfaT) + alfaT*turkin1(Lb-1)
eps = epsbot / ( hu(Lb) - hu(Lb-1) )
tureps1(Lb-1) = eps*(1d0-alfaT) + alfaT*tureps1(Lb-1)
endif
endif
vicwmax = 0.05d0*hu(LL) ! 0.009UH, Elder
if (iturbulencemodel == 3) then ! k-eps
vicwwu (Lb0:Lt) = min(vicwmax, cmukep*turkin1(Lb0:Lt)*turkin1(Lb0:Lt) / tureps1(Lb0:Lt) )
else if (iturbulencemodel == 4) then ! k-tau
vicwwu (Lb0:Lt) = min(vicwmax, cmukep*turkin1(Lb0:Lt)*tureps1(Lb0:Lt) )
endif
if (jaustarint == 1) then
vicwwu(Lt) = 0d0
vicwwu(Lb0) = 0d0
endif
do L = Lt+1 , Lb + kmxL(LL) - 1 ! copy to surface for z-layers
turkin1(L) = turkin1(Lt)
tureps1(L) = tureps1(Lt)
enddo
call vertical_profile_u0( dzu, womegu, Lb, Lt, kxL, LL)
else ! dry
tureps1(Lb0:Lb + kmxL(LL) - 1 ) = epseps
turkin1(Lb0:Lb + kmxL(LL) - 1 ) = epstke
endif ! if (hu(L) > 0) then
enddo ! links loop
!$xOMP END PARALLEL DO
turkin0 = turkin1
tureps0 = tureps1
endif
call linkstocenterstwodoubles(vicwws, vicwwu)
end subroutine update_verticalprofiles
subroutine getustbcfuhi( LL,Lb,ustbLL,cfuLL,hdzb, z00,cfuhi3D) ! see Uittenbogaard's subroutine USTAR
use m_flow
use m_waves, only : ustokes, vstokes
implicit none
integer, intent (in) :: LL, Lb
double precision, intent (out) :: ustbLL, cfuLL, hdzb, z00
double precision, intent(out) :: cfuhi3D ! 3D bedfriction coeffient, advi(Lb) = adbi(Lb) + cfuhi3D
integer :: ifrctyp
double precision :: frcn, sqcf, cz, uu
integer :: nit, nitm = 100
double precision :: r, rv = 123.8d0, e = 8.84d0 , eps = 1d-2, s, sd, er, ers, dzb
cfuhi3D = 0d0
if (jafrculin > 0) then
cfuhi3D = cfuhi3D + frculin(LL)/hu(Lb)
endif
frcn = frcu(LL)
if (frcn == 0d0 ) return
ifrctyp = ifrcutp(LL)
if (ifrctyp < 10) then
if (frcn > 0d0 ) then
call getczz0(hu(LL), frcn, ifrctyp, cz, z00)
hdzb = 0.5d0*hu(Lb) + c9of1*z00 ! half bottom layer plus 9z0
if (jaustarint == 0) then
! sqcf = vonkar/log(c9of1 + hdzb/z00) ! till 012015
sqcf = vonkar/log(hdzb/z00)
else if (jaustarint == 1) then ! Yoeri 2014 long time default for jaustarint == 1
dzb = hu(Lb) + c9of1*z00
sqcf = vonkar / ( log(dzb/z00)-1d0 )
else if (jaustarint == 2) then ! remobilised through jaustarint == 2, good convergence
dzb = hu(Lb)/ee + c9of1*z00
sqcf = vonkar / ( log(dzb/z00) )
endif
else
hdzb = 0.5d0*hu(Lb)
sqcf = 0d0
endif
if (jawave == 3) then
uu = sqrt( (u1(Lb)-ustokes(Lb))*(u1(Lb)-ustokes(Lb)) + (v(Lb)-vstokes(Lb))*(v(Lb)-vstokes(Lb)) )
else
uu = sqrt( u1(Lb)*u1(Lb) + v(Lb)*v(Lb) )
endif
uu = max(uu, 1d-4) ! until 3D handled like 2D iterative loop , solves Roses problem: ust=1.1e-104 to the power 3 is underflow
! if (jawave > 0) then
! endif
ustbLL = sqcf*uu ! ustar based upon bottom layer velocity
cfuLL = sqcf*sqcf/hu(Lb)
!advi(Lb) = advi(Lb) + cfuLL*uu ! g / (H.C.C) = (g.K.K) / (A.A) travels in cfu
cfuhi3D = cfuLL*uu
else if (ifrctyp == 10) then ! Hydraulically smooth, glass etc
nit = 0
if (jawave == 3) then
uu = sqrt( (u1(Lb)-ustokes(Lb))*(u1(Lb)-ustokes(Lb)) + (v(Lb)-vstokes(Lb))*(v(Lb)-vstokes(Lb)) )
else
uu = sqrt( u1(Lb)*u1(Lb) + v(Lb)*v(Lb) )
endif
r = uu*hu(Lb)/viskin ! Local re-number:
r = max(r,0.001d0)
er = e*r
if (r.lt.rv) then ! Viscous sublayer:
s = sqrt(r)
else
s = 12d0 ! In log-layer; initial trial for s:
100 continue
nit = nit+1
sd = s
ers = max(er/sd, 1.0001d0)
s = log(ers)/vonkar
if (nit.ge.nitm) then
call error ('***ERROR in USTAR: no convergence.', ' ', ' ' )
endif
if (s.gt.r) then
call error ('***ERROR in USTAR: S too large.', ' ', ' ' )
endif
if (abs(sd-s).gt.(eps*s)) then
go to 100 ! Convergence criterium:
endif
endif
if (s > 0d0) then
sqcf = 1d0/s
else
sqcf = 0d0
endif
ustbLL = sqcf*uu ! ustar based upon bottom layer velocity
cfuLL = sqcf*sqcf/hu(Lb)
hdzb = 0.5d0*hu(Lb)
if (cfuLL > 100d0) then
nit = nit + 1
endif
! advi(Lb) = advi(Lb) + cfuLL*uu ! g / (H.C.C) = (g.K.K) / (A.A) travels in cfu
cfuhi3D = cfuLL*uu
else ! noslip
! advi(Lb) = advi(Lb) + 2d0*(vicwwu(Lb)+vicouv)/hu(Lb)**2
cfuhi3D = 2d0*(vicwwu(Lb)+vicouv)/hu(Lb)**2
endif
end subroutine getustbcfuhi
subroutine vertical_profile_u0(dzu, womegu, Lb, Lt, kxL, LL)
use m_flow
use m_flowgeom
use m_flowtimes
use m_missing
implicit none
double precision :: a(kmxx),b(kmxx),c(kmxx),d(kmxx),e(kmxx), dzu(kxL), womegu(kxL-1), dzv(kmxx)
integer :: Lb,Lt,kxL,LL
integer :: L, k, k1, k2
double precision :: dzLw, vstress, adv , adv1, tt
double precision :: rhof, gdxi, gdxids, bui, du, cu, ac1, ac2, hup, twot = 0.666666666666d0, slopec
a(1:kxL) = 0d0 ; b(1:kxL) = dti ; c(1:kxL) = 0d0 ; d(1) = u0(Lb)*dti ! put u1 in ddk
adv = 0d0; adv1 = 0d0
ac1 = acL(LL) ; ac2 = 1d0 - ac1
do L = Lb, 0 ! Lt
k = L - Lb + 1
k1 = ln(1,L) ; k2 = ln(2,L)
dzv(k) = ac1*(zws(k1) - zws(k1-1)) + ac2*(zws(k2) - zws(k2-1)) ! volume weighted dzu , ok for pillar
enddo
do L = Lb, Lt - 1
k = L - Lb + 1
dzLw = 0.5d0 * ( dzu(k+1) + dzu(k) )
vstress = (vicwwu(L) + vicoww ) / dzLw ! long time default like DPM, finite volume weights, dim = (m/s)
! vstress = (vicwwu(L) + vicoww + viskin ) / dzLw ! 08-12-14 : add kinematic viscosity
! vstress = ( max(vicwwu(L), vicoww) + viskin ) / dzLw ! 23-12-14 : D3D like
if (javau == 3) then ! vertical advection upwind implicit
if (womegu(k) > 0) then
if (jarhoxu > 0) then
adv1 = womegu(k)*rhou(L)/rhou(L+1) ; adv = 0d0
else
adv1 = womegu(k) ; adv = 0d0 ! here, omegu(k) lies above u point of same index
endif
else
if (jarhoxu > 0) then
adv = -womegu(k)*rhou(L+1)/rhou(L) ; adv1 = 0d0
else
adv = -womegu(k) ; adv1 = 0d0
endif
endif
! adv = 0d0 ; adv1 = 0d0 ! noslip test
!tt = vstress/dzu(k+1) + adv1/dzv(k+1)
tt = (vstress + adv1)/dzu(k+1)
b(k+1) = b(k+1) + tt
a(k+1) = a(k+1) - tt
!tt = vstress/dzu(k ) + adv/dzv(k )
tt = (vstress + adv)/dzu(k )
b(k ) = b(k ) + tt
c(k ) = c(k ) - tt
!a(k+1) = a(k+1) - adv1/dzu(k+1)
!b(k+1) = b(k+1) + adv/dzu(k+1)
!
!b(k) = b(k) + adv1/dzu(k)
!c(k) = c(k) - adv/dzu(k)
!d(k) = d(k) - adv1/dzu(k) * u0(L) + adv/dzu(k) * u0(L+1)
!d(k+1) = d(k+1) + adv1/dzu(k+1) * u0(L) - adv/dzu(k+1) * u0(L+1)
else if (javau == 4) then ! vertical advection central implicit
adv = 0.5d0*womegu(k) ! here, omegu(k) lies above u point of same index
b(k+1) = b(k+1) + (vstress - adv) / dzu(k+1)
a(k+1) = a(k+1) - (vstress + adv) / dzu(k+1)
b(k ) = b(k ) + (vstress + adv) / dzu(k)
c(k ) = c(k ) - (vstress - adv) / dzu(k)
else
adv = 0d0; adv1 = 0d0
endif
d(k+1) = u0(L+1)*dti
enddo
gdxi = ag*dxi(LL)
k1 = ln(1,LL) ; k2 = ln(2,LL)
gdxids = gdxi*( s0(k2) - s0(k1) )
slopec = 0d0
if (drop3D > 0d0) then
hup = s0(k2) - ( min(bob(1,LL), bob(2,LL) ) + drop3D*twot*hu(LL) )
if (hup < 0) then
slopec = hup
else
hup = s0(k1) - ( min( bob(1,LL), bob(2,LL) ) + drop3D*twot*hu(LL) )
if (hup < 0) then
slopec = -hup
endif
endif
endif
cu = gdxi*teta(LL)
du = gdxids*(1d0-teta(LL)) + gdxi*slopec
do L = Lb, Lt
k = L - Lb + 1
b(k) = b(k) + advi(L)
d(k) = d(k) - adve(L) - du
enddo
call tridag(a,b,c,d,e,Ru(Lb:),kxL)
d(1:kxL) = cu
call tridag(a,b,c,d,e,Fu(Lb:),kxL)
end subroutine vertical_profile_u0
subroutine tridag(a,b,c,d,e,u,n)
implicit none
integer :: n, j
double precision :: a(n),b(n),c(n),d(n),e(n),u(n), bet, accur = 1e-15
bet =b(1)
u(1)=d(1)/bet
do j=2,n
e(j)=c(j-1)/bet
bet=b(j)-a(j)*e(j)
if (abs(bet) < accur) then
bet = sign(accur,bet)
endif
u(j)=(d(j)-a(j)*u(j-1))/bet
enddo
do j=n-1,1,-1
u(j)=u(j)-e(j+1)*u(j+1)
enddo
end subroutine tridag
subroutine getprof_1D(L, hpr, area, width, japerim)
use m_profiles
use m_flow
use m_flowgeom
implicit none
integer :: L, japerim
double precision :: hpr ! hoogte in profiel
double precision :: area ! wet cross sectional area
double precision :: width ! width at water surface
double precision :: perim ! wet perimeter
double precision :: profw ! width of profile
double precision :: hydrad ! hydraulic radius
double precision :: area2, width2, perim2, cf2, alfa ! second prof i.c. interpolation
double precision :: frcn, cz, cf
integer :: LL, ka, kb, itp, ifrctyp
LL = L
if (L > lnxi) then ! for 1D boundary links, refer to attached link
LL = LBND1D(L)
endif
if (prof1D(1,LL) > 0 ) then ! direct profile based upon link value
ka = 0; kb = 0 ! do not use profiles
profw = prof1D(1,LL)
itp = prof1D(3,LL)
else
ka = -prof1D(1,LL); kb = -prof1D(2,LL)
profw = profiles1D(ka)%width
itp = profiles1D(ka)%ityp
endif
if (itp == 1) then ! pipe
call pipe (hpr, profw, area, width, japerim, perim)
else if (itp == 2) then ! rectan, peri=wu + 2*hpr
call rectan (hpr, profw, area, width, japerim, perim)
else if (itp == 3) then ! rectan, peri=wu
call rectan2D(hpr, profw, area, width, japerim, perim)
else if (itp == 100 .or. itp == 101) then ! itp >= 100, yzprof
call yzprofile(hpr,ka,itp, area, width, japerim, perim, cf )
endif
if (ka .ne. 0 .and. kb .ne. ka) then ! interpolate in profiles
profw = profiles1D(kb)%width
itp = profiles1D(kb)%ityp
alfa = prof1d(3,LL)
if (itp == 1) then ! pipe
call pipe (hpr, profw, area2, width2, japerim, perim2)
else if (itp == 2) then ! rectan, peri=wu + 2*hpr
call rectan (hpr, profw, area2, width2, japerim, perim2)
else if (itp == 3) then ! rectan, peri=wu
call rectan2D(hpr, profw, area2, width2, japerim, perim2)
else if (itp == 100 .or. itp == 101) then ! >= 10, conveyance approach
call yzprofile(hpr, kb,itp,area2, width2, japerim, perim2, cf2 )
endif
area = (1d0-alfa)*area + alfa*area2
width = (1d0-alfa)*width + alfa*width2
if (japerim == 1) then
if (itp == 101) then ! 1D conveyance
cf = (1d0-alfa)*cf + alfa*cf2
else
perim = (1d0-alfa)*perim + alfa*perim2
endif
endif
endif
if (japerim == 1) then
if (itp == 101) then ! 1D conveyance
cfuhi(L) = cf
else
frcn = frcu(L)
if (frcn > 0) then
hydrad = area / perim ! hydraulic radius
ifrctyp = ifrcutp(L)
call getcz(hydrad, frcn, ifrctyp, cz)
cfuhi(L) = ag/(hydrad*cz*cz) ! see note on 2D conveyance in sysdoc5
else
cfuhi(L) = 0d0
endif
endif
endif
end subroutine getprof_1D
subroutine yzprofile(hpr, ka, itp, area, width, japerim, perim, cfhi )
use m_profiles
use m_physcoef, only : ag
use m_flow , only : slotw1D
implicit none
integer :: ka, japerim, itp
double precision :: hpr ! hoogte in profiel
double precision :: area ! wet cross sectional area
double precision :: width ! width at water surface
double precision :: perim ! wet perimeter
double precision :: cfhi ! cfuhi(L)
double precision :: wid ! wid of segment
double precision :: ar ! ar of segment
double precision :: conv, convall ! (sum of) conv
double precision :: hpr2 ! height in segment under consideration
double precision :: frcn ! user defined friction coefficient
double precision :: bl1, bl2, b21 ! bottom levels segment, b21, diff of bl1,bl2, always > 0
double precision :: wu2, ai, aconv, per, hyr, Cz
integer :: ifrctyp ! user defined frcition type
integer :: k, numseg, jac
numseg = size ( profiles1D(ka)%y ) - 1
area = 0d0 ; width = 0d0 ; convall = 0d0; perim = 0d0
jac =0
if (japerim == 1) then
if (itp == 100) then
jac = 1 ! lumped
else
jac = 2 ! 1D conveyance
endif
frcn = profiles1D(ka)%frccf ! todo, but much much later : make segmented
ifrctyp = profiles1D(ka)%frctp
endif
do k = 1,numseg
if (profiles1D(ka)%z(k) < profiles1D(ka)%z(k+1) ) then
BL1 = profiles1D(ka)%z(k) ; BL2 = profiles1D(ka)%z(k+1)
else
BL2 = profiles1D(ka)%z(k) ; BL1 = profiles1D(ka)%z(k+1)
endif
hpr2 = hpr - bl1
if (hpr2 > 0d0) then
b21 = BL2 - BL1
wu2 = abs( profiles1D(ka)%y(k) - profiles1D(ka)%y(k+1) )
ai = b21/wu2
call getseg1D(hpr2,wu2,b21,ai,frcn,ifrctyp, wid,ar,conv,per,jac)
width = width + wid
area = area + ar
if (jac == 2) then
convall = convall + conv
else if (jac == 1) then
perim = perim + per
endif
endif
enddo
width = width + slotw1D
area = area + slotw1D*hpr
if (jac == 2) then
if (convall > 0 ) then
aconv = ( area/convall )**2
cfhi = ag*aconv
else
cfhi = 0d0
endif
endif
end subroutine yzprofile
subroutine rectan(hpr, br, area, width, japerim, perim)
implicit none
integer :: japerim
double precision :: hpr ! hoogte in profiel
double precision :: br ! breedte van profiel
double precision :: area ! wet cross sectional area
double precision :: width ! width at water surface
double precision :: perim ! wet perimeter
area = hpr*br
width = br
perim = 2d0*hpr + br
end subroutine rectan
subroutine rectan2D(hpr, br, area, width, japerim, perim)
implicit none
integer :: japerim
double precision :: hpr ! hoogte in profiel
double precision :: br ! breedte van profiel
double precision :: area ! wet cross sectional area
double precision :: width ! width at water surface
double precision :: perim ! wet perimeter
area = hpr*br
width = br
perim = br
end subroutine rectan2D
subroutine pipe(hpr, dia, area, width, japerim, perim) ! half open part
use m_sferic
use m_flow, only : slotw1D
!
! this subroutine computes wetted circle surface as function
! of diameter d and waterdepth dpt, as an option (if jd=1) it can compute
! the derivative da(dpt)/ddpt and (if jw=1) it can also compute the wetted
! perimeter
!
! dpt I, water depth
! dia I, diameter
! wet O, wetted surface
! dwdd O, det/ddpt
! wtp O, wetted perimeter
! jd I, compute dwdd if jd=1
! jw I, compute wtp if jw=1
! sl I, slotbreedte
implicit none
integer, intent(in) :: japerim
double precision, intent(in) :: dia, hpr
double precision, intent(out) :: area, width, perim
! Local variables
double precision :: are, dacos, dsqrt, fi, r, sq
r = 0.5*dia
are = r - hpr
if (hpr< r) then
fi = dacos(are/r)
sq = dsqrt(hpr*(dia - hpr))
area = fi*r*r - sq*are
width = 2*sq ! + slotw1D
if (japerim == 1) perim = 2*fi*r ! + slotw1D
else
area = 0.5d0*pi*r*r+(hpr-r)*dia
width = dia ! + slotw1D
if (japerim ==1) then
if (hpr < dia) then
fi = dacos(are/r)
sq = dsqrt(hpr*(dia - hpr))
area = fi*r*r - sq*are
perim = 2*fi*r
else
area = pi*r*r
perim = twopi*r
endif
endif
endif
end subroutine pipe
subroutine chknan(a, b, n)
use m_flow
implicit none
integer :: n
double precision :: a(n)
character(len=*) :: b
integer :: i
logical :: isnan
character(len=40) :: tex
do i = 1,n
if (isnan(a(i)) ) then
write(tex,'(I10)') i
write(*,*) 'isnan: ', b , tex
call error ('isnan: ', b , tex)
endif
! write(mdump,*) b, i, a(i)
enddo
end subroutine chknan
subroutine checknans()
use m_flowgeom
use m_flow
use m_reduce
implicit none
call newfil(mdump , 'dump')
call chknan(s0 , 's0 ', ndx)
call chknan(s1 , 's1 ', ndx)
call chknan(bbr , 'bbr ', ndx)
call chknan(ccr , 'ccr ', ndx)
call chknan(ddr , 'ddr ', ndx)
call chknan(bb , 'bb ', ndx)
call chknan(dd , 'dd ', ndx)
call chknan(vol0 , 'vol0 ', ndx)
call chknan(vol1 , 'vol1 ', ndx)
call chknan(au , 'au ', ndx)
call chknan(ba , 'ba ', ndx)
call chknan(a1 , 'a1 ', ndx)
call chknan(hu , 'hu ', ndx)
call chknan(u0 , 'u0 ', ndx)
call chknan(u1 , 'u1 ', ndx)
call doclose(mdump)
end subroutine checknans
subroutine einstein_garcia(da,rs,dj1,dj2)
use m_einstein_garcia
implicit none
double precision :: da,rs, dj1, dj2
double precision :: aa, cck, rsk, dj12, dj22
integer :: i1, i2,k
if (da < 0.001d0) then
i1 = 1; i2 = 1
else if (da < 0.005d0) then
i1 = 1; i2 = 2
else if (da < 0.01d0) then
i1 = 2; i2 = 3
else if (da < 0.05d0) then
i1 = 3; i2 = 4
else if (da < 0.1d0) then
i1 = 4; i2 = 5
else
i1 = 5; i2 = 5
endif
if (i1 == i2) then
aa = 0d0
else
aa = ( da - d(i1) ) / ( d(i2) - d(i1) )
endif
dj1 = 0d0
dj2 = 0d0
dj12 = 0d0
dj22 = 0d0
do k = 0,6
rsk = rs**k
!cck = (1d0-aa)*c1(i1,k) + aa*c1(i2,k)
!dj1 = dj1 + cck*rsk
!cck = (1d0-aa)*c2(i1,k) + aa*c2(i2,k)
!dj2 = dj2 + cck*rsk
dj1 = dj1 + c1(i1,k)*rsk
dj12 = dj12 + c1(i2,k)*rsk
dj2 = dj2 + c2(i1,k)*rsk
dj22 = dj22 + c2(i2,k)*rsk
enddo
dj1 = (1d0-aa)*dj1 + aa*dj12
dj2 = (1d0-aa)*dj2 + aa*dj22
if (dj1 .ne. 0d0) then
dj1 = 1d0/dj1
endif
if (dj2 .ne. 0d0) then
dj2 = -1d0/dj2
endif
end subroutine einstein_garcia
subroutine check_einstein_garcia(aref,h,z0,rs,ein)
implicit none
double precision :: aref,h,z0,rs,ein, ucrouse, z, dz
integer :: num, k
ein = 0d0
z = aref
num = 10000
dz = (h - z) / dble(num)
z = z - 0.5d0*dz
do k = 1,num
z = z + dz
ucrouse = log(z/z0) * ( (aref/(h-aref))*( (h-z)/z) )** rs
ein = ein + ucrouse*dz
enddo
end subroutine check_einstein_garcia
subroutine check_einstein_garcia2(aref,h,z0,rs,ein)
use m_sediment, only : numintverticaleinstein
implicit none
double precision :: aref,h,z0,rs,ein, ucrouse1, ucrouse2, dz, g,d1,di,d, z1, z2
double precision :: a,b,y1,y2,zl,zm,zlm,zlm2,alfa
integer :: n, k
ein = 0d0
n = numintverticaleinstein
g = 1.1
d1 = (h-aref)*(1-g)/(1-g**n)
di = d1
!d = 0d0 ! just checking
!do k = 1,n
! d = d + di
! di = g*di
!enddo
!di = d1
z2 = aref
y1 = z2/z0
zL = log(y1)
!y2 = h/z0
!zm = log(y2)
!alfa = 1d0/6d0
!a = (zL-zM) / (y1**alfa - y2**alfa)
!b = zL - a*y1**alfa
ucrouse2 = zl * ( (h-z2)/z2 ) ** rs
do k = 1,n
z1 = z2
z2 = z1 + di
ucrouse1 = ucrouse2
ucrouse2 = 0
if (k < n) then
zlm = log(z2/z0)
! zlm = a*(z2/z0)**alfa + b
ucrouse2 = zlm * ( (h-z2)/z2 ) ** rs
endif
ein = ein + 0.5d0*(ucrouse1+ucrouse2)*di
di = g*di
enddo
ein = ein * (aref/(h-aref) )** rs
end subroutine check_einstein_garcia2
double precision function ucrouse(z,z0,h,a,rs)
use m_einstein_garcia
implicit none
double precision :: z, z0, h, a, rs
ucrouse = log(z/z0) * ( (a/(h-a))*( (h-z)/z) )** rs
end function
subroutine setfixedweirs() ! override bobs along pliz's, jadykes == 0: only heights, 1 = also dyke attributes
use m_netw
use m_flowgeom
use m_flow
use m_missing
use m_alloc
use unstruc_model
use timespace
use unstruc_messages
use m_fixedweirs
use m_kdtree2
use m_sferic
use m_polygon
use m_partitioninfo
implicit none
integer :: np, k, kk, n1, n2, n12, n, nn, L, LL, ja, jacros, minp, kint, ierr, nt, nh, i, Lf
integer :: jaweir, Lastfoundk, kf, kL, jarestorepol, Lnt, k1, nna, nnb, nl1, nl2, k3, k4
integer , allocatable :: iwu(:), ihu(:)
double precision :: SL, SM, XCR, YCR, CRP, Xa, Ya, Xb, Yb, zc, af, dz1, dz2, xn, yn, adjacentbob, cosphi, sig
double precision, external :: dcosphi, dbdistance
double precision, allocatable :: csh(:), snh(:)
double precision, dimension(:), allocatable :: dSL
integer, dimension(:), allocatable :: iLink
integer, dimension(:), allocatable :: iLcr ! link crossed yes no
integer, dimension(:), allocatable :: iPol
integer :: iL, numLL, numcrossedLinks
integer :: mout
integer :: ierror
integer :: jakdtree=1
character(len=5) :: sd
character(len=1), external :: get_dirsep
if ( len_trim(md_fixedweirfile) == 0 ) then
ifixedweirscheme = 0
return
endif
call readyy('Setfixedweirs', 0d0)
allocate (ihu(lnxi)) ; ihu = 0
allocate (csh(lnxi)) ; csh = 0d0
allocate (snh(lnxi)) ; snh = 0d0
call oldfil (minp, md_fixedweirfile)
N1 = index (trim(md_fixedweirfile) , get_dirsep() , .true.)
! fix for Linux-prepared input on Windows
if ( N1.eq.0 ) then
N1 = index(trim(md_fixedweirfile), char(47), .true.)
end if
sd = ''
if (jampi == 1) then
sd = '_'//trim(sdmn)
end if
N2 = INDEX (trim(md_fixedweirfile) , '.' , .true.)
if (n2 == 0) then
n2 = len_trim(md_fixedweirfile)
else
n2 = n2 -1
end if
call newfil(mout, 'DFM_interpreted_fxwvalues_'//trim(md_fixedweirfile(n1+1:n2))//trim(sd)//'.xyz')
write (mout, '(a)') '* xu yu crest(bob) width(wu) xk3 yk3 xk4 yk4'
if (npl < 10000) then
jarestorepol = 1
call savepol()
else
jarestorepol = 0 ! jammer dan
call delpol
endif
call reapol(minp, 0)
kint = max(lnxi/1000,1)
n = 0 ; nt = 0; nh = 0
Lastfoundk = 0
if ( jakdtree.eq.1 ) then
! allocate
! note: yes, the following arrays will be much too large in general, but now there is neither a need to reallocate,
! nor a module subroutine required, which complies with the "Jip and Janneke" design paradigm
allocate(iLink(Lnx))
allocate(iLcr(Lnx)) ; Ilcr = 0
allocate(ipol(Lnx))
allocate(dSL(Lnx))
call find_crossed_links_kdtree2(treeglob,NPL,XPL,YPL,2,Lnx,0,numcrossedLinks, iLink, iPol, dSL, ierror)
numLL = numcrossedLinks
do iL = 1,numLL
L = iLink(il)
iLcr(L) = 1
enddo
! check if kdtree was succesfull, disable if not so
if ( ierror.ne.0 ) then
deallocate(iLink)
deallocate(ipol)
deallocate(dSL)
jakdtree = 0
end if
end if
if ( jakdtree.eq.0 ) then
numLL = Lnxi
end if
do iL = 1,numLL
if ( jakdtree.eq.0 ) then
L = iL
else
L = iLink(iL)
k = iPol(iL)
end if
if (mod(L,kint) == 0) then
AF = dble(L)/dble(lnxi)
call readyy('Setfixedweirs', af )
endif
n1 = ln(1,L) ; n2 = ln(2,L)
xa = xz(n1) ; ya = yz(n1)
xb = xz(n2) ; yb = yz(n2)
if ( jakdtree.eq.0 ) then
iloop:do i = 1,2
if (i == 1) then
if (Lastfoundk == 0) cycle
kf = max(1, Lastfoundk - 100)
kL = min(npl-1, Lastfoundk + 100)
else
kf = 1
kL = npl-1
endif
Lastfoundk = 0
do k = kf,kL
if (xpl(k) .ne. dmiss .and. xpl(k+1) .ne. dmiss) then
CALL CROSSinbox (XPL(k), YPL(k), XPL(k+1), YPL(k+1), Xa, Ya, Xb, Yb, jacros, SL, SM, XCR, YCR, CRP)
if ( jacros.eq.1 ) then
Lastfoundk = k
exit iloop
end if
endif
enddo
enddo iloop
else
! use kdtree to find nearest dike
k = iPol(iL)
jacros = 1
sL = dSL(iL)
end if
if (jacros == 1) then
! set fixed weirs
zc = sl*zpL(k+1) + (1d0-sl)*zpL(k)
bob(1,L) = max( zc, bob(1,L), bob(2,L) ) ; bob(2,L) = bob(1,L)
jaweir = 0
if (jakol45 > 0) then
dz1 = sl*dzL(k+1) + (1d0-sl)*dzL(k)
dz2 = sl*dzR(k+1) + (1d0-sl)*dzR(k)
if (min (dz1,dz2) >= sillheightmin ) then
jaweir = 1
endif
if (jaconveyance2D > 0) then ! now set adjacent bobs of netlinks | sufficiently perpendicular to fixedweir to local ground level
do i = 1,2
n1 = lncn(i,L)
do kk = 1, nmk(n1) ! | |
Lnt = nod(n1)%lin(kk) ! ---------o---------o-------fixedweir
Lf = lne2ln(Lnt) ! | |
if (Lf == 0) cycle
if (iLcr(abs(Lf)) == 1) cycle
nna = kn(1,Lnt)
nnb = kn(2,Lnt)
xa = xk(nna) ; ya = yk(nna)
xb = xk(nnb) ; yb = yk(nnb)
COSPHI = DCOSPHI(Xpl(k), Ypl(k), xpl(k+1), ypl(k+1), xa, ya, xb, yb)
if (abs(cosphi) < 0.5d0) then
if (nna .ne. n1) then
nh = nna
nna = nnb
nnb = nh
endif ! na is now basepoint
xa = xk(nna) ; ya = yk(nna)
xb = xk(nnb) ; yb = yk(nnb)
call duitpl(Xpl(k), Ypl(k), xpl(k+1), ypl(k+1), xa, ya, xb, yb, sig)
adjacentbob = dmiss
if (sig > 0 ) then
if (dz2 > 3d0 .and. dz1 < 3d0) then ! kade at other side deeper than 3 m
adjacentbob = zc - dz1 ! then set kade ground level
endif
else
if (dz1 > 3d0 .and. dz2 < 3d0) then
adjacentbob = zc - dz2
endif
endif
if (Lf > 0 .and. adjacentbob .ne. dmiss) then
if (lncn(1,Lf) == n1) then
bob(1,Lf) = adjacentbob
else
bob(2,Lf) = adjacentbob
endif
nl1 = ln(1,Lf) ; nl2 = ln(2,Lf)
bl(nl1) = min(bl(nl1), adjacentbob )
bl(nl2) = min(bl(nl2), adjacentbob )
endif
endif
enddo
enddo
endif
else
jaweir = 1 ! no sill heigths present in file : always weir treatment assumed
endif
if (kn(3,L) == 3) then ! no weir treatment on 1D2D links
jaweir = 0
endif
n = n + 1
if ( jaweir == 1 ) then ! flag ihu + for weirs
ihu(n) = L ! weir
nt = nt + 1
else
ihu(n) = -L ! flag ihu - for just high bobs
nh = nh + 1
endif
call normalout(Xpl(k), Ypl(k), xpl(k+1), ypl(k+1), csh(n), snh(n) ) ! store fixed weir direction with links
if (ihu(n) > 0) then ! set weir treatment
nfxw = nfxw + 1
if (ifixedweirscheme .ge. 3 .and. ifixedweirscheme .le. 8) then ! subgrid weir using compact scheme nr 2
call setfixedweirscheme3onlink(L)
call normalout( XPL(k), YPL(k), XPL(k+1), YPL(k+1) , xn, yn)
k3 = lncn(1,L) ; k4 = lncn(2,L)
wu(L) = dbdistance ( xk(k3), yk(k3), xk(k4), yk(k4) ) ! set 2D link width
wu(L) = wu(L) * abs( xn*csu(L) + yn*snu(L) ) ! projected lenght of fixedweir
if ( javillemonte.eq.1 ) then
weircos(L) = abs(xn*csu(L) + yn*snu(L))
endif
endif
write (mout, '(8(f24.4))') xu(L), yu(L), bob(1,L), fixedweircontraction*wu(L), xk(k3), yk(k3), xk(k4), yk(k4)
endif
endif
enddo
call doclose(mout)
if (jarestorepol == 1) call restorepol()
nfxw = n
if (isimplefixedweirs == 1) then
if (nfxw > 0) then
if (allocated (lnfxw) ) deallocate(lnfxw)
allocate ( lnfxw(nfxw) ,stat=ierr)
call aerr('lnfxw(nfxw)',ierr,nfxw)
lnfxw(1:n) = ihu(1:n)
if (allocated (csfxw) ) deallocate(csfxw)
allocate ( csfxw(nfxw) ,stat=ierr)
call aerr('csfxw(nfxw)',ierr,nfxw)
csfxw(1:n) = csh(1:n)
if (allocated (snfxw) ) deallocate(snfxw)
allocate ( snfxw(nfxw) ,stat=ierr)
call aerr('snfxw(nfxw)',ierr,nfxw)
snfxw(1:n) = snh(1:n)
if (allocated (nfxwL) ) deallocate(nfxwL)
allocate ( nfxwL(Lnx) ,stat=ierr) ; nfxwL = 0
call aerr('nfxwL(Lnx)',ierr,Lnx)
endif
endif
deallocate(ihu, csh, snh)
do i = 1, nfxw
L = lnfxw(i)
if (L > 0) then
wu(L) = wu(L) * fixedweircontraction
nfxwL(L) = i
endif
enddo
call doclose(minp)
if (nt > 0) then
call mess(LEVEL_INFO,'Number of flow Links with fixed weirs :: ', nt)
endif
if (nh > 0) then
call mess(LEVEL_INFO,'Number of flow Links with highlines :: ', nh)
endif
call readyy(' ', -1d0 )
1234 continue
! deallocate
if ( jakdtree.eq.1 ) then
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(iPol) ) deallocate(iPol)
if ( allocated(dSL) ) deallocate(dSL)
end if
end subroutine setfixedweirs
subroutine switchiadvnearlink(L)
use m_flowgeom
use m_flow
implicit none
integer :: L, k1, k2, kk,LL, iadv1, iadv2
k1 = ln(1,L) ; k2 = ln(2,L)
if (u0(L) > 0) then
iadv1 = 8 ! piaczek incoming upwind
iadv2 = 0 ! noadv downstream
else if (u0(L) < 0) then
iadv1 = 0
iadv2 = 8
else ! == (now safe for grid direction)
iadv1 = 8
iadv2 = 8
end if
do kk = 1,nd(k1)%lnx
LL = iabs( nd(k1)%ln(kk) )
if ( iadv(LL) .ne. 22) then
iadv(LL) = iadv1
endif
enddo
do kk = 1,nd(k2)%lnx
LL = iabs( nd(k2)%ln(kk) )
if ( iadv(LL) .ne. 22) then
iadv(LL) = iadv2
endif
enddo
end subroutine switchiadvnearlink
subroutine setfixedweirscheme3onlink(L)
use m_flowgeom
use m_flow
implicit none
integer :: L, nn, n12,kk,LL
iadv(L) = 21 ; teta(L) = 1d0
if (ifixedweirscheme == 7) then ! Rajaratnam . later, get this from polygon
iadv(L) = 23
else if (ifixedweirscheme == 8) then ! Waquatabellen
iadv(L) = 24
else if (ifixedweirscheme == 9) then ! Villemonte
iadv(L) = 25
endif
do nn = 1,2
n12 = ln(nn,L)
do kk = 1,nd(n12)%lnx ! and flag non-21 links to perot incoming only
LL = iabs( nd(n12)%ln(kk) )
if ( iadv(LL) < 21 .or. iadv(LL) > 25) then
iadv(LL) = 4
endif
teta(LL) = 1d0
enddo
enddo
end subroutine setfixedweirscheme3onlink
subroutine heatu(timhr)
use m_flow
use m_flowgeom
use m_sferic
implicit none
double precision :: timhr
double precision :: qsnom
integer :: n
heatsrc0 = 0d0 ! array of heat sources zero
if (jamapheatflux > 0) then ! map output zero
if ( jatem.eq.3 ) then
Qtotmap=0d0
else if ( jatem.eq.5 ) then
Qtotmap=0d0
Qsunmap=0d0
Qevamap=0d0
Qconmap=0d0
Qlongmap=0d0
Qfrevamap=0d0
Qfrconmap=0d0
end if
endif
call qsun_nominal(anglon, anglat, timhr, qsnom) ! for models not in spherical coordinates do this just once
!$OMP PARALLEL DO &
!$OMP PRIVATE(n)
do n = 1,ndxi
if (hs(n) < 0.01d0) cycle
if (nd(n)%lnx == 0) cycle
call heatun(n,timhr,qsnom)
enddo
!$OMP END PARALLEL DO
end subroutine heatu
subroutine heatun(n, timhr, qsno)
use m_flow
use m_flowgeom
use m_sferic
use m_itdate
use unstruc_model
use m_flowtimes
use m_heatfluxes
implicit none
double precision, intent (in) :: timhr, qsno
integer , intent (in) :: n
integer :: i, k, kb, kt, k2, L, LL, ncols, lunadh = 0 , jafree = 0 ! D3D
double precision :: rlon, rlat, sc, qsn, qsu, qsnom, presn, tairn, twatn, twatK, rhumn, cloun, windn
double precision :: ce, ch, qwmx, qahu, tl, Qcon, Qeva, Qlong, sg, pvtamx, pvtwmx, pvtahu, delvap
double precision :: zabs, zlo, zup, explo, expup, ratio, rcpiba, qheat, atot
double precision :: w(20), Qtot, Qfree, b, gred, wfree, Qfrcon, Qfreva, rhoa0, rhoa10
double precision :: prair=0.7d0, pr2=.49d0, xnuair=16d-6, cfree=0.14d0
double precision :: rdry=287.05d-2 , rvap=461.495d-2 , evafac = 1d0
double precision :: hlc, arn
presn = 1d-2*paver ! Air pressure (mbar)
rhumn = 1d-2*backgroundhumidity ! ( )
cloun = 1d-2*backgroundcloudiness ! ( )
ce = Dalton ! Dalton number = 1.50e-3 (Gill, 1982) evaporative flux
ch = Stanton ! Stanton number = 1.45e-3 (Friehe&Schmitt, 1976) convective heat flux
qsu = 0d0
qsnom = qsno
if (jatem == 3) then ! excess
L = iabs(nd(n)%ln(1))
windn = sqrt( wx(L)*wx(L) + wy(L)*wy(L) )
call getkbotktop(n,kb,kt)
arn = ba(n)
twatn = tem1(kt)*arn
do LL = 1,nd(n)%lnx
L = iabs( nd(n)%ln(LL) )
k2 = ln(1,L) + ln(2,L) - n
twatn = twatn + tem1(ktop(k2))*ba(k2)
arn = arn + ba(k2)
enddo
if (arn > 0d0) then
twatn = twatn / arn
else
twatn = tem1(kt)
endif
tairn = tair(n)
hlc = 4.48d0 + 0.049d0 * twatn + fwind * ( 3.5d0 + 2.05d0*windn ) * ( 1.12d0 + 0.018d0*twatn + 0.00158d0*twatn**2 )
qheat = -hlc*(twatn-tairn)
rcpiba = rcpi*ba(n)
heatsrc0(kt) = heatsrc0(kt) + qheat*rcpiba ! fill heat source array
if (jamapheatflux > 0) then ! todo, only at mapintervals
Qtotmap(n) = qheat
endif
else if (jatem == 5) then
call getkbotktop(n,kb,kt) ! get forcings windspeed pressure cloudiness etc
twatn = tem1(kt)
tairn = tair(n)
rhumn = min(1d0, max(0d0, 1d-2*rhum(n) ) )
cloun = min(1d0, max(0d0, 1d-2*clou(n) ) )
L = iabs(nd(n)%ln(1))
windn = sqrt( wx(L)*wx(L) + wy(L)*wy(L) )
if (japatm > 0) then
presn = 1d-2*patm(n)
endif
! Solar radiation restricted by presence of clouds and reflection of water surface (albedo)
if (jasol == 1) then ! Measured solar radiation qradin specified in .tem file
qsu = qrad(n) * (1-albedo)
else ! Calculate solar radiation from cloud coverage specified in file
if (jsferic == 1) then
call qsun_nominal(xz(n), yz(n), timhr, qsnom)
endif
if (qsnom > 0d0) then
qsu = qsnom * (1d0 - 0.40d0*cloun - 0.38d0*cloun*cloun) * (1d0-albedo)
else
qsu = 0d0
endif
endif
rcpiba = rcpi*ba(n)
qsn = qsu*rcpiba
if (qsn > 0d0 ) then
if (kmx > 0) then ! distribute incoming radiation over water column
zabs = (min(0.5d0*hs(n) ,Secchidepth)) / 1.7d0
zlo = 0d0 ; explo = 1d0
do k = kt,kb,-1
zup = zlo ; expup = explo
zlo = zws(kt) - zws(k-1)
ratio = zlo/zabs
if (ratio > 4d0 .or. k.eq.kb) then
explo = 0.0
else
explo = exp(-ratio)
endif
heatsrc0(k) = heatsrc0(k) + qsn*(expup-explo)
enddo
else
heatsrc0(n) = heatsrc0(n) + qsn
endif
endif
! PVTWMX = PVapour at TWater and MaX relative humidity
! PVTAMX = PVapour at TAir and MaX relative humidity
pvtamx = 10d0**((0.7859d0+0.03477d0*tairn)/(1d0+0.00412d0*tairn)) ! saturation pressure of water vapour in air remote (ewl)
pvtwmx = 10d0**((0.7859d0+0.03477d0*twatn)/(1d0+0.00412d0*twatn)) ! and near water surface (ew); eq.(A.12):
pvtahu = rhumn*pvtamx ! vapour pressure in air remote (eal)
qwmx = (0.62d0*pvtwmx)/(presn - 0.38d0*pvtwmx) ! specific humidity of air remote and
qahu = (0.62d0*pvtahu)/(presn - 0.38d0*pvtahu) ! saturated air near water surface; eq.(A.9)+(A.10):
tl = 2.5d6 - 2.3d3*twatn ! latent heat tl; eq.(A.19.b):
if (Stanton < 0) then ! if specified negative, use windspeed dependent Cd coeff
ch = abs(Stanton)*cdwcof(L)
endif
if (Dalton < 0) then ! if specified negative, use windspeed dependent Cd coeff
ce = abs(Dalton )*cdwcof(L)
endif
delvap = qwmx-qahu ! D3D, both positive and negative evaporation, cannot be correct
if (jadelvappos == 1) then
delvap = max(0d0, delvap) ! DPM, DFM This must be positive, otherwise heat is pumped into water
endif ! causing air to cool down below prescribed temperature, immedia. and
Qeva = -ce*rhoair*windn*delvap*tl ! heat loss of water by evaporation eq.(A.19.a); Dalton number is ce:
Qcon = -ch*rcpa*windn*(twatn-tairn) ! heat loss of water by convection eq.(A.23); Stanton number is ch:
twatK = twatn + tkelvn
Qlong = -em*stf*(twatK**4d0)*(0.39d0-0.05d0*sqrt(pvtahu)) ! heat loss by effective infrared back radiation hl, restricted by
Qlong = Qlong*(1d0 - 0.6d0*cloun**2 ) ! presence of clouds and water vapour in air; eq.(A.22):
Qfree = 0d0 ; Qfrcon = 0d0 ; Qfreva = 0d0 ! Contribution by free convection:
rhoa0 = ((presn-pvtwmx)/rdry + pvtwmx/rvap) / (Twatn + Tkelvn)
rhoa10 = ((presn-pvtahu)/rdry + pvtahu/rvap) / (Tairn + Tkelvn)
gred = 2d0*ag*(rhoa10-rhoa0)/(rhoa0+rhoa10)
if (gred > 0d0) then ! Ri= (gred/DZ)/ (du/dz)2, Ri>0.25 stable
wfree = gred*xnuair/pr2
wfree = cfree*wfree**0.33333333d0
Qfrcon = -rcpa*wfree*(twatn-tairn)*evafac ! Free convective sensible heat loss:
Qfreva = -wfree*(qwmx-qahu)*tl*evafac*(rhoa0+rhoa10)*0.5d0 ! Free convective latent/evaporation heat loss:
Qfree = Qfrcon + Qfreva
endif
qheat = Qeva + Qcon + Qlong + Qfree ! net heat flux [W/m^2] into water, solar radiation excluded:
heatsrc0(kt) = heatsrc0(kt) + qheat*rcpiba ! fill heat source array
if (jamapheatflux > 0) then ! todo, only at mapintervals
Qsunmap(n) = Qsu
Qevamap(n) = Qeva
Qconmap(n) = Qcon
Qlongmap(n) = Qlong
Qfrevamap(n) = Qfreva
Qfrconmap(n) = Qfrcon
Qtotmap(n) = Qsu + qheat
endif
!if (ti_xls > 0) then
Atot = 0d0 ! these 2 lines outside loop
w = 0d0 ! array of spatially averaged output
b = ba(n) ! Spatially averaged time series output :
atot = atot + b ! Total area
w( 1) = timhr/24d0 ! Time in days
w( 2) = w( 2) + b*tairn ! tair
w( 3) = w( 3) + b*tem1(kt) ! Twatn, SST
w( 4) = w( 4) + b*tem1(kb) ! tbed
w( 5) = w( 5) + b*(qsu + qheat) ! qtot
w( 6) = w( 6) + b*Qsu ! Qsun
w( 7) = w( 7) + b*Qlong ! QLw
w( 8) = w( 8) + b*Qcon ! Qcon
w( 9) = w( 9) + b*Qeva ! Qeva
w(10) = w(10) + b*Qfrcon ! Qfreecon
w(11) = w(11) + b*Qfreva ! Qfree
w(12) = w(12) + b*windn ! wind
w(13) = w(13) + b*rhumn ! rhum
w(14) = w(14) + b*cloun ! clou
w(15) = w(15) + b*presn ! pres
ncols = 15
if (Atot > 0d0) then
w(2:ncols) = w(2:ncols) / Atot
endif
Qsunav = w(6) ; Qlongav = w(7) ; Qconav = w(8) ; Qevaav = w(9) ; Qfrconav = w(10) ; Qfrevaav = w(11)
!if (lunadh == 00) then
! call newfil(lunadh, trim(md_ident)//'Spatially_Averaged_Heatfluxes.tek')
! write(lunadh,'(a)') '* column 1: minut :'
! write(lunadh,'(a)') '* column 2: T_air :'
! write(lunadh,'(a)') '* column 3: SST :'
! write(lunadh,'(a)') '* column 4: T_bed :'
! write(lunadh,'(a)') '* column 5: Q_tot :'
! write(lunadh,'(a)') '* column 6: Qsun : input solar radiation '
! write(lunadh,'(a)') '* column 7: Qlw : back radiation'
! write(lunadh,'(a)') '* column 8: Qcon : convection'
! write(lunadh,'(a)') '* column 9: Qeva : evaporation'
! write(lunadh,'(a)') '* column 10: Qfrconav : free convection'
! write(lunadh,'(a)') '* column 11: Qfrevaav : free evaporation'
! write(lunadh,'(a)') '* column 12: Wind :'
! write(lunadh,'(a)') '* column 13: Rhum :'
! write(lunadh,'(a)') '* column 14: Clou :'
! write(lunadh,'(a)') '* column 15: Pres :'
! write(lunadh,'(a)') 'BL01'
! write(lunadh,'(a)') '105125 15 '
!endif
!write(lunadh,'(20(1x,g12.6))') ( w(i), i = 1,ncols )
!endif
endif
end subroutine heatun
subroutine qsun_nominal(rlon, rlat, timhr, qs)
use m_sferic
use m_flowtimes, only : timjan, tzone
implicit none
double precision :: rlat, rlon, timhr, qs
double precision :: decln, w0, w1, d, e, tm , snh
! Calculate sine of the angle of the sun above the horizon: SNH
! d is the declination angle
! June 21st is the 171st day after TM=0
tm = timjan + timhr
!if (jsferic > 0) then
tm = tm + 24.0d0*rlon/360.0d0 - tzone
!endif
w0 = twopi / (365.24d0*24d0)
w1 = twopi / (24d0)
decln = 23.5d0*dg2rd
d = decln * cos(w0*tm - 2.950d0)
e = rlat*dg2rd
snh = -cos(e) * cos(d) * cos(w1*tm) + sin(e) * sin(d)
snh = max(0d0,min(1d0,snh))
qs = 1368d0 * snh * 0.76d0
end subroutine qsun_nominal
!> used for debugging the z-layer administration in parallel computations
subroutine debugit()
use m_partitioninfo
use m_flowgeom
use m_flow
use unstruc_messages
implicit none
double precision, dimension(:,:), allocatable :: dum
integer :: k, L
integer :: ierror
ierror = 0
if ( jampi.eq.0 ) return ! intended for parallel computations only
! allocate dummy array
allocate(dum(2,Ndx))
! filly dummy array
do k=1,Ndx
dum(1,k) = dble(kmxn(k))
dum(2,k) = bl(k)
end do
! synchonisy dummy array
call update_ghosts(ITYPE_SALL, 2, Ndx, dum, ierror)
if ( ierror.ne.0 ) then
call qnerror('debugit: error', '', '')
goto 1234
end if
! check values
do k=1,Ndx
if ( int(dum(1,k)).ne.kmxn(k) ) then
write(6,"('debugit: kmxn error, k=', I7 )") k
ierror = 1
goto 1234
end if
if ( dum(2,k).ne.bl(k) ) then
write(6,"('debugit: bl error, k=', I7 )") k
ierror = 1
goto 1234
end if
end do
if ( allocated(dum) ) deallocate(dum)
allocate(dum(1,Lnx))
! filly dummy array
do L=1,Lnx
dum(1,L) = dble(kmxL(L))
end do
! synchonisy dummy array
call update_ghosts(ITYPE_U, 1, Lnx, dum, ierror)
if ( ierror.ne.0 ) then
call qnerror('debugit: error', '', '')
goto 1234
end if
! check values
do L=1,Lnx
if ( int(dum(1,L)).ne.kmxL(L) ) then
write(6,"('debugit: kmxL error, L=', I7 )") L
ierror = 1
end if
end do
if ( ierror.eq.1 ) then
call mess(LEVEL_ERROR, 'debugit: vertical layer administration out of sync', ' ', ' ')
stop
end if
1234 continue
if ( allocated(dum) ) deallocate(dum)
return
end subroutine debugit
!> disable ghostcells that have no internal cells in the other subdomains by setting the wu of their flowlinks to zero
!> and rely on sethu to disable the flowlinks
!> an invalid ghostcell is a flownode, say k, that:
!> -is not a boundary node (k.le.Ndxi), and
!> -is not in the own subdomain (idomain(k).ne.my_rank), and
!> -is not a member of ghostlist_sall
subroutine disable_invalid_ghostcells_with_wu()
use m_partitioninfo
use m_flowgeom, only: Ndx, Ndxi, nd, wu
implicit none
integer, dimension(:), allocatable :: imask
integer :: i, k, L
integer :: ierror
ierror = 0 ! so far, so good
if ( jampi.eq.0 ) return ! nothing to do
ierror = 1
! allocate
allocate(imask(Ndx)) ! safety, could also be Ndxi
! mark the flownodes in the ghostlist
imask = 0
do i=1,nghostlist_sall(ndomains-1)
k = ighostlist_sall(i)
imask(k) = 1
end do
! check non-boundary flownodes and disable cells that are neither in own subdomain nor in ghoslist by setting wu's of their flowlinks to zero
do k=1,Ndxi
if ( imask(k).eq.0 .and. idomain(k).ne.my_rank ) then
do i=1,nd(k)%lnx
L = iabs(nd(k)%ln(i))
wu(L) = 0d0
end do
end if
end do
ierror = 0
1234 continue
if ( allocated(imask) ) deallocate(imask)
return
end subroutine disable_invalid_ghostcells_with_wu
! Anti-creep
subroutine anticreep( L )
use m_flow
use m_flowgeom
use m_transport
use m_flowparameters
implicit none
double precision, allocatable, dimension(:) :: polal ! Z-coordinate horizontal layers in nm
double precision, allocatable, dimension(:) :: pocol
double precision, allocatable, dimension(:) :: polar ! Z-coordinate horizontal layers in nmu
double precision, allocatable, dimension(:) :: pocor
double precision, allocatable, dimension(:) :: poflu ! Z-coordinate gradient flux
double precision, allocatable, dimension(:) :: point
double precision, allocatable, dimension(:) :: drho, dsal, dtem
double precision, allocatable, dimension(:) :: kicol, kicor
integer :: k1, k2, kbl, kbr, ktl, ktr, kll, krr, kl, kr, kl1, kl2, kr1, kr2
integer :: kpoint, kf, L, k, j, Lb, Lt, LL, kfmax, kfmax1, kflux
double precision :: grad, grad1, grad2, cl, cr, flux, flux1
double precision :: zbot, ztop, zmid, zbed, farea, area
double precision :: rhods, rhodt, temp, sal, dummy, dpbdx
allocate (polal(0:kmx),pocol(0:kmx),polar(0:kmx),pocor(0:kmx))
allocate (poflu(0:2*kmx+1),kicol(0:2*kmx+1),kicor(0:2*kmx+1))
allocate (point(0:2*kmx+1), drho(0:2*kmx+1), dsal(0:2*kmx+1), dtem(0:2*kmx+1))
if( jasal == 0 .and. jatem == 0 ) return
k1 = ln(1,L) ; k2 = ln(2,L)
call getkbotktop( k1, kbl, ktl )
call getkbotktop( k2, kbr, ktr )
call getLbotLtop( L, Lb, Lt )
zbed = ( bob(1,L) + bob(2,L) ) * 0.5d0 ! interpolates the bed level on flow link
!
!***position horizontal interfaces left and right
!
polal = 0d0
pocol = 0d0
polar = 0d0
pocor = 0d0
polal(0) = zws(kbl-1)
polar(0) = zws(kbr-1)
do k = 1,kmx
kl = kbl + k - 1
kr = kbr + k - 1
polal(k) = zws(kl)
polar(k) = zws(kr)
pocol(k) = ( zws(kl) + zws(kl-1) ) * 0.5d0
pocor(k) = ( zws(kr) + zws(kr-1) ) * 0.5d0
enddo
!
!***merge polal and polar
!
kll = 0
krr = 0
do k = 0,2*kmx+1
j = 0
if ( polal(kll) < polar(krr) ) then
point(k) = polal(kll)
kll = kll + 1
if ( kll > kmx ) then
kpoint = k + 1
point(kpoint) = polar(krr)
j = 1
exit
endif
else
point(k) = polar(krr)
krr = krr + 1
if ( krr > kmx ) then
kpoint = k + 1
point(kpoint) = polal(kll)
j = 1
exit
endif
endif
enddo
if( j == 0 ) kpoint = 2 * kmx + 1
!
!***position flux points
!
poflu = 0d0
kflux = kpoint
do k = 1,kflux
poflu(k) = 0.5d0 * ( point(k) + point(k-1) )
enddo
!
!***k-index concentration points left and right for flux point
!
kll = 1
krr = 1
do kf = 1,kflux
kicol(kf) = 0
kicor(kf) = 0
do k = kll,kmx
if ( poflu(kf) >= polal(k-1) .and. poflu(kf) <= polal(k) ) then
kicol(kf) = k
kll = k
exit
endif
enddo
do k = krr,kmx
if ( poflu(kf) >= polar(k-1) .and. poflu(kf) <= polar(k) ) then
kicor(kf) = k
krr = k
exit
endif
enddo
enddo
!
!***computation diffusive flux using limiter
!
drho = 0d0
dsal = 0d0
dtem = 0d0
do kf = kflux,1,-1
kll = kicol(kf)
krr = kicor(kf)
if ( kll * krr == 0 ) cycle
kl = kbl + kll - 1 ! changes the number of layer to number of cell
kr = kbr + krr - 1
if ( point(kf) <= zbed ) exit
drho(kf) = 0d0
dsal(kf) = 0d0
dtem(kf) = 0d0
!
!***flux
!
if ( pocor(krr) > pocol(kll) ) then
kl1 = ktl + 1
do k = kl+1,ktl
if ( pocol(k-kbl+1) > pocor(krr) ) then
kl1 = k
exit
endif
enddo
kl2 = kl1 - 1
else
kl1 = kbl - 1
do k = kl-1,kbl,-1
if ( pocol(k-kbl+1) < pocor(krr) ) then
kl1 = k
exit
endif
enddo
kl2 = kl1 + 1
endif
if ( pocol(kll) > pocor(krr) ) then
kr1 = ktr + 1
do k = kr+1,ktr
if ( pocor(k-kbr+1) > pocol(kll) ) then
kr1 = k
exit
endif
enddo
kr2 = kr1 - 1
else
kr1 = kbr - 1
do k = kr-1,kbr,-1
if ( pocor(k-kbr+1) < pocol(kll) ) then
kr1 = k
exit
endif
enddo
kr2 = kr1 + 1
endif
if ( jasal > 0 ) then
cl = sa1(kl2)
if ( kl1 >= kbl .and. kl1 <= ktl ) cl = ( ( pocol(kl2-kbl+1) - pocor(krr ) ) * sa1(kl1) &
+ ( pocor(krr ) - pocol(kl1-kbl+1) ) * sa1(kl2) ) &
/ ( pocol(kl2-kbl+1) - pocol(kl1-kbl+1) )
cr = sa1(kr2)
if ( kr1 >= kbr .and. kr1 <= ktr ) cr = ( ( pocor(kr2-kbr+1) - pocol(kll ) ) * sa1(kr1) &
+ ( pocol(kll ) - pocor(kr1-kbr+1) ) * sa1(kr2) ) &
/ ( pocor(kr2-kbr+1) - pocor(kr1-kbr+1) )
grad1 = ( sa1(kr) - cl ) ! / dx(L)
grad2 = ( cr - sa1(kl) ) ! / dx(L)
grad = 0d0 ; if ( grad1 * grad2 > 0d0 ) grad = 2.0d0 * grad1 * grad2 / (grad1 + grad2)
sal = acl(L) * sa1(kl) + ( 1d0 - acl(L) ) * sa1(kr)
temp = backgroundwatertemperature
if ( jatem > 0 ) temp = acl(L) * tem1(kl) + ( 1d0 - acl(L) ) * tem1(kr)
call dens_eck( temp, sal, dummy, rhods, dummy )
drho(kf) = drho(kf) + rhods * grad
dsal(kf) = grad
endif
if ( jatem > 0 ) then
cl = tem1(kl2)
if ( kl1 >= kbl .and. kl1 <= ktl ) cl = ( ( pocol(kl2-kbl+1) - pocor(krr ) ) * tem1(kl1) &
+ ( pocor(krr ) - pocol(kl1-kbl+1) ) * tem1(kl2) ) &
/ ( pocol(kl2-kbl+1) - pocol(kl1-kbl+1) )
cr = tem1(kr2)
if ( kr1 >= kbr .and. kr1 <= ktr ) cr = ( ( pocor(kr2-kbr+1) - pocol(kll ) ) * tem1(kr1) &
+ ( pocol(kll ) - pocor(kr1-kbr+1) ) * tem1(kr2) ) &
/ ( pocor(kr2-kbr+1) - pocor(kr1-kbr+1) )
grad1 = ( tem1(kr) - cl ) ! / dx(L)
grad2 = ( cr - tem1(kl) ) ! / dx(L)
grad = 0d0 ; if ( grad1 * grad2 > 0d0 ) grad = 2.0d0 * grad1 * grad2 / (grad1 + grad2)
temp = acl(L) * tem1(kl) + ( 1d0 - acl(L) ) * tem1(kr)
sal = backgroundsalinity
if ( jasal > 0 ) sal = acl(L) * sa1(kl) + ( 1d0 - acl(L) ) * sa1(kr)
call dens_eck( temp, sal, dummy, dummy, rhodt )
drho(kf) = drho(kf) + rhodt * grad
dtem(kf) = grad
endif
enddo
dpbdx = 0d0
flux1 = 0d0
kfmax = kflux
kfmax1 = kflux
do k = kmx,1,-1
ztop = acl(L) * zws(kbl+k-1) + ( 1d0 - acl(L) ) * zws(kbr+k-1)
zbot = acl(L) * zws(kbl+k-2) + ( 1d0 - acl(L) ) * zws(kbr+k-2)
zmid = ( zbot + ztop ) * 0.5d0
LL = Lb + k - 1
do kf = kfmax,1,-1
kll = kicol(kf)
krr = kicor(kf)
if ( point(kf) <= zbed ) exit
if ( kll * krr == 0 ) cycle
if ( zmid < point(kf-1) ) then
flux = ag * ( point(kf) - point(kf-1) ) * drho(kf) / rhomean
flux1 = flux1 + flux
dpbdx = flux1
elseif( zmid < point(kf) .and. zmid >= point(kf-1) ) then
flux = ag * ( point(kf) - zmid ) * drho(kf) / rhomean
dpbdx = flux1 + flux
kfmax = kf
exit
endif
enddo
if (jabaroctimeint .le. 1) then ! explicit
adve(LL) = adve(LL) + dpbdx / dx(L) ! to compensate for not dividing by dx above
else
adve(LL) = adve(LL) + (1.5d0*dpbdx - 0.5d0*dpbdx0(L) ) / dx(L) ! to compensate for not dividing by dx above
endif
if (abs(jabaroctimeint) >= 2) then
dpbdx0(L) = dpbdx
endif
do kf = kfmax1,1,-1
farea = - max( point(kf )-ztop, 0d0 ) & ! to find the flux area between the flux pieces and the sigma layer
+ max( point(kf )-zbot, 0d0 ) &
- max( point(kf-1)-zbot, 0d0 )
if ( farea < 0 ) then
kfmax1 = kf
exit
endif
dsalL(LL) = dsalL(LL) + dsal(kf) * farea
dtemL(LL) = dtemL(LL) + dtem(kf) * farea
enddo
dsalL(LL) = dsalL(LL) / ( ztop - zbot )
dtemL(LL) = dtemL(LL) / ( ztop - zbot )
enddo
if (abs(jabaroctimeint) >= 2) then
jabaroctimeint = abs(jabaroctimeint)
endif
deallocate(polal,pocol,polar,pocor)
deallocate(poflu,kicol,kicor)
deallocate(point, drho, dsal, dtem)
end subroutine anticreep
subroutine dens_eck( temp, sal, rholoc ,rhods ,rhodt )
implicit none
double precision, intent(in) :: temp, sal
double precision, intent(out) :: rholoc, rhods, rhodt
double precision :: cp0, clam, clam0, cp1, clam1, alph0, cp1ds, cp1dt, cladt, rhom, den
!
!! Data statements
!
alph0 = 0.698d0
rhom = 0.0d0
!
!! executable statements -------------------------------------------------------
!
den = temp * temp
cp0 = 5890.0d0 + 38.00d0 * temp - 0.3750d0 * den
clam = 1779.5d0 + 11.25d0 * temp - 0.0745d0 * den
clam0 = 3.8d0 + 0.01d0 * temp
cp1 = cp0 + 3.0d0 * sal
clam1 = clam - clam0 * sal
rholoc = 1000.0d0 * cp1 / ( alph0 * cp1 + clam1 ) ! - rhom
den = ( alph0 * cp1 + clam1)**2
cp1ds = 3.0d0
rhods = 1000.0d0 * ( cp1ds * clam1 + cp1 * clam0 ) / den
cp1dt = 38.00d0 - 0.750d0 * temp
cladt = 11.25d0 - 0.149d0 * temp - 0.01d0 * sal
rhodt = 1000.0d0 * ( cp1dt * clam1 - cp1 * cladt ) / den
end subroutine dens_eck
!> speed test: compute z = Ax+y
!> note: no communcation included in parallel runs, only test speed
subroutine axpy(Mglob,Nglob)
use m_partitioninfo
use unstruc_messages
use m_timer
implicit none
integer, intent(in) :: Mglob !> global size of x
integer, intent(in) :: Nglob !> global size of y
double precision, dimension(:), allocatable :: x, y, z
double precision, dimension(:,:), allocatable :: A
integer :: irun
integer :: ierror
integer :: M, N, i, j
ierror = 1
! compute array sizes based on number of subdomains
M = Mglob
N = Nglob
! allocate
allocate(x(M))
allocate(y(N))
allocate(z(N))
allocate(A(N,M))
! fill matrix A and vector x
do j=1,M
do i=1,N
call random_number(A(i,j))
end do
call random_number(x(j))
end do
! fill vecor y
do i=1,N
call random_number(y(i))
end do
call starttimer(IAXPY)
! z = Ax + y
do i=1,N
z(i) = y(i)
do j=1,M
z(i) = z(i) + A(i,j)*x(j)
end do
end do
call stoptimer(IAXPY)
ierror = 0
1234 continue
! deallocate
if ( allocated(x) ) deallocate(x)
if ( allocated(y) ) deallocate(y)
if ( allocated(A) ) deallocate(A)
end subroutine axpy
! update geometry data that may have been incorrectly computed in the ghost area
subroutine update_geom(iphase)
use m_partitioninfo
use m_flowgeom
implicit none
integer, intent(in) :: iphase ! phase, 0 (all), 1 (first) or 2 (second)
integer :: ierror
if ( iphase.eq.0 .or. iphase.eq.1 ) then
call update_ghosts(ITYPE_SALL, 1, Ndx, xz, ierror)
call update_ghosts(ITYPE_SALL, 1, Ndx, yz, ierror)
end if
if (iphase.eq.0 .or. iphase.eq.2 ) then
call update_ghosts(ITYPE_SALL, 1, Ndx, bl, ierror)
end if
return
end subroutine update_geom