!----- AGPL --------------------------------------------------------------------
!
! Copyright (C) Stichting Deltares, 2017-2020.
!
! 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$
! $HeadURL$
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
SUBROUTINE INIDAT()
USE m_missing
use m_netw
USE M_BOAT
USE M_AFMETING
USE M_SEASTATE
use unstruc_model
use unstruc_display
use unstruc_messages
use M_splines, only: increasespl, maxspl, maxsplen, readsplines
USE M_SAMPLES
use m_commandline_option
use dfm_signals
use gridoperations
use m_monitoring_crosssections, only: increaseCrossSections, maxcrs
implicit none
interface
subroutine realan(mlan, antot)
integer, intent(inout) :: mlan
integer, intent(inout), optional :: antot
end subroutine realan
end interface
double precision :: ag, cdflow, cfl, cfric, deltx, delty, deltz, dscr, dx, e0, eps, epsgs, fbouy, fdyn, gx, gy, gz
integer :: ierr
integer :: itgs
integer :: ja, istat
integer :: janet
integer :: jav
integer :: jqn
integer :: jview
integer :: k, i
integer :: maxitgs
integer :: minp
integer :: moments
integer :: n1, n2
integer :: ndraw
integer :: nlevel
double precision :: pi
double precision :: rho
double precision :: rhow
double precision :: rk
double precision :: rmiss
double precision :: splfac
double precision :: splfac2
double precision :: wpqr
double precision :: xyz
double precision :: zfac
double precision :: zupw
integer, save :: jaSkipCmdLineArgs = 0 !< Later set to 1, to read cmdline args just once.
COMMON /DRAWTHIS/ ndraw(50)
COMMON /HELPNOW/ WRDKEY,NLEVEL
COMMON /SPLINEFAC/ SPLFAC, SPLFAC2
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
COMMON /SETTINGS/ FDYN, FBOUY, CDFLOW, CFRIC, MOMENTS, JANET
COMMON /QNRGF/ JQN
COMMON /PERSPX/ WPQR,DELTX,DELTY,DELTZ,ZFAC,DSCR,ZUPW
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
COMMON /GRAVITY/ GX,GY,GZ
COMMON /SOLVER/ EPSGS, MAXITGS, ITGS
COMMON /PLOTFIL/ PLOTJE
CHARACTER PLOTJE*255
LOGICAL JAWEL
CHARACTER WRDKEY*40, inarg*255, EXT*4
! for command line options
character(len=MAXOPTLEN) :: Soption ! option
integer :: Nkeys ! number of keys for this option
character(len=MAXKEYLEN), dimension(MAXKEYS) :: Skeys ! keys
integer, dimension(MAXKEYS) :: ivals ! values
integer :: ikey
! 1=CLS
! 2=GRID/NET 1=RECHT 2=SPLINE
! 3=LAND 1=NORMAAL 2=PUNTJES
! 4=SAM 1=FCIR 2=CIJFER
! 5=DEP 1=DOT 2=FIL 3=LIN 4=NOPOINT 5=CIJFER
! 6=POLYGON
! 7=TEKENENEN ELEMENTEN UIT ELEMENT ADMINISTRATIE
! 8=DRAW INTERPOL YES/NO NODEVALS
! 9=MET 1=VLAK 2=PER 3=SUNPER 4=DRYFL 5=PROJ
! 10=HCOPY 1=JA
! 11=COUR 1=M,2=N,3=MN STRESSES
! 12=ISOSCALE 1=NODES, 2=LINKS, 3=BOTH, 4=OFF
! 13=?
! 14=ELEMENT STRESSES
! 15=SPLINES
! 16=PREVIOUS STATE GRID
! 17=SECOND DEPTH
! 18=BOAT
! 19=DDBOUNDARIES, INTERNAL BOUNDARIES
call dfm_add_signalwatchers() ! Register ourselves to Ctrl-C and Ctrl-Z presses, etc. for emergency map files.
CALL ININUMBERS()
call maketekaltimes()
JQN = 2
NDRAW(1) = 1 ! clear screen yes/no
NDRAW(2) = 1 ! display network
NDRAW(3) = 1 ! display landboundary
NDRAW(4) = 0 ! void
NDRAW(5) = 2 ! void
NDRAW(6) = 0 ! void
NDRAW(7) = 1 ! WHICH netLINk VALue, 1 = NO
NDRAW(8) = 1 ! WHICH netNODe VALue, 1 = NO
NDRAW(9) = 1 ! NORMAL OR PERSPECTIVE
NDRAW(10) = 0 ! also plot to file yes/no
NDRAW(11) = 4 ! HOW HISPLAY LINVAL, ,Linkhow: 1=no, 2=numbers, 3=isofil smooth, 4 = isofil, 5=dots
NDRAW(12) = 3 ! 1=nodes, 2=links, 3=nodes+links, 4 = no isoscale
NDRAW(13) = 2 !1 !0 ! SHOW UV VECTORS AND FLOW FORCES
NDRAW(14) = 2 ! reserved for disval
NDRAW(15) = 1 ! display splines
NDRAW(16) = 0 ! display PREVIOUS NETWORK
NDRAW(17) = 0 ! void
NDRAW(18) = 2 ! Sideview, 1 = no, 2=small, 3=larger, 4=largest
NDRAW(19) = 4 ! HOW DISPLAY NODEVAL, Nodehow: 1=no, 2=numbers, 3=isofil smooth, 4 = isofil, 5=dots
NDRAW(20) = 0 ! void
NDRAW(21) = 0 ! void
NDRAW(22) = 0 ! SHOW netcell types tri, quads penta, hexa
NDRAW(26) = 0 ! 1 = BITMAP
NDRAW(27) = 1 ! 1 = nothing, 2 = both surf and bot, 3 just bot, 4 just surf
NDRAW(28) = 2 ! values at Flow Nodes 1=no, 2=s1, 3=bl, 4=ba, 5=v1 , nodewhat
NDRAW(29) = 1 ! values at Flow Links 1=no, 2=u1, 3=q1, 4=au, , linkwhat
ndraw(30) = 1 ! do not show all flow links
ndraw(31) = 1 ! do not show show values at cell corners, 2=ucnx, 3=ucny
ndraw(32) = 1 ! show samples coloured dot
ndraw(33) = 1 ! show values at net cells, 2=number, 3=aspect ratio, 4=orientation vectors, 5=aspect ratio and orientation vectors, 6=cell area, 7=coarsening information
ndraw(34) = 0 ! Banf, 0=no, 1 =seqtr, 3=(seqtr-s), tekbanf
ndraw(35) = 1 ! yes draw reference profiles (only for 3D)
ndraw(36) = 0 ! values on flow nodes minus plotlin default 0
ndraw(37) = 2 ! 0 = no, 1 = probe, no boundaryvalues, 2=probe+boundaryvalues
ndraw(38) = 1 ! display curvilinear grid: 0 = no, 1 = lines, 2 = count netw
ndraw(39) = 0 ! 1=predraw bathy in link colours, 0 = not do so
ndraw(40) = 0 ! waterbal
ndraw(41) = 1 ! sorsin
plotje = ' '
jview = len_trim (plotje)
JVIEW = 1
JAV = 3
ITGS = 0
NUML = 0
NUMK = 0
NUML0 = 0
NUMK0 = 0
NUMP = 0
MXLAN = 0
NPL = 0
NSMAX = 0
NS = 0
NS2 = 0
MC = 0
NC = 0
MXBOAT = 0
NCLBOAT = 170
CALL PARAMTEXT('Waterlevel (m )', 1)
if (.not. allocated(xk)) then
allocate( xk (1), yk (1), zk (1) , NOD (1) , KC (1) , NMK (1) , KN(3,1), LC(1), RNOD(1), RLIN(1))
allocate(nod(1)%lin(1))
NMK = 0
endif
if (.not. allocated(xk0)) then
allocate( xk0(1), yk0(1), zk0(1) , NOD0(1) , KC0(1) , NMK0(1), KN0(3,1), LC0(1) )
allocate(nod0(1)%lin(1))
nmk0 = 0
endif
KMAX = 1
LMAX = 1
CALL INCREASENETW(KMAX, LMAX)
CALL INCREASEPOL(MAXPOL, 0)
!write (*,*) 'increased pols'
CALL INCREASEGRID(2,2)
!write (*,*) 'increased grid'
call increasespl(maxspl, maxsplen)
!write (*,*) 'increased spl'
!call increaseCrossSections(maxcrs)
!write (*,*) 'increased crs'
CALL INCREASESAM(2)
!write (*,*) 'increased sam'
CALL INCREASELAN(MAXLAN)
!write (*,*) 'increased lan'
CALL ZERONET()
!write (*,*) 'zeronet'
XK0 = 0 ; YK0 = 0 ; ZK0 = 0
!XK1 = 0 ; YK1 = 0 ; ZK1 = 0
RK = 0
RNOD = dmiss ; RLIN = dmiss
XLAN = xymis ; YLAN = xymis ; ZLAN = 0 ; NCLAN = 0
XPL = 0 ; YPL = 0
KN = 0 ; KN0 = 0
NMK = 0 ; NMK0 = 0
KC = 0 ; KC0 = 0
LC = 0 ; LC0 = 0
DX = 1.0d20
RMISS = -999
ZUPW = 1d0
AG = 9.81d0
PI = ACOS(-1.)
RHOW = 1000
JVAST = 0
RLENGTH = 1
RWIDTH = 0.01d0
RTHICK = 0.01d0
LFAC = 2
MOMENTS = 1
XYZ = 0
TWOPI = 2*ACOS(-1d0)
WAVLEN = WAVCEL*WAVPER
WAVKX = TWOPI/WAVLEN
WAVOM = TWOPI/WAVPER
CALL INISFERIC()
if ( jaSkipCmdLineArgs.eq.1 ) then
iarg_autostart = -1
else
do k=1,numfiles
inarg = inputfiles(k)
INQUIRE(FILE = trim(inarg),EXIST = JAWEL)
if (JAWEL) then
! Find file extention based on first full stop symbol '.' at the back of the string.
N1 = INDEX (inarg,'.', .true.)
N2 = len_trim(inarg)
EXT = ' '
EXT = inarg(N1:N2)
IF (EXT .EQ. '.ldb' .OR. EXT .EQ. '.LDB' ) THEN
CALL OLDFIL (MINP, inarg)
CALL REALAN (MINP)
ELSE IF (EXT .EQ. '.net' .OR. (EXT .EQ. '.nc' .and. inarg(max(1,N1-4):max(1,N1-1)) == '_net') ) THEN
!CALL OLDFIL (MINP, inarg)
CALL loadNetwork(trim(inarg),istat,1)
if (istat == 0) then
md_netfile = ' ' ; md_netfile = trim(inarg)
endif
ELSE IF (EXT .EQ. '.bmp' .OR. EXT .EQ. '.BMP' ) THEN
CALL LOADBITMAP(inarg)
ELSE IF (EXT .EQ. '.mdu' .OR. EXT .EQ. '.MDU' ) THEN
CALL LOADMODEL(inarg)
ELSE IF (EXT .EQ. '.xyz' .OR. EXT .EQ. '.XYZ' ) THEN
CALL OLDFIL(MINP, inarg)
CALL REASAM(MINP, 1)
ELSE IF (EXT .EQ. '.asc' .OR. EXT .EQ. '.ASC' ) THEN
CALL OLDFIL(MINP, inarg)
call doclose(MINP)
call read_samples_from_arcinfo(trim(inarg), ja)
ELSE IF (EXT .EQ. '.pol' .OR. EXT .EQ. '.POL' ) THEN
CALL OLDFIL(MINP, inarg)
CALL REAPOL(MINP, 0)
ELSE IF (EXT .EQ. '.pli' .OR. EXT .EQ. '.PLI' ) THEN
CALL OLDFIL(MINP, inarg)
CALL REAPOL(MINP, 0)
ELSE IF (EXT .EQ. '.spl' .OR. EXT .EQ. '.SPL' ) THEN
CALL OLDFIL (MINP, inarg)
CALL READSPLINES(MINP)
ELSE IF (EXT .EQ. '.grd' .OR. EXT .EQ. '.GRD' ) THEN
CALL OLDFIL(MINP, inarg)
CALL REAgrid(MINP, inarg,ja)
ELSE IF (EXT .EQ. '.rst' .OR. EXT .EQ. '.RST' ) THEN
md_restartfile = trim(inarg)
ELSE IF (EXT .EQ. '.cfg' .OR. EXT .EQ. '.CFG' ) THEN
md_cfgfile = inarg
ENDIF
else
call mess(LEVEL_INFO, 'File not found: '''//trim(inarg)//'''. Ignoring this commandline argument.')
end if
end do
end if
jaSkipCmdLineArgs = 1 !< Do not process cmdline again (for example when reading another mdu via files menu)
! Merge cmd line switches with mdu file settings
if (iarg_autostart /= -1) then
md_jaAutoStart = iarg_autostart
end if
if ( jaGUI.eq.1 ) then
CALL MINMXNS()
!CALL WEAREL()
end if
WRDKEY = 'PROGRAM PURPOSE'
NLEVEL = 1
RETURN
END SUBROUTINE INIDAT
subroutine maketekaltimes()
use m_flowtimes
implicit none
logical :: jawel
integer :: minp, mout, i, k
double precision :: tim, a(30)
character*20 dateandtime
inquire (file = '102023.DAT', exist = jawel)
if (jawel) then
refdat = '19920831'
call oldfil(minp, '102023.DAT')
call newfil(mout, '102023.tek')
write(mout,'(a)') '*COLUMN 1 : DATE'
write(mout,'(a)') '*COLUMN 2 : TIME'
write(mout,'(a)') '*COLUMN 3 : REF TEU'
write(mout,'(a)') '*COLUMN 4 : V TEU'
write(mout,'(a)') '*COLUMN 5 : Z TEU'
write(mout,'(a)') '*COLUMN 6 : TRIM TEU '
write(mout,'(a)') '*COLUMN 7 : VX2 STROOM'
write(mout,'(a)') '*COLUMN 8 : VY2 STROOM '
write(mout,'(a)') '*COLUMN 9 : GOLF 1 '
write(mout,'(a)') '*COLUMN 10 : GOLF 2'
write(mout,'(a)') '*COLUMN 11 : GOLF 3'
write(mout,'(a)') '*COLUMN 12 : X COG PAN '
write(mout,'(a)') '*COLUMN 13 : Y COG PAN '
write(mout,'(a)') '*COLUMN 14 : Z COG PAN '
write(mout,'(a)') '*COLUMN 15 : ROLL PAN '
write(mout,'(a)') '*COLUMN 16 : PITCH PAN '
write(mout,'(a)') '*COLUMN 17 : YAW PAN '
write(mout,'(a)') '*COLUMN 18 : F LIJN 1 '
write(mout,'(a)') '*COLUMN 19 : F LIJN 2 '
write(mout,'(a)') '*COLUMN 20 : F LIJN 3 '
write(mout,'(a)') '*COLUMN 21 : F LIJN 4 '
write(mout,'(a)') '*COLUMN 22 : F LIJN 5 '
write(mout,'(a)') '*COLUMN 23 : F LIJN 6 '
write(mout,'(a)') '*COLUMN 24 : FX TOT '
write(mout,'(a)') '*COLUMN 25 : FY TOT '
write(mout,'(a)') '*COLUMN 26 : MZ TOT '
write(mout,'(a)') '*COLUMN 27 : FX FEND V'
write(mout,'(a)') '*COLUMN 28 : FY FEND V'
write(mout,'(a)') '*COLUMN 29 : FZ FEND V'
write(mout,'(a)') '*COLUMN 30 : FX FEND A'
write(mout,'(a)') '*COLUMN 31 : FY FEND A'
write(mout,'(a)') '*COLUMN 32 : FZ FEND A'
write(mout,'(a)') 'bl01'
write(mout,'(a)') '6202 32'
do i=1,4
read(minp,*)
enddo
do i=1,6202
read(minp,*) tim, (a(k), k = 1,30)
call maketime(dateandtime, tim)
dateandtime(9:9) = ' '
write(mout,'(a, 30F10.3)') dateandtime, (a(k), k = 1,30)
enddo
call doclose(minp)
call doclose(mout)
endif
end subroutine maketekaltimes
SUBROUTINE INIDEPMAX2
use unstruc_display
implicit none
double precision :: VMAX,VMIN,DV,VAL
integer :: NCOLS,NV,NIS,NIE,JAAUTO
double precision :: VMAX2,VMIN2,DV2,VAL2
integer :: NCOLS2,NV2,NIS2,NIE2,JAAUTO2
COMMON /DEPMAX2/ VMAX2,VMIN2,DV2,VAL2(256),NCOLS2(256),NV2,NIS2,NIE2,JAAUTO2
COMMON /DEPMAX/ VMAX,VMIN,DV,VAL(256),NCOLS(256),NV,NIS,NIE,JAAUTO
VMAX2 = VMAX
VMIN2 = VMIN
NV2 = NV
! Actual ncols2 set later in setcoltabfile
NIS2 = NIS
NIE2 = NIE
JAAUTO2 = JAAUTO
RETURN
END SUBROUTINE INIDEPMAX2
subroutine dumpstations(name)
use m_observations
use m_flow
use m_flowgeom
implicit none
integer :: mhis2, n, k, L1
character (len=*) :: name
L1 = index('.',name)
call newfil(mhis2, trim(name(1:L1))//'stat' )
do n = 1,numobs
k = kobs(n)
write(mhis2,'(6f16.6,2x,A)' ) xobs(n), yobs(n) , smxobs(n) , cmxobs(n), bl(k), ba(k), trim(namobs(n))
enddo
write(mhis2,*) ' '
do n = 1,numobs
k = kobs(n)
write(mhis2,*) s1(k)
enddo
write(mhis2,*) ' '
do n = 1,numobs
k = kobs(n)
write(mhis2,*) sqrt( ucx(k)*ucx(k) + ucy(k)*ucy(k) )
enddo
call doclose(mhis2)
end subroutine dumpstations
subroutine wrihistek(tim)
use m_observations
use m_monitoring_crosssections
use m_flow
use m_flowgeom
use m_ship
use unstruc_model
use m_flowtimes
use unstruc_files, only: defaultFilename
implicit none
integer :: n, i, ntbal
double precision :: tim, ue, te
character(len=256) :: nam
if (mxls /= 0 .and. dnt == 1) then ! volerr, volerrcum
call doclose(mxls)
mxls = 0
end if
! return ! His file broken
if (mxls == 0) then
nam = defaultFilename('histek')
call newfil(mxls, nam)
ntbal = -1 + int(Tstop_user - Tstart_user) / Ti_xls
if (nshiptxy == 0) then
write(mxls,'(a)') '* column 1 : Time (min) '
write(mxls,'(a)') '* column 2 : Waterlevel Obs 1 (m ) '
write(mxls,'(a)') '* column 3 : Waterdepth Obs 1 (m ) '
write(mxls,'(a)') 'BL01'
write(mxls,'(i0, a)') ntbal, ' 4'
else
write(mxls, '(a)' ) '*tim, (fx2(n), fy2(n), fm2(n), fricx(n), fricy(n), fricm(n), &
fx2(n)+fricx(n), fy2(n)+fricy(n), fm2(n)+fricm(n), shx(n), shu(n), squat(n), squatbow(n), n=1, nshiptxy ), cfav'
write(mxls, '(a)' ) 'BL01'
write(mxls,'(i0, a)') ntbal, ' 15'
endif
endif
if (nshiptxy == 1) then
write(mxls, '(100f18.5)' ) tim, (fx2(n), fy2(n), fm2(n), fricx(n), fricy(n), fricm(n), &
fx2(n)+fricx(n), fy2(n)+fricy(n), fm2(n)+fricm(n), shx(n), shu(n), squat(n), squatbow(n), n=1, nshiptxy ), cfav
else
!if (ncrs.gt.0) then
! write(mxls,'(13f14.4)') ( crs(i)%sumvalcur(1), i=1,min(6,ncrs) )
!endif
ue = sqrt(2*9.81)
Te = 2*400/ue
!write(mxls,'(13f14.6)') tim/Te , ucx(kobs(1)) / ue ! , s1(kobs(1)) - bl(kobs(1))
if (numobs > 0 .and. kobs(1) > 0 ) then
write(mxls,'(13f14.6)') tim/60d0, s1(kobs(1)), s1(kobs(1)) - bl(kobs(1))
endif
endif
end subroutine wrihistek
SUBROUTINE WRIRSTfileold(tim)
use m_flowtimes
use unstruc_model
use m_flow
use m_flowgeom
use unstruc_files, only: defaultFileName
implicit none
double precision :: tim
integer :: mout
call newfil(mout, defaultFileName('xyz', timestamp=tim))
call wrirstold(mout)
end subroutine wrirstfileold
SUBROUTINE WRIRSTold(MOUT)
USE M_FLOWTIMES
USE M_FLOW
USE M_FLOWGEOM
use unstruc_model
use m_sediment, only: jaceneqtr
use unstruc_netcdf, only: unc_write_net
implicit none
INTEGER :: MOUT, k, kk, kb, kt, l
! WRITE(MOUT,'(a,2x,F25.14,2i10,a)') REFDAT, TIME1, NDX, LNX, ' (refdat, timsec, ndx, lnx)'
if (jagrw < 2) then
! WRITE(MOUT,'(A,I10)') 'S1 ', NDX, ' 3'
DO K = 1,NDX
WRITE(MOUT,*) XZ(K) , YZ(K), S1(K)
ENDDO
else
! WRITE(MOUT,'(A,I10)') 'S1 ', NDX, ' 4'
DO K = 1,NDX
WRITE(MOUT,*) XZ(K) , YZ(K), S1(K), SGRW1(K)
ENDDO
endif
! WRITE(MOUT,'(A,I10)') 'U1 ', LNX
! DO L = 1,LNX
! WRITE(MOUT,*) U1(L)
! ENDDO
call doclose(mout)
if (jasal > 0) then
call newfil(mout, trim(getoutputdir())//trim(md_ident)//'_'//'_salbot.xyz')
do kk = 1,ndxi
call getkbotktop(kk,kb,kt)
write(mout,*) xz(kk), yz(kk), sa1(kb)
enddo
call doclose (mout)
if (kmx > 1) then
call newfil(mout, trim(getoutputdir())//trim(md_ident)//'_'//'_saltop.xyz')
do kk = 1,ndxi
call getkbotktop(kk,kb,kt)
write(mout,*) xz(kk), yz(kk), sa1(kt)
enddo
call doclose (mout)
endif
endif
if (jased > 0) then
if (jaceneqtr .ne. 1) then
call unc_write_net(trim(getoutputdir())//trim(md_ident)//'_'//'_new_net.nc' ) ! write resulting bathymetry
endif
endif
END SUBROUTINE WRIRSTold
!> Reads raw restart data from a formatted restart file by wrirst.
!! Water levels and velocities are directly stored into the flow arrays.
SUBROUTINE REARST(Mrst,JA)
use unstruc_model
USE UNSTRUC_MESSAGES
USE M_FLOWTIMES
USE M_FLOW
USE M_FLOWGEOM
implicit none
INTEGER, intent(inout) :: Mrst !< Input file pointer (should already be open)
integer, intent(out) :: ja !< Return status (0 = success)
integer :: k
integer :: l
INTEGER :: NDXR, LNXR ! alleen binnen deze subroutine
LOGICAL :: JAWEL
DOUBLE PRECISION :: DUM
ja = 0
! READ(Mrst,*) REFDATLOC, TSTART_USERLOC, NDXR, LNXR
READ(Mrst,*) DUM , DUM, NDXR, LNXR
IF (NDXR .NE. NDX .OR. LNXR .NE. LNX) THEN
WRITE(MSGBUF, '(A)' ) 'DIMENSIONS ON RESTART FILE NOT EQUAL TO CURRENT MODEL DIMENSIONS' ; CALL MSG_FLUSH()
CALL QNERROR ( 'DIMENSIONS ON RESTART FILE NOT EQUAL TO CURRENT MODEL DIMENSIONS' , ' ', ' ')
ja = 1
ENDIF
READ(Mrst,*)
DO K = 1,NDX
READ(Mrst,*, END = 999, ERR = 888) S0(K)
ENDDO
S0 = MAX(BL, S0)
s1 = s0
READ(Mrst,*)
DO L = 1,LNX
READ(Mrst,*, END = 999) U0(L)
ENDDO
call doclose(mrst)
u1 = u0
RETURN
888 ja = 1
return
999 CALL QNEOFERROR(MRST)
call doclose(mrst)
ja = 1
END SUBROUTINE reaRST
SUBROUTINE read_restart_from_map(filename,ierr)
use unstruc_netcdf
use dfm_error
implicit none
character(len=*), intent(in) :: filename
integer, intent(out) :: ierr !< Error status (DFM_NOERR==0 is successful)
integer :: k
integer :: l
INTEGER :: Mmap, NDXR, LNXR
call unc_read_map(filename, 0d0, ierr)
END SUBROUTINE read_restart_from_map
SUBROUTINE PARAMTEXT(OPTION,NR)
use M_isoscaleunit
implicit none
integer :: l1
integer :: l2
CHARACTER*(*) OPTION
INTEGER NR
L1 = INDEX(OPTION,'(')
L2 = INDEX(OPTION,')')
UNIT(NR) = ' ' ; PARAMTEX(NR) = ' '
IF (L1 .NE. 0) WRITE(UNIT(NR)(1:L2-L1+1),'(A)') OPTION(L1:L2)
WRITE(PARAMTEX(NR)(1:14) ,'(A)') OPTION(1:14)
RETURN
END SUBROUTINE PARAMTEXT
SUBROUTINE MAKENET(japaramscreen)
use m_netw
use m_makenet ! NTYP ANGLE SIZE THICK NRX NRY
use m_polygon
use m_grid
use m_missing
use m_sferic
use geometry_module, only: pinpok
use gridoperations
implicit none
integer, intent(in) :: japaramscreen !< Load parameter screen or not (1/0)
double precision :: ael
double precision :: ag
double precision :: cfl
double precision :: cs
double precision :: dx
double precision :: dy
double precision :: e0
double precision :: eps
double precision :: hs
integer :: in, jn, k0, l0, m, mh, n, nh, nn, numkn, numln
double precision :: rho
double precision :: rhow
double precision :: siz
double precision :: sn
double precision :: xplmax
double precision :: xplmin
double precision :: xx
double precision :: yplmax
double precision :: yplmin
double precision :: yy
double precision :: X(8), Y(8), Z(8), XD, YD
! COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
if (japaramscreen == 1) then
CALL MAKENETPARAMETERS()
end if
! get parameters from polygon if available
call pol2netparams()
! IF (NPL > 0) THEN
! CALL DMINMAX( XPL , NPL , XPLMIN, XPLMAX, NPL)
! CALL DMINMAX( YPL , NPL , YPLMIN, YPLMAX, NPL)
! X0 = XPLMIN ; Y0 = YPLMIN
! ENDIF
AEL = PI*THICK*THICK/4 ! RDIAM in mm
SIZ = SIZE
HS = SIZE*0.5d0
CS = COS(ANGLE*PI/180.) ; SN = SIN(ANGLE*PI/180.)
IF (NTYP .EQ. 0) THEN
DX = DX0
DY = DY0
ELSE IF (NTYP .LE. 3) THEN
DX = SIZ*COS(ANGLE*PI/180.)
DY = SIZ*SIN(ANGLE*PI/180.)
ELSE IF (NTYP .EQ. 4) THEN
DX = 0.5d0*SIZ ; DY = DX*SQRT(3d0)
ELSE IF (NTYP .EQ. 5) THEN
DX = HS; DY = sqrt(3d0)*DX
ENDIF
IF (NPL > 0) THEN
IF (NRX <= 1) THEN
NRX = (XPLMAX-XPLMIN)/DX
NRY = (YPLMAX-YPLMIN)/DY
ELSE IF (DX == 0) THEN
DX = (XPLMAX-XPLMIN)/NRX
DY = (YPLMAX-YPLMIN)/NRY
ENDIF
ENDIF
IF (NTYP == 0) THEN
MC = NRX+1 ; NC = NRY+1
CALL INCREASEGRID(MC,NC)
DO N = 1,NC
DO M = 1,MC
XC(M,N) = X0 + (M-1)*DX*CS - (N-1)*DY*SN
YC(M,N) = Y0 + (M-1)*DX*SN + (N-1)*DY*CS
if (jsferic == 1 .and. n > 1) then
dy = dx*cos(dg2rd*yc(m,n-1))
YC(M,N) = YC(M,N-1) + dy
endif
ENDDO
ENDDO
call del_grid_outside_pol()
! CALL GRIDTONET()
! MC = 0 ; NC = 0; XC = DMISS; YC = DMISS
ELSE
K0 = NUMK
L0 = NUML
NUMKN = (NRX+1)*(NRY+1)
NUMLN = 6*NUMKN
CALL INCREASENETW(K0+NUMKN, L0 + NUMLN)
call readyy('makenet',0d0)
Z = Z0
DO N = 1,NRY
call readyy('makenet', dble(n-1)/dble(nry-1) )
DO M = 1,NRX
IF (NTYP .EQ. 0) THEN
XX = dble(M-1)*DX0
YY = dble(N-1)*DY0
X(1) = X0 + XX*CS - YY*SN ; NN = 4
Y(1) = Y0 + YY*CS + XX*SN
XX = XX + DX0
X(2) = X0 + XX*CS - YY*SN ; NN = 4
Y(2) = Y0 + YY*CS + XX*SN
YY = YY + DY0
X(3) = X0 + XX*CS - YY*SN ; NN = 4
Y(3) = Y0 + YY*CS + XX*SN
XX = XX - DX0
X(4) = X0 + XX*CS - YY*SN ; NN = 4
Y(4) = Y0 + YY*CS + XX*SN
XD = 0.25d0*(X(1)+X(2)+X(3)+X(4))
YD = 0.25d0*(Y(1)+Y(2)+Y(3)+Y(4))
ELSE IF (NTYP .EQ. 1) THEN
XD = X0 + DX + dble(M-1)*2*DX ; NN = 4
YD = Y0 + DY + dble(N-1)*2*DY
X(1) = XD ; Y(1) = YD - DY
X(2) = XD + DX ; Y(2) = YD
X(3) = XD ; Y(3) = YD + DY
X(4) = XD - DX ; Y(4) = YD
ELSE IF (NTYP .EQ. 2) THEN
JN = MOD(M-1,2)
XD = X0 + DX + HS + dble(M-1)*(DX+2*HS) ; NN = 6
YD = Y0 + DY + JN*DY + dble(N-1)*(2*DY)
X(1) = XD - HS ; Y(1) = YD - DY
X(2) = XD + HS ; Y(2) = YD - DY
X(3) = XD + HS + DX ; Y(3) = YD
X(4) = XD + HS ; Y(4) = YD + DY
X(5) = XD - HS ; Y(5) = YD + DY
X(6) = XD - HS - DX ; Y(6) = YD
ELSE IF (NTYP .EQ. 3) THEN
XD = X0 + DX + HS + dble(M-1)*2*(DX+HS) ; NN = 6
YD = Y0 + DY + dble(N-1)*2*DY
X(1) = XD - HS ; Y(1) = YD - DY
X(2) = XD + HS ; Y(2) = YD - DY
X(3) = XD + HS + DX ; Y(3) = YD
X(4) = XD + HS ; Y(4) = YD + DY
X(5) = XD - HS ; Y(5) = YD + DY
X(6) = XD - HS - DX ; Y(6) = YD
ELSE IF (NTYP .EQ. 4) THEN
XD = X0 + DX + dble(M-1)*2*DX ; NN = 6
YD = Y0 + DY + dble(N-1)*2*DY
X(1) = XD - DX ; Y(1) = YD - DY
X(2) = XD + DX ; Y(2) = YD - DY
X(3) = XD + DX + DX ; Y(3) = YD
X(4) = XD + DX ; Y(4) = YD + DY
X(5) = XD - DX ; Y(5) = YD + DY
X(6) = XD ; Y(6) = YD
ELSE IF (NTYP .EQ. 5) THEN
mh = nrx/2 ; nh = nry/2
JN = MOD(M-1,2)
XD = X0 + DX - HS + dble(M-1-mh)*(DX+2*HS) ; NN = 6
YD = Y0 + JN*DY + dble(N-1-nh)*(2*DY) - dy
X(1) = XD - HS ; Y(1) = YD - DY
X(2) = XD + HS ; Y(2) = YD - DY
X(3) = XD + HS + DX ; Y(3) = YD
X(4) = XD + HS ; Y(4) = YD + DY
X(5) = XD - HS ; Y(5) = YD + DY
X(6) = XD - HS - DX ; Y(6) = YD
ENDIF
CALL PINPOK(XD,YD,NPL,XPL,YPL,IN, jins, dmiss)
IF (IN == 1) THEN
! CALL ADDMAZE(X,Y,Z,AEL,NN,NTYP)
CALL ADDMAZE(X,Y,Z,NN)
ENDIF
ENDDO
ENDDO
ENDIF
CALL SETNODADM(0)
call readyy('makenet', -1d0 )
RETURN
END SUBROUTINE MAKENET
SUBROUTINE ADDMAZE(X,Y,Z,N) ! FOR FLOW GRIDS
use m_netw
use gridoperations
implicit none
double precision :: X(N), Y(N), Z(N)
integer :: N
integer :: k
integer :: k2
integer :: lnu
INTEGER KK(8)
DO K = 1,N
CALL ISNODEDB( KK(K), X(K), Y(K))
IF (KK(K) .LE. 0) THEN
! CALL GIVENEWNODENUM(KK(K))
numk = numk + 1
kk(k) = numk
! SETPOINTDB MAKEN
XK(KK(K)) = X(K) ; YK(KK(K)) = Y(K) ; ZK(KK(K)) = Z(K)
IF (KC(KK(K)) .EQ. 0) KC(KK(K)) = 1
ENDIF
ENDDO
DO K = 1,N
K2 = K+1 ; IF (K .EQ. N) K2 = 1
CALL CONNECTDB(KK(K),KK(K2),lnu)
ENDDO
RETURN
END SUBROUTINE ADDMAZE
SUBROUTINE MERGENET()
use m_netw
USE M_MERGENET ! NUMM JBLUNT
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
double precision :: eps
integer :: ierr
integer :: in1
integer :: j
integer :: ja
integer :: k, kk, k1, k2
integer :: l
integer :: numj
INTEGER, ALLOCATABLE :: KM(:)
logical :: lboundnode ! true if netnode is on boundary
logical :: jamerged ! Whether or not any merge operations were performed.
ALLOCATE(KM(KMAX), STAT=IERR)
KM = 0
jamerged = .false.
! CALL MERGENETPARAMETERS()
! J = 0
! DO K = 1, NUMK
! CALL DPINPOK( XK(K), YK(K), ZK(K), NPL, XPL, YPL, IN1)
! IF (IN1 .EQ. 1) THEN
! IF (NMK(K) .LE. NUMM) THEN
! J = J + 1 ; KM(J) = K
! ENDIF
! ENDIF
! ENDDO
j = 0
in1 = -1
do k=1,numk
! CALL DPINPOK( XK(K), YK(K), ZK(K), NPL, XPL, YPL, IN1)
! IF (IN1 .EQ. 1) THEN
lboundnode = .false.
do k1=1,nmk(k)
L = nod(k)%lin(k1)
if ( lnn(L) == 1 ) then
lboundnode = .true.
exit
end if
end do
if ( lboundnode ) then
j = j+1
km(j) = k
end if
! ENDIF
end do
EPS = 0.01d0
NUMJ = J
DO K = 1,NUMJ - 1
K1 = KM(K)
IF (K1 .GE. 1) THEN
eps = 1d9
do kk = 1,nmk(k1)
L = nod(k1)%lin(kk)
! if (lnn(L) == 1) then ! SPvdP: this gives problems
if ( kn(1,L).lt.1 .or. kn(2,L).lt.1 ) cycle
eps = min(eps, dbdistance( XK(kn(1,L)), YK(kn(1,L)), XK(kn(2,L)), YK(kn(2,L)), jsferic, jasfer3D, dmiss) )
! endif
enddo
if ( eps.eq.1d9 ) eps=0d0 ! no links considered => eps=0
DO L = K + 1, NUMJ
K2 = KM(L)
IF (K2 .GE. 1) THEN
! Note that mergenet merges boundary net nodes.
! Not only in two disjoint net parts, but also two neighbouring net nodes
! at a boundary may be merged. (i.e., gridtonet of a curvigrid may produce
! a net with triangles.)
IF (dbdistance( XK(K1), YK(K1), xk(k2), yk(k2), jsferic, jasfer3D, dmiss) < 0.25d0*eps ) THEN
CALL MERGENODES(K1,K2,JA)
KM(K) = 0 ; KM(L) = 0
jamerged = .true.
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
if (jamerged) then
call setnodadm(0)
end if
RETURN
END SUBROUTINE MERGENET
SUBROUTINE FINDK( XL, YL, ZL, KV )
use m_netw
implicit none
double precision :: XL, YL, ZL
integer :: KV
integer :: k
double precision :: RMIN, R, &
DX, DY, DZ
RMIN = 99D+20
KV = 0
DO K = 1,NUMK
IF (XK(K) .NE. 0) THEN
DX = XL - XK(K)
DY = YL - YK(K)
DZ = ZL - ZK(K)
R = DX*DX + DY*DY + DZ*DZ
IF (R .LT. RMIN) THEN
RMIN = R
KV = K
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE FINDK
!> move a whole spline
subroutine movespline(ispline, inode, xp, yp)
use m_splines
implicit none
integer, intent(in) :: ispline !< spline number
integer, intent(in) :: inode !< spline control point
double precision, intent(in) :: xp, yp !< new active spline control point (np) coordinates
double precision :: dx, dy
integer :: num
call nump(ispline,num)
if ( ispline.gt.0 .and. ispline.le.maxspl .and. inode.gt.0 .and. inode.le.num) then
dx = xp - xsp(ispline, inode)
dy = yp - ysp(ispline, inode)
xsp(ispline, 1:maxsplen) = xsp(ispline, 1:maxsplen) + dx
ysp(ispline, 1:maxsplen) = ysp(ispline, 1:maxsplen) + dy
end if
return
end subroutine movespline
!> copy and move a whole spline
subroutine copyspline(ispline, inode, xp, yp)
use m_splines
use m_sferic
use geometry_module, only: dbdistance, dcosphi
use m_missing, only: dmiss
implicit none
integer, intent(inout) :: ispline !< spline number
integer, intent(in) :: inode !< spline control point
double precision, intent(in) :: xp, yp !< new spline control point coordinates
double precision, dimension(maxsplen) :: xspp, yspp, xlist, ylist
double precision :: dx, dy, dnx, dny, dsx, dsy, curv, alphan, alphas
double precision :: x0, y0, x1, y1, ds, t
integer :: i, j, num
double precision, parameter :: EPS=1d-4
integer, parameter :: Nresample=1
call nump(ispline,num)
if ( ispline.gt.0 .and. ispline.le.maxspl .and. inode.gt.0 .and. inode.le.num) then
x0 = xsp(ispline,inode)
y0 = ysp(ispline,inode)
xlist(1:num) = xsp(ispline,1:num)
ylist(1:num) = ysp(ispline,1:num)
call spline(xlist, num, xspp)
call spline(ylist, num, yspp)
call comp_curv(num, xlist, ylist, xspp, yspp, dble(inode-1), curv, dnx, dny, dsx, dsy)
ds = dbdistance(x0,y0,xp,yp, jsferic, jasfer3D, dmiss)
if ( jsferic.eq.1 ) then
ds = ds/(Ra*dg2rd)
end if
alphan = dcosphi(x0,y0,x0+EPS*dnx,y0+EPS*dny,x0,y0,xp,yp, jsferic, jasfer3D, dxymis)*ds
alphas = 0d0
call newspline()
! copy and sample spline
call spline(xlist, num, xspp)
call spline(ylist, num, yspp)
do i=1,num
do j = 1,Nresample
t = dble(i-1) + dble(j-1)/dble(Nresample)
call splint(xlist, xspp, num, t, x1)
call splint(ylist, yspp, num, t, y1)
call addsplinepoint(mcs, x1, y1)
end do
end do
! move spline
ispline = mcs ! activate new spline
call nump(ispline,num)
call spline(xlist, num, xspp)
call spline(ylist, num, yspp)
! ds = dbdistance(x0,y0,xp,yp)
! alphan = dcosphi(x0,y0,x0+EPS*dnx,y0+EPS*dny,x0,y0,xp,yp)*ds
!! alphas = dcosphi(x0,y0,x0+EPS*dsx,y0+EPS*dsy,x0,y0,xp,yp)*ds
! alphas = 0d0
do i=1,num
call comp_curv(num, xlist, ylist, xspp, yspp, dble(i-1), curv, dnx, dny, dsx, dsy)
x1 = xsp(ispline,i) + alphan*dnx + alphas*dsx
y1 = ysp(ispline,i) + alphan*dny + alphas*dsy
xsp(ispline,i) = x1
ysp(ispline,i) = y1
end do
end if
return
end subroutine copyspline
!> copy and move a polygon orthogonally
subroutine copypol(ipol, xp, yp)
use m_sferic
use m_polygon
use m_sferic
use m_missing
use geometry_module, only: getdxdy
implicit none
integer, intent(in) :: ipol !< polygon point
double precision, intent(in) :: xp, yp !< new polygon point coordinates
double precision, dimension(:), allocatable :: dnx, dny !< node-based normal vectors
double precision :: dsx, dsy, dnxL, dnyL, dnxR, dnyR, ds, dist, fac
double precision :: dnxLi, dnyLi, dnxRi, dnyRi, dnxi, dnyi, dx, dy, det
integer :: i, jstart, jend, jpoint, numadd
logical :: Lotherpart = .true. !< also make other part (.true.) or not (.false.)
! find the start and end index in the polygon array
call get_polstartend(NPL, XPL, YPL, ipol, jstart, jend)
numadd = jend-jstart+1
if ( numadd.lt.2 .or. ipol.lt.jstart .or. ipol.gt.jend ) return ! no polygon found
if ( Lotherpart ) numadd = 2*numadd
! copy polygon
jpoint = NPL
if ( xpl(jpoint).ne.DMISS ) then ! add dmiss
NPL = NPL+numadd+1
call increasepol(NPL, 1)
jpoint = jpoint+1
xpl(jpoint) = DMISS
ypl(jpoint) = DMISS
zpl(jpoint) = DMISS
jpoint = jpoint+1
else
NPL = NPL+numadd
call increasepol(NPL, 1)
jpoint = jpoint+1
end if
! allocate
allocate(dnx(numadd), dny(numadd))
dnxLi = 0d0
dnyLi = 0d0
dnxRi = 0d0
dnyRi = 0d0
dnxi = 0d0
dnyi = 0d0
! compute normal vectors
do i=jstart,jend
if ( i.lt.jend ) then
!dsx = getdx(xpl(i),ypl(i),xpl(i+1),ypl(i+1))
!dsy = getdy(xpl(i),ypl(i),xpl(i+1),ypl(i+1))
call getdxdy(xpl(i),ypl(i),xpl(i+1),ypl(i+1),dsx,dsy,jsferic)
ds = sqrt(dsx**2+dsy**2)
dnxR = -dsy / ds
dnyR = dsx / ds
else
dnxR = dnxL
dnyR = dnyL
end if
if ( i.eq.jstart ) then
dnxL = dnxR
dnyL = dnyR
end if
fac = 1d0 / (1d0 + dnxL*dnxR + dnyL*dnyR)
dnx(i-jstart+1) = fac * (dnxL + dnxR)
dny(i-jstart+1) = fac * (dnyL + dnyR)
! store normal vectors for selected polygon point
if ( i.eq.ipol ) then
dnxLi = dnxL
dnyLi = dnyL
dnxRi = dnxR
dnyRi = dnyR
dnxi = dnx(i-jstart+1)
dnyi = dny(i-jstart+1)
end if
dnxL = dnxR
dnyL = dnyR
end do
! determine layer thickness
! dx = getdx(xpl(ipol),ypl(ipol),xp,yp)
! dy = getdy(xpl(ipol),ypl(ipol),xp,yp)
call getdxdy(xpl(ipol),ypl(ipol),xp,yp,dx,dy,jsferic)
det = dx*dnyi-dy*dnxi
if ( det.gt.1d-8 ) then
dist = dx*dnxRi + dy*dnyRi
else if ( det.lt.-1d-8 ) then
dist = dx*dnxLi + dy*dnyLi
else
dist = dx*dnxi + dy*dnyi
end if
! add new polygon
if ( jsferic.eq.1 ) dist = dist/(Ra*dg2rd)
do i=jstart,jend
dy = dny(i-jstart+1)*dist
dx = dnx(i-jstart+1)*dist
if ( jsferic.eq.1 ) dx = dx /cos((ypl(i)+0.5d0*dy)*dg2rd)
xpl(jpoint+i-jstart) = xpl(i) + dx
ypl(jpoint+i-jstart) = ypl(i) + dy
zpl(jpoint+i-jstart) = zpl(i)
if ( Lotherpart ) then
xpl(jpoint + numadd - 1 - (i-jstart)) = xpl(i) - dx
ypl(jpoint + numadd - 1 - (i-jstart)) = ypl(i) - dy
zpl(jpoint + numadd - 1 - (i-jstart)) = zpl(i)
end if
end do
! deallocate
deallocate(dnx, dny)
return
end subroutine copypol
subroutine insertsamples(L1,L2)
use m_samples
use m_gridsettings, only: mfac
implicit none
integer :: L1, L2
integer :: k
double precision :: aa, bb
do k = 1,mfac
ns = ns + 1
call increasesam(ns)
aa = dble(k)/dble(mfac+1) ; bb = 1d0-aa
xs(ns) = bb*xs(L1) + aa*xs(L2)
ys(ns) = bb*ys(L1) + aa*ys(L2)
zs(ns) = bb*zs(L1) + aa*zs(L2)
enddo
! user is editing samples: mark samples as unstructured
MXSAM = 0
MYSAM = 0
IPSTAT = IPSTAT_NOTOK
end subroutine insertsamples
subroutine removewallfromsamples()
use m_samples
use m_polygon
implicit none
integer :: k, k2, k3, kk, mout
call newfil(mout, 'wall.xyz')
call savesam()
kk = 0
do k = 1,ns
! call findnearwallpoint(k,k2)
call findneargroundpoint(k,k3)
if (k3 .ne. 0) then ! .and. k2 .ne. 0) then
npl = npl + 1
xpl(npl) = xs(k)
ypl(npl) = ys(k)
write(mout,*) xs(k), ys(k), zs(k)
else
kk = kk + 1
xs2(kk) = xs(k)
ys2(kk) = ys(k)
zs2(kk) = zs(k)
endif
enddo
close (mout)
ns2 = kk
call restoresam()
end subroutine removewallfromsamples
subroutine findnearwallpoint(k1,k2)
use m_samples
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: k1,k2,k
k2 = 0
do k = 1,ns
if (k .ne. k1) then
if (dbdistance(xs(k), ys(k), xs(k1), ys(k1), jsferic, jasfer3D, dmiss) < 0.25d0) then
if (zs(k) == zs(k1) ) then
k2 = k ; return
endif
endif
endif
enddo
end subroutine findnearwallpoint
subroutine findneargroundpoint(k1,k2)
use m_samples
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: k1,k2,k,kk,n1,n2
k2 = 0
n1 = max(1,k1-2000)
n2 = min(ns,k1+2000)
do k = n1,n2
if (k .ne. k1) then
if (dbdistance(xs(k), ys(k), xs(k1), ys(k1), jsferic, jasfer3D, dmiss)< 0.5d0) then
if ( zs(k1) - zs(k) > 0.9d0) then
k2 = k ; return
endif
endif
endif
enddo
end subroutine findneargroundpoint
subroutine write_flowdiff()
use m_flow
use m_samples
implicit none
COMMON /DIAGNOSTICFILE/ MDIAG
integer mdiag
double precision :: avdiffm, avdifwq, fm, wq
integer :: k, kk, num
double precision, external :: znod
avdiffm = 0d0 ; avdifwq = 0d0; num = 0
do k = 1,ns
call in_flowcell(xs(k), ys(k), KK)
if (kk > 0) then
fm = znod(kk)
wq = plotlin(kk)
if (fm > 0d0 .and. wq > 0d0) then
write(mdiag, *) zs(k), fm, wq
avdiffm = avdiffm + abs( fm - zs(k) )
avdifwq = avdifwq + abs( wq - zs(k) )
num = num + 1
endif
endif
enddo
if (num > 0) then
avdiffm = avdiffm / num
avdifwq = avdifwq / num
endif
write(mdiag,*) ' avdiffm, avdifwq,num ' , avdiffm, avdifwq,num
end subroutine write_flowdiff
SUBROUTINE MODLN2( X, Y, Z, MMAX, NUMPI, MP, XP, YP, NPUT)
USE M_MISSING
implicit none
! WIJZIG AANTAL PUNTEN OP EEN ENKELE LIJN
! DELETE , NPUT = -2
! OF INSERT, NPUT = -1
! DELETE ENTIRE LINE, -3
! DELETE ALL EXCEPT SELECTED LINE, -4
double precision :: X(MMAX), Y(MMAX), Z(MMAX)
integer :: MMAX, NUMPI, MP, nput
double precision :: XP, YP, ZP
integer :: i
integer :: istart
integer :: j
integer :: k
integer :: jstart, jend
ZP = DMISS ! set Z-value of newly inserted points to DMISS
IF (NPUT .EQ. -2) THEN
! DELETE PUNT
IF (MP .EQ. 0) THEN
CALL OKAY(0)
ELSE IF (NUMPI .EQ. 2) THEN
! LAATSTE TWEE PUNTEN VAN EEN SPLINE, DUS DELETE DE HELE SPLIN
DO 10 I = 1,MMAX
X(I) = 0
Y(I) = 0
Z(I) = 0
10 CONTINUE
NUMPI = 0
ELSE
! EEN WILLEKEURIG ANDER PUNT
NUMPI = NUMPI - 1
DO 20 J = MP,NUMPI
X(J) = X(J+1)
Y(J) = Y(J+1)
Z(J) = Z(J+1)
20 CONTINUE
ENDIF
ELSE IF (NPUT .EQ. -1) THEN
! ADD PUNT
IF (NUMPI .LT. MMAX) THEN
IF (MP .NE. 0) THEN
! EEN NIEUW PUNT OP EEN BESTAANDE SPLINE TUSSENVOEGEN
NUMPI = NUMPI + 1
DO 30 J = NUMPI,MP+2,-1
X(J) = X(J-1)
Y(J) = Y(J-1)
Z(J) = Z(J-1)
30 CONTINUE
MP = MP + 1
X(MP) = XP
Y(MP) = YP
Z(MP) = ZP
CALL OKAY(0)
ELSE
NUMPI = NUMPI + 1
MP = NUMPI
X(MP) = XP
Y(MP) = YP
Z(MP) = ZP
CALL OKAY(0)
ENDIF
ELSE
CALL OKAY(0)
ENDIF
ELSE IF (NPUT .EQ. -3 .or. NPUT.EQ.-4) THEN
IF ( NPUT .EQ. -3 ) THEN
! DELETE ENTIRE LINE
K = MP
40 CONTINUE
IF (K .LE. MMAX) THEN
IF (X(K) .NE. dmiss) THEN
X(K) = dmiss
K = K + 1
GOTO 40
ENDIF
ENDIF
K = MP - 1
50 CONTINUE
IF (K .GE. 1) THEN
IF (X(K) .NE. dmiss) THEN
X(K) = dmiss
K = K - 1
GOTO 50
ENDIF
ENDIF
ELSE IF ( NPUT .EQ. -4 ) THEN
! DELETE ALL EXCEPT SELECTED LINE
! get start and end indices of the line
call get_polstartend(MMAX, X, Y, MP, jstart, jend)
! delete leading part in array
if ( jstart.gt.1 ) then
x(1:jstart-1) = DMISS
end if
! delete trailing part in array
if ( jend.lt.MMAX) then
x(jend+1:MMAX) = DMISS
end if
END IF
K = 0
ISTART = 0
DO 60 I = 1,NUMPI
IF (X(I) .NE. dmiss) THEN
K = K + 1
X(K) = X(I)
Y(K) = Y(I)
Z(K) = Z(I)
ISTART = 1
ELSE IF (ISTART .EQ. 1) THEN
K = K + 1
X(K) = X(I)
Y(K) = Y(I)
Z(K) = Z(I)
ISTART = 0
ENDIF
60 CONTINUE
NUMPI = K
! If numpi points to a dmiss element at tail, decrement it.
if (k > 0 .and. istart == 0) then
numpi = numpi - 1
end if
mp = 0 ! Reset active point (subsequent "insert" will continue at tail of last polyline)
ENDIF
CALL DISPNODE(MP)
RETURN
END SUBROUTINE MODLN2
!> Checks whether a point is (almost) one of the polyline points.
!!
!! Checks at a radius dcir around all polyline points and sets
!! input coordinates to the exact polyline point coordinates when
!! it is found.
SUBROUTINE ISPOI1( X, Y, N, XL, YL, MV)
use m_wearelt
use m_missing
implicit none
integer :: i
integer :: ishot
integer :: m1
integer :: m2
integer :: ns
! is dit een POLYGpunt?
integer, intent(in) :: N !< Index of last filled polyline point (npol<=maxpol)
double precision, intent(in) :: X(n), Y(n) !< Entire polyline coordinate arrays.
double precision, intent(inout) :: XL, YL !< x- and y-coordinates of the point to be checked (set to exact point coordinates when found).
integer, intent(out) :: MV !< The index of the polygon point (if found, otherwise 0)
integer :: MVOL
DATA MVOL /0/
MV = 0
ISHOT = 0
NS = N
!
666 CONTINUE
! If a previous point was found in a previous call (mvol/=0)
! then first search 'nearby' in poly (500 pts to the left and right)
! If this fails (goto 666 with ishot==1), reset search range to entire poly.
IF (ISHOT .EQ. 0 .AND. MVOL .NE. 0) THEN
M1 = MAX(1,MVOL - 500)
M2 = MIN(NS,MVOL + 500)
ISHOT = 1
ELSE
M1 = 1
M2 = NS
ISHOT = 0
ENDIF
!
DO 10 I = M1,M2
IF (X(I) .NE. dmiss) THEN
IF (ABS(XL - X(I)) .LT. RCIR) THEN
IF (ABS(YL - Y(I)) .LT. RCIR) THEN
XL = X(I)
YL = Y(I)
MV = I
MVOL = MV
CALL DISPNODE(MV)
RETURN
ENDIF
ENDIF
ENDIF
10 CONTINUE
!
IF (ISHOT .EQ. 1) GOTO 666
MVOL = 0
CALL DISPNODE(MVOL)
RETURN
END SUBROUTINE ISPOI1
!> Checks whether a polyline point is at the start or end of a polyline.
!!
!! Multiple polylines are stored in one large array, separated by dmiss.
!! To know whether point at index L1 is a start/end point of one of these
!! polylines, check on a neighbouring dmiss.
logical function ispolystartend( X, Y, N, MAXPOL, ipoi) result(res)
use m_missing
implicit none
integer, intent(in) :: MAXPOL !< Length of polyline coordinate arrays.
double precision, intent(in) :: X(MAXPOL), Y(MAXPOL) !< Entire polyline coordinate arrays
integer, intent(in) :: N !< Index of last filled polyline point (npol<=maxpol)
integer, intent(in) :: ipoi !< Index of polyline point to be checked.
! First check invalid input
if (ipoi <= 0 .or. ipoi > n .or. n > maxpol) then
res = .false.
return
end if
! Next, check on trivial end points
if (ipoi == 1 .or. ipoi == n) then
res = .true.
return
end if
! Generic case: somewhere in middle of poly, check on dmiss.
res = (x(ipoi-1) == dmiss .or. x(ipoi+1) == dmiss)
end function ispolystartend
!> indentify the points in an array
subroutine makelineindex(num, x, idx)
use m_missing
use geometry_module, only: get_startend
implicit none
integer, intent(inout) :: num !< array size
double precision, dimension(num), intent(in) :: x !< line array
integer, dimension(num), intent(out) :: idx !< idx array
integer :: nidx, ipoint
integer :: jstart, jend
integer :: i
! default
idx = 0
! check for DMISS-only
dolp: do
do i=1,num
if ( x(i).ne.DMISS ) exit dolp
end do
num = 0
return
end do dolp
! initialize pointer
ipoint = 1
! initialize counter
nidx = 0
! loop over the sections
do while ( ipoint.le.num )
! increase counter
nidx = nidx+1
! get start and end array postions of this section
call get_startend(num-ipoint+1, x(ipoint:num), x(ipoint:num), jstart, jend, dmiss)
jstart = ipoint+jstart-1
jend = ipoint+jend-1
! fill index array
do i=jstart,jend
if ( x(i).ne.DMISS ) idx(i) = nidx
end do
! shift pointer
ipoint = jend + 1
end do
return
end subroutine
!> Merges two polylines, indicated by two start/end points
!!
!! Multiple polylines are stored in one large array, separated by dmiss.
!! Possibly, one or two of the polylines is flipped and then glued to the other.
subroutine mergepoly( X, Y, Z, maxpol, n, i1, i2)
USE M_MISSING
implicit none
double precision, intent(inout) :: X(MAXPOL), Y(MAXPOL) !< Entire polyline coordinate arrays
double precision, intent(inout) :: Z(MAXPOL) !< polyline Z-value array
integer, intent(inout) :: N !< Index of last filled polyline point (npol<=maxpol)
integer, intent(in) :: MAXPOL !< Length of polyline coordinate arrays.
integer, intent(inout) :: i1, i2 !< Indices of polyline start/ends which need to be connected.
integer :: i, im, in, ih, ii, n2, nh
logical :: jadiff, jaflip
double precision, allocatable :: xh(:), yh(:), zh(:)
double precision :: xt, yt, zt
if (i1 == i2 .or. i1 <= 0 .or. i1 > n .or. i2 <= 0 .or. i2 > n) return
if (X(i1) == dmiss .or. X(i2) == dmiss) return
! Handle 'leftmost(in array)' polyline first
if (i1 > i2) then
ih = i1
i1 = i2
i2 = ih
end if
! Check whether i1 and i2 are two different polylines. If not: return.
jadiff = .false.
do i=i1,i2
if (X(i) == dmiss) then
jadiff = .true.
exit
end if
end do
if (.not. jadiff) then
return
end if
! If i1 is *first* point, then flip, such that it becomes the
! last (to enable coupling to i2-polyline later on)
jaflip = .false.
if (i1 < n) then
if (X(i1+1) /= dmiss) then
jaflip = .true.
end if
end if
! Flip first polyline if necessary.
if (jaflip) then
! Find end point first
im = n ! Default end index: n
do i=i1+1,n
if (X(i) == dmiss) then
im = i-1
exit
end if
end do
! End point found, now flip from i1 to im.
ih = (i1+im-1)/2
do i=i1,ih
ii = im-i+i1
xt = x(i); yt = y(i); zt = z(i)
x(i) = x(ii); y(i) = y(ii); z(i) = z(ii)
x(ii) = xt; y(ii) = yt; z(ii) = zt
end do
! Flip indices, such that i1 is the rightmost
ih = i1
i1 = im
im = ih
end if
! If i2 is *last* point, then flip, such that it becomes the first (to enable coupling to im later on)
jaflip = .false.
if (X(i2-1) /= dmiss) then
jaflip = .true.
end if
! Flip second polyline if necessary
if (jaflip) then
in = i2
do i=i2-1,1,-1
if (X(i) == dmiss) then
in = i+1
exit
end if
end do
! Start point found, now flip from in to i2
ih = (in+i2-1)/2
do i=in,ih
ii = i2-i+in
xt = x(i); yt = y(i); zt = z(i)
x(i) = x(ii); y(i) = y(ii); z(i) = z(ii)
x(ii) = xt; y(ii) = yt; z(ii) = zt
end do
! Flip indices, such that i2 is the leftmost
ih = i2
i2 = in
in = ih
else
! No flip, but do find the last (rightmost) element of 2nd polyline.
in = n
do i=i2+1,n
if (X(i) == dmiss) then
in = i-1
exit
end if
end do
end if
n2 = in-i2+1
! If there is a non-zero-length polyline between i1 and i2, back it up.
if (i2 - i1 >= 3) then
nh = i2-i1-3
allocate(xh(nh), yh(nh), zh(nh))
do i=1,nh
xh(i) = x(i1+1+i)
yh(i) = y(i1+1+i)
zh(i) = z(i1+1+i)
end do
else
nh = 0
end if
! Now shift second polyline to the left, such that i2 gets directly next to i1
do i=i2,in
ih = i1+1+i-i2
x(ih) = x(i)
y(ih) = y(i)
z(ih) = z(i)
end do
x(i1+n2+1) = dmiss
y(i1+n2+1) = dmiss
z(i1+n2+1) = dmiss
if (nh > 0) then
do ih=1,nh
i = i1+n2+1+ih
x(i) = xh(ih)
y(i) = yh(ih)
z(i) = zh(ih)
end do
deallocate(xh, yh, zh)
x(i1+n2+1+nh+1) = dmiss
y(i1+n2+1+nh+1) = dmiss
z(i1+n2+1+nh+1) = dmiss
ih = i1+n2+nh+3 ! Index of next non-dmiss entry
else
ih = i1+n2+2
end if
if (n > in) then
do i=in+2,n
ii = ih+i-in-2
x(ii) = x(i)
y(ii) = y(i)
z(ii) = z(i)
end do
x(ih+n-in-1:n) = dmiss
y(ih+n-in-1:n) = dmiss
z(ih+n-in-1:n) = dmiss
end if
n = ih+n-in-2
end subroutine mergepoly
SUBROUTINE X0ISX1(X0,Y0,Z0,X1,Y1,Z1,KMAX)
implicit none
double precision :: X0(KMAX), X1(KMAX), &
Y0(KMAX), Y1(KMAX), &
Z0(KMAX), Z1(KMAX)
integer :: KMAX
integer :: K
DO 10 K = 1,KMAX
X0(K) = X1(K)
Y0(K) = Y1(K)
Z0(K) = Z1(K)
10 CONTINUE
RETURN
END SUBROUTINE X0ISX1
SUBROUTINE DX0ISX1(X0,Y0,Z0,X1,Y1,Z1,KMAX)
implicit none
integer :: k
DOUBLE PRECISION X0(KMAX), X1(KMAX), &
Y0(KMAX), Y1(KMAX), &
Z0(KMAX), Z1(KMAX)
integer :: KMAX
DO 10 K = 1,KMAX
X0(K) = X1(K)
Y0(K) = Y1(K)
Z0(K) = Z1(K)
10 CONTINUE
RETURN
END SUBROUTINE DX0ISX1
SUBROUTINE F0ISF1(X0,X1,KMAX)
implicit none
double precision :: X0(KMAX), X1(KMAX)
integer :: KMAX
integer :: K
DO 10 K = 1,KMAX
X0(K) = X1(K)
10 CONTINUE
RETURN
END SUBROUTINE F0ISF1
SUBROUTINE DF0ISF1(X0,X1,KMAX)
implicit none
DOUBLE PRECISION X0(KMAX), X1(KMAX)
integer :: KMAX
integer :: K
DO 10 K = 1,KMAX
X0(K) = X1(K)
10 CONTINUE
RETURN
END SUBROUTINE DF0ISF1
DOUBLE PRECISION FUNCTION DLENGTH(K1,K2)
use m_netw
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: K1, K2
double precision :: XD,YD,ZD
IF (NETFLOW == 1) THEN
XD = XK(K2) - XK(K1)
YD = YK(K2) - YK(K1)
ZD = ZK(K2) - ZK(K1)
DLENGTH = SQRT(XD*XD + YD*YD + ZD*ZD)
ELSE ! FLOW
DLENGTH = DBDISTANCE(XK(K1), YK(K1), XK(K2), YK(K2), jsferic, jasfer3D, dmiss)
ENDIF
RETURN
END FUNCTION DLENGTH
SUBROUTINE DELPOL()
USE M_POLYGON
USE M_MISSING
implicit none
if ( allocated(xpl) ) XPL = XYMIS
if ( allocated(ypl) ) YPL = XYMIS
NPL = 0
MP = 0
MPS = 0
RETURN
END SUBROUTINE DELPOL
!> gives link length
double precision function dLinklength(L)
use m_netw
use m_missing, only: dmiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbpinpol, dbdistance
use gridoperations
implicit none
integer, intent(in) :: L !< link number
double precision :: dx, dy
integer :: La, k1, k2
La = iabs(L)
k1 = kn(1,La)
k2 = kn(2,La)
dLinklength = dbdistance(xk(k1), yk(k1), xk(k2), yk(k2), jsferic, jasfer3D, dmiss)
end function dLinklength
subroutine triangulate_quadsandmore(ja) ! ja==1, findcells moet opnieuw
use m_netw
use m_flowgeom
use m_polygon
use m_missing, only: dmiss, JINS
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
integer ja
integer in, k, k1, k2, k3, k4, k5, lnu
call findcells(0)
in = -1
do k = 1,nump
if (netcell(k)%n >= 4) then
call dbpinpol(xz(k), yz(k), in, dmiss, JINS, NPL, xpl, ypl, zpl)
if (in == 1) then
k1 = netcell(k)%nod(1); k2 = netcell(k)%nod(2); k3 = netcell(k)%nod(3); k4 = netcell(k)%nod(4)
if (netcell(k)%n == 4) then
if (dbdistance( xk(k1), yk(k1), xk(k3), yk(k3), jsferic, jasfer3D, dmiss) < dbdistance( xk(k2), yk(k2), xk(k4), yk(k4), jsferic, jasfer3D, dmiss) ) then
call connectdbn(k1, k3, lnu) ; ja = 1
else
call connectdbn(k2, k4, lnu) ; ja = 1
endif
else if (netcell(k)%n == 5) then
call connectdbn(k1, k3, lnu) ; ja = 1
call connectdbn(k1, k4, lnu)
else if (netcell(k)%n == 6) then
k5 = netcell(k)%nod(5) ; ja = 1
call connectdbn(k1, k3, lnu)
call connectdbn(k1, k4, lnu)
call connectdbn(k1, k5, lnu)
endif
endif
endif
enddo
end subroutine triangulate_quadsandmore
SUBROUTINE WRIswan(MNET,filnam)
use m_netw
use m_polygon
use m_missing
use geometry_module, only: dbdistance, cross, normaloutchk
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
integer :: MNET
character(len=*) :: filnam
double precision :: xz2, yz2, dl, xn, yn, sl, sm, crp, xcr, ycr
integer :: k, L, n, kk, ja, k1, k2, k3, k4, jacros, lin
call savepol()
npl = 0
ja = 0
call triangulate_quadsandmore(ja)
if (ja == 1) then
call findcells(3) ! search triangles again
endif
call restorepol()
kc = 0 ! binnenpunten
do L = 1, numl
if (lnn(L) == 1) then ! dichte randen
k3 = kn (1,L)
k4 = kn (2,L)
kc(k3) = 1 ; kc(k4) = 1
endif
enddo
do L = 1, numl
if (lnn(L) == 1) then
k1 = lne(1,L)
k3 = kn (1,L)
k4 = kn (2,L)
dl = dbdistance( xk(k3), yk(k3), xk(k4), yk(k4), jsferic, jasfer3D, dmiss)
call normaloutchk(xk(k3), yk(k3), xk(k4), yk(k4), xzw(n), yzw(n), xn, yn, ja, jsferic, jasfer3D, dmiss, dxymis)
xz2 = xzw(n) + dl*xn ; yz2 = yzw(n) + dl*yn
lin = 2
do n = 1,npl-1
if (xpl(n) .ne. dmiss) then
if (xpl(n+1) .ne. dmiss) then
call cross(xpl(n), ypl(n), xpl(n+1), ypl(n+1), xzw(n), yzw(n), xz2, yz2, JACROS,SL,SM,XCR,YCR,CRP,jsferic, dmiss)
if (jacros == 1) then
kc(k3) = lin ; kc(k4) = lin ! open door polygon
endif
else
lin = lin + 1
endif
endif
enddo
endif
enddo
write(mNET,'(I12,A)') numk, ' 2 0 1'
DO K = 1, NUMK
WRITE(MNET,'(i12, 2F16.5, i3)') k, XK(K), YK(K), kc(k)
ENDDO
call doclose(mnet)
L = index(filnam,'.')
call newfil(mnet, filnam(1:L)//'nodz')
write(mNET,'(I12,A)') numk, ' 1 0 1'
DO K = 1, NUMK
WRITE(MNET,'(F16.5)') ZK(K)
ENDDO
call doclose(mnet)
call newfil(mnet, filnam(1:L)//'ele')
write(mNET,'(I12,A)') nump, ' 3 0'
do k = 1,nump
WRITE(MNET,'(4i12)') k, (netcell(k)%nod(kk),kk=1,3)
enddo
CALL DOCLOSE(MNET)
RETURN
END SUBROUTINE WRIswan
SUBROUTINE WRINET(MNET)
use m_netw
implicit none
integer :: MNET
integer :: i
integer :: j
integer :: k
integer :: l
integer :: lcdum
write(mNET,'(A,I12)') 'NR of NETNODES = ', numk ! nump = ndx
write(mNET,'(A,I12)') 'NR of NETLINKS = ', numL ! nump = ndx
WRITE(MNET,'(A)') 'NODE LIST, X, Y COORDINATES'
DO K = 1, NUMK
WRITE(MNET,'(3F26.15)') XK(K), YK(K), ZK(K)
ENDDO
WRITE(MNET,'(A)') 'LINK LIST, LEFT AND RIGHT NODE NRS'
LCDUM = 1
DO L = 1, NUML
WRITE(MNET,'(3I16)') KN(1,L), KN(2,L), KN(3,L)
ENDDO
CALL DOCLOSE(MNET)
RETURN
END SUBROUTINE WRINET
SUBROUTINE REAJANET(MNET,JA,JADOORLADEN)
use m_netw
use gridoperations
implicit none
integer :: MNET, JA, JADOORLADEN
integer :: k
integer :: k0
integer :: l
integer :: l0
integer :: n1
integer :: numkn
integer :: numln
double precision :: x10
CHARACTER REC*3320
IF (JADOORLADEN .EQ. 0) THEN
K0 = 0
L0 = 0
ELSE
K0 = NUMK
L0 = NUML
ENDIF
JA = 0
READ(MNET,'(A)',end = 777) REC ! COMMENT
READ(MNET,'(A)',end = 777) REC
N1 = INDEX(REC,'=') + 1
READ(REC(N1:),*, err = 555) NUMKN
READ(MNET,'(A)',end = 777) REC
N1 = INDEX(REC,'=') + 1
READ(REC(N1:),*, err = 555) NUMP
READ(MNET,'(A)',end = 777) REC
READ(MNET,'(A)',end = 777) REC
N1 = INDEX(REC,'=') + 1
READ(REC(N1:),*, err = 555) NUMLN
READ(MNET,'(A)',end = 777) REC
READ(MNET,'(A)',end = 777) REC
READ(MNET,'(A)',end = 777) REC
DO K = 1,4
READ(MNET,'(A)',end = 777) REC
ENDDO
CALL INCREASENETW(K0+NUMKN, L0 + NUMLN)
DO K = K0+1, K0+NUMKN
READ(MNET,'(A)',END = 777) REC
READ(REC,*,ERR = 999) XK(K), YK(K)
ENDDO
!XK = XK - 270000
!YK = YK - 2700000
NUMK = K0+NUMKN
KC = 1
DO K = 1,NUMP
READ(MNET,*)
ENDDO
DO L = L0+1, L0+NUMLN
READ(MNET,'(A)',END = 777) REC
READ(REC,*,ERR = 888) x10, KN(1,L), KN(2,L)
KN(1,L) = KN(1,L) + K0
KN(2,L) = KN(2,L) + K0
KN(3,L) = 2
ENDDO
NUML = L0+NUMLN
CALL SETNODADM(0)
ja = 1
return
999 CALL QNREADERROR('READING NETNODES, BUT GETTING ', REC, MNET)
RETURN
888 CALL QNREADERROR('READING NETLINKS, BUT GETTING ', REC, MNET)
777 CALL QNEOFERROR(MNET)
RETURN
555 CALL QNREADERROR('READING NR OF NETNODES, BUT GETTING ', REC, MNET)
RETURN
444 CALL QNREADERROR('READING NR OF NETLINKS, BUT GETTING ', REC, MNET)
RETURN
END SUBROUTINE REAJANET
SUBROUTINE READADCIRCNET(MNET,JA,JADOORLADEN)
use m_netw
use m_polygon
use m_landboundary
use m_missing
use gridoperations
implicit none
integer :: MNET, JA, JADOORLADEN
integer :: k, j
integer :: k0, K1, K2, K3, kk, nn
integer :: l
integer :: l0
integer :: n1
integer :: numkn
integer :: numln
integer :: NOPE, NETA, itmp, NBOU, NVEL, NVELL, IBTYPE, NBVV, IBCONN
integer :: jamergeweirnodes
double precision :: BARINHT, BARINCFSB, BARINCFSP
double precision :: x10
CHARACTER REC*3320
IF (JADOORLADEN .EQ. 0) THEN
K0 = 0
L0 = 0
ELSE
K0 = NUMK
L0 = NUML
ENDIF
JA = 0
CALL READYY('Converting ADCIRC data...',0d0)
READ(MNET,'(A)',end = 777) REC ! COMMENT
READ(MNET,'(A)',end = 777) REC
READ(REC,*, err = 555) nump, NUMKN
NUMLN = 3*NUMP
CALL INCREASENETW(K0+NUMKN, L0 + NUMLN)
CALL READYY('Converting ADCIRC data...',.2d0)
DO K = K0+1, K0+NUMKN
READ(MNET,'(A)',END = 777) REC
READ(REC,*,ERR = 999) KK, XK(K), YK(K), ZK(K)
ENDDO
NUMK = K0+NUMKN
KC = 1
L = L0
DO K = 1,NUMP
READ(MNET,'(A)',END = 777) REC
READ(REC,*,ERR = 999) KK, nn, k1, k2, k3
L = L + 1 ; kn(1,L) = k1 ; kn(2,L) = k2 ; kn(3,L) = 2
L = L + 1 ; kn(1,L) = k2 ; kn(2,L) = k3 ; kn(3,L) = 2
L = L + 1 ; kn(1,L) = k3 ; kn(2,L) = k1 ; kn(3,L) = 2
ENDDO
NUML = L
CALL READYY('Converting ADCIRC data...',.4d0)
CALL SETNODADM(0)
call SAVENET()
CALL READYY('Converting ADCIRC data...',.7d0)
READ(MNET,'(A)',end = 777) REC ! NOPE param
READ(REC,*, err = 555) NOPE
READ(MNET,'(A)',end = 777) REC ! NETA param
READ(REC,*, err = 555) NETA
do k=1,NOPE
READ(MNET,'(A)',end = 777) REC ! NVDLL(k), IBTYPEE(k)
READ(REC,*, err = 555) itmp !, itmp
do j=1,itmp
READ(MNET,'(A)',end = 777) REC ! NBDV(k,j) ! discard for now
end do ! j
end do ! k
READ(MNET,'(A)',end = 777) REC ! NBOU param
READ(REC,*, err = 555) NBOU
READ(MNET,'(A)',end = 777) REC ! NVEL param
READ(REC,*, err = 555) NVEL
call confrm('Do you want to merge ADCIRC double levee-points into single points?', jamergeweirnodes)
if (jamergeweirnodes == 1) then
NPL = 0
call increasepol(NVEL+NBOU, 0) ! Store center line of adcirc levee as one polyline per levee, for later use as fixedweir pliz.
XPL = dmiss; YPL = dmiss; ZPL = dmiss
end if
MXLAN = 0
call increaselan(2*(NVEL+NBOU)) ! Store both sides of adcirc levee as two landboundary polylines per levee, for visual inspection.
do k=1, NBOU
READ(MNET,'(A)',end = 777) REC ! NVELL(k), IBTYPE(k) param
READ(REC,*, err = 555) NVELL, IBTYPE
if (k > 1) then
! Set empty separator/xymiss between polylines per boundary segment.
NPL = NPL + 1
MXLAN = MXLAN + 1
end if
do j=1,NVELL
READ(MNET,'(A)',end = 777) REC ! boundary definition line, depending on ibtype
select case(IBTYPE)
case (0, 1, 2, 10, 11, 12, 20, 21, 22, 30)
! NBVV(k,j) ? include this line only if IBTYPE(k) = 0, 1, 2, 10, 11, 12, 20, 21, 22, 30
continue
case (3, 13, 23)
! NBVV(k,j), BARLANHT(k,j), BARLANCFSP(k,j) include this line only if IBTYPE(k) = 3, 13, 23
continue
case (4,24)
! NBVV(k,j), IBCONN(k,j), BARINHT(k,j), BARINCFSB(k,j), BARINCFSP(k,j) include this line only if IBTYPE(k) = 4, 24
READ(REC,*, err = 555) NBVV, IBCONN, BARINHT, BARINCFSB, BARINCFSP ! todo put in mlan/mpol
k1 = K0+NBVV
k2 = K0+IBCONN
MXLAN = MXLAN+1
XLAN(MXLAN) = XK(k1); YLAN(MXLAN) = YK(k1); ZLAN(MXLAN) = BARINHT
XLAN(MXLAN+NVELL+1) = XK(k2); YLAN(MXLAN+NVELL+1) = YK(k2); ZLAN(MXLAN+NVELL+1) = BARINHT ! second side comes after the end of the first side
if (jamergeweirnodes == 1) then
XK(k2) = .5d0*(XK0(K1) + XK0(K2))
YK(k2) = .5d0*(YK0(K1) + YK0(K2))
ZK(k2) = max(ZK(K1), ZK(K2))
NPL = NPL+1
XPL(NPL) = XK(k2); YPL(NPL) = YK(k2); ZPL(NPL) = BARINHT ! TODO: sill left/right/contract
if (xpl(npl) < -100) then
continue
end if
! NOTE: This assumes that the opposite node is ONLY marked for deletion, NOT YET deleted, such that node numbering won't change yet, and file reading can continue with original numbers!
call MERGEUNCONNECTEDNODES(K1,K2,JA)
end if
case (5,25)
! NBVV(k,j), IBCONN(k,j), BARINHT(k,j), BARINCFSB(k,j), BARINCFSP(k,j), PIPEHT(k,j), PIPECOEF(k,j), PIPEDIAM(k,j), include this line only if IBTYPE(k) = 5, 25
continue
end select
end do ! j
if (IBTYPE == 4 .or. IBTYPE==24) then
MXLAN = MXLAN+NVELL+1 ! At the end of each levee string, update the MXLAN counter, because *also* the second side of levee was already stored in the above loop (but MXLAN counter was still only kept for first side).
end if
end do ! k
CALL READYY('Converting ADCIRC data...',.7d0)
call doclose(mnet)
CALL SETNODADM(0)
CALL READYY('Converting ADCIRC data...',-1d0)
ja = 0
return
999 CALL QNREADERROR('READING NETNODES, BUT GETTING ', REC, MNET)
RETURN
888 CALL QNREADERROR('READING NETLINKS, BUT GETTING ', REC, MNET)
777 CALL QNEOFERROR(MNET)
RETURN
555 CALL QNREADERROR('READING NR OF NETNODES, BUT GETTING ', REC, MNET)
RETURN
444 CALL QNREADERROR('READING NR OF NETLINKS, BUT GETTING ', REC, MNET)
RETURN
END SUBROUTINE READADCIRCNET
SUBROUTINE REANET(MNET,JA,JADOORLADEN)
use m_netw
use gridoperations
implicit none
INTEGER :: MNET, JA, LMOD
integer :: JADOORLADEN
double precision :: af
integer :: i, KMOD, mout
integer :: k, nr, numbersonline
integer :: k0
integer :: knread
integer :: l
integer :: l0
integer :: n1
integer :: netfiltyp
integer :: numkn
integer :: numln
CHARACTER REC*3320
NETFILTYP = 2 !NEW
IF (NETFLOW == 2) THEN
CALL CLEARFLOWMODELINPUTS()
ENDIF
IF (JADOORLADEN==1) THEN
K0 = 0
L0 = 0
ELSE
K0 = NUMK
L0 = NUML
ENDIF
JA = 1
READ(MNET,'(A)',end = 777, err = 707) REC
N1 = INDEX(REC,'=') + 1
READ(REC(N1:),*, end = 555, err = 555) NUMKN
READ(MNET,'(A)') REC
N1 = INDEX(REC,'=') + 1
READ(REC(N1:),*, end = 444, err = 444) NUMLN
READ(MNET,'(A)') REC
call readyy('reanet',0d0)
CALL INCREASENETW(K0+NUMKN, L0 + NUMLN)
call readyy('reanet',0.05d0)
KMOD = MAX(1,NUMK/100)
DO K = K0+1, K0+NUMKN
if (mod(k,KMOD) == 0) then
af = 0.05d0 + 0.45d0*dble(k-1-K0)/dble(numkn)
call readyy('reanet',af)
endif
READ(MNET,'(A)',err=888, END = 777) REC
nr = numbersonline(rec)
if (nr == 3) then
READ(REC,*,ERR = 999) XK(K), YK(K), ZK(K)
else
READ(REC,*,ERR = 999) XK(K), YK(K)
ZK(K) = ZKUNI
endif
ENDDO
if (netfiltyp == 1) READ(MNET,*)
READ(MNET,*)
LMOD = MAX(1,NUMLn/1000)
DO L = L0+1, L0+NUMLN
if (mod(l,LMOD) == 0) then
af = 0.5d0 + 0.5d0*dble(l-1)/dble(numln)
call readyy('reanet',af)
endif
READ(MNET,'(A)',END = 777) REC
IF (NETFILTYP == 2) THEN
KNREAD = 0
nr = numbersonline(rec)
if (nr == 3) then
READ(REC,*,ERR = 888) KN(1,L), KN(2,L), KNREAD
else
READ(REC,*,ERR = 888) KN(1,L), KN(2,L)
endif
ENDIF
KN(1,L) = KN(1,L) + K0
KN(2,L) = KN(2,L) + K0
IF (KNREAD .NE. 1) KNREAD = 2
KN(3,L) = KNREAD
ENDDO
666 NUMK = K0 + NUMKN
NUML = L0 + NUMLN
JA = 0
CALL DOCLOSE(MNET)
CALL SETNODADM (0)
call readyy('reanet',-1d0)
netstat = NETSTAT_CELLS_DIRTY
xkmin = minval(xk(1:numk))
xkmax = maxval(xk(1:numk))
RETURN
999 CALL QNREADERROR('READING NETNODES, BUT GETTING ', REC, MNET)
RETURN
888 CALL QNREADERROR('READING NETLINKS, BUT GETTING ', REC, MNET)
RETURN
707 CALL QNREADERROR('READING NET FILE, GOT UNEXPECTED CONTENT ', REC, MNET)
RETURN
777 CALL QNEOFERROR(MNET)
RETURN
555 CALL QNREADERROR('READING NR OF NETNODES, BUT GETTING ', REC, MNET)
RETURN
444 CALL QNREADERROR('READING NR OF NETLINKS, BUT GETTING ', REC, MNET)
RETURN
END SUBROUTINE REANET
SUBROUTINE CLOSEWORLD()
USE M_NETW
USE M_SFERIC
implicit none
INTEGER :: K1, K2, ja
double precision :: xmn, xmx
IF (JSFERIC == 0) RETURN
XMN = minval(XK(1:numk))
XMX = maxval(XK(1:numk))
IF (ABS(XMN) < 1D-10 .AND. ABS(XMX-360d0) < 1D-10 ) THEN !MAKE YOUR OWN 0-360 CONNECTIONS, only once
DO K1 = 1, NUMK
IF (REAL (XK(K1)) == 0.0) THEN
DO K2 = 1,NUMK
IF (REAL (XK(K2)) == 360.0) THEN
IF (ABS(YK(K1) - YK(K2) ) < 1D-10 ) THEN
CALL MERGENODES(K2,K1,JA)
EXIT
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
END SUBROUTINE CLOSEWORLD
SUBROUTINE DEALLOCNET()
use m_netw
USE M_FLOWgeom
implicit none
integer :: p, numpx
NUMK = 0; NUML = 0
IF (SIZE(XK) > 0) THEN
DEALLOCATE(NOD,XK ,YK , KC ,NMK)
DEALLOCATE(KN,LC)
ENDIF
IF (SIZE(XK0) > 0) THEN
DEALLOCATE(NOD0,XK0 ,YK0 ,ZK0 , KC0 ,NMK0)
DEALLOCATE(KN0,LC0)
ENDIF
IF ( SIZE(LNN) > 0) THEN
DEALLOCATE (LNN, LNE, ln2lne)
ENDIF
IF (NUMP > 0) THEN
numpx = size(netcell)
do p=1,numpx
if (allocated(netcell(p)%nod)) then
deallocate(netcell(p)%nod, netcell(p)%lin)
end if
end do
deallocate (netcell)
nump = 0
ENDIF
END SUBROUTINE DEALLOCNET
SUBROUTINE ZERONET()
use m_netw
implicit none
integer :: nl
integer :: numtotr
XK = 0; YK=0; ZK=0
KN =0 ; NL=0; NMK=0 ! S1=0
KC = 0; LC=0
NUMK = 0
NUML = 0
NUMTOTR=0
RETURN
END SUBROUTINE ZERONET
DOUBLE PRECISION FUNCTION GETRCIR()
use m_wearelt
implicit none
GETRCIR = RCIR
END FUNCTION GETRCIR
SUBROUTINE MAKEPANELXY(JPANEL)
use m_netw
USE M_AFMETING
use gridoperations
implicit none
integer :: JPANEL
double precision :: ael
double precision :: ag
double precision :: cfl
double precision :: cs
double precision :: drukmax
double precision :: dx
double precision :: dy
double precision :: e0
double precision :: eps
integer :: i
integer :: i2
integer :: j
integer :: jav
integer :: jofreeze
integer :: jview
integer :: k
integer :: k1
integer :: k2
integer :: l
integer :: l0
integer :: ld
integer :: ll
integer :: lld
integer :: llu
integer :: lr
integer :: lrd
integer :: lru
integer :: lu
integer :: n
integer :: numdik
integer :: numels
integer :: numh
integer :: numrb
integer :: numv
double precision :: pi
double precision :: rekmax
double precision :: rho
double precision :: rhow
double precision :: rmas
double precision :: rmk
double precision :: rml
double precision :: rnl
double precision :: sn
double precision :: x
double precision :: xkk
double precision :: xyz
double precision :: y
double precision :: ykk
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
COMMON /SET2/ REKMAX, DRUKMAX, NUMDIK, JOFREEZE
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
DOUBLE PRECISION DX1, DY1, DZ1
double precision :: DR(4)
integer :: INI, JaNET
DATA INI /0/
JaNET = 1 - JPANEL
IF (NPL .LE. 1 .OR. NPL .GT. 4) RETURN
CALL SAVENET()
DO I = 1,NPL
I2 = I + 1
IF (I .EQ. 4) I2 = 1
DX = XPL(I) - XPL(I2)
DY = YPL(I) - YPL(I2)
DR(I) = SQRT(DX*DX + DY*DY)
ENDDO
IF (NPL .EQ. 4) THEN
RML = (DR(1) + DR(3)) / 2
RNL = (DR(2) + DR(4)) / 2
ELSE IF (NPL .EQ. 2) THEN
RML = DR(1)
RNL = MIN(RML,RWIDTH)
ELSE IF (NPL .EQ. 3) THEN
RML = DR(1)
RNL = DR(2)
ENDIF
IF (NPL .EQ. 2 .AND. JANET .EQ. 0 .OR. NPL .EQ. 3) THEN
DX = XPL(2) - XPL(1)
DY = YPL(2) - YPL(1)
SN = DY/RML
CS = DX/RML
XPL(3) = XPL(2) - RNL*SN
YPL(3) = YPL(2) + RNL*CS
XPL(4) = XPL(1) - RNL*SN
YPL(4) = YPL(1) + RNL*CS
NPL = 4
ENDIF
RLENGTH = MAX(RML,RNL)
RWIDTH = MIN(RML,RNL)
IF (JVAST .EQ. 0) THEN
RTHICK = RWIDTH / 4
ENDIF
IF (RNL .LT. RML) THEN
NC = NUMDIK
MC = (NUMDIK-1)*RLENGTH/RWIDTH + 1
ELSE
MC = NUMDIK
NC = (NUMDIK-1)*RLENGTH/RWIDTH + 1
ENDIF
IF (JANET .EQ. 1) THEN ! Netstructuur
AEL = PI*RDIAM*RDIAM/4 ! RDIAM in mm
ELSE
NUMELS = ( NC + 2*(NC-1) ) ! Net plus kruisverbinding
AEL = 1E6* RWIDTH * RTHICK / NUMELS ! oppervlakte in mm2, BREEDTE in m
RMK = RHO * RLENGTH * RWIDTH * RTHICK / (MC * NC) !knoop massa (kg)
ENDIF
K0 = NUMK
L0 = NUML
IF (NPL .EQ. 2 .AND. JANET .EQ. 1) THEN ! Toevoegen lijnelement
RETURN
ENDIF
! IF (NPL .EQ. 4) THEN
! ZZ = 0
! CALL ADDBLOCK(XPL,YPL,ZZ,JANET)
! RETURN
! ENDIF
! knoopnummers uitdelen
DO 10 J = 1,NC
Y = dble(J-1)/dble(NC-1)
DO 10 I = 1,MC
X = dble(I-1)/dble(MC-1)
K = (J-1)*MC + I + K0
XKK = XPL(1)*(1-X)*(1-Y) + XPL(2)*( X)*(1-Y) + &
XPL(3)*( X)*( Y) + XPL(4)*(1-X)*( Y)
YKK = YPL(1)*(1-X)*(1-Y) + YPL(2)*( X)*(1-Y) + &
YPL(3)*( X)*( Y) + YPL(4)*(1-X)*( Y)
IF (JVIEW .EQ. 1) THEN
XK(K) = XKK
YK(K) = YKK
ZK(K) = 0d0
ELSE IF (JVIEW .EQ. 2) THEN
XK(K) = XKK
YK(K) = 0d0
ZK(K) = YKK
ELSE IF (JVIEW .EQ. 3) THEN
XK(K) = 0d0
YK(K) = XKK
ZK(K) = YKK
ENDIF
10 CONTINUE
NUMK = K0 + MC*NC
! horizontale elementen krijgen twee knoopnummers
L = L0
DO 20 J = 1,NC
DO 20 I = 1,MC-1
L = L + 1
K1 = (J-1)*MC + I + K0
K2 = (J-1)*MC + I + 1 + K0
KN(1,L) = K1
KN(2,L) = K2
20 CONTINUE
NUMH = L
! verticale elementen
DO 30 J = 1,NC-1
DO 30 I = 1,MC
L = L + 1
K1 = (J-1)*MC + I + K0
K2 = (J )*MC + I + K0
KN(1,L) = K1
KN(2,L) = K2
30 CONTINUE
NUMV = L
IF (JPANEL .EQ. 1) THEN
! diagonalen naar rechtsboven
DO 40 J = 1,NC-1
DO 40 I = 1,MC-1
L = L + 1
K1 = (J-1)*MC + I + K0
K2 = (J )*MC + I + 1 + K0
KN(1,L) = K1
KN(2,L) = K2
40 CONTINUE
NUMRB = L
! diagonalen naar linksboven
DO 41 J = 1,NC-1
DO 41 I = 2,MC
L = L + 1
K1 = (J-1)*MC + I + K0
K2 = (J )*MC + I - 1 + K0
KN(1,L) = K1
KN(2,L) = K2
41 CONTINUE
ENDIF
NUML = L
DO 50 J = 1,NC
DO 50 I = 1,MC
K = (J-1)*MC + I + K0
IF (I .LT. MC) THEN ! ELEMENT NAAR RECHTS
NMK(K) = NMK(K) + 1
LR = L0 + (J-1)*(MC-1) + I
CALL SETNODLIN(K,NMK(K),LR)
ENDIF
IF (I .GT. 1) THEN ! LINKS
NMK(K) = NMK(K) + 1
LL = L0 + (J-1)*(MC-1) + I - 1
CALL SETNODLIN(K,NMK(K),LL)
ENDIF
IF (J .LT. NC) THEN ! BOVEN
NMK(K) = NMK(K) + 1
LU = NUMH + (J-1)*MC + I
CALL SETNODLIN(K,NMK(K),LU)
ENDIF
IF (J .GT. 1) THEN ! ONDER
NMK(K) = NMK(K) + 1
LD = NUMH + (J-2)*MC + I
CALL SETNODLIN(K,NMK(K),LD)
ENDIF
IF (JPANEL .EQ. 1) THEN
IF (J .LT. NC .AND. I .LT. MC) THEN ! RECHTS BOVEN
NMK(K) = NMK(K) + 1
LRU = NUMV + (J-1)*(MC-1) + I
CALL SETNODLIN(K,NMK(K),LRU)
ENDIF
IF (J .GT. 1 .AND. I .GT. 1) THEN ! LINKSONDER
NMK(K) = NMK(K) + 1
LLD = NUMV + (J-2)*(MC-1) + I - 1
CALL SETNODLIN(K,NMK(K),LLD)
ENDIF
IF (I .GT. 1 .AND. J .LT. NC) THEN ! LINKSBOVEN
NMK(K) = NMK(K) + 1
LLU = NUMRB + (J-1)*(MC-1) + I - 1
CALL SETNODLIN(K,NMK(K),LLU)
ENDIF
IF (J .GT. 1 .AND. I .LT. MC) THEN ! RECHTSONDER
NMK(K) = NMK(K) + 1
LRD = NUMRB + (J-2)*(MC-1) + I
CALL SETNODLIN(K,NMK(K),LRD)
ENDIF
ENDIF
50 CONTINUE
DO L = L0+1, NUML
K1 = KN(1,L)
K2 = KN(2,L)
DX1 = XK(K1) - XK(K2)
DY1 = YK(K1) - YK(K2)
DZ1 = ZK(K1) - ZK(K2)
! RL(L) = SQRT(DX1*DX1+DY1*DY1+DZ1*DZ1)
! EA(L) = AEL ! Voorlopig alle elementen even grote doorsnede
ENDDO
DO K = K0+1, NUMK
IF (NETFLOW .EQ. 1) THEN
DO N = 1,NMK(K)
L = NOD(K)%LIN(N)
RMAS = RHO ! *RL(L)*EA(L)*1E-6
! RM(K) = RM(K) + 0.5d0*RMAS
ENDDO
! RM(K) = RMK
ENDIF
KC(K) = 1
ENDDO
IF (INI .EQ. 0) THEN
DO J = 1,NC ! Uiteinden LINKS VASTZETTEN
K = (J-1)*(MC) + 1 + K0
KC(K) = -1
ENDDO
ENDIF
CALL DPUTAR (XK ,XK1 ,KMAX)
CALL DPUTAR (YK ,YK1 ,KMAX)
CALL DPUTAR (ZK ,ZK1 ,KMAX)
RETURN
END SUBROUTINE MAKEPANELXY
SUBROUTINE ADDBLOCK(X,Y,Z,JANET)
use gridoperations
implicit none
integer :: ja
integer :: jav
integer :: jview
integer :: k
integer :: n
double precision :: xyz
double precision :: X(4), Y(4), Z
integer :: JANET
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
INTEGER KK(8)
DO K = 1,8
N = K
IF (K .EQ. 5) THEN
Z = Z + 1D0
ENDIF
IF (K .GE. 5) N = K - 4
CALL ISNODE2(KK(K), X(N), Y(N), Z)
IF (KK(K) .LE. 0) THEN
CALL GIVENEWNODENUM(KK(K))
XYZ = Z
CALL SETPOINT(X(N),Y(N),Z,KK(K))
ENDIF
ENDDO
CALL ADDELEM(KK(1),KK(2),JA)
CALL ADDELEM(KK(2),KK(3),JA)
CALL ADDELEM(KK(3),KK(4),JA)
CALL ADDELEM(KK(4),KK(1),JA)
CALL ADDELEM(KK(5),KK(6),JA)
CALL ADDELEM(KK(6),KK(7),JA)
CALL ADDELEM(KK(7),KK(8),JA)
CALL ADDELEM(KK(8),KK(5),JA)
CALL ADDELEM(KK(1),KK(5),JA)
CALL ADDELEM(KK(2),KK(6),JA)
CALL ADDELEM(KK(3),KK(7),JA)
CALL ADDELEM(KK(4),KK(8),JA)
CALL ADDELEM(KK(1),KK(3),JA)
CALL ADDELEM(KK(5),KK(7),JA)
CALL ADDELEM(KK(4),KK(5),JA)
CALL ADDELEM(KK(3),KK(6),JA)
CALL ADDELEM(KK(4),KK(7),JA)
CALL ADDELEM(KK(1),KK(6),JA)
RETURN
END SUBROUTINE ADDBLOCK
SUBROUTINE POLTOLINES()
use m_netw
use m_afmeting
use gridoperations
implicit none
double precision :: ael
double precision :: ag
double precision :: cfl
double precision :: e0
double precision :: eps
integer :: k
integer :: k1
integer :: k2
double precision :: pi
double precision :: rho
double precision :: rhow
double precision :: rml
double precision :: zp
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
DOUBLE PRECISION DLENGTH
AEL = PI*RDIAM*RDIAM/4 ! RDIAM in mm
DO K = 1,NPL-1
CALL ISNODE( K1, XPL(K), YPL(K), ZP )
IF (K1 .EQ. 0) THEN
CALL GIVENEWNODENUM(K1)
CALL SETPOINT(XPL(K),YPL(K),ZP,K1)
ENDIF
CALL ISNODE( K2, XPL(K+1), YPL(K+1), ZP )
IF (K2 .EQ. 0) THEN
CALL GIVENEWNODENUM(K2)
CALL SETPOINT(XPL(K+1),YPL(K+1),ZP,K2)
ENDIF
RML = DLENGTH(K1,K2)
CALL CONNECT(K1,K2,LFAC,AEL,RML)
ENDDO
RETURN
END SUBROUTINE POLTOLINES
SUBROUTINE DSETNEWPOINT(XP,YP,K)
use m_netw
use m_missing
use gridoperations
implicit none
DOUBLE PRECISION :: XP, YP
INTEGER :: K
CALL GIVENEWNODENUM(K)
XK(K) = XP; YK(K) = YP ; ZK(K) = dmiss; KC(K) = K
RETURN
END SUBROUTINE DSETNEWPOINT
SUBROUTINE SETPOINT(XP,YP,ZP,K1)
use m_netw
use gridoperations
implicit none
double precision :: XP, YP, ZP
integer :: K1
integer :: jav
integer :: jview
double precision :: xyz
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
CALL TWEEDRIE(XP,YP,XK(K1),YK(K1),ZK(K1))
IF (JVIEW .EQ. 1) THEN
ZK(K1) = zp ! XYZ
ELSE IF (JVIEW .EQ. 2) THEN
XK(K1) = XYZ
ELSE IF (JVIEW .EQ. 3) THEN
YK(K1) = XYZ
ENDIF
IF (KC(K1) .EQ. 0) KC(K1) = 1
RETURN
END SUBROUTINE SETPOINT
SUBROUTINE addnetpointnocheck(XP,YP,ZP,K1)
use m_netw
implicit none
double precision :: xp, yp, ZP
integer :: k1
numk = numk + 1
k1 = numk
xk(k1) = xp
yk(k1) = yp
ZK(K1) = ZP
kc(k1) = 1
RETURN
END SUBROUTINE addnetpointnocheck
SUBROUTINE ISNODEDB(KP, XP, YP)
use m_netw
implicit none
integer :: KP
DOUBLE PRECISION :: XP, YP, eps = 1d-6
integer :: K
KP = 0
DO K = NUMK, 1,-1
IF ( abs(XP-XK(K)) < eps .AND. abs(YP-YK(K)) < eps ) THEN
KP = K
RETURN
ENDIF
ENDDO
RETURN
END SUBROUTINE ISNODEDB
SUBROUTINE ISNODE(KP, XP, YP, ZP)
use m_netw
use m_wearelt
use m_missing
use gridoperations
implicit none
integer :: KP
double precision :: XP, YP, ZP
integer :: ll
double precision :: xkk
double precision :: ykk
double precision :: zkk
integer :: K, KPREV
IF (KP < 0) THEN
KPREV = IABS(KP)
ELSE
KPREV = 0
ENDIF
KP = 0
ZP = dmiss
DO K = 1,NUMK
IF (K == KPREV) CYCLE
CALL DRIETWEE(XK(K),YK(K),ZK(K),XKK,YKK,ZKK)
IF (ABS(XKK-XP) .LT. RCIR .AND. ABS(YKK-YP) .LT. RCIR) THEN
KP = K
CALL DISPNODE(KP)
ZP = ZKK
! XYZ = ZKK
RETURN
ENDIF
ENDDO
END SUBROUTINE ISNODE
SUBROUTINE ISNODE2(KP, XP, YP, ZP) ! X,Y,Z MOETEN ALLEN KLOPPEN
use m_netw
use m_wearelt
implicit none
integer :: KP
double precision :: XP, YP, ZP
double precision :: eps
integer :: jav
integer :: jview
integer :: k
double precision :: xyz
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
KP = 0
EPS = 0.01d0*RCIR
DO K = NUMK,1,-1
IF (ABS(XK(K)-XP) .LT. EPS .AND. ABS(YK(K)-YP) .LT. EPS .AND. ABS(ZK(K)-ZP) .LT. EPS) THEN
KP = K
RETURN
ENDIF
ENDDO
RETURN
END SUBROUTINE ISNODE2
!> Tries to find the number of the netlink close to a point.
!! The provided point should lie within a rhombus with the netlink
!! as a diagonal and another diagonal with length searchradius rcir.
!! The returned zp value is the z-coordinate of the link's center.
SUBROUTINE ISLINK(LL, XP, YP, ZP)
use m_netw
use m_wearelt
use m_missing, only: jins, dmiss, dxymis
use geometry_module, only: pinpok, normalout
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
integer, intent(out) :: LL !< Number of first netlink found, 0 if none.
double precision, intent(in) :: XP, YP !< Coordinates of input point.
double precision, intent(out) :: ZP !< Z-coordinate of netlink's center.
integer :: jav, jview
integer :: k1, k2, l, in, jins_old
double precision :: xkk
double precision :: xyz
double precision :: ykk
double precision :: zkk
double precision :: xprange(4), yprange(4)
double precision :: xk1p, yk1p, xk2p, yk2p, rx, ry
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
DOUBLE PRECISION :: H=0.5d0
! store
jins_old = jins
jins = 1 ! otherwise pinpok has inverse behavior
LL = 0
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
CALL DRIETWEE(H*(XK(K1)+XK(K2)),H*(YK(K1)+YK(K2)),H*(ZK(K1)+ZK(K2)),XKK,YKK,ZKK)
! Get screen-projected coordinates of link nodes 1 and 2, and construct search range around it.
CALL DRIETWEE(XK(K1), YK(K1), ZK(K1), xk1p,yk1p,ZKK)
CALL DRIETWEE(XK(K2), YK(K2), ZK(K2), xk2p,yk2p,ZKK)
call normalout(xk1p, yk1p, xk2p, yk2p, rx, ry, jsferic, jasfer3D, dmiss, dxymis)
xprange(1) = xk1p; yprange(1) = yk1p
xprange(2) = xkk+rcir*rx; yprange(2) = ykk+rcir*ry
xprange(3) = xk2p; yprange(3) = yk2p
xprange(4) = xkk-rcir*rx; yprange(4) = ykk-rcir*ry
! call movabs(xprange(1), yprange(1))
! call clnabs(xprange(2), yprange(2), 41)
! call clnabs(xprange(3), yprange(3), 41)
! call clnabs(xprange(4), yprange(4), 41)
call PINPOK(xp, yp, 4, xprange, yprange, IN, jins, dmiss)
if (in == 1) then
LL = L
CALL DISPNODE(LL)
ZP = ZKK
return
end if
! IF (ABS(XKK-XP) .LT. RCIR .AND. ABS(YKK-YP) .LT. RCIR) THEN
! LL = L
! CALL DISPNODE(LL)
! ZP = ZKK
! XYZ = ZKK
! RETURN
! ENDIF
ENDIF
ENDDO
ZP = XYZ
CALL DISPNODE(LL)
! restore
jins = jins_old
RETURN
END SUBROUTINE ISLINK
SUBROUTINE ISflowlink(XP, YP, LL) ! IS THIS A flow NODE OR A flow LINK ?
use m_netw
use m_flowgeom
use m_wearelt
implicit none
double precision :: XP, YP
integer :: LL
integer n, l, k1, k2
double precision :: xa, ya
LL = 0
DO L = 1,lnx
if (L > lnx1D) then
k1 = lncn(1,l) ; k2 = lncn(2,L) ! eigenlijk 3 en 4
xa = 0.5*(xk(k1) + xk(k2)) ; ya = 0.5*(yk(k1) + yk(k2))
else
k1 = ln(1,L) ; k2 = ln(2,L)
xa = 0.5*(xz(k1) + xz(k2)) ; ya = 0.5*(yz(k1) + yz(k2))
endif
IF (ABS(XA-XP) .LT. 3*RCIR .AND. ABS(YA-YP) .LT. 3*RCIR) THEN
LL = L
CALL DISLN(LL)
RETURN
ENDIF
ENDDO
RETURN
END SUBROUTINE ISflowlink
SUBROUTINE MERGENODESINPOLYGON()
use m_netw
use kdtree2Factory
use unstruc_messages
use m_sferic
use m_missing
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use gridoperations
implicit none
INTEGER :: K, KK, KM, K1, K2, KK1, KK2, KA, KB, kn3, L, LL, JA, JACROS
INTEGER :: IBR, KP, N, JADUM
DOUBLE PRECISION :: DIST, DISMIN
DOUBLE PRECISION :: SL, SM, XCR, YCR, CRP, XB, YB
integer :: kint, Lint, in
double precision :: R2search ! squared search radius
integer :: NN
integer :: numk_inpoly ! number of nodes in polygon
integer, parameter :: NUMKDTREEMIN = 100 ! minimum number of nodes required for kdtree
integer, parameter :: jakdtree = 1 ! use kdtree (1) or not (0)
integer :: itp, i, kkother, kother, nummerged, jadone, ierror, nrl1d
double precision, dimension(:), allocatable :: xx, yy ! coordinates of nodes in polygon
integer, dimension(:), allocatable :: iperm ! permutation array
double precision :: xboundmin, xboundmax, d
double precision :: dtol
logical :: Lmerge
if ( janeedfix.eq.1 ) then
dtol=1d-4
else
dtol=0d0
end if
CALL SAVENET()
call setnodadm(0)
KC = 0
in = -1
node:DO K = 1,NUMK
CALL DBPINPOL( XK(K), YK(K), in, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.gt.0 ) then
kc(k) = 0 ! Initialize for link loop below
DO kk=1,nmk(K)
LL = abs(nod(k)%lin(kk))
! KC(1D NODES) = 1 , KC(2D NODES) = 2
if (kn(3,LL) == 1 .or. kn(3,LL) == 6) then
itp = 1 ! "1D" netnode type
else if (kn(3,LL) == 3 .or. kn(3,LL) == 4 .or. kn(3,LL) == 5 .or. kn(3,LL) == 7) then
itp = kn(3,LL) ! 1d2d connections
else if (kn(3,LL) == 2) then
itp = 2 ! "2D" netnode type
else
itp = 0
end if
kc(k) = max(kc(k), itp)
end do
end if
ENDDO node
if ( jsferic.eq.1 ) then
call get_meshbounds(xboundmin, xboundmax)
end if
CALL READYY(' ', 0.5d0 )
kint = max(numk/100,1)
if (tooclose > 0) then
CALL READYY('Merging nodes',0d0)
jadone = 0
if ( jakdtree.eq.1 .and. numk.gt.NUMKDTREEMIN ) then
call mess(LEVEL_INFO, 'Merging nodes on top of each other...')
! get coordinates of nodes in polygon
allocate(xx(numk))
xx = 0d0
allocate(yy(numk))
yy = 0d0
allocate(iperm(numk))
iperm = 0
nummerged = 0
numk_inpoly = 0
do k=1,numk
if ( kc(k) >= 1 .and. xk(k).ne.DMISS .and. yk(k).ne.DMISS ) then
numk_inpoly=numk_inpoly+1
if ( janeedfix.eq.1 ) then
! kdtree may run into problems (infinite recursion) with duplicate input data: perturb data
call random_number(d)
xx(numk_inpoly) = xk(k) + dtol*d
call random_number(d)
yy(numk_inpoly) = yk(k) + dtol*d
else
xx(numk_inpoly) = xk(k)
yy(numk_inpoly) = yk(k)
end if
iperm(numk_inpoly) = k
end if
end do
! compute squared search radius, add toleance due to kdtree perturbations
if ( jsferic.eq.0 ) then
R2search = (tooclose+2d0*dtol)**2
else
R2search = (tooclose+2d0*dtol*Ra)**2
end if
! initialize kdtree
call build_kdtree(treeglob,numk_inpoly,xx,yy, ierror, jsferic, dmiss)
! deallocate arrays with node coordinates
deallocate(xx)
deallocate(yy)
if ( ierror.eq.0 ) then
jadone = 1
! find and merge nodes on top of each other
do kk=1,numk_inpoly
k = iperm(kk)
if ( k.eq.0 ) cycle ! already merged
IF (MOD(K,kint) .EQ. 0) THEN
CALL READYY(' ',MIN( 1d0,dble(k)/kint ) )
ENDIF
! fill query vector
call make_queryvector_kdtree(treeglob,xk(k),yk(k), jsferic)
! count number of points in search area
NN = kdtree2_r_count(treeglob%tree,treeglob%qv,R2search)
if ( NN.gt.1 ) then ! at least two nodes need to be merged
! resize results array if necessary
call realloc_results_kdtree(treeglob,NN)
! find other nodes
call kdtree2_n_nearest(treeglob%tree,treeglob%qv,NN,treeglob%results)
! merge with other nodes
do i=1,NN
kkother = treeglob%results(i)%idx
kother = iperm(kkother)
! exclude own node and nodes already merged
if ( kother.ne.k .and. kother.gt.0 ) then
Lmerge = .false.
if (kc(k) == 1 .and. (kc(kother) == 1 .or. kc(kother) >= 3)) then
Lmerge = .true.
else if (kc(k) == 2 .and. kc(kother) == 2) then
Lmerge = .true.
else if (kc(k) >= 3 .and. nmk(k) > 1) then ! Only 1d2d links if they are not endpoints that should connect inside a 2D cell.
Lmerge = .true.
end if
if ( Lmerge .and. janeedfix.eq.1 ) then
! because of random perturbations<=tolerance added to kdtree: check real distance
Lmerge = ( dbdistance(xk(k),yk(k),xk(kother),yk(kother), jsferic, jasfer3D, dmiss).lt.tooclose )
end if
if ( Lmerge ) then
kc(k) = max(kc(k), kc(kother)) ! merged node gets maximum of the two node types
call mergenodes(kother,k,ja)
if ( ja.eq.1 ) then
iperm(kkother) = 0
nummerged = nummerged+1
endif
else
continue
end if
end if
end do
end if
end do
call mess(LEVEL_INFO, 'done.')
call mess(LEVEL_INFO, 'number of merges: ', nummerged)
end if
! deallocate permutation array
if ( allocated(iperm) ) deallocate(iperm)
! deallocate kdtree
if ( treeglob%itreestat.ne.ITREE_EMPTY ) call delete_kdtree2(treeglob)
end if
if ( jadone.ne.1 ) then
! non-kdtree
DO K = 1,NUMK
IF (MOD(K,kint) .EQ. 0) THEN
CALL READYY(' ',MIN( 1d0,dble(k)/kint ) )
ENDIF
IF (KC(K) > 0) THEN
DO KK = K+1,NUMK
IF (KC(KK) > 0) THEN
IF (dbdistance( XK(K), yk(k), XK(KK), yk(kk), jsferic, jasfer3D, dmiss ) < TOOCLOSE ) THEN
CALL MERGENODES(K,KK,JA)
IF (JA .EQ. 1) THEN
KC(K) = -ABS(KC(K))
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
end if
if ( jsferic.eq.1 ) then
call rearrange_worldmesh(xboundmin, xboundmax)
end if
CALL READYY(' ',-1d0)
endif
if (CONNECT1DEND > 0) then
CALL READYY('Connecting 1D nodes',0d0)
DO K = 1,NUMK ! MERGE 1d ENDPOINTS TO 1d ENDPOINTS THAT ARE REALLY CLOSE
IF (MOD(K,kint) .EQ. 0) THEN
CALL READYY(' ',.5d0*MIN( 1d0,dble(k)/kint ) )
ENDIF
IF (KC(K) == 1 .AND. NMK(K) == 1) THEN
DO KK = K+1,NUMK
IF (KC(KK) == 1 .AND. NMK(KK) == 1) THEN
IF (dbdistance( XK(K), yk(k), XK(KK), yk(kk), jsferic, jasfer3D, dmiss) < 0.2*CONNECT1DEND ) THEN
CALL MERGENODES(K,KK,JA)
IF (JA .EQ. 1) THEN
KC(K) = -1
KC(KK) = -1
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
CALL SETBRANCH_LC(nrl1d)
if (nrl1d == 0) then
CALL READYY(' ',-1d0) ; netstat = NETSTAT_OK
return
endif
KC = 1
DO L = 1,NUML
IF (KN(3,L) == 2) THEN ! KC(1D NODES) = 1 , KC(2D NODES) = 2
KC( KN(1,L) ) = 2
KC( KN(2,L) ) = 2
ENDIF
ENDDO
Lint = max(NUML/100,1)
DO L = 1,NUML
IF (MOD(L,Lint) .EQ. 0) THEN
CALL READYY(' ',.5d0+.5d0*MIN( 1d0,dble(L)/Lint ) )
ENDIF
IF (KN(3,L) == 1 .or. KN(3,L) == 4) THEN
kn3 = kn(3,L)
K1 = KN(1,L) ; K2 = KN(2,L)
IF (KC(K1) > 0 .and. KC(K2) > 0) THEN
KA = 0
IF (NMK(K1) == 1 .AND. NMK(K2)== 2) THEN
KA = K1 ; KB = K2
ELSE IF (NMK(K2) == 1 .AND. NMK(K1)== 2) THEN
KA = K2 ; KB = K1
ENDIF
IF (KA .NE. 0) THEN
DISMIN = 1D9 ; KM = 0
DO K = 1,NUMK
IF (KA .NE. K .AND. KC(K) == 1) THEN
JADUM = 1
IF (LC(L) == LC(NOD(K)%LIN(1)) ) THEN
! Known bug: do not only check %lin(1), but all links.
JADUM = 0
CYCLE ! SKIP OWN BRANCH
ENDIF
IF (dbdistance( XK(K), yk(k), XK(Ka), yk(ka), jsferic, jasfer3D, dmiss ) < CONNECT1DEND ) THEN
DIST = dbdistance( XK(KA),YK(KA),XK(K),YK(K), jsferic, jasfer3D, dmiss)
IF ( Dist < DISMIN ) THEN
dismin = dist ; KM = K
ENDIF
ENDIF
ENDIF
ENDDO
IF (KM .NE. 0) THEN
IF (DISMIN < 0.5*UNIDX1D) THEN
CALL MERGENODES(KA,KM,JA)
ELSE
NUML = NUML + 1
KN(1,NUML) = KA
KN(2,NUML) = KM
KN(3,NUML) = kn3 ! 1 or 4
LC( NUML) = LC(L)
ENDIF
KC(KA) = 0
KC(KM) = 0
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
CALL READYY(' ',-1d0)
netstat = NETSTAT_OK
ENDIF
END SUBROUTINE MERGENODESINPOLYGON
RECURSIVE SUBROUTINE WALK1D(K1,IBR,NRL,JASTOP,KN316)
use m_netw
use gridoperations
IMPLICIT NONE
INTEGER :: K1,K2,K,IBR,NRL,JASTOP,LX,KN316
INTEGER :: KK,L, KA
JASTOP = 0
DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LC(L) == 0 .AND. KN(3,L) == KN316) THEN
CALL OTHERNODE (K1,L,K2)
CALL GAANWESTOPPEN(K2,KN316,JASTOP,L)
LC(L) = IBR ; NRL = NRL + 1
LIB(NRL) = L ; K1BR(NRL) = K1 ; IBN(NRL) = IBR; NRLB(L) = NRL
IF (JASTOP == 1) THEN
RETURN
ENDIF
KA = K2
CALL WALK1D(KA,IBR,NRL,JASTOP,KN316)
IF (JASTOP == 1) THEN
RETURN
ENDIF
ENDIF
ENDDO
END SUBROUTINE WALK1D
SUBROUTINE GAANWESTARTEN(L,K1,KN316,JASTART)
USE M_NETW
IMPLICIT NONE
INTEGER :: L,K1,K2,KN316,JASTART,J, JASTOP, J1, J2
JASTART = 0
IF (KN(3,L) /= KN316) RETURN
DO J = 1,2
K1 = KN(J,L)
CALL GAANWESTOPPEN(K1,KN316,JASTART,L)
IF (JASTART == 1 ) THEN
RETURN
ENDIF
ENDDO
END SUBROUTINE GAANWESTARTEN
SUBROUTINE GAANWESTOPPEN(K,KN316,JASTOP,LO) !SET JASTOP = 1 ALS WE GAAN STOPPEN
USE M_NETW
IMPLICIT NONE
INTEGER :: K2,KN316,JASTOP,N1,N6,KK,L,K1,K,LO
JASTOP = 0 ; N1 = 0 ; N6 = 0
IF (NMK0(K) == 1) THEN
JASTOP = 1 ; RETURN
ENDIF
DO KK = 1,NMK(K)
L = NOD(K)%LIN(KK)
IF (KN(3,L) == 1) THEN
N1 = N1 + 1
ELSE IF (KN(3,L) == 6) THEN
N6 = N6 + 1
ENDIF
ENDDO
IF (KN316 == 1) THEN
IF (N1 + N6 .NE. 2) THEN ! altijd stoppen bij niet doorgaande node
JASTOP = 1
ENDIF
ELSE IF (KN316 == 6) THEN ! alleen stoppen bij aantal 6 jes ongelijk 2
IF (N6 .NE. 2) THEN
JASTOP = 1
ENDIF
ENDIF
END SUBROUTINE GAANWESTOPPEN
SUBROUTINE SETBRANCH_LC(nrl1d)
USE M_NETW
use gridoperations
IMPLICIT NONE
INTEGER :: NRL1D, NRL, NRLO, L, JONCE, K, K1, K2, K3, IBR, N, JASTOP, JASTART, IERR, IBX, KS, KK, KE, ja, JA1, JA2
INTEGER :: NRL1D6, KN316, NRL1D16, NUM0, J
call setnodadm(0)
IF (ALLOCATED(NMK0) ) DEALLOCATE(NMK0) ; ALLOCATE(NMK0(NUMK)) ; NMK0 = 0
LC = 0 ; NRL1D = 0 ; NRL1D6 = 0
DO L = 1,NUML
IF (KN(3,L) == 1 .or. KN(3,L) == 6) THEN
K1 = KN(1,L) ; K2 = KN(2,L) ; K3 = KN(3,L)
NMK0(K1) = NMK0(K1) + 1
NMK0(K2) = NMK0(K2) + 1
IF (KN(3,L) == 1) THEN
NRL1D = NRL1D + 1 ! count 1D links
ELSE IF (KN(3,L) == 6) THEN
NRL1D6 = NRL1D6 + 1
ENDIF
ELSE
LC(L) = -1
ENDIF
ENDDO
if (NRL1D + NRL1D6 == 0) then
netstat = NETSTAT_OK ; return
endif
IF (ALLOCATED(IBN)) DEALLOCATE(IBN,LIB,K1BR,NRLB)
ALLOCATE (IBN(NUML), LIB(NUML), K1BR(NUML), NRLB(NUML) ) ; IBN = 0; LIB = 0; K1BR = 0; NRLB = 0
IBR = 0; NRL = 0
DO J = 1,2
IF (J == 1) THEN
KN316 = 6 ; NRL1D16 = NRL1D6
ELSE
KN316 = 1 ; NRL1D16 = NRL1D6 + NRL1D
ENDIF
DO WHILE (NRL < NRL1D16)
NRLO = NRL
DO L = 1,NUML
IF (LC(L) == 0) THEN
JASTART = 0
CALL GAANWESTARTEN(L,K1,KN316,JASTART)
IF (JASTART == 1) THEN
IBR = IBR + 1
CALL WALK1D(K1,IBR,NRL,JASTOP,KN316)
ENDIF
ENDIF
ENDDO
IF (NRL == NRLO) THEN ! REPAIR CODE, FILL IN ISOLATED BRANCHES
DO L = 1,NUML
IF ( LC(L) == 0 .AND. KN316 == KN(3,L) ) THEN
IBR = IBR + 1
LC(L) = IBR ; NRL = NRL + 1
LIB(NRL) = L ; K1BR(NRL) = KN(1,L) ; IBN(NRL) = IBR; NRLB(L) = NRL
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO
IBX = IBR ; MXNETBR = IBR
IF ( ALLOCATED(NETBR) ) DEALLOCATE(NETBR)
ALLOCATE ( NETBR(IBX) ,STAT=IERR)
CALL AERR('NETBR(IBX)',IERR,NUML)
IBR = 1
KS = 1
NRL1D = NRL1D16
DO K = 1,NRL1D
ja = 0
if ( k < NRL1D ) then
if ( IBR .NE. IBN(K+1) ) then
ja = 1
endif
else
ja = 1
endif
IF ( ja == 1 ) THEN
KE = K
N = KE - KS + 1
ALLOCATE ( NETBR(IBR)%LN(N) ,STAT=IERR )
CALL AERR('NETBR(IBR)%LN(N)',IERR, IBR)
NETBR(IBR)%NX = N
DO KK = KS, KE
L = LIB(KK)
K1 = K1BR(KK)
IF ( K1 == KN(1,L) ) THEN
NETBR(IBR)%LN(KK-KS+1) = L
ELSE IF (K1 == KN(2,L) ) THEN
NETBR(IBR)%LN(KK-KS+1) = -L
ELSE
CALL OKAY(0) ! PROGRAMMING NO GOOD
ENDIF
ENDDO
if ( k < NRL1D ) then
IBR = IBN(K+1)
KS = K + 1
ENDIF
ENDIF
ENDDO
netstat = NETSTAT_OK
END SUBROUTINE SETBRANCH_LC
SUBROUTINE CUTCELWU(n12, jamasks, ipoly)
use m_netw
use m_flowgeom
use kdtree2Factory
use m_missing, only : dmiss, jins
use m_cutcells
use unstruc_messages
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
use m_flow, only : numlimdt, numlimdt_baorg, baorgfracmin
implicit none
integer, intent(in) :: N12 ! 3: only mask nodes, 4: preparation for cut cells (set kfs), 5: actual cut cells (change wu, nd), 6: dry cells
integer, intent(in) :: jamasks ! do not use masks (0), store masks (1), use stored masks (2)
integer, intent(in) :: ipoly ! polygon number for masks
integer :: ja, KMOD
integer :: K, KM, K1, K2, K3, K4, L, LL, LNU,N,N1,N2,NN, LF, IC, LLU, IN, KL
INTEGER , ALLOCATABLE :: KNP(:)
INTEGER :: KK(4)
DOUBLE PRECISION :: XM, YM, XXC(8), YYC(8), DAREA, DLENGTH, DLENMX
double precision, dimension(:), allocatable :: xmL, ymL ! intersection coordinates
integer, dimension(:), allocatable :: Lmask ! link mask
double precision :: cx, cy, R2search, Area, cof0
integer :: i, ip1, num, k_start, k_end, numsam, ierror
integer :: jadelete
integer :: jakdtree
integer :: jasplitpol, numpolies, ip
type(tpoly), dimension(:), allocatable :: pli_loc
double precision, parameter :: dtol = 1d-8
jakdtree = 1
CALL READYY('CUTCELWU',0d0)
IN = -1
! write(6,"('cutcelwu:', I4)") 1
if ( jamasks.eq.0 .or. jamasks.eq.1 ) then
! generate mask "kc"
jasplitpol = 0
numpolies = 1
if ( NPL.gt.100 ) then
call mess(LEVEL_INFO, 'splitting polygons...')
call split_pol(2,2,100,100)
call mess(LEVEL_INFO, 'done')
jasplitpol = 1
call pol_to_tpoly(numpolies, pli_loc, keepExisting=.false.)
end if
if ( n12.ge.4 ) then ! n12=3: mask nodes
KC = 0
end if
do ip=1,numpolies
if ( jasplitpol.eq.1 ) then
NPL = 0
call tpoly_to_pol(pli_loc,iselect=ip)
in = -1
end if
if( jakdtree == 1 ) then
!
! gravity point of polygon
!
Area = 0d0
cx = 0d0
cy = 0d0
num = 0
do i = 1,NPL
ip1 = i+1; if ( ip1.gt.NPL ) ip1 = ip1-NPL
if( xpl(ip1) == DMISS ) cycle
cof0 = xpl(i) * ypl(ip1) - xpl(ip1) * ypl(i)
Area = Area + cof0
cx = cx + ( xpl(i) + xpl(ip1) ) * cof0
cy = cy + ( ypl(i) + ypl(ip1) ) * cof0
num = num + 1
enddo
area = area * 0.5d0
if ( area.eq.0d0 ) cycle
cx = cx / area / 6.0d0
cy = cy / area / 6.0d0
!
! find the circumcircle
!
R2search = 0d0
do i = 1,npl-1
R2search = max( R2search, dbdistance(xpl(i),ypl(i),cx,cy, jsferic, jasfer3D, dmiss)**2 )
enddo
! write(6,"('cutcelwu:', I4)") 2
call make_queryvector_kdtree( treeglob,cx, cy, jsferic)
numsam = kdtree2_r_count( treeglob%tree, treeglob%qv, R2search )
! write(6,"('cutcelwu:', I4)") 3
k_start = 1
k_end = numsam
if ( numsam.gt.0 ) then
call realloc_results_kdtree(treeglob,numsam)
call kdtree2_n_nearest(treeglob%tree,treeglob%qv,numsam,treeglob%results)
call tekpolygon()
! call qnerror(' ', ' ', ' ')
end if
! write(6,"('cutcelwu:', I4)") 4
do k = k_start,k_end ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
k1 = treeglob%results(k)%idx
if ( kc(k1).ne.1 ) then
CALL DBPINPOL( xk(k1), yk(k1), IN, dmiss, jins, NPL, xpl, ypl, zpl)
KC(K1) = IN
end if
enddo
! write(6,"('cutcelwu:', I4)") 5
!!!
else
DO K = 1,NUMK ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
CALL DBPINPOL( XK(K), YK(K), IN, dmiss, jins, NPL, xpl, ypl, zpl)
KC(K) = IN
ENDDO
endif
end do
if ( jasplitpol.eq.1 ) then
call restorepol()
call dealloc_tpoly(pli_loc)
end if
else
! use stored masks
kc = 0
do i = ik(ipoly),ik(ipoly+1)-1
kc(jk(i)) = 1
end do
end if
if ( n12.ge.4 ) then ! 4, 5, or 6
ALLOCATE (KNP (NUMP)); KNP = 0
DO N = 1,NUMP
NN = netcell(N)%N
! IF ( NN == 4 ) THEN
DO K = 1,NN
K1 = NETCELL(N)%NOD(K)
IF (KC(K1) == 1) THEN
KNP(N) = 1
ENDIF
ENDDO
! ENDIF
ENDDO
KMOD = MAX(1,NUMP/100)
! write(6,"('cutcelwu:', I4)") 6
! if ( jakdtree_cross.eq.1 ) then
! call find_intersecting_polysections()
! end if
! write(6,"('cutcelwu:', I4)") 7
num = 0 !< number of netlink-polygon intersections
if ( jamasks.eq.1 ) then
allocate(Lmask(numL))
Lmask = 0
allocate(xmL(numL))
allocate(ymL(numL))
end if
DO N = 1,NUMP
if (mod(n,KMOD) == 0) CALL READYY('CUTCELWU', dble(n)/dble(nump))
IF ( KNP(N) == 1 ) THEN ! AT LEAST 1 POINT INSIDE POLYGON, SO CHECK CUTC
NN = netcell(N)%N
IC = 0
DO LL = 1,NN
L = netcell(N)%LIN(LL)
!IF (LNN (L) <= 1) THEN
! CYCLE
!ELSE
! IF (N12 == 5) LF = LNE2LN(L)
!ENDIF
if ( n12.ne.6 ) then ! 6: netgeom only
! SPvdP: cell next to net boundary may be cut, and not necessarily at the boundary. So need to include boundary link too
Lf = lne2ln(L)
else
jadelete = 0
end if
LLU = LL + 1 ; IF (LLU> NN) LLU = 1
K1 = NETCELL(N)%NOD(LL)
K2 = NETCELL(N)%NOD(LLU)
if ( jamasks.eq.0 .or. jamasks.eq.1 ) then
if ( kc(kn(1,L)).eq.1 .or. kc(kn(2,L)).eq.1 ) then
CALL CROSSLINKPOLY(L,0,0,(/0/),(/0/),XM,YM,JA)
else
ja = 0
end if
! if ( kc(kn(1,L)).ne.kc(kn(2,L)) .and. ja.eq.0 ) then
! call qnerror('cutcelwu: error', ' ', ' ')
! end if
else
! use stored intersections
ja = 0
do i=idxL(L),idxL(L+1)-1
if ( pdxL(i).eq.ipoly ) then
ja = 1
xm = xdxL(i)
ym = ydxL(i)
exit
end if
end do
end if
IF ( JA == 1 ) THEN
if ( jamasks.eq.1 ) then
! store intersections with polygon
Lmask(L) = 1
xmL(L) = xm
ymL(L) = ym
end if
IF (N12 == 5) THEN ! OP DEZE MANIER UITSTEL AANPASSING TOT NA DE WEGINGEN VAN LINK CENTER/CORNER WEIGHTS
IF (KC(K1) == 1 .and. kc(k2).ne.1 ) THEN ! 1 OUTSIDE
IC = IC + 1 ; XXC(IC) = XM ; YYC(IC) = YM
IC = IC + 1 ; XXC(IC) = XK(K2) ; YYC(IC) = YK(K2)
if ( Lf.gt.0) then
if (wu(LF) .ne. 0d0) WU( LF ) = DBDISTANCE(XM,YM,XK(K2),YK(K2), jsferic, jasfer3D, dmiss)
endif
ELSE if ( kc(k1).ne.1 .and. kc(k2).eq.1 ) then
IF (IC == 0) THEN
IC = IC + 1 ; XXC(IC) = XK(K1) ; YYC(IC) = YK(K1)
ENDIF
IC = IC + 1 ; XXC(IC) = XM ; YYC(IC) = YM
if ( Lf.gt.0 ) then
if (wu(LF) .ne. 0d0) WU( LF ) = DBDISTANCE(XM,YM,XK(K1),YK(K1), jsferic, jasfer3D, dmiss)
endif
else if ( kc(k1).eq.1 .and. kc(k2).eq.1 .and. Lf.gt.0 ) then
wu(Lf) = 0d0
ENDIF
ELSE IF (N12 == 4) THEN
kfs(n) = 1 ! temporary cutcell flag, TO CHANGE LINKTOCENTER AND LINKTOCORNERSWEIGHTING FOR CUTCELLS
else if ( n12.eq.6 ) then
jadelete = 0
IF (KC(K1) == 1 .and. kc(k2).ne.1 ) THEN ! 1 OUTSIDE
if ( DBDISTANCE(XM,YM,XK(K2),YK(K2), jsferic, jasfer3D, dmiss).le.dtol ) then
jadelete = 1
end if
ELSE if ( kc(k1).ne.1 .and. kc(k2).eq.1 ) then
if ( DBDISTANCE(XM,YM,XK(K1),YK(K1), jsferic, jasfer3D, dmiss).le.dtol ) then
jadelete = 1
endif
else if ( kc(k1).eq.1 .and. kc(k2).eq.1 ) then
jadelete = 1
ENDIF
if ( jadelete.eq.1 ) then
lnn(L) = -iabs(lnn(L))
end if
ENDIF
ELSE
IF (KC(K1) == 0 .AND. KC(K2) == 0) THEN
IF (N12 == 5) THEN
IF (IC == 0) THEN
IC = IC + 1 ; XXC(IC) = XK(K1) ; YYC(IC) = YK(K1)
ENDIF
IC = IC + 1 ; XXC(IC) = XK(K2) ; YYC(IC) = YK(K2)
ENDIF
ELSE IF (N12 == 4) THEN
LNN(L) = 0
else if ( n12.eq.6 ) then
lnn(L) = -iabs(lnn(L))
ENDIF
ENDIF
ENDDO
IF (N12 == 5 .AND. IC > 0) THEN
CALL dAREAN( XXC, YYC, IC, DAREA, DLENGTH, DLENMX ) ! AREA AND LENGTH OF POLYGON
if (numlimdt(n) <= numlimdt_baorg) then
BA(N) = max( DAREA, Baorgfracmin*ba(n) )
endif
BA(N) = MAX(BA(N), BAMIN) ! ; BAI(N) = 1D0/BA(N) ! BAI ZIT IN ADVECTIEWEGING
if (ic > 2) then
DEALLOCATE( ND(N)%X , ND(N)%Y )
ALLOCATE ( ND(N)%X(IC), ND(N)%Y(IC))
ND(N)%X(1:IC) = XXC(1:IC)
ND(N)%Y(1:IC) = YYC(1:IC)
endif
ENDIF
IF (N12 == -5) THEN
IF (IC < 3) THEN
do KL = 1,nd(n)%lnx
L = iabs( nd(n)%ln(KL) ) ; wu(L) = 0d0
enddo
ba(n) = 0d0
ELSE
CALL dAREAN( XXC, YYC, IC, DAREA, DLENGTH, DLENMX ) ! AREA AND LENGTH OF POLYGON
IF (DAREA/BA(n) < 0.05d0) then
do KL = 1,nd(n)%lnx
L = iabs( nd(n)%ln(KL) ) ; wu(L) = 0d0
enddo
ba(n) = 0d0
ELSE
BA(N) = MAX(DAREA,BAMIN) ! ; BAI(N) = 1D0/BA(N) ! BAI ZIT IN ADVECTIEWEGING
DEALLOCATE( ND(N)%X , ND(N)%Y )
ALLOCATE ( ND(N)%X(IC), ND(N)%Y(IC))
ND(N)%X(1:IC) = XXC(1:IC)
ND(N)%Y(1:IC) = YYC(1:IC)
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
end if
! write(6,"('cutcelwu:', I4)") 8
! if ( n12.eq.5 ) then
!! SPvdP: disable flow-links that are associated to disabled net-links
! do Lf=1,Lnx
! L = iabs(ln2lne(Lf))
! if ( L.gt.0 ) then
! if ( lnn(L).eq.0 ) then
! wu(Lf) = 0d0
! end if
! end if
! end do
! end if
if ( jamasks.eq.1 ) then
! store mask
call store_cutcellmasks(numk, kc, numL, Lmask, xmL, ymL)
end if
! write(6,"('cutcelwu:', I4)") 9
if ( allocated(knp) )DEALLOCATE(KNP)
if ( jamasks.eq.1 ) then
if ( allocated(Lmask) ) deallocate(Lmask)
if ( allocated(xmL) ) deallocate(xmL)
if ( allocated(ymL) ) deallocate(ymL)
end if
CALL READYY('CUTCELWU', -1d0)
END SUBROUTINE CUTCELwu
subroutine renumber_cutcellmasks(perm)
use network_data, only: numL
use m_cutcells
implicit none
integer, dimension(numL), intent(in) :: perm !< permuation array
integer, dimension(:), allocatable :: idxL_bak
double precision, dimension(:), allocatable :: xdxL_bak, ydxL_bak
integer, dimension(:), allocatable :: pdxL_bak
integer :: i, ii, L, LL, num
if ( jastored.ne.1 ) then
return ! nothing to do
end if
! allocate
allocate(idxL_bak(numL+1))
num = idxL(numL+1)-1
allocate(xdxL_bak(num))
allocate(ydxL_bak(num))
allocate(pdxL_bak(num))
! copy
do L=1,numL+1
idxL_bak(L) = idxL(L)
end do
do i=1,num
xdxL_bak(i) = xdxL(i)
ydxL_bak(i) = ydxL(i)
pdxL_bak(i) = pdxL(i)
end do
! apply permutation
idxL_bak(1) = 1
do LL=1,numL
L = perm(LL)
num = idxL_bak(L+1)-idxL_bak(L)
idxL(LL+1) = idxL(LL) + num
ii = idxL_bak(L)
do i=idxL(LL),idxL(LL+1)-1
xdxL(i) = xdxL_bak(ii)
ydxL(i) = ydxL_bak(ii)
pdxL(i) = pdxL_bak(ii)
ii = ii+1
end do
end do
! deallocate
if ( allocated(idxL_bak) ) deallocate(idxL_bak)
if ( allocated(xdxL_bak) ) deallocate(xdxL_bak)
if ( allocated(ydxL_bak) ) deallocate(ydxL_bak)
if ( allocated(pdxL_bak) ) deallocate(pdxL_bak)
return
end subroutine renumber_cutcellmasks
SUBROUTINE CUTCELWUx(n12)
use m_netw
USE M_FLOWGEOM
use m_missing, only: dmiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: N12
integer :: ja, KMOD
integer :: K, KM, K1, K2, K3, K4, L, LL, LNU,N,N1,N2,NN, LF, IC, LLU, IN
INTEGER , ALLOCATABLE :: KNP(:)
INTEGER :: KK(4)
DOUBLE PRECISION :: XM, YM, XXC(8), YYC(8), DAREA, DLENGTH, DLENMX
CALL READYY('CUTCELWU',0d0)
IN = -1
DO K = 1,NUMK ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
CALL DBPINPOL( XK(K), YK(K), IN, dmiss, jins, NPL, xpl, ypl, zpl)
KC(K) = IN
ENDDO
ALLOCATE (KNP (NUMP)); KNP = 0
DO N = 1,NUMP
NN = netcell(N)%N
IF ( NN == 4 ) THEN
DO K = 1,NN
K1 = NETCELL(N)%NOD(K)
IF (KC(K1) == 1) THEN
KNP(N) = 1
ENDIF
ENDDO
ENDIF
ENDDO
KMOD = MAX(1,NUMP/100)
DO N = 1,NUMP
if (mod(n,KMOD) == 0) CALL READYY('CUTCELWU', dble(n)/dble(nump))
IF ( KNP(N) == 1 ) THEN ! AT LEAST 1 POINT INSIDE POLYGON, SO CHECK CUTC
NN = netcell(N)%N
IC = 0
DO LL = 1,NN
L = netcell(N)%LIN(LL)
IF (LNN (L) <= 1) THEN
CYCLE
ELSE
IF (N12 == 5) LF = LNE2LN(L)
ENDIF
! SPvdP: cell next to net boundary may be cut, and not necessarily at the boundary. So need to include boundary link too
! Lf = lne2ln(L)
LLU = LL + 1 ; IF (LLU> NN) LLU = 1
K1 = NETCELL(N)%NOD(LL)
K2 = NETCELL(N)%NOD(LLU)
CALL CROSSLINKPOLY(L,0,0,(/0/),(/0/),XM,YM,JA)
IF ( JA == 1 ) THEN
IF (N12 == 5) THEN ! OP DEZE MANIER UITSTEL AANPASSING TOT NA DE WEGINGEN VAN LINK CENTER/CORNER WEIGHTS
IF (KC(K1) == 1) then ! .and. kc(k2).ne.1 ) THEN ! 1 OUTSIDE
IC = IC + 1 ; XXC(IC) = XM ; YYC(IC) = YM
IC = IC + 1 ; XXC(IC) = XK(K2) ; YYC(IC) = YK(K2)
WU( LF ) = DBDISTANCE(XM,YM,XK(K2),YK(K2), jsferic, jasfer3D, dmiss)
ELSE ! if ( kc(k1).ne.1 .and. kc(k2).eq.1 ) then
IF (IC == 0) THEN
IC = IC + 1 ; XXC(IC) = XK(K1) ; YYC(IC) = YK(K1)
ENDIF
IC = IC + 1 ; XXC(IC) = XM ; YYC(IC) = YM
WU( LF ) = DBDISTANCE(XM,YM,XK(K1),YK(K1), jsferic, jasfer3D, dmiss)
!else if ( kc(k1).eq.1 .and. kc(k2).eq.1 .and. Lf.gt.0 ) then
! wu(Lf) = 0d0
ENDIF
ELSE IF (N12 == 4) THEN
kfs(n) = 1 ! temporary cutcell flag, TO CHANGE LINKTOCENTER AND LINKTOCORNERSWEIGHTING FOR CUTCELLS
ENDIF
ELSE
IF (KC(K1) == 0 .AND. KC(K2) == 0) THEN
IF (N12 == 5) THEN
IF (IC == 0) THEN
IC = IC + 1 ; XXC(IC) = XK(K1) ; YYC(IC) = YK(K1)
ENDIF
IC = IC + 1 ; XXC(IC) = XK(K2) ; YYC(IC) = YK(K2)
ENDIF
ELSE IF (N12 == 4) THEN
LNN(L) = 0
ENDIF
ENDIF
ENDDO
IF (N12 == 5 .AND. IC > 0) THEN
CALL dAREAN( XXC, YYC, IC, DAREA, DLENGTH, DLENMX ) ! AREA AND LENGTH OF POLYGON
BA(N) = MAX(DAREA,BAMIN) ! ; BAI(N) = 1D0/BA(N) ! BAI ZIT IN ADVECTIEWEGING
DEALLOCATE( ND(N)%X , ND(N)%Y )
ALLOCATE ( ND(N)%X(IC), ND(N)%Y(IC))
ND(N)%X(1:IC) = XXC(1:IC)
ND(N)%Y(1:IC) = YYC(1:IC)
ENDIF
ENDIF
ENDDO
if ( n12.eq.51 ) then
! SPvdP: disable flow-links that are associated to disabled net-links
do Lf=1,Lnx
L = iabs(ln2lne(Lf))
if ( L.gt.0 ) then
if ( lnn(L).eq.0 ) then
wu(Lf) = 0d0
end if
end if
end do
end if
DEALLOCATE(KNP)
CALL READYY('CUTCELWU', -1d0)
END SUBROUTINE CUTCELwux
SUBROUTINE CUTCELLS(n12)
use m_netw
use gridoperations
implicit none
integer, intent(in) :: N12
integer :: ja, KMOD
integer :: K, KM, K1, K2, K3, K4, L, LL, LNU,N,N1,N2,NN, IN
INTEGER , ALLOCATABLE :: KNP(:), KNEW(:)
INTEGER :: KK(4)
DOUBLE PRECISION :: XM, YM
CALL READYY('CUTCELLS',0d0)
CALL FINDCELLS(0) ! ALL FACES INSIDE LANDBOUNDARY PIECE
ALLOCATE (KNP (NUMP)); KNP = 0
ALLOCATE (KNEW(NUML)); KNEW = 0
DO N = 1,NUMP
NN = netcell(N)%N
IF ( NN >= 4 ) THEN
K1 = NETCELL(N)%NOD(1)
KNP(N) = KC(K1)
DO K = 2,NN
K1 = NETCELL(N)%NOD(K)
KNP(N) = KNP(N)*KC(K1) ! COMPLETELY INSIDE = 1
ENDDO
ENDIF
ENDDO
KMOD = MAX(1,NUMP/100)
DO N = 1,NUMP
if (mod(n,KMOD) == 0) CALL READYY('CUTCELLS', dble(n)/dble(nump))
IF ( KNP(N) == 0 ) THEN ! AT LEAST 1 POINT OUTSIDE POLYGON
NN = netcell(N)%N
DO LL = 1,NN
L = netcell(N)%LIN(LL)
IF (KNEW(L) == 0) THEN
CALL CROSSLINKPOLY(L,0,0,(/0/),(/0/),XM,YM,JA)
IF ( JA == 1 ) THEN
CALL DSETNEWPOINT( XM, YM, KM )
KNEW(L) = KM
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
DO N = 1,NUMP
K = 0
NN = netcell(N)%N
DO LL = 1,NN
L = netcell(N)%LIN(LL)
K1 = KN(1,L) ; K2 = KN(2,L)
IF ( KNP(N) == 0 ) THEN ! SHOULD BE HANDLED
IF (KNEW(L) .NE. 0) THEN ! NIEUW PUNT KOPPELEN
IF (KNEW(L) > 0) THEN
IF (KC(K1) == 1) THEN
CALL NEWLINK( KNEW(L), K2, LNU)
ELSE
CALL NEWLINK( KNEW(L), K1, LNU)
ENDIF
KNEW(L) = -1*KNEW(L)
ENDIF
K = K + 1
KK(K) = IABS(KNEW(L))
ENDIF
ENDIF
ENDDO
IF (K >= 2) THEN
CALL NEWLINK(KK(1), KK(2), LNU)
ENDIF
IF (K >= 3) THEN
CALL NEWLINK(KK(2), KK(3), LNU)
ENDIF
IF (K >= 4) THEN
CALL NEWLINK(KK(3), KK(4), LNU)
ENDIF
ENDDO
IF (N12 .NE. 4) THEN
DO L = 1, NUML
K1 = KN(1,L) ; K2 = KN(2,L) ! NETPUNTEN DIE NIET IN NUMP VOORKWAMEN OOK MAAR GELIJK WEG
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
IF (KC(K1) == 1 .OR. KC(K2) == 1) THEN
KN(1,L) = 0 ; KN(2,L) = 0
ENDIF
ENDIF
ENDDO
ENDIF
DEALLOCATE(KNP,KNEW)
CALL SETNODADM(0)
CALL READYY('CUTCELLS', -1d0)
END SUBROUTINE CUTCELLS
SUBROUTINE CUTCELLSORG()
use m_netw
use m_missing, only: dmiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol
use gridoperations
implicit none
integer :: iabs
integer :: ja, KMOD
integer :: k
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: km
integer :: l
integer :: ll
integer :: lnu
integer :: n
integer :: n1
integer :: n2
integer :: nn
integer :: nr
INTEGER , ALLOCATABLE :: KNP(:), KNEW(:), LDIN(:), LD1(:), LD2(:)
INTEGER :: KK(4)
DOUBLE PRECISION :: XM, YM
IF (MXLAN == 0) RETURN
CALL READYY('CUTCELLS',0d0)
CALL SAVEPOL()
ALLOCATE(LDIN(MXLAN), LD1(1000), LD2(1000))
LDIN = 0 ; LD1 = 0 ; LD2 = 0
LDIN(1) = -1
DO K = 1,MXLAN
CALL DBPINPOL( XLAN(K), YLAN(K), LDIN(K), dmiss, jins, NPL, xpl, ypl, zpl ) ! ALL LDB POINTS INSIDE POLYGON
ENDDO
NR = 0; N1 = 0; N2 = 0
DO K = 1,MXLAN ! + 1 ! TODO [AvD] allocate met +1 en even doorlopen
IF (XLAN(K) .NE. -999D0 .AND. LDIN(K) == 1) THEN
IF (N1 == 0) N1 = K
N2 = K
IF (LDIN(K) == 1) JA = 1 ! SOME POINT OF LDB IS INSIDE POL,
ELSE IF (N1 .NE. 0) THEN ! THIS LDB SEGMENT WILL BE HANDLED
IF (JA == 1) THEN
NR = NR + 1; LD1(NR) = N1; LD2(NR) = N2
ENDIF
N1 = 0; N2 = 0
ENDIF
ENDDO
DO NN = 1,NR
N1 = LD1(NN) ; N2 = LD2(NN)
CALL COPYLDBPIECETOPOL(N1,N2)
CALL FINDCELLS(4) ! ALL FACES INSIDE LANDBOUNDARY PIECE
ALLOCATE (KNP (NUMP)); KNP = 0
ALLOCATE (KNEW(NUML)); KNEW = 0
DO N = 1,NUMP
IF ( netcell(N)%N == 4 ) THEN
K1 = netcell(N)%NOD(1)
K2 = netcell(N)%NOD(2)
K3 = netcell(N)%NOD(3)
K4 = netcell(N)%NOD(4)
KNP(N) = KC(K1)*KC(K2)*KC(K3)*KC(K4) ! COMPLETELY INSIDE = 1
ENDIF
ENDDO
KMOD = MAX(1,NUMP/100)
DO N = 1,NUMP
if (mod(n,KMOD) == 0) CALL READYY('CUTCELLS', dble(n)/dble(nump))
IF ( KNP(N) == 0 ) THEN ! AT LEAST 1 POINT OUTSIDE POLYGON
DO LL = 1,4
L = netcell(N)%LIN(LL)
IF (KNEW(L) == 0) THEN
CALL CROSSLINKPOLY(L,0,0,(/0/),(/0/),XM,YM,JA)
IF ( JA == 1 ) THEN
CALL DSETNEWPOINT( XM, YM, KM )
KNEW(L) = KM
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
DO N = 1,NUMP
K = 0
DO LL = 1,4
L = netcell(N)%LIN(LL)
K1 = KN(1,L) ; K2 = KN(2,L)
IF ( KNP(N) == 0 ) THEN ! SHOULD BE HANDLED
IF (KNEW(L) .NE. 0) THEN ! NIEUW PUNT KOPPELEN
IF (KNEW(L) > 0) THEN
IF (KC(K1) == 1) THEN
CALL NEWLINK( KNEW(L), K2, LNU)
ELSE
CALL NEWLINK( KNEW(L), K1, LNU)
ENDIF
KNEW(L) = -1*KNEW(L)
ENDIF
K = K + 1 ; KK(K) = IABS(KNEW(L))
ENDIF
ENDIF
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
IF (KC(K1) == 1 .OR. KC(K2) == 1) THEN
KN(1,L) = 0 ; KN(2,L) = 0
ENDIF
ENDIF
ENDDO
IF (K >= 2) THEN
CALL NEWLINK(KK(1), KK(2), LNU)
ENDIF
IF (K >= 3) THEN
CALL NEWLINK(KK(2), KK(3), LNU)
ENDIF
IF (K >= 4) THEN
CALL NEWLINK(KK(3), KK(4), LNU)
ENDIF
ENDDO
CALL SETNODADM(0)
DEALLOCATE(KNP,KNEW)
ENDDO
DEALLOCATE ( LDIN, LD1, LD2 )
CALL RESTOREPOL()
CALL SETNODADM(0)
CALL READYY('CUTCELLS', -1d0)
END SUBROUTINE CUTCELLSORG
!> Finds the crossing of link L with the current polyline.
!! returns first crossing, if found, JA=1
SUBROUTINE CROSSLINKPOLY(L,num,ipoly,jdxL,pdxL,XM,YM,JA)
use m_missing, only: dmiss
use m_netw
use kdtree2Factory
use m_sferic, only: jsferic, jasfer3D
use unstruc_messages
use geometry_module, only: dbdistance, crossinbox
implicit none
integer :: L, JA
DOUBLE PRECISION :: XM, YM
integer, intent(in) :: num !< number of polygon sections that intersect netlink L
integer, intent(in) :: ipoly !< polygon identifier
integer, dimension(num), intent(in) :: jdxL !< polygon sections that intersect netlink L
integer, dimension(num), intent(in) :: pdxL !< polygon numbers that intersect netlink L
integer :: jacros
integer :: k, k_, kend
integer :: k1
integer :: k2
integer :: ku
DOUBLE PRECISION :: XP1, YP1, XP2, YP2, SL, SM, XCR, YCR, CRP, dis, xcr1, ycr1
double precision, parameter :: dtol = 1d-8
integer :: i
integer :: janew
integer :: numcrossed
integer, parameter :: MAXCROSS = 100
double precision, dimension(MAXCROSS) :: xcross, ycross
K1 = KN(1,L); K2 = KN(2,L)
! initialization
xm = 0d0
ym = 0d0
JA = 0
numcrossed = 0
if ( num.eq.0 ) then
kend = NPL
else
kend = num
end if
DO K_= 1,kend
if ( num.eq.0 ) then
k = k_
else
if ( pdxL(k_).ne.ipoly ) cycle
k = jdxL(k_)
end if
KU = K + 1
IF (K == NPL) KU = 1
XP1 = XPL(K ) ; YP1 = YPL(K )
XP2 = XPL(KU) ; YP2 = YPL(KU)
! Formerly:
! CALL DCROSS (XP1, YP1, XP2, YP2, XK(K1), YK(K1), XK(K2), YK(K2), JACROS, SL, SM, XM, YM, CRP)
! IF (JACROS == 1) THEN
! IF (SL > 0D0 .AND. SL < 1D0 .AND. SM > 0D0 .AND. SM < 1D0) THEN
! JA = 1
! EXIT
! ENDIF
! ENDIF
! New and equivalent (apart from '<' vs. '.le.'):
!CALL CROSSinbox (XP1, YP1, XP2, YP2, XK(K1), YK(K1), XK(K2), YK(K2), jacros, SL, SM, XCR, YCR, CRP)
CALL CROSSinbox (XK(K1), YK(K1), XK(K2), YK(K2), XP1, YP1, XP2, YP2, jacros, SL, SM, XCR, YCR, CRP, jsferic, dmiss)
! fix for spherical coordinates (enforce same reference point for local projections)
if ( jsferic.eq.1 .and. SM.gt.0.75d0 .and. jacros.eq.1 ) then
CALL CROSSinbox (XK(K1), YK(K1), XK(K2), YK(K2), XP2, YP2, XP1, YP1, jacros, SL, SM, XCR, YCR, CRP, jsferic, dmiss)
end if
if (jacros == 1) then
!IF (SL > 0D0 .AND. SL < 1D0 .AND. SM > 0D0 .AND. SM < 1D0) THEN
! JA = 1
! XM = XCR
! YM = YCR
! EXIT
!ENDIF
! check if this cross is different from previous
janew = 1
do i=1,numcrossed
dis = dbdistance(xcr,ycr,xcross(i),ycross(i), jsferic, jasfer3D, dmiss)
if ( dis.le.dtol ) then
janew = 0
exit
end if
end do
if ( janew.eq.1 ) then
numcrossed = numcrossed+1
if ( numcrossed.gt.MAXCROSS ) then
write (msgbuf, '(a,i0,i0)') 'crosslinkpoly: numcrossed>MAXCROSS', numcrossed, MAXCROSS
call qnerror(trim(msgbuf), ' ', ' ')
end if
xcross(numcrossed) = xcr
ycross(numcrossed) = ycr
end if
end if
ENDDO
if ( mod(numcrossed,2).eq.0 ) then
! even number of intersections: no intersection
ja = 0
else
! odd number of intersections: take one (average)
ja = 1
xm = 0d0
ym = 0d0
xm = xcross(1)
ym = ycross(1)
end if
END SUBROUTINE CROSSLINKPOLY
subroutine crosspoly(xa,ya,xb,yb,xpl,ypl,npl,XM,YM,CRPM,JA,isec, distanceStartPolygon)
use m_missing
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: crossinbox, dbdistance
implicit none
integer :: npl, ja
integer, intent(out) :: isec !< crossed polyline section (>0) or not crossed (0)
!locals
double precision :: xa, xb, ya, yb, xm, ym, crpm
double precision :: xpl(npl), ypl(npl)
double precision, intent(inout) :: distanceStartPolygon !< distance from the start point of the polygon
integer :: jacros
integer :: k
integer :: k1
integer :: k2
integer :: ku
double precision :: XP1, YP1, XP2, YP2, sl, sm, XCR, YCR, CRP, currentSegmentLength
isec = 0
JA = 0
distanceStartPolygon = 0.0d0
DO K = 1,NPL - 1
KU = K + 1
XP1 = XPL(K ) ; YP1 = YPL(K )
XP2 = XPL(KU) ; YP2 = YPL(KU)
currentSegmentLength = dbdistance(xp1,yp1,xp2,yp2, jsferic, jasfer3D, dmiss)
if ( xp1.eq.DMISS .or. yp1.eq.DMISS .or. xp2.eq.DMISS .or. yp2.eq.DMISS ) cycle ! SPvdP: added
CALL CROSSinbox (XP1, YP1, XP2, YP2, Xa, Ya, Xb, Yb, jacros, sl, sm, XCR, YCR, CRP, jsferic, dmiss)
if (jacros == 1) then
JA = JA+1
XM = XCR
YM = YCR
crpm = crp
isec = k
distanceStartPolygon = distanceStartPolygon + currentSegmentLength * sl
return ! SPvdP: added
end if
distanceStartPolygon = distanceStartPolygon + currentSegmentLength
end do
end subroutine crosspoly
SUBROUTINE REFINELINES()
use m_netw
USE M_GRIDSETTINGS
use m_missing, only: dmiss, jins
use geometry_module, only: pinpok
implicit none
integer :: INL
integer :: k1
integer :: k2
integer :: l
integer :: lnu
double precision :: a0, r0, XX, YY, ZZ
IF (MFAC .LE. 1) RETURN
DO L = 1,NUML
K1 = KN(1,L)
K2 = KN(2,L)
XX = 0.5D0*( XK(K1) + XK(K2) )
YY = 0.5D0*( YK(K1) + YK(K2) )
ZZ = 0.5D0*( ZK(K1) + ZK(K2) )
CALL PINPOK( XX, YY, NPL, XPL, YPL, INL, jins, dmiss)
IF (INL .EQ. 1) THEN
CALL DELELEM(K1,K2,LNU)
CALL CONNECT(K1,K2,mFAC,A0, R0)
ENDIF
ENDDO
RETURN
END SUBROUTINE REFINELINES
SUBROUTINE REFINECELLSONLY()
use m_netw
USE M_POLYGON
use gridoperations
implicit none
integer :: ja
integer :: k
integer :: k1
integer :: kp
integer :: lnu
integer :: n
integer :: nn
DOUBLE PRECISION :: XL, YL, ZL = 0D0
CALL FINDCELLS(0)
DO N = 1,NUMP
CALL ALLIN(N,JA)
IF (JA == 0) CYCLE
CALL GETAVCOR (N,XL,YL,ZL)
CALL dSETNEWPOINT(XL,YL,KP)
NN = netcell(N)%N
DO K = 1,NN
K1 = netcell(N)%NOD(K)
CALL CONNECTDB(KP,K1,LNU)
ENDDO
ENDDO
CALL SETNODADM(0)
END SUBROUTINE REFINECELLSONLY
SUBROUTINE REFINECELLSANDFACES()
use m_netw
USE m_polygon
USE M_SAMPLES
USE M_FLOWTIMES
USE m_physcoef
USE m_missing
USE m_ec_interpolationsettings
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use m_ec_basic_interpolation, only: triinterp2, bilin_interp, averaging2
use m_flowexternalforcings, only: transformcoef
use gridoperations
implicit none
INTEGER :: IERR, JA, KM, K1, K2, K, KP, L, L1, L2, LNU, N, NN, NR, KA, KB, JADOEN, N3, KK, JA2
INTEGER :: JACOURANTNETWORK, JDLA, N1, N2, K2A, K2B, KKP, KKN, N6
integer :: ic1, ic2, numL_old, kkm1, kkp1, kkm2, kkp2, Lm2, Lp2, numtris, num, iter, MAXITER
DOUBLE PRECISION :: XL, YL, ZL, CELLSIZE, COURANT, CELLAREA, C, DIS, XN,YN, RS
INTEGER, ALLOCATABLE :: KPL(:,:), KP2(:), NA(:)
DOUBLE PRECISION, ALLOCATABLE :: XC(:), YC(:), ZC(:), AR(:)
DOUBLE PRECISION, ALLOCATABLE :: XX(:,:), YY(:,:)
INTEGER , ALLOCATABLE :: NNN (:)
CALL SAVENET()
JACOURANTNETWORK = 1
ZL = ZKUNI
JDLA = 1
10 JADOEN = 0
CALL FINDCELLS(0)
numL_old = numL
IF (NS < 3 ) THEN
JACOURANTNETWORK = 0
ENDIF
ALLOCATE ( XC(NUMP) , STAT = IERR)
CALL AERR('XC(NUMP)', IERR, NUMP )
ALLOCATE ( YC(NUMP) , STAT = IERR)
CALL AERR('YC(NUMP)', IERR, NUMP )
ALLOCATE ( AR(NUMP) , STAT = IERR)
CALL AERR('AR(NUMP)', IERR, NUMP )
AR = DMISS
DO N = 1,NUMP
CALL getcellsurface ( N, AR(N), XC(N), YC(N) )
ENDDO
ALLOCATE( ZC(NUMP) , STAT = IERR)
CALL AERR('ZC(NUMP)', IERR, NUMP )
ZC = DMISS
! First interpolate bottom level in netcell-based zc, then use zc as cellmask
IF (JACOURANTNETWORK == 1) THEN
ALLOCATE ( NA(NUMP) , STAT = IERR)
CALL AERR('NA(NUMP)', IERR, NUMP )
NA = 0
if (interpolationtype == INTP_INTP) then
if ( MXSAM.gt.0 .and. MYSAM.gt.0 ) then
! bilinear interpolation of structured sample data
call bilin_interp(Numk, xc, yc, zc, dmiss, XS, YS, ZS, MXSAM, MYSAM, jsferic)
else
CALL triinterp2(XC,YC,ZC,NUMP,JDLA, &
XS, YS, ZS, NS, dmiss, jsferic, jins, jasfer3D, NPL, MXSAM, MYSAM, XPL, YPL, ZPL, transformcoef)
end if
else if (interpolationtype == INTP_AVG) then
n6 = 6
ALLOCATE( XX(N6,NUMP), YY(N6,NUMP), NNN(NUMP), STAT = IERR )
CALL AERR('XX(N6,NUMP), YY(N6,NUMP), NNN(NUMP)', IERR, (1+2*N6)*NUMP)
DO N = 1,NUMP
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,XC,YC,ZC,NUMP,XX,YY,N6,NNN,0,&
dmiss, jsferic, jasfer3D, JINS, NPL, xpl, ypl, zpl)
DEALLOCATE(XX,YY,NNN)
endif
DO N = 1,NUMP
! IF (ZC(N) .NE. DMISS .AND. NETCELL(N)%N == 4) THEN
IF (ZC(N) .NE. DMISS .AND. ( NETCELL(N)%N == 3 .or. NETCELL(N)%N == 4)) THEN
CELLSIZE = SQRT( AR(N) )
C = SQRT(AG*ABS(ZC(N)) )
COURANT = C*DT_MAX/CELLSIZE
IF (COURANT < 1D0 .AND. CELLSIZE > 2*SMALLESTSIZEINCOURANT) THEN
ZC(N) = COURANT
JADOEN = 1
ELSE
ZC(N) = DMISS
ENDIF
ELSE
ZC(N) = DMISS
ENDIF
ENDDO
DO K = 1,NUMITCOURANT
DO L = 1,NUML
IF (LNN(L) == 2) THEN
N1 = LNE(1,L) ; N2 = LNE(2,L)
IF (ZC(N1) .NE. DMISS) THEN ! .AND. ZC(N2) == DMISS) THEN
NA(N2) = NA(N2) + 1
ENDIF
IF (ZC(N2) .NE. DMISS) THEN ! .AND. ZC(N2) .NE. DMISS) THEN
NA(N1) = NA(N1) + 1
ENDIF
ENDIF
ENDDO
DO N = 1,NUMP
IF (NA(N) > 0) THEN ! 1) THEN
ZC(N) = 0.5 ! ANY VALUE < 1 TO FLAG CELL MUST BE SPLIT
ENDIF
ENDDO
ENDDO
else ! SPvdP: make cellmask based on nodemask
do n=1,nump
zc(n) = dmiss
CALL ALLIN(N,JA)
if ( ja.eq.1 ) zc(n) = 0.5d0
end do
ENDIF
ALLOCATE ( KPL(3,NUML) , STAT=IERR ) ; KPL = 0 ! PER LINK REF NAAR LINKER EN RECHTER CENTRAAL NIEUW CELPUNT, 3rd: original endpoint
CALL AERR('KPL(3,NUML)', IERR, 2*NUML )
ALLOCATE ( KP2( NUML) , STAT=IERR ) ; KP2 = 0 ! PER LINK REF NAAR BIJGEPLAATST MIDDEN LINK PUNT
CALL AERR('KP2( NUML)', IERR, NUML )
DO N = 1,NUMP
! CALL ALLIN(N,JA)
! IF (JA == 0) CYCLE
! IF (JACOURANTNETWORK == 1) THEN
IF (ZC(N) == DMISS) CYCLE
! ENDIF
NN = netcell(N)%N
if ( NN.ne.3 ) then ! SPvdP: create new center node for non-triangles only
CALL dSETNEWPOINT(XC(N), YC(N), KP) ! HET CENTRALE PUNT IN CEL
else
kp = netcell(N)%nod(1) ! use first point
end if
DO K = 1,NN
K1 = netcell(N)%NOD(K)
NR = NMK(K1)
L1 = netcell(N)%LIN(K)
ka = kn(1,L1) ; kb = kn(2,l1)
JA2 = 0
IF (NN == 3 .OR. NN == 4) THEN ! FOR ALL LINKS OF TRIANGLES AND QUADS
JA2 = 1
ELSE
call DLINEDIS2(XC(N),YC(N), XK(KA),YK(KA),XK(KB),YK(KB),JA,DIS,XN,YN,RS)
IF (RS > 0.3D0 .AND. RS < 0.7D0) THEN ! ZIT HET CENTRALE PUNT 'MIDDEN' TUSSEN EEN CELRAND DAN VERFIJN DIE RAND
JA2 = 1
ENDIF
ENDIF
IF (JA2 == 1) THEN
! IF (KPL(1,L1) == 0) THEN
! KPL(1,L1) = KP !; NCL(1,L1) = K
! ELSE
! KPL(2,L1) = KP !; NCL(2,L1) = K
! ENDIF
IF ( lne(1,L1).eq.n ) THEN
KPL(1,L1) = KP !; NCL(1,L1) = K
ELSE
KPL(2,L1) = KP !; NCL(2,L1) = K
ENDIF
ENDIF
ENDDO
ENDDO
DO L = 1,NUML
IF (KPL(1,L) .NE. 0 .or. KPL(2,L) .NE. 0) THEN
K1 = KN(1,L) ; K2 = KN(2,L)
XL = 0.5D0*( XK(K1) + XK(K2) )
YL = 0.5D0*( YK(K1) + YK(K2) )
CALL dSETNEWPOINT(XL,YL,KP); KP2(L) = KP ! PUNT OP LINK ZELF
KPL(3,L) = KN(2,L)
KN(2,L) = KP
CALL NEWLINK(KP, K2, LNU)
IF (KPL(1,L) .NE. 0) THEN
if ( netcell(lne(1,L))%N.ne.3 ) then ! SPvdP: no center point for triangles
CALL NEWLINK(KP, KPL(1,L), LNU)
end if
END IF
IF (KPL(2,L) .NE. 0) THEN
if ( netcell(lne(2,L))%N.ne.3 ) then ! SPvdP: no center point for triangles
CALL NEWLINK(KP, KPL(2,L), LNU)
end if
ENDIF
ENDIF
ENDDO
! SPvdP: check for triangles with two sides refined and refine the third
MAXITER = 1
do iter=1,MAXITER
numtris = 0
do n=1,nump
NN = netcell(n)%N
if ( NN.ne.3 ) cycle ! triangles only
num = 0
do kk=1,NN
L = netcell(n)%lin(kk)
if ( kp2(L).ne.0 ) then
num = num+1
if ( num.eq.1 ) L1 = L
end if
end do
if ( num.ne.1 ) cycle ! one unrefined side only
! refine the single unrefined side
if ( KPL(1,L1).eq.0 ) KPL(1,L1) = kn(1,L1)
if ( KPL(2,L1).eq.0 ) KPL(2,L1) = kn(1,L1)
K1 = KN(1,L1) ; K2 = KN(2,L1)
XL = 0.5D0*( XK(K1) + XK(K2) )
YL = 0.5D0*( YK(K1) + YK(K2) )
CALL dSETNEWPOINT(XL,YL,KP); KP2(L1) = KP ! PUNT OP LINK ZELF
KPL(3,L1) = KN(2,L1)
KN(2,L1) = KP
CALL NEWLINK(KP, K2, LNU)
end do
if ( numtris.eq.0 ) exit
end do
if ( numtris.ne.0 ) then
call qnerror('refinecellsandfaces: numtris.ne.0', ' ', ' ')
end if
! SPvdP: make links inside triangles
do n=1,nump
NN = netcell(n)%N
if ( NN.ne.3 ) cycle
do kk=1,3
k1 = kp2(netcell(n)%lin(kk))
k2 = kk+1; if ( k2.gt.NN ) k2=k2-NN
k2 = kp2(netcell(n)%lin(k2))
if ( k1.gt.0 .and. k2.gt.0 .and. k1.ne.k2 ) then
call newlink(k1,k2,Lnu)
end if
end do
end do
! SPvdP: connect new nodes with inactive part of the net
do L=1,numL_old
! check and see if this link neighbors a refined and an unrefined cell
if ( lnn(L).lt.2 ) cycle
ic1 = lne(1,L)
ic2 = lne(2,L)
if ( (zc(ic1).eq.DMISS .and. zc(ic2).eq.DMISS) .or. &
(zc(ic1).ne.DMISS .and. zc(ic2).ne.DMISS) ) cycle
! find the refined neighboring cell
if ( zc(ic1).eq.DMISS ) then
n = ic1
else
n = ic2
end if
NN = netcell(n)%N
! find link in the netcell administration
do kk=1,NN
if ( netcell(n)%lin(kk).eq.L ) exit
end do
if ( netcell(n)%lin(kk).ne.L ) cycle ! should never happen
kp = kp2(L)
if ( kp.ne.0 ) then
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+NN
L1 = netcell(n)%lin(kkm1) ! left-connected link
kkp1 = kk+1; if ( kkp1.gt.NN ) kkp1=kkp1-NN
L2 = netcell(n)%lin(kkp1) ! right-connected link
! nearest node on the left-connected link
kA = kp2(L1)
if ( kA.lt.1 ) then
! check if the next link has a refinement
kkm2 = kkm1-1; if ( kkm2.lt.1 ) kkm2=kkm2+NN
Lm2 = netcell(n)%lin(kkm2)
if ( kp2(Lm2).eq.0 ) then ! next link has no refinement
! note: original nodes of link L are: kn(1,L) and kpL(3,L)
if ( kn(1,L1).eq.kn(1,L) .or. kn(1,L1).eq.kpL(3,L) ) then
kA = kn(2,L1)
else
kA = kn(1,L1)
end if
else
kA = kp2(Lm2)
end if
end if
! nearest node on the right-connected link
kB = kp2(L2)
if ( kB.lt.1 ) then
! check if the next link has a refinement
kkp2 = kkp1+1; if ( kkp2.gt.NN ) kkp2=kkp2-NN
Lp2 = netcell(n)%lin(kkp2)
if ( kp2(Lp2).eq.0 ) then ! next link has no refinement
! note: original nodes of link L are: kn(1,L) and kpL(3,L)
if ( kn(1,L2).eq.kn(1,L) .or. kn(1,L2).eq.kpL(3,L) ) then
kB = kn(2,L2)
else
kB = kn(1,L2)
end if
else
kB = kp2(Lp2)
end if
end if
call newlink(kA,kp,Lnu)
call newlink(kp,kB,Lnu)
end if
end do
DEALLOCATE(XC,YC,AR,KPL,KP2)
IF (ALLOCATED(ZC)) THEN
DEALLOCATE(ZC)
ENDIF
if ( allocated(NA) ) deallocate(NA)
netstat = NETSTAT_CELLS_DIRTY
CALL SETNODADM (0)
IF (JACOURANTNETWORK == 1 .AND. JADOEN == 1 .AND. NUMK < 1E6) THEN ! NOT BEYOND 4*1 MILLION GRIDPOINTS
GOTO 10
ENDIF
END SUBROUTINE REFINECELLSANDFACES
!> original locate
SUBROUTINE LOCATE_ORG(XX,N,X,J)
INTEGER :: N, J
DOUBLE PRECISION :: XX(N), X
INTEGER :: JL, JU, JM
JL=0
JU=N+1
10 IF(JU-JL.GT.1)THEN
JM=(JU+JL)/2
IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN
JL=JM
ELSE
JU=JM
ENDIF
GO TO 10
ENDIF
J=JL
RETURN
END
SUBROUTINE MAKECOARSE2FINETRIANGLECONNECTIONCELLS()
use m_netw
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use m_missing, only : dxymis
use geometry_module, only: dcosphi
use gridoperations
implicit none
INTEGER :: N3(6), N4(4)
DOUBLE PRECISION :: ARN, XCN, YCN
INTEGER :: N, NN, K3, K, K0, NR, KA, KB, K1, K2, L1, L2, LNU, K01, KP, K7, KK3, K03, NN3, KK, L, K23
CALL FINDCELLS(0)
DO N = 1,NUMP
NN = netcell(N)%N
IF (NN == 5 .OR. NN ==6) THEN
K3 = 0 ; N3 = 0
DO K = 1,NN
K0 = netcell(N)%NOD(K)
NR = NMK(K0)
IF (NR == 3) THEN
KA = K + 1; IF (KA > NN) KA = KA - NN ; K1 = netcell(N)%NOD(KA) ! L2 L1 K0 K1 K2
KA = K + 2; IF (KA > NN) KA = KA - NN ; K2 = netcell(N)%NOD(KA)
KA = K - 1; IF (KA < 1 ) KA = KA + NN ; L1 = netcell(N)%NOD(KA)
KA = K - 2; IF (KA < 1 ) KA = KA + NN ; L2 = netcell(N)%NOD(KA)
IF ( ABS(dcosphi(XK(L2), YK(L2), XK(L1), YK(L1) , XK(L1), YK(L1), XK(K0), YK(K0), jsferic, jasfer3D, dxymis ) ) < 0.3 .AND. &
ABS(dcosphi(XK(K0), YK(K0), XK(K1), YK(K1) , XK(K1), YK(K1), XK(K2), YK(K2), jsferic, jasfer3D, dxymis ) ) < 0.3 ) THEN
IF ( ABS(dcosphi(XK(L1), YK(L1), XK(K0), YK(K0) , XK(K0), YK(K0), XK(K1), YK(K1), jsferic, jasfer3D, dxymis ) ) > 0.7 ) THEN
! PROBABLY THE SMALL SIDES AROUND THE CENTRAL POINT
K3 = K3 + 1
N3(K3) = K
ENDIF
ENDIF
ENDIF
ENDDO
IF (K3 == 3) THEN
K3 = 1D0* K3
ENDIF
IF (K3 == 1 .AND. NN == 5) THEN
K0 = netcell(N)%NOD(N3(K3))
KA = N3(K3) + 2 ; IF (KA > NN) KA = KA - NN ; K1 = netcell(N)%NOD(KA)
KB = N3(K3) - 2 ; IF (KB < 1) KB = KB + NN ; K2 = netcell(N)%NOD(KB)
CALL NEWLINK(K0, K1, LNU)
CALL NEWLINK(K0, K2, LNU)
ELSE IF (K3 == 2 .AND. NN == 6 ) THEN
K3 = 1
K0 = netcell(N)%NOD(N3(K3)) ; K01 = K0
KA = N3(K3) + 2 ; IF (KA > NN) KA = KA - NN ; K1 = netcell(N)%NOD(KA)
KB = N3(K3) - 2 ; IF (KB < 1) KB = KB + NN ; K2 = netcell(N)%NOD(KB)
CALL NEWLINK(K0, K1, LNU)
CALL NEWLINK(K0, K2, LNU)
K3 = 2
K0 = netcell(N)%NOD(N3(K3))
KA = N3(K3) + 2 ; IF (KA > 6) KA = KA - 6 ; K1 = netcell(N)%NOD(KA)
KB = N3(K3) - 2 ; IF (KB < 1) KB = KB + 6 ; K2 = netcell(N)%NOD(KB)
IF (K1 .NE. K01) CALL NEWLINK(K0, K1, LNU)
IF (K2 .NE. K01) CALL NEWLINK(K0, K2, LNU)
ELSE IF (K3 == -3 .AND. NN == 7 ) THEN ! NAAR CENTRAAL POINT MET VIJF LINKJES, TWEE VANUIT HOEKEN, DIRE VANUIT K3 = 3
CALL getcellsurface ( N, ARN, XCN, YCN) ! SORRY, 7 IS EILAND EN WORDT DUS SOWIESO NIET HERKEND, EVEN VERGETEN
CALL dSETNEWPOINT(XCN, YCN, KP)
DO K3 = 1,3
K0 = netcell(N)%NOD(N3(K3))
CALL NEWLINK(K0, KP, LNU)
ENDDO
DO K7 = 1,7
K = NETCELL(N)%NOD(K7)
KK3 = 0 ! VOOR PUNTEN DIE GEEN K3 ZIJN
DO K3 = 1,3
K03 = N3(K3)
KK3 = K03
ENDDO
IF (KK3 == 0) THEN
NN3 = 0
DO KK = 1, NMK(K)
L = NETCELL(N)%LIN(K7)
CALL OTHERNODE(K,L,K2)
DO K3 = 1,3
K23 = N3(K3)
IF (K23 == K2) THEN
NN3 = NN3 + 1
ENDIF
ENDDO
IF (NN3 .NE. 2) THEN
CALL NEWLINK(K0, KP, LNU)
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDIF
ENDDO
CALL SETNODADM(0)
END SUBROUTINE MAKECOARSE2FINETRIANGLECONNECTIONCELLS
SUBROUTINE REFINEQUADS()
use m_netw
USE M_AFMETING
use gridoperations
implicit none
integer :: jaddrand
integer :: k, KMOD
integer :: k1
integer :: k12
integer :: k2
integer :: k23
integer :: k3
integer :: k34
integer :: k4
integer :: k41
integer :: ki
integer :: kk
integer :: km
integer :: l
integer :: l12
integer :: l12o
integer :: l23
integer :: l23o
integer :: l34
integer :: l34o
integer :: l41
integer :: l41o
integer :: lfa
integer :: ll
integer :: ll2
integer :: lnu
integer :: n
integer :: nf
integer :: numkorg
DOUBLE PRECISION :: XM, YM, ZM
INTEGER , ALLOCATABLE :: KNP(:)
INTEGER KKI(5), LLI(5)
integer :: numk_old, jatolan ! for generating polygon
integer, allocatable, dimension(:) :: kc_old ! for generating polygon
LFA = 2
JADDRAND = 1
CALL INCREASENETW(4*NUMK,6*NUML)
NUMKORG = NUMK
numk_old = numk
CALL FINDCELLS(4); LC = 0
CALL READYY('Refine quads',0d0)
ALLOCATE (KNP(NUMP)); KNP = 0
DO N = 1,NUMP
IF ( netcell(N)%N == 4 ) THEN
K1 = netcell(N)%NOD(1)
K2 = netcell(N)%NOD(2)
K3 = netcell(N)%NOD(3)
K4 = netcell(N)%NOD(4)
KNP(N) = KC(K1)*KC(K2)*KC(K3)*KC(K4)
ENDIF
ENDDO
KMOD = MAX(1,NUMK/100)
DO N = 1,NUMP
if (mod(n,KMOD) == 0) CALL READYY('Refine quads', dble(n)/dble(nump))
IF ( KNP(N) == 1 ) THEN
K1 = netcell(N)%NOD(1)
K2 = netcell(N)%NOD(2)
K3 = netcell(N)%NOD(3)
K4 = netcell(N)%NOD(4)
L12 = netcell(N)%LIN(1) ; L12O = L12
L23 = netcell(N)%LIN(2) ; L23O = L23
L34 = netcell(N)%LIN(3) ; L34O = L34
L41 = netcell(N)%LIN(4) ; L41O = L41
K12 = 0
IF (KN(1,L12) .NE. 0 .AND. M13QUAD >= 0) THEN
CALL REFINELINK2(L12,K12) ; LC(L12O) = -K12 ; IF (LNN(L12O) == 2) KC(K12) = 3
ENDIF
K23 = 0
IF (KN(1,L23) .NE. 0 .AND. M13QUAD <= 0) THEN
CALL REFINELINK2(L23,K23) ; LC(L23O) = -K23 ; IF (LNN(L23O) == 2) KC(K23) = 3
ENDIF
K34 = 0
IF (KN(1,L34) .NE. 0 .AND. M13QUAD >= 0) THEN
CALL REFINELINK2(L34,K34) ; LC(L34O) = -K34 ; IF (LNN(L34O) == 2) KC(K34) = 3
ENDIF
K41 = 0
IF (KN(1,L41) .NE. 0 .AND. M13QUAD <= 0) THEN
CALL REFINELINK2(L41,K41) ; LC(L41O) = -K41 ; IF (LNN(L41O) == 2) KC(K41) = 3
ENDIF
IF (M13QUAD == 0) THEN
XM = 0.25D0*(XK(K1) + XK(K2) + XK(K3) + XK(K4) )
YM = 0.25D0*(YK(K1) + YK(K2) + YK(K3) + YK(K4) )
CALL DSETNEWPOINT(XM,YM,KM) ; KC(KM) = 2
ENDIF
IF (M13QUAD == 0 ) THEN
IF (K12 /= 0) THEN
CALL NEWLINK (KM ,K12, lnu)
ELSE IF (LC(L12) < 0 ) THEN
CALL NEWLINK (KM ,-LC(L12), lnu)
ENDIF
IF (K34 /= 0) THEN
CALL NEWLINK (KM ,K34,lnu)
ELSE IF (LC(L34) < 0 ) THEN
CALL NEWLINK (KM ,-LC(L34), lnu)
ENDIF
ELSE IF (M13QUAD > 0) THEN
IF (K12 == 0) K12 = -LC(L12)
IF (K34 == 0) K34 = -LC(L34)
CALL NEWLINK (K12 ,K34, lnu)
ENDIF
IF (M13QUAD == 0) THEN
IF (K23 /= 0) THEN
CALL NEWLINK (KM ,K23,lnu)
ELSE IF (LC(L23) < 0 ) THEN
CALL NEWLINK (KM ,-LC(L23), lnu)
ENDIF
IF (K41 /= 0) THEN
CALL NEWLINK (KM ,K41,lnu)
ELSE IF (LC(L41) < 0 ) THEN
CALL NEWLINK (KM ,-LC(L41), lnu)
ENDIF
ELSE IF (M13QUAD < 0) THEN
IF (K23 == 0) K23 = -LC(L23)
IF (K41 == 0) K41 = -LC(L41)
CALL NEWLINK (K23 ,K41, lnu)
ENDIF
ENDIF
ENDDO
KMOD = MAX(1,NUMP/100)
DO N = 1, NUMP
if (mod(n,KMOD) == 0) CALL READYY('Refine quads', dble(n)/dble(nump))
IF (KNP(N) == 0) THEN
NF = netcell(N)%N
IF (NF == 4) THEN
KI = 0
DO KK = 1,NF
K = netcell(N)%NOD (KK)
L = netcell(N)%LIN(KK)
IF (LC(L) < 0) THEN
KI = KI + 1; KKI(KI) = -LC(L); LL = KK
ENDIF
ENDDO
IF (KI == 1) THEN
K0 = KKI(1)
LL2 = LL + 2
IF (LL2 > 4) LL2 = LL2-4
LL2 = netcell(N)%LIN(LL2)
K1 = KN(1,LL2) ; K2 = KN(2,LL2)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
CALL NEWLINK(K0,K1,LNU) ! ; KC(K1) = 6
CALL NEWLINK(K0,K2,LNU) ! ; KC(K2) = 6
ENDIF
ELSE IF (KI == 2) THEN
CALL NEWLINK(KKI(1),KKI(2),LNU)
DO KK = 1, NF
K = netcell(N)%NOD (KK)
IF (KC(K) == 0) THEN
CALL NEWLINK(KKI(1),K,LNU) !; KC(KKI(1)) = 3
CALL NEWLINK(KKI(2),K,LNU) !; KC(KKI(2)) = 3
EXIT
ENDIF
ENDDO
ENDIF
ENDIF
ENDIF
ENDDO
CALL READYY('Refine quads',-1d0)
CALL SETNODADM(0)
DEALLOCATE(KNP)
jatolan = 1
call confrm('Copy refinement border to polygon?', jatolan)
if ( jatolan.eq.1 ) then
! store original node mask
allocate(kc_old(numk))
kc_old = min(kc,1) ! see admin_mask
! deative polygon
call savepol()
call delpol()
call findcells(100)
! reactivate polygon
call restorepol()
! mark cells crossed by polygon, by setting lnn of their links appropriately
kc_old(numk_old+1:numk) = 1
call mark_cells_crossed_by_poly(numk,kc_old)
call delpol()
call copynetboundstopol(0, 0, 0, 1)
deallocate(kc_old)
end if
RETURN
END SUBROUTINE REFINEQUADS
SUBROUTINE REFINELINK2(L12,K12)
use m_netw
implicit none
integer :: L12,K12
integer :: k1
integer :: k2
integer :: lnu
DOUBLE PRECISION :: XM, YM
K1 = KN(1,L12) ; KC(K1) = 5
K2 = KN(2,L12) ; KC(K2) = 5
KN(1,L12) = 0 ; KN(2,L12) = 0
XM = 0.5D0*(XK(K1) + XK(K2))
YM = 0.5D0*(YK(K1) + YK(K2))
CALL DSETNEWPOINT(XM,YM,K12)
CALL NEWLINK(K1 ,K12,lnu) ! fast version without refinement
CALL NEWLINK(K12,K2 ,lnu) ! fast version without refinement
END SUBROUTINE REFINELINK2
subroutine connectcurvilinearquadsDDtype()
use m_netw
use sorting_algorithms, only: indexx
use geometry_module, only: dbdistance, cross
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
integer :: ins
integer :: ip
integer :: ja
integer :: ja1
integer :: ja2
integer :: jab
integer :: k
integer :: k1
integer :: k1a
integer :: k1b
integer :: k1d
integer :: k1e
integer :: k1k
integer :: k2
integer :: k2a
integer :: k2b
integer :: k2d
integer :: k2e
integer :: k2k
integer :: k3
integer :: k4
integer :: km
integer :: km1
integer :: km1b
integer :: km2
integer :: km2b
integer :: km3
integer :: kmd
integer :: l
integer :: l1
integer :: l2
integer :: la
integer :: lb
integer :: ld
integer :: le
integer :: li
integer :: ll
integer :: lnu
integer :: m
integer :: mer
integer :: n
integer :: nlinks
integer :: np
integer :: npb
integer :: npd
integer :: npe
integer :: num
integer :: nx = 5, ny
integer, allocatable :: nnq(:), nadjq(:,:), L1adjq(:), LLadjq(:), L2adjq(:,:), merg(:,:), kins(:), kins2(:)
double precision :: r2, xm, ym, xkkn1, ykkn1
integer, allocatable :: nnp(:), nnl(:), nrl(:), nnl2(:,:), k1L(:), k2L(:)
double precision :: sL, sm, xcr, ycr, crp
integer :: i, jacross, k1dum
double precision, dimension(:), allocatable :: dist
integer, dimension(:), allocatable :: idx
integer, dimension(:), allocatable :: kdum
call findcells(0) ! find quads
ny = 4*nump
allocate ( nnq(ny), nadjq(nx,ny), L1adjq(ny), LLadjq(ny) , L2adjq(nx,ny) )
nnq = 0; nadjq = 0; L1adjq = 0; LLadjq = 0; L2adjq = 0
allocate ( merg(2,ny), kins(2*nx) ,kins2(2*nx))
merg = 0 ; kins = 0 ;kins2 = 0
allocate(dist(2*nx))
dist = 0d0
allocate(idx(2*nx))
idx = 0
allocate(kdum(2*nx))
idx = 0
n = 0
do L = 1,numl ! locally store potential link nrs and their face nrs, only those with four edges
if ( lnn(L) == 1 .and. lc(L) == 1 ) then
np = lne(1,L)
if (netcell(np)%n == 4) then
n = n + 1
endif
endif
enddo
ny = n
allocate ( nnp(ny), nnl(ny), nrl(ny), nnl2(nx,ny), k1L(ny), k2L(ny) )
nnp = 0; nnl = 0; nrl = 0; nnl2 = 0 ; k1L = 0; k2L = 0
n = 0
do L = 1,numl ! locally store potential link nrs and their face nrs, only those with four edges
if ( lnn(L) == 1 .and. lc(L) == 1 ) then
np = lne(1,L)
if (netcell(np)%n == 4) then
n = n + 1
nnp(n) = np ; nnl(n) = L
endif
endif
enddo
kc(1:numk) = 1
Lc(1:numk) = 1
nlinks = n
do L = 1, nlinks ! count nr of adjacent links per link and store adjacent links
L1 = nnl(L)
do LL = 1, nlinks
L2 = nnl(LL)
if (L .ne. LL) then
call islinkadjacenttolink( L1, L2, ja, k1k, k2k)
if (ja == 1) then
nrl(L) = nrl(L) + 1 ; nnl2(nrl(L),L) = LL ! nr of adj lnks adj lnk nrs
if (k1k > 0) k1L(L) = k1k ! merg nod 1 to nod k1k
if (k2k > 0) k2L(L) = k2k ! merg nod 2 to nod k2k
endif
endif
enddo
enddo
mer = 0
do L = 1, nlinks
if (nrl(L) >= 1) then
L1 = nnl(L); np = nnp(L)
k1 = kn( 1, L1 ) ; k2 = kn( 2, L1 )
xkkn1 = xk(k1)
ykkn1 = yk(k1)
kins = 0
ins = 0
do Li = 1,nrl(L)
LL = nnl2(Li,L)
L2 = nnl(LL)
k3 = kn(1,L2) ; k4 = kn(2, L2)
if (nrl(L) >= nrl(LL) ) then
km1 = k1L(L) ! k merge 1
if (km1 > 0) then
if (kc(k1) == 1) then
mer = mer + 1 ; merg(1,mer) = k1 ; merg(2,mer) = km1 ; kc(k1) = -1
endif
endif
km2 = k2L(L) ! k merge 2
if (km2 > 0) then
if (kc(k2) == 1) then
mer = mer + 1 ; merg(1,mer) = k2 ; merg(2,mer) = km2 ; kc(k2) = -1
endif
endif
if (nrl(L) > nrl(LL) ) then
if (kc(k3) == 1 .and. k3 .ne. km1 .and. k3 .ne. km2 ) then
ins = ins + 1 ; kins(ins) = k3 ; kc(k3) = 0
endif
if (kc(k4) == 1 .and. k4 .ne. km1 .and. k4 .ne. km2 ) then
ins = ins + 1 ; kins(ins) = k4 ; kc(k4) = 0
endif
endif
if (Lc(L1) == 1 .and. lc(L2) == 1) then
Lc(L1) = 0 ; kn(1,L1) = 0 ; kn(2,L1) = 0
endif
endif
enddo
if ( ins.gt.0 ) then
! SPvdP: first order kins
! compute distance from kn(1,L1) to kins
do i=1,ins
dist(i) = dbdistance(xkkn1,ykkn1,xk(kins(i)),yk(kins(i)), jsferic, jasfer3D, dmiss)
end do
! get permutation array
call indexx(ins,dist,idx)
! order on increasing distance
kdum = kins
do i=1,ins
kins(i) = kdum(idx(i))
end do
! get opposing netlink and nodes
call tegenovernodesandlink(np,L1,k1a,k2a,La)
! if lines kins(1)-k1a and kins(ins)-k2a cross: invert
call cross(xk(k1), yk(k1), xk(k1a), yk(k1a), xk(k2), yk(k2), xk(k2a), yk(k2a), jacross, sL, sm, xcr, ycr, crp, jsferic, dmiss)
if ( jacross.eq.1 ) then
k1dum = k1a
k1a = k2a
k2a = k1dum
end if
if (ins == 1) then ! 1-on-2 coupling:
call newlink(kins(1), k1a, lnu) ! two diagonals from inside point to opp. corners
call newlink(kins(1), k2a, lnu)
else if (ins == 2) then ! 1-on-3 coupling:
xm = 0.5d0*( xk(k1a) + xk(k2a) ) !
ym = 0.5d0*( yk(k1a) + yk(k2a) ) ! +-+---1---+
call dsetnewpoint(xm, ym, km) ! | | / | |
call newlink(kins(1), km , lnu) ! +-i | |
call newlink(kins(1), k1a, lnu) ! | | > m |
call newlink(kins(2), km , lnu) ! +-i | |
call newlink(kins(2), k2a, lnu) ! | | \ | |
! +-+---2---+
call newlink(km , k1a, lnu)
call newlink(km , k2a, lnu)
call nextcel(np,La,npb,k1b,k2b,Lb)
call dellink(La)
if (npb == 0 ) cycle
call newlink(km, k1b, lnu)
call newlink(km, k2b, lnu)
else if (ins == 3) then
xm = 0.5d0*( xk(k1a) + xk(k2a) )
ym = 0.5d0*( yk(k1a) + yk(k2a) )
call dsetnewpoint(xm, ym, km)
call newlink(kins(2), km, lnu)
call newlink(km, k2a, lnu)
call newlink(km, k1a, lnu)
call newlink(kins(1), km , lnu)
call newlink(kins(1), k1a, lnu)
call newlink(kins(3), km , lnu)
call newlink(kins(3), k2a, lnu)
call nextcel(np,La,npb,k1b,k2b,Lb)
call dellink(La)
if (npb == 0 ) cycle
call newlink(km, k1b, lnu)
call newlink(km, k2b, lnu)
else if (ins == 4) then
call nextcel(np ,La,npb,k1b,k2b,Lb)
call nextcel(npb,Lb,npd,k1d,k2d,Ld)
call nextcel(npd,LD,npe,k1e,k2e,Le)
! SPvdP: check and fix orientation if applicable
if ( k1b.gt.0 .and. k2b.gt.0 ) then
call cross(xk(k1a), yk(k1a), xk(k1b), yk(k1b), xk(k2a), yk(k2a), xk(k2b), yk(k2b), jacross, sL, sm, xcr, ycr, crp, jsferic, dmiss)
if ( jacross.eq.1 ) then
k1dum = k1b
k1b = k2b
k2b = k1dum
end if
if ( k1d.gt.0 .and. k2d.gt.0 ) then
call cross(xk(k1b), yk(k1b), xk(k1d), yk(k1d), xk(k2b), yk(k2b), xk(k2d), yk(k2d), jacross, sL, sm, xcr, ycr, crp, jsferic, dmiss)
if ( jacross.eq.1 ) then
k1dum = k1d
k1d = k2d
k2d = k1dum
end if
if ( k1e.gt.0 .and. k2e.gt.0 ) then
call cross(xk(k1d), yk(k1d), xk(k1e), yk(k1e), xk(k2d), yk(k2d), xk(k2e), yk(k2e), jacross, sL, sm, xcr, ycr, crp, jsferic, dmiss)
if ( jacross.eq.1 ) then
k1dum = k1e
k1e = k2e
k2e = k1dum
end if
end if
end if
end if
xm = 0.75d0*xk(k1a) + 0.25d0*xk(k2a)
ym = 0.75d0*yk(k1a) + 0.25d0*yk(k2a)
call dsetnewpoint(xm, ym, km1)
xm = 0.50d0*xk(k1a) + 0.50d0*xk(k2a)
ym = 0.50d0*yk(k1a) + 0.50d0*yk(k2a)
call dsetnewpoint(xm, ym, km2)
xm = 0.25d0*xk(k1a) + 0.75d0*xk(k2a)
ym = 0.25d0*yk(k1a) + 0.75d0*yk(k2a)
call dsetnewpoint(xm, ym, km3)
call newlink(kins(2), km2, lnu)
call newlink(kins(3), km2, lnu)
call newlink(kins(2), km1, lnu)
call newlink(kins(3), km3, lnu)
call newlink(kins(1), km1, lnu)
call newlink(kins(4), km3, lnu)
call newlink(k1a, km1, lnu)
call newlink(km1, km2, lnu)
call newlink(km2, km3, lnu)
call newlink(km3, k2a, lnu)
call dellink(La)
if (npb == 0) cycle
xm = 0.66d0*xk(k1b) + 0.34d0*xk(k2b)
ym = 0.66d0*yk(k1b) + 0.34d0*yk(k2b)
call dsetnewpoint(xm, ym, km1b)
xm = 0.34d0*xk(k1b) + 0.66d0*xk(k2b)
ym = 0.34d0*yk(k1b) + 0.66d0*yk(k2b)
call dsetnewpoint(xm, ym, km2b)
call newlink(km1 , km1b, lnu)
call newlink(km1b, km2 , lnu)
call newlink(km2 , km2b, lnu)
call newlink(km2b, km3 , lnu)
call newlink(k1b, km1b , lnu)
call newlink(km1b, km2b , lnu)
call newlink(km2b, k2b , lnu)
call dellink(Lb)
if (npd == 0) cycle
xm = 0.5d0*xk(k1d) + 0.5d0*xk(k2d)
ym = 0.5d0*yk(k1d) + 0.5d0*yk(k2d)
call dsetnewpoint(xm, ym, kmd)
call newlink(km1b, kmd,lnu)
call newlink(km2b, kmd, lnu)
call newlink(k1d, kmd, lnu)
call newlink(k2d, kmd, lnu)
call dellink(Ld)
if (npe == 0) cycle
call newlink(kmd, k2e, lnu)
call newlink(kmd, k1e, lnu)
endif
endif
endif
enddo
do m = 1,mer
k1 = merg(1,m) ; k2 = merg(2,m)
if (kc(k2) .ne. 0) then
call mergeUNCONNECTEDnodes(k1,k2,ja)
kc(k2) = 0
endif
enddo
call setnodadm(0)
kc(1:numk) = 1
goto 1234
return
mer = 0
do np = 1,nump
if (nnq(np) .ge. 1) then ! cell with neighbours
L1 = L1adjq(np)
K1 = kn(1,L1); K2 = kn(2,L1)
jab = 0
if ( lc (L1) == 1 ) then ! eigen link bestaat nog
kn(1,L1) = 0 ; kn(2,L1) = 0; jab = 1 ! direct link grote cel opheffen
endif
ins = 0 ! nr of 'inside' points of small cell (i.e. not cornering points)
ip = 1 ! in adjacent cell 1-3 and 2-4 instead of 1-4- and 2-3
do num = 1,nnq(np)
if (jab == 1) then
LC(L2adjq (num,np)) = -1 ! via -1 vlaggen dat de buren niet ook stuk hoeven
endif
L2 = L2adjq (num,np)
k3 = kn(1,L2) ; k4 = kn(2,L2)
if (k3 == 0 .or. k4 == 0) exit
r2 = DBDISTANCE( XK(K3),YK(K3),XK(K4),YK(K4), jsferic, jasfer3D, dmiss) ; r2 = 0.3d0*r2
if (kc(k3) > 0) then
call closeenough( XK(K3),YK(K3),XK(K1),YK(K1), r2, ja1 )
call closeenough( XK(K3),YK(K3),XK(K2),YK(K2), r2, ja2 )
if (ja1 == 1) then
mer = mer + 1 ; merg(1,mer) = k1 ; merg(2,mer) = k3 ; kc(k3) = -1
else if (ja2 == 1) then
mer = mer + 1 ; merg(1,mer) = k2 ; merg(2,mer) = k3 ; kc(k3) = -1 ; ip=-1
else
if (nnq(np) > 1) then
ins = ins + 1 ; kins(ins) = k3 ; kc(k3) = -k3
endif
endif
endif
if (kc(k4) > 0) then
call closeenough( XK(K4),YK(K4),XK(K1),YK(K1), r2, ja1 )
call closeenough( XK(K4),YK(K4),XK(K2),YK(K2), r2, ja2 )
if (ja1 == 1) then
mer = mer + 1 ; merg(1,mer) = k1 ; merg(2,mer) = k4 ; kc(k4) = -1 ; ip = -1
else if (ja2 == 1) then
mer = mer + 1 ; merg(1,mer) = k2 ; merg(2,mer) = k4 ; kc(k4) = -1
else
if (nnq(np) > 1) then
ins = ins + 1 ; kins(ins) = k4 ; kc(k4) = -k4
endif
endif
endif
enddo
if (ip < 1) then
kins2 = kins
do k = 1,ins
kins(k) = kins2(ins-k+1)
enddo
endif
if (ins >= 1) then ! connection of inside points to opposite face
call tegenovernodesandlink(np,L1,k1a,k2a,La)
if (ins == 1) then
call newlink(kins(1), k1a, lnu)
call newlink(kins(1), k2a, lnu)
else if (ins == 2) then
xm = 0.5d0*( xk(k1a) + xk(k2a) )
ym = 0.5d0*( yk(k1a) + yk(k2a) )
call dsetnewpoint(xm, ym, km)
call newlink(kins(1), km , lnu)
call newlink(kins(1), k1a, lnu)
call newlink(kins(2), km , lnu)
call newlink(kins(2), k2a, lnu)
call newlink(km , k1a, lnu)
call newlink(km , k2a, lnu)
call nextcel(np,La,npb,k1b,k2b,Lb)
call dellink(La)
if (npb == 0 ) exit
call newlink(km, k1b, lnu)
call newlink(km, k2b, lnu)
else if (ins == 3) then
xm = 0.5d0*( xk(k1a) + xk(k2a) )
ym = 0.5d0*( yk(k1a) + yk(k2a) )
call dsetnewpoint(xm, ym, km)
call newlink(kins(2), km, lnu)
call newlink(km, k2a, lnu)
call newlink(km, k1a, lnu)
call newlink(kins(1), km , lnu)
call newlink(kins(1), k1a, lnu)
call newlink(kins(3), km , lnu)
call newlink(kins(3), k2a, lnu)
call nextcel(np,La,npb,k1b,k2b,Lb)
call dellink(La)
if (npb == 0 ) exit
call newlink(km, k1b, lnu)
call newlink(km, k2b, lnu)
else if (ins == 4) then
call nextcel(np ,La,npb,k1b,k2b,Lb)
call nextcel(npb,Lb,npd,k1d,k2d,Ld)
call nextcel(npd,LD,npe,k1e,k2e,Le)
xm = 0.75d0*xk(k1a) + 0.25d0*xk(k2a)
ym = 0.75d0*yk(k1a) + 0.25d0*yk(k2a)
call dsetnewpoint(xm, ym, km1)
xm = 0.50d0*xk(k1a) + 0.50d0*xk(k2a)
ym = 0.50d0*yk(k1a) + 0.50d0*yk(k2a)
call dsetnewpoint(xm, ym, km2)
xm = 0.25d0*xk(k1a) + 0.75d0*xk(k2a)
ym = 0.25d0*yk(k1a) + 0.75d0*yk(k2a)
call dsetnewpoint(xm, ym, km3)
call newlink(kins(2), km2, lnu)
call newlink(kins(3), km2, lnu)
call newlink(kins(2), km1, lnu)
call newlink(kins(3), km3, lnu)
call newlink(kins(1), km1, lnu)
call newlink(kins(4), km3, lnu)
call newlink(k1a, km1, lnu)
call newlink(km1, km2, lnu)
call newlink(km2, km3, lnu)
call newlink(km3, k2a, lnu)
call dellink(La)
if (npb == 0) exit
xm = 0.66d0*xk(k1b) + 0.34d0*xk(k2b)
ym = 0.66d0*yk(k1b) + 0.34d0*yk(k2b)
call dsetnewpoint(xm, ym, km1b)
xm = 0.34d0*xk(k1b) + 0.66d0*xk(k2b)
ym = 0.34d0*yk(k1b) + 0.66d0*yk(k2b)
call dsetnewpoint(xm, ym, km2b)
call newlink(km1 , km1b, lnu)
call newlink(km1b, km2 , lnu)
call newlink(km2 , km2b, lnu)
call newlink(km2b, km3 , lnu)
call newlink(k1b, km1b , lnu)
call newlink(km1b, km2b , lnu)
call newlink(km2b, k2b , lnu)
call dellink(Lb)
if (npd == 0) exit
xm = 0.5d0*xk(k1d) + 0.5d0*xk(k2d)
ym = 0.5d0*yk(k1d) + 0.5d0*yk(k2d)
call dsetnewpoint(xm, ym, kmd)
call newlink(km1b, kmd,lnu)
call newlink(km2b, kmd, lnu)
call newlink(k1d, kmd, lnu)
call newlink(k2d, kmd, lnu)
call dellink(Ld)
if (npe == 0) exit
call newlink(kmd, k2e, lnu)
call newlink(kmd, k1e, lnu)
endif
endif
endif
enddo
do m = 1,mer
k1 = merg(1,m) ; k2 = merg(2,m)
if (kc(k2) .ne. 0) then
call mergeUNCONNECTEDnodes(k2,k1,ja)
endif
enddo
call setnodadm(0)
kc(1:numk) = 1
1234 continue
deallocate ( nnq, nadjq, L1adjq, LLadjq, L2adjq, merg, kins, kins2 )
deallocate(dist, idx, kdum)
end subroutine connectcurvilinearquadsDDtype
! call nextcel(np,La,npb,k1b,k2b,Lb)
subroutine nextcel(np,LL,npa,k1a,k2a,La) ! give face, link and nodes, opposite to plakrand LL of cel np
use m_netw
implicit none
integer :: LL,np,La,npa,k1a,k2a
La = 0 ; npa = 0 ; k1a = 0 ; k2a = 0
if (np == 0) return
if (lne(1,LL) == np) then ! find cell behind current np, eindplaat
npa = lne(2,LL)
else if (lne(2,LL) == np) then
npa = lne(1,LL)
endif
if (npa == 0) return
call tegenovernodesandlink(npa,LL,k1a,k2a,La)
end subroutine nextcel
subroutine tegenovernodesandlink(np,LL,k1a,k2a,La)
use m_netw
implicit none
integer :: np,LL,k1a,k2a,La
integer :: lk
integer :: n
integer :: na
do n = 1,netcell(np)%n
Lk = netcell(np)%lin(n)
if (Lk == LL) then
exit
endif
enddo
if (n == 1) then
na = 3
else if (n == 2) then
na = 4
else if (n == 3) then
na = 1
else if (n == 4) then
na = 2
endif
La = netcell(np)%lin(na)
k1a = kn(1, La)
k2a = kn(2, La)
end subroutine tegenovernodesandlink
subroutine closeenough ( x1,y1,x2,y2,r,ja)
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbdistance
implicit none
double precision :: x1,y1,x2,y2, r2, r
integer :: ja
ja = 0
r2 = dbdistance(x1,y1,x2,y2, jsferic, jasfer3D, dmiss)
if (r2 < r) then
ja = 1
endif
end subroutine
subroutine islinkadjacenttolink(L1,L2,ja,k1k,k2k)
use m_netw
use m_sferic, only : jsferic, jasfer3D
use m_missing, only : dxymis
use geometry_module, only: dcosphi
implicit none
integer :: L1,L2,ja,k1k,k2k
double precision :: x1,y1,x2,y2,x3,y3,x4,y4
double precision :: dp
x1 = xk(kn(1,L1)) ; y1 = yk(kn(1,L1))
x2 = xk(kn(2,L1)) ; y2 = yk(kn(2,L1))
x3 = xk(kn(1,L2)) ; y3 = yk(kn(1,L2))
x4 = xk(kn(2,L2)) ; y4 = yk(kn(2,L2))
call adjacent(x1,y1,x2,y2,x3,y3,x4,y4,ja,k1k,k2k)
! Links are close to eachother, now also check whether they're almost parallel
if (ja == 1) then
dp = dcosphi(x1,y1,x2,y2,x3,y3,x4,y4, jsferic, jasfer3D, dxymis)
if (abs(dp) > .9d0 .and. abs(dp) <= 1d0) then
ja = 1
if (k1k > 0) k1k = kn(k1k,L2)
if (k2k > 0) k2k = kn(k2k,L2)
else
ja = 0
end if
end if
end subroutine islinkadjacenttolink
subroutine isquadadjacenttoline(L1,n,L2)
use m_netw
implicit none
integer :: L1,n,L2
integer :: ja
integer :: l
integer :: ll
integer :: k1k, k2k
double precision :: x1,y1,x2,y2,x3,y3,x4,y4
L2 = 0
x1 = xk(kn(1,L1)) ; y1 = yk(kn(1,L1))
x2 = xk(kn(2,L1)) ; y2 = yk(kn(2,L1))
do ll = 1,4
L = netcell(n)%lin(LL)
x3 = xk(kn(1,L)) ; y3 = yk(kn(1,L))
x4 = xk(kn(2,L)) ; y4 = yk(kn(2,L))
call adjacent(x1,y1,x2,y2,x3,y3,x4,y4,ja,k1k,k2k)
if (ja == 1) then
L2 = L
return
endif
enddo
end subroutine isquadadjacenttoline
subroutine adjacent(x1,y1,x2,y2,x3,y3,x4,y4,ja,k1k,k2k)
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbdistance, dlinedis
implicit none
integer :: jac
double precision :: x1,y1,x2,y2,x3,y3,x4,y4
integer :: ja, k1k,k2k
double precision :: r1,r2,rm,xd,yd,xm,ym,dis1,dis2
integer :: ja1, ja2
k1k = 0
k2k = 0
ja = 0
if (x1 == x2 .and. y1 == y2 .or. &
x3 == x4 .and. y3 == y4) return
r1 = dbdistance(x1,y1,x2,y2, jsferic, jasfer3D, dmiss)
r2 = dbdistance(x3,y3,x4,y4, jsferic, jasfer3D, dmiss)
rm = 0.4d0*min(r1,r2)
if (r1 <= r2) then
xm = 0.5d0*(x1+x2) ; ym = 0.5d0*(y1+y2)
CALL DLINEDIS(Xm,Ym,X3,Y3,X4,Y4,JA1,DIS1,Xd,Yd, jsferic, jasfer3D, dmiss)
if (ja1 == 1 .and. dis1 < rm) then
ja = 1
endif
else
xm = 0.5d0*(x3+x4) ; ym = 0.5d0*(y3+y4)
CALL DLINEDIS(Xm,Ym,X1,Y1,X2,Y2,JA1,DIS1,Xd,Yd, jsferic, jasfer3D, dmiss)
if (ja1 == 1 .and. dis1 < rm) then
ja = 1
endif
endif
if (ja == 1) then
call closeenough ( x1,y1,x3,y3,rm,jac)
if (jac == 1) then
k1k = 1
else
call closeenough ( x1,y1,x4,y4,rm,jac)
if (jac == 1) then
k1k = 2
endif
endif
call closeenough ( x2,y2,x3,y3,rm,jac)
if (jac == 1) then
k2k = 1
else
call closeenough ( x2,y2,x4,y4,rm,jac)
if (jac == 1) then
k2k = 2
endif
endif
endif
end subroutine adjacent
SUBROUTINE polygontocurvilinear()
use m_netw
USE M_polygon
implicit none
integer :: ncorn(4)
! call givecornernrs(ncorn)
end subroutine polygontocurvilinear
SUBROUTINE quadsTOTRI()
use m_netw
use gridoperations
implicit none
double precision :: a
integer :: k0
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: l
integer :: l12
integer :: np
integer :: numtri
double precision :: r
DOUBLE PRECISION DLENGTH
CALL FINDcells(4) ! quads
L = NUMTRI
DO NP = 1,NUMP
K1 = netcell(NP)%NOD(1)
K2 = netcell(NP)%NOD(2)
K3 = netcell(NP)%NOD(3)
K4 = netcell(NP)%NOD(4)
CALL FINDEL(K1,K2,L12)
A = 0 ! EA(L12)
R = DLENGTH(K1,K2)
CALL CONNECT(K1,K3,1,A,R)
L = L + 1
K0 = 1 + (L-1)*3
KTRI(K0) = K1
KTRI(K0+1) = K2
KTRI(K0+2) = K3
L = L + 1
K0 = 1 + (L-1)*3
KTRI(K0) = K4
KTRI(K0+1) = K1
KTRI(K0+2) = K3
ENDDO
NUMTRI = K0+2
RETURN
END SUBROUTINE quadsTOTRI
SUBROUTINE GETMIDDLEKNOT(K1,K2,K12,A12,R12)
use m_netw
use gridoperations
implicit none
integer :: K1,K2,K12,K22
double precision :: A12, R12
integer :: l1
integer :: l2
integer :: n1
integer :: n2
DO N1 = 1,NMK(K1)
L1 = NOD(K1)%LIN(N1)
CALL OTHERNODE(K1,L1,K12)
DO N2 = 1,NMK(K2)
L2 = NOD(K2)%LIN(N2)
CALL OTHERNODE(K2,L2,K22)
IF (K12 .EQ. K22) THEN
A12 = 0 ! ( EA(L1) + EA(L2) ) /2
R12 = 0 ! ( RL(L1) + RL(L2) ) /2
RETURN
ENDIF
ENDDO
ENDDO
K12 = 0
RETURN
END SUBROUTINE GETMIDDLEKNOT
!> Finds the net link number between two net nodes.
SUBROUTINE FINDEL(K1,K2,L1)
use m_netw
implicit none
integer, intent(in ) :: K1, K2 !< The two net node numbers between which a net link is searched for.
integer, intent( out) :: L1 !< The shared netlink between nodes k1 and k2, or 0 when not found.
integer :: l2
integer :: n1
integer :: n2
DO N1 = 1,NMK(K1)
L1 = NOD(K1)%LIN(N1)
DO N2 = 1,NMK(K2)
L2 = NOD(K2)%LIN(N2)
IF (L1 .EQ. L2) RETURN
ENDDO
ENDDO
L1 = 0
RETURN
END SUBROUTINE FINDEL
SUBROUTINE ALREADYTRI(K1,K2,K3,JA)
use m_netw
implicit none
integer :: K1,K2,K3,JA
integer :: n1
integer :: n2
integer :: n3
integer :: np
JA = 0
DO NP = NUMP, 1, -1
IF (netcell(NP)%N .EQ. 3) THEN
N1 = netcell(NP)%NOD(1)
N2 = netcell(NP)%NOD(2)
N3 = netcell(NP)%NOD(3)
IF ((K1.EQ.N1 .OR. K1.EQ.N2 .OR. K1.EQ.N3 ) .AND. &
(K2.EQ.N1 .OR. K2.EQ.N2 .OR. K2.EQ.N3 ) .AND. &
(K3.EQ.N1 .OR. K3.EQ.N2 .OR. K3.EQ.N3 ) ) THEN
JA = np
call qnerror('already 3', ' ',' ')
RETURN
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE ALREADYTRI
SUBROUTINE ALREADYQUAD(K1,K2,K3,K4,JA)
use m_netw
implicit none
integer :: K1,K2,K3,K4,JA
integer :: n1
integer :: n2
integer :: n3
integer :: n4
integer :: np
JA = 0
DO NP = NUMP, 1, -1
IF (netcell(NP)%N .EQ. 4) THEN
N1 = netcell(NP)%NOD(1)
N2 = netcell(NP)%NOD(2)
N3 = netcell(NP)%NOD(3)
N4 = netcell(NP)%NOD(4)
IF ((K1.EQ.N1 .OR. K1.EQ.N2 .OR. K1.EQ.N3 .OR. K1.EQ.N4) .AND. &
(K2.EQ.N1 .OR. K2.EQ.N2 .OR. K2.EQ.N3 .OR. K2.EQ.N4) .AND. &
(K3.EQ.N1 .OR. K3.EQ.N2 .OR. K3.EQ.N3 .OR. K3.EQ.N4) .AND. &
(K4.EQ.N1 .OR. K4.EQ.N2 .OR. K4.EQ.N3 .OR. K4.EQ.N4) ) THEN
JA = np
call qnerror('already 4', ' ',' ')
RETURN
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE ALREADYQUAD
SUBROUTINE ALREADYPENTA(K1,K2,K3,K4,K5,JA)
use m_netw
implicit none
integer :: K1,K2,K3,K4,K5,JA
integer :: n1
integer :: n2
integer :: n3
integer :: n4
integer :: n5
integer :: np
JA = 0
! IF (K1 .EQ. 61 .OR. K2 .EQ. 61 .OR. K3 .EQ. 61 .OR. K4 .EQ. 61 .OR. K5 .EQ. 61) THEN
! JA = 1
! RETURN ! BUCKEYBALL
! ENDIF
DO NP = NUMP, 1, -1
IF (netcell(NP)%N .EQ. 5) THEN
N1 = netcell(NP)%NOD(1)
N2 = netcell(NP)%NOD(2)
N3 = netcell(NP)%NOD(3)
N4 = netcell(NP)%NOD(4)
N5 = netcell(NP)%NOD(5)
IF ((K1.EQ.N1 .OR. K1.EQ.N2 .OR. K1.EQ.N3 .OR. K1.EQ.N4 .OR. K1 .EQ. N5) .AND. &
(K2.EQ.N1 .OR. K2.EQ.N2 .OR. K2.EQ.N3 .OR. K2.EQ.N4 .OR. K2 .EQ. N5) .AND. &
(K3.EQ.N1 .OR. K3.EQ.N2 .OR. K3.EQ.N3 .OR. K3.EQ.N4 .OR. K3 .EQ. N5) .AND. &
(K4.EQ.N1 .OR. K4.EQ.N2 .OR. K4.EQ.N3 .OR. K4.EQ.N4 .OR. K4 .EQ. N5) .AND. &
(K5.EQ.N1 .OR. K5.EQ.N2 .OR. K5.EQ.N3 .OR. K5.EQ.N4 .OR. K5 .EQ. N5) ) THEN
JA = np
call qnerror('already 5', ' ',' ')
RETURN
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE ALREADYPENTA
SUBROUTINE ALREADYHEXA(K1,K2,K3,K4,K5,K6,JA)
use m_netw
implicit none
integer :: K1,K2,K3,K4,K5,K6,JA
integer :: n1
integer :: n2
integer :: n3
integer :: n4
integer :: n5
integer :: n6
integer :: np
JA = 0
! IF (K1 .EQ. 61 .OR. K2 .EQ. 61 .OR. K3 .EQ. 61 .OR. K4 .EQ. 61 .OR. K5 .EQ. 61 .OR. K6 .EQ. 61) THEN
! JA = 1
! RETURN ! FOOTBALL
! ENDIF
DO NP = NUMP, 1, -1
IF (netcell(NP)%N .EQ. 6) THEN
N1 = netcell(NP)%NOD(1)
N2 = netcell(NP)%NOD(2)
N3 = netcell(NP)%NOD(3)
N4 = netcell(NP)%NOD(4)
N5 = netcell(NP)%NOD(5)
N6 = netcell(NP)%NOD(6)
IF ((K1.EQ.N1 .OR. K1.EQ.N2 .OR. K1.EQ.N3 .OR. K1.EQ.N4 .OR. K1.EQ.N5 .OR. K1.EQ.N6) .AND. &
(K2.EQ.N1 .OR. K2.EQ.N2 .OR. K2.EQ.N3 .OR. K2.EQ.N4 .OR. K2.EQ.N5 .OR. K2.EQ.N6) .AND. &
(K3.EQ.N1 .OR. K3.EQ.N2 .OR. K3.EQ.N3 .OR. K3.EQ.N4 .OR. K3.EQ.N5 .OR. K3.EQ.N6) .AND. &
(K4.EQ.N1 .OR. K4.EQ.N2 .OR. K4.EQ.N3 .OR. K4.EQ.N4 .OR. K4.EQ.N5 .OR. K4.EQ.N6) .AND. &
(K5.EQ.N1 .OR. K5.EQ.N2 .OR. K5.EQ.N3 .OR. K5.EQ.N4 .OR. K5.EQ.N5 .OR. K5.EQ.N6) .AND. &
(K6.EQ.N1 .OR. K6.EQ.N2 .OR. K6.EQ.N3 .OR. K6.EQ.N4 .OR. K6.EQ.N5 .OR. K6.EQ.N6) ) THEN
JA = np
call qnerror('already 6', ' ',' ')
RETURN
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE ALREADYHEXA
subroutine trace_netlink_polys()
use network_data
use m_alloc
use gridoperations
implicit none
integer :: i, ip, L, kcur, knext, lcur, iloc
if ( .not.allocated(Lc) ) allocate(Lc(numL))
lc = 0
ip = 0
call realloc(netlinkpath_xk, numk+numl)
call realloc(netlinkpath_yk, numk+numl)
call realloc(netlinkpath_end, numl)
iloc = 0
do i=1,numl
! Check whether link was already written to file.
if (lc(i) == 1) then
cycle
end if
ip = ip+1
kcur = kn(1,i)
iloc = iloc+1
netlinkpath_xk(iloc) = xk(kcur)
netlinkpath_yk(iloc) = yk(kcur)
!zloc(1) = 0d0
kcur = kn(2,i)
iloc = iloc+1
netlinkpath_xk(iloc) = xk(kcur)
netlinkpath_yk(iloc) = yk(kcur)
!zloc(2) = 0d0
lc(i) = 1
! We started a new path, now trace connected links as long as possible.
do
lcur = 0
! Find an outgoing link of current net node that wasn't yet traced.
do L=1,nmk(kcur)
if (lc(nod(kcur)%lin(L)) == 0) then
lcur = nod(kcur)%lin(L)
exit
end if
end do
if (lcur == 0) then ! no further links in string found, leave this loop and write it.
exit
end if
! lcur is new link: add it to linestring
iloc = iloc+1
call othernode(kcur, lcur, knext)
netlinkpath_xk(iloc) = real(xk(knext))
netlinkpath_yk(iloc) = real(yk(knext))
lc(lcur) = 1
kcur = knext
end do
netlinkpath_end(ip) = iloc
end do !i=1,numl
numpath = ip
end subroutine trace_netlink_polys
!> Check network data for possible errors.
!! Netlink crossings are stored in linkcross, and can be shown through display menu.
subroutine checknetwork()
use network_data
use unstruc_colors
use m_alloc
use geometry_module, only: cross
use m_missing, only: dmiss
use m_sferic, only: jsferic
implicit none
integer, allocatable :: linkQueue(:), jaLinkVisited(:)
integer :: nLink = 0
integer :: k, k1, k2, ka, kb, lprog, L, LL, jacros, nSearchRange, ncrossmax
double precision :: sl, sm, xcr, ycr, crp, E, E1
! It's impossible to reallocate in recursive findLinks, so reserve sufficient space here.
allocate(linkQueue(1000))
allocate(jaLinkVisited(numl))
! Allocate/reset linkcross array
ncrossmax = max(1,int(numl*0.01))
if (allocated(linkcross)) deallocate(linkcross)
allocate(linkcross(2, ncrossmax))
linkcross = 0
nlinkcross = 0
lprog = 0
nSearchRange = 3 !< For a given link, search at most three connected links ahead
E = 1E-6 ; E1 = 1-E
call readyy('Checking net link crossings', 0d0)
!! Check crossing links
do L=1,numl
if (L>=lprog) then
call readyy('Checking net link crossings', dble(L)/dble(numl))
lprog = lprog + int(numl/100.0)
end if
K1 = kn(1,L)
K2 = kn(2,L)
lr: do k=1,2
linkQueue(1:nLink) = 0
nLink = 0
call findLinks(kn(k,L))
do LL=1,nLink
jaLinkVisited(linkQueue(LL)) = 0
KA = KN(1,linkQueue(LL)) ; KB = KN(2,linkQueue(LL))
! If interfaces share same node, no further action:
if (k1 == ka .or. k1 == kb .or. k2 == ka .or. k2 == kb ) cycle
call cross(XK(K1), YK(K1), XK(K2), YK(K2), XK(KA), YK(KA), XK(KB), YK(KB), JACROS,SL,SM,XCR,YCR,CRP, jsferic, dmiss)
IF (jacros == 1.and. SL > E .AND. SL < E1 .AND. SM > E .AND. SM < E1 ) THEN
if (nlinkcross >= ncrossmax) then
ncrossmax = int(1.2*ncrossmax) + 1
call realloc(linkcross, (/ 2, ncrossmax /), fill=0)
end if
nlinkcross = nlinkcross+1
linkcross(1,nlinkcross) = L
linkcross(2,nlinkcross) = linkQueue(LL)
EXIT lr
END IF
end do
end do lr
end do
call readyy('Checking net link crossings', -1d0)
deallocate(linkQueue)
deallocate(jaLinkVisited)
contains
!> Finds the set of links connected to a specified node through a certain
!! maximum number of intermediate links (nSearchRange=3).
!!
!! This set is used to detect link crossings within only a small range
!! from each link (brute force approach O(numl*numl) would be too expensive.
recursive subroutine findLinks(k)
!use m_alloc
use network_data
implicit none
integer :: k
!integer, intent(inout) :: linkQueue(:)
integer :: L, LL, k2, nQmax
integer, save :: nSearchDepth = 0
if ( k.lt.1 .or. k.gt.numk ) return
if (nSearchDepth >= nSearchRange) return
nQmax = size(linkQueue)
nSearchDepth = nSearchDepth+1
do L=1,nmk(k)
LL = nod(k)%lin(L)
if (LL <= 0) exit
if (nLink > nQmax) exit ! Impossible to realloc in this recursive subroutine
if (jaLinkVisited(LL)==1) then ! Walk links only once.
cycle
else
jaLinkVisited(LL)=1
end if
! 1. Add current link
nLink = nLink+1
linkQueue(nLink) = LL
! 2. And check recursively any connected links
if (kn(2,LL) == k) then
k2 = kn(1,LL)
else
k2 = kn(2,LL)
end if
call findLinks(k2)
end do
nSearchDepth = nSearchDepth-1
end subroutine findLinks
end subroutine checknetwork
!> Renumber net nodes by RCM reordering with kn links as input.
!! Only called by the user. The netlinks kn are NOT reordered, as this will
!! be done in renumberFlowNodes anyway.
subroutine renumberNodes()
use network_data
use unstruc_messages
use gridoperations
implicit none
integer , allocatable :: adj_row(:)
integer , allocatable :: adj(:)
integer , allocatable :: perm(:), perm_inv(:)
integer, allocatable :: i1(:)
double precision, allocatable :: dp1(:)
integer, allocatable :: adj_tmp(:,:), adj_tmp2(:)
integer, external :: adj_bandwidth, adj_perm_bandwidth
integer :: numltot, numlcur, j, k, kk, k1, k2, km, L, bw, bwrn, sumdiff, sumdiffrn
call readyy('Renumber nodes', 0d0 )
numltot = 2*numl ! Undirected links: 2 adjacency elements per link.
allocate(adj_row(numk+1), adj(numltot), perm(numk), perm_inv(numk), i1(numl), dp1(numk))
allocate(adj_tmp(20, numk))
allocate(adj_tmp2(numk))
! Build adjacency list by hand: fill 2D array adj_tmp(20, numk) and
! flatten it afterwards to adj(numltot).
adj_tmp2 = 0
do L=1,numl
k1 = kn(1,L)
k2 = kn(2,L)
km = adj_tmp2(k1)
! For node k1, store its neighbours in sorted order.
do k=1,km
if (adj_tmp(k, k1) > k2) then
exit
end if
end do
adj_tmp(k+1:km+1,k1) = adj_tmp(k:km,k1)
adj_tmp(k, k1) = k2
adj_tmp2(k1) = km+1
! Same for node k2
km = adj_tmp2(k2)
do k=1,km
if (adj_tmp(k, k2) > k1) then
exit
end if
end do
adj_tmp(k+1:km+1,k2) = adj_tmp(k:km,k2)
adj_tmp(k, k2) = k1
adj_tmp2(k2) = km+1
end do
call readyy('Renumber nodes', .3d0 )
! Flatten the adjacency list.
j = 1
do k=1,numk
adj_row(k) = j
do kk=1,adj_tmp2(k)
adj(j) = adj_tmp(kk, k)
j = j + 1
end do
end do
adj_row(numk+1) = j
call readyy('Renumber nodes', .35d0 )
bw = adj_bandwidth(numk, numltot, adj_row, adj)
! Find a renumbering (permutation)
call genrcm(numk, numltot, adj_row, adj, perm)
call perm_inverse3(numk, perm, perm_inv)
call readyy('Renumber nodes', .75d0 )
! Now apply the permutation to net node numbers
dp1 = xk
do k=1,numk
xk(k) = dp1(perm(k))
end do
dp1 = yk
do k=1,numk
yk(k) = dp1(perm(k))
end do
dp1 = zk
do k=1,numk
zk(k) = dp1(perm(k))
end do
sumdiff = 0
do L=1,numl
sumdiff = sumdiff + abs(kn(1,L)-kn(2,L))
end do
i1 = kn(1,:)
do L=1,numl
kn(1,L) = perm_inv(i1(L))
end do
i1 = kn(2,:)
do L=1,numl
kn(2,L) = perm_inv(i1(L))
end do
! No numbering necessary for kn(3,:) (Links are still in same order)
! Finish with some stats
sumdiffrn = 0
do L=1,numl
sumdiffrn = sumdiffrn + abs(kn(1,L)-kn(2,L))
end do
call readyy('Renumber nodes', 1d0 )
bwrn = adj_perm_bandwidth(numk, numltot, adj_row, adj, perm, perm_inv)
write(msgbuf,*) 'Renumber nodes...'
call dbg_flush()
write(msgbuf,*) 'Sumdiff:', sumdiff, ' Sumdiff renum: ', sumdiffrn
call dbg_flush()
write(msgbuf,*) 'Bandwidth:', bw, ' Bandwidth renum: ', bwrn
call dbg_flush()
deallocate(adj_row, adj, perm, perm_inv, i1, dp1)
deallocate(adj_tmp,adj_tmp2)
call readyy('Renumber nodes', -1d0 )
CALL SETNODADM(0)
end subroutine renumberNodes
!> Renumber flow nodes in an early stage.
!! Called only from withing flow_geominit, it operates on lne, kn and netcell
!! data. The actual construction of all flow_geom data remains exactly the
!! same in flow_geominit. Two steps are taken:
!! * renumber (=reorder) netcell by RCM reordering with lne links as input.
!! * reorder lne links based on the new netcell numbers.
!! The kn netlinks are reorder exactly the same as lne. They have to
!! be ordered identically.
!! * Also update the (net-)link numbers in %lin
!! Note: Only 2D cells/links are renumbered (so blocks 1:numl1D, and
!! numl1D+1:numl remain intact). Also: boundary links are ignored.
subroutine renumberFlowNodes()
use network_data
use m_flowgeom
use unstruc_messages
use m_alloc
use m_partitioninfo, only: idomain, iglobal_s, jampi, my_rank
implicit none
integer , allocatable :: adj_row(:)
integer , allocatable :: adj(:)
integer , allocatable :: perm(:), perm_inv(:), perm_lnk(:), perm_inv_lnk(:), idomain1(:), iglobal_s1(:)
integer, allocatable :: i1(:)
double precision, allocatable :: xz1(:), yz1(:)
type(tface), allocatable :: tface1(:)
integer, allocatable :: adj_tmp(:,:), adj_tmp2(:)
integer, external :: adj_bandwidth, adj_perm_bandwidth
integer :: numltot, numlcur, ii, jj, i, j, indx, isgn, k, kk, k1, k2, km, L, LL, p, p1, bw, bwrn, sumdiff, sumdiffrn
call readyy('Renumber flow nodes', 0d0 )
jaFlowNetChanged = 1
numltot = 2*numl ! Undirected links: 2 adjacency elements per link.
allocate(adj_row(NUMP+1), adj(numltot), &
perm(NUMP), perm_inv(NUMP), perm_lnk(numl), perm_inv_lnk(numl), &
i1(NUML), xz1(NUMP), yz1(NUMP), tface1(NUMP))
allocate(adj_tmp(20, NUMP))
allocate(adj_tmp2(NUMP))
! Build adjacency list by hand: fill 2D array adj_tmp(20, numk) and
! flatten it afterwards to adj(numltot).
! Built-in adj_set_ij is VERY slow, don't use it.
adj_tmp2 = 0
do L=1,NUML
k1 = iabs(lne(1,L))
k2 = iabs(lne(2,L))
if (k1 > nump .or. k2 > nump .or. k1 == 0 .or. k2 == 0) then
cycle ! Don't use 1D links for now.
end if
km = adj_tmp2(k1)
! For node k1, store its neighbours in sorted order.
do k=1,km
if (adj_tmp(k, k1) > k2) then
exit
end if
end do
adj_tmp(k+1:km+1,k1) = adj_tmp(k:km,k1)
adj_tmp(k, k1) = k2
adj_tmp2(k1) = km+1
! Same for node k2
km = adj_tmp2(k2)
do k=1,km
if (adj_tmp(k, k2) > k1) then
exit
end if
end do
adj_tmp(k+1:km+1,k2) = adj_tmp(k:km,k2)
adj_tmp(k, k2) = k1
adj_tmp2(k2) = km+1
end do
call readyy('Renumber flow nodes', .15d0 )
! Flatten the adjacency list.
j = 1
do k=1,NUMP
adj_row(k) = j
do kk=1,adj_tmp2(k)
adj(j) = adj_tmp(kk, k)
j = j + 1
end do
end do
adj_row(NUMP+1) = j
call readyy('Renumber flow nodes', .18d0 )
bw = adj_bandwidth(NUMP, numltot, adj_row, adj)
! Find a renumbering (permutation)
call genrcm(NUMP, numltot, adj_row, adj, perm)
call perm_inverse3(NUMP, perm, perm_inv)
call readyy('Renumber flow nodes', .35d0 )
! Now apply the permutation to relevant net cell numbers
! (This will propagate automatically to all flow node related arrays in flow_geominit)
! Only xz and yz are already available and should be permuted now.
tface1(1:NUMP) = netcell(1:NUMP)
xz1(1:NUMP) = xz(1:NUMP)
yz1(1:NUMP) = yz(1:NUMP)
do k=1,NUMP
netcell(k) = tface1(perm(k))
xz(k) = xz1(perm(k))
yz(k) = yz1(perm(k))
end do
xz1(1:NUMP) = xzw(1:NUMP)
yz1(1:NUMP) = yzw(1:NUMP)
do k=1,NUMP
xzw(k) = xz1(perm(k))
yzw(k) = yz1(perm(k))
end do
xz1(1:NUMP) = ba(1:NUMP)
do k=1,NUMP
ba(k) = xz1(perm(k))
end do
! see if we can update idomain
if ( allocated(idomain) ) then
if ( ubound(idomain,1).ge.nump ) then
call realloc(idomain1, nump, keepExisting=.false.)
idomain1(1:nump) = idomain(1:nump)
do k=1,nump
idomain(k) = idomain1(perm(k))
end do
deallocate(idomain1)
end if
end if
! see if we can update iglobal
if ( allocated(iglobal_s) ) then
if ( ubound(iglobal_s,1).ge.nump ) then
call realloc(iglobal_s1, nump, keepExisting=.false., fill=0)
iglobal_s1(1:nump) = iglobal_s(1:nump)
do k = 1, nump
iglobal_s(k) = iglobal_s1(perm(k))
enddo
deallocate(iglobal_s1)
end if
end if
!i1(1:NUMP) = lc(1:NUMP)
!do k=1,NUMP
! LC(k) = i1( perm(k) )
!end do
sumdiff = 0
do L=1,NUML
sumdiff = sumdiff + abs(abs(lne(1,L))-abs(lne(2,L)))
end do
i1 = lne(1,1:NUML)
do L=1,NUML
if (abs(i1(L)) > nump .or. i1(L) == 0) cycle
lne(1,L) = sign(1,i1(L)) * perm_inv(abs(i1(L)))
end do
i1 = lne(2,1:NUML)
do L=1,NUML
if (abs(i1(L)) > nump .or. i1(L) == 0) cycle
lne(2,L) = sign(1,i1(L)) * perm_inv(abs(i1(L)))
end do
! Finish with some stats
sumdiffrn = 0
do L=1,NUML
sumdiffrn = sumdiffrn + abs(abs(lne(1,L))-abs(lne(2,L)))
end do
call readyy('Renumber flow nodes', 0.5d0 )
bwrn = adj_perm_bandwidth(NUMP, numltot, adj_row, adj, perm, perm_inv)
write(msgbuf,*) 'Renumber flow nodes...'
call dbg_flush()
write(msgbuf,*) 'Sumdiff:', sumdiff, ' Sumdiff renum: ', sumdiffrn
call dbg_flush()
write(msgbuf,*) 'Bandwidth:', bw, ' Bandwidth renum: ', bwrn
call dbg_flush()
! return
! STEP 2: Reorder flow links (to follow the renumbered flow nodes, when possible)
! Only for: NUML1D+1:NUML
indx = 0
! Make identity permutation first.
do L=1,NUML
perm_lnk(L) = L
end do
! Now build the permutation list, based on sort order of lne.
! Only after this 'postponed sorting', the lne list itself will be permuted.
do
if (numl-numl1D <= 1) exit
call sort_heap_external ( numl-numl1D, indx, i, j, isgn )
ii = i + numl1D
jj = j + numl1D
if (indx > 0) then
! * interchange items I and J;
! * call again.
p1 = perm_lnk(ii)
perm_lnk(ii) = perm_lnk(jj)
perm_lnk(jj) = p1
else if (indx < 0) then
! * compare items I and J;
! * set ISGN = -1 if I < J, ISGN = +1 if J < I;
! * call again.
if (abs(lne(1,perm_lnk(ii))) < abs(lne(1,perm_lnk(jj))) .or. &
abs(lne(1,perm_lnk(ii))) == abs(lne(1,perm_lnk(jj))) .and. &
abs(lne(2,perm_lnk(ii))) < abs(lne(2,perm_lnk(jj))) ) then
isgn = -1
else
isgn = 1
end if
else
! * equal to 0, the sorting is done.
exit
end if
end do
! Also determine inverse permutation (needed for renumbering %lin)
do L=1,numl
perm_inv_lnk(perm_lnk(L)) = L
end do
call readyy('Renumber flow nodes', 0.7d0 )
! Now perm_lnk contains the desired reordering of link numbers.
! Permute kn and lne
i1 = kn(1,1:NUML)
do L=numl1d+1,numl
kn(1,L) = i1(perm_lnk(L))
end do
i1 = kn(2,1:NUML)
do L=numl1d+1,numl
kn(2,L) = i1(perm_lnk(L))
end do
i1 = kn(3,1:NUML)
do L=numl1d+1,numl
kn(3,L) = i1(perm_lnk(L))
end do
!i1 = LC(1:NUML)
!do L=1,NUML ! hk: we need LC because of small piece of 1D2D admin in LC
! LC(L) = i1(perm_lnk(L))
!end do
i1 = lne(1,1:NUML)
do L=numl1d+1,numl
lne(1,L) = i1(perm_lnk(L))
end do
i1 = lne(2,1:NUML)
do L=numl1d+1,numl
lne(2,L) = i1(perm_lnk(L))
end do
i1 = lnn(1:NUML)
do L=numl1d+1,numl
lnn(L) = i1(perm_lnk(L))
end do
! Renumber in the %lin
do k=1,numk
do LL=1,NMK(K)
NOD(K)%LIN(LL) = perm_inv_lnk(NOD(K)%LIN(LL))
end do
end do
do p=1,nump
do L=1,netcell(p)%n
netcell(p)%lin(L) = perm_inv_lnk(netcell(p)%lin(L))
end do
end do
call renumber_cutcellmasks(perm_lnk)
! permute cutcell related arrays
! call permute_cutcellmasks(iperm_lnk)
call readyy('Renumber flow nodes', 1d0 )
deallocate(adj_row)
deallocate(adj)
deallocate(perm)
deallocate(perm_inv)
deallocate(perm_lnk)
deallocate(perm_inv_lnk)
deallocate(i1)
deallocate(xz1)
deallocate(yz1)
deallocate(tface1)
deallocate(adj_tmp)
deallocate(adj_tmp2)
call readyy('Renumber flow nodes', -1d0 )
! DO NOT CALL FINDCELLS FROM NOW ON, IT WILL DESTROY THE RENUMBERING
netstat = NETSTAT_OK
end subroutine renumberFlowNodes
!> find one-dimensional net cells
!> it is assumed that kc has been allocated
!> it is assumed that findcells has already been called (for 2d cells)
subroutine find1dcells()
use network_data
use m_alloc
use m_flowgeom, only: xz, yz, ba
use gridoperations
implicit none
integer :: K1, K2, K3, L, LNX1D, N, NC1, NC2
integer :: i, ierr, k, kcell
logical :: Lisnew
integer :: ierror
ierror = 1
nump1d2d = nump
! BEGIN COPY from flow_geominit
KC = 2 ! ONDERSCHEID 1d EN 2d NETNODES
DO L = 1, NUML
K1 = KN(1,L) ; K2 = KN(2,L) ; K3 = KN(3,L)
IF (K3 >= 1 .and. K3 <= 7) THEN
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDDO
DO L = 1, NUML1D
K1 = KN(1,L) ; K2 = KN(2,L)
if (k1 == 0) cycle
NC1 = 0 ; NC2 = 0
IF (NMK(K1) == 1 .and. kn(3,L) .ne. 1 .and. kn(3,L) .ne. 6) THEN
CALL INCELLS(XK(K1), YK(K1), NC1) ! IS INSIDE 2D CELLS()
ENDIF
IF (NMK(K2) == 1 .and. kn(3,L) .ne. 1 .and. kn(3,L) .ne. 6) THEN
CALL INCELLS(XK(K2), YK(K2), NC2)
ENDIF
if (nc1 .ne. 0 .and. nc1 == nc2) then
nc2 = 0
endif
IF (NC1 == 0) THEN
IF ( KC(K1) == 1) THEN ! NIEUWE 1d CELL
nump1d2d = nump1d2d + 1
KC(K1) = -nump1d2d ! MARKEREN ALS OUD
ENDIF
LNE(1,L) = -iabs(KC(K1)) ! NEW 1D CELL flag 1D links through negative lne ref
ELSE
LNE(1,L) = NC1 ! ALREADY EXISTING 2D CELL
ENDIF
IF (NC2 == 0) THEN
IF ( KC(K2) == 1) THEN ! NIEUWE 1d CELL
nump1d2d = nump1d2d + 1
KC(K2) = -nump1d2d
ENDIF
LNE(2,L) = -iabs(KC(K2)) ! NEW 1D CELL
ELSE
LNE(2,L) = NC2 ! ALREADY EXISTING 2D CELL
ENDIF
LNN(L) = 2
ENDDO
! END COPY from flow_geominit
! fill 1D netcell administration and set cell centers
call realloc(xzw, nump1d2d)
call realloc(yzw, nump1d2d)
call realloc(xz, nump1d2d)
call realloc(yz, nump1d2d)
call realloc(ba, nump1d2d, KeepExisting=.true., fill=0d0) ! 1D ba's will be filled halfway through flow_geominit, just allocate and initialize 1D part here
call increasenetcells(nump1d2d, 1.0, .true.)
do k=nump+1,nump1d2d
netcell(k)%N = 0
call realloc(netcell(k)%NOD, 1, stat=ierr, keepExisting=.false., fill=0)
call realloc(netcell(k)%LIN, 1, stat=ierr, keepExisting=.false., fill=0)
end do
do k=1,numk
if ( kc(k).lt.0 ) then ! 1d cell
nc1 = -kc(k) ! cell number
N = netcell(nc1)%N
! check if this node is new in this cell
Lisnew = .true.
do i=1,N
if ( netcell(nc1)%nod(i).eq.k ) then
Lisnew = .false.
exit
end if
end do
if ( Lisnew ) then ! new node for this cell
N = N+1
if ( N.gt.1 ) then
call realloc(netcell(nc1)%NOD, N, stat=ierr, keepExisting=.true., fill=0)
call realloc(netcell(nc1)%LIN, N, stat=ierr, keepExisting=.true., fill=0)
end if
netcell(nc1)%N = N
netcell(nc1)%nod(N) = k
end if
end if
end do
! do L=1,numL1d
! k1 = kn(1,L)
! k2 = kn(2,L)
! nc1 = kc(k1)
! nc2 = kc(k2)
! if ( nc1.lt.0 ) then
! kcell = -nc1
! N = netcell(kcell)%N + 1
! if ( N.gt.2 ) then
! call realloc(netcell(kcell)%nod, N, stat=ierr, keepExisting=.true., fill=0)
! call realloc(netcell(kcell)%lin, N, stat=ierr, keepExisting=.true., fill=0)
! end if
! netcell(kcell)%N = N
! netcell(kcell)%nod(N) = k2
! netcell(kcell)%lin(N) = L
! end if
! if ( nc2.lt.0 ) then
! kcell = -nc2
! N = netcell(kcell)%N + 1
! if ( N.gt.2 ) then
! call realloc(netcell(kcell)%nod, N, stat=ierr, keepExisting=.true., fill=0)
! call realloc(netcell(kcell)%lin, N, stat=ierr, keepExisting=.true., fill=0)
! end if
! netcell(kcell)%N = N
! netcell(kcell)%nod(N) = k1
! netcell(kcell)%lin(N) = L
! end if
! end do
do k=1,numk
if ( kc(k).lt.0 ) then ! 1d cell associated with net node k
kcell = -kc(k)
xzw(kcell) = xk(k)
yzw(kcell) = yk(k)
xz(kcell) = xk(k)
yz(kcell) = yk(k)
end if
end do
! safety: 1D-cells can have negative lne, which will cause problems
if ( nump1d2d.gt.nump ) then
netstat = NETSTAT_CELLS_DIRTY
end if
ierror = 0
1234 continue
return
end subroutine find1dcells
LOGICAL FUNCTION RECHTSAF_active(K1,K2,K3)
use m_netw
use geometry_module, only : duitpl
use m_sferic, only: jsferic
implicit none
integer :: K1, K2, K3
double precision :: sig
rechtsaf_active = .false.
call duitpl(xk(k1), yk(k1), xk(k2), yk(k2), xk(k2), yk(k2), xk(k3), yk(k3), sig, jsferic)
if (sig < 0) then
rechtsaf_active = .true.
else
rechtsaf_active = .false.
endif
return
end FUNCTION RECHTSAF_active
SUBROUTINE CONNECT(K1,K2,LFAC,A0,R00)
use m_netw
use gridoperations
implicit none
integer :: K1,K2,LFAC
double precision :: A0, R00
double precision :: ag
double precision :: cfl
double precision :: e0
double precision :: eps
integer :: ja
integer :: kl
integer :: kr
integer :: l
integer :: ll
integer :: lnu
double precision :: pi
double precision :: r0
double precision :: rho
double precision :: rhow
double precision :: rmas
DOUBLE PRECISION DLENGTH
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
DO L = 1,NUML
IF (KN(1,L) .EQ. K1 .AND. KN(2,L) .EQ. K2 .OR. &
KN(1,L) .EQ. K2 .AND. KN(2,L) .EQ. K1 ) THEN
! CALL CONFRM('POINTS ALREADY CONNECTED, CONTINUE', JA)
! IF (JA .NE. 1) RETURN
RETURN
ENDIF
ENDDO
R0 = R00
IF (R0 .LE. 0) R0 = DLENGTH(K1,K2)
DO LL = 1,LFAC
! CALL GIVENEWLINKNUM(LNU) ! En increase NUML als nodig
IF (LL .EQ. 1) THEN
KL = K1
IF (LFAC .GT. 1) THEN ! LUS EIGENLIJK ANDERS STARTEN
CALL GIVENEWNODENUM(KR)
ELSE
KR = K2
ENDIF
ELSE IF (LL .EQ. LFAC) THEN
KL = KR
KR = K2
ELSE
KL = KR
CALL GIVENEWNODENUM(KR)
ENDIF
!CALL ADDLINKTONODES(KL,KR,LNU)
!CALL CONNECTDB(KL,KR,LNU)
CALL CONNECTDBN(KL,KR,LNU)
KN(3,LNU) = KN3TYP
XK(KL) = XK(K1) + (XK(K2) - XK(K1))*dble(LL-1)/dble(LFAC)
YK(KL) = YK(K1) + (YK(K2) - YK(K1))*dble(LL-1)/dble(LFAC)
ZK(KL) = ZK(K1) + (ZK(K2) - ZK(K1))*dble(LL-1)/dble(LFAC)
XK(KR) = XK(K1) + (XK(K2) - XK(K1))*dble(LL )/dble(LFAC)
YK(KR) = YK(K1) + (YK(K2) - YK(K1))*dble(LL )/dble(LFAC)
ZK(KR) = ZK(K1) + (ZK(K2) - ZK(K1))*dble(LL )/dble(LFAC)
ENDDO
JA = 1
RETURN
END SUBROUTINE CONNECT
SUBROUTINE NEWLINK(K1,K2,LNU) ! no checks
use m_netw
use unstruc_colors
use gridoperations
implicit none
integer :: K1, K2, LNU
NUML = NUML + 1
IF (NUML >= LMAX) THEN
CALL INCREASENETW(NUMK,NUML)
ENDIF
KN(1,NUML) = K1
KN(2,NUML) = K2
KN(3,NUML) = KN3TYP
LNU = NUML
CALL TEKLINK(NUML,NCOLDN)
END SUBROUTINE NEWLINK
SUBROUTINE OGIVENEWLINKNUM(LNU)
use m_netw
use gridoperations
implicit none
integer :: LNU
integer :: kx
integer :: l
integer :: lx
DO L = 1,NUML
IF (KN(1,L) .EQ. 0 .AND. KN(2,L) .EQ. 0) THEN
LNU = L
RETURN
ENDIF
ENDDO
IF (NUML .LT. LMAX) THEN
NUML = NUML + 1
LNU = NUML
ELSE
KX = 1.2*NUMK ; LX = 1.2*NUML
CALL INCREASENETW(KX, LX)
ENDIF
RETURN
END SUBROUTINE OGIVENEWLINKNUM
SUBROUTINE GIVENEWLINKNUM(LNU)
use m_netw
use gridoperations
implicit none
integer :: LNU
integer :: kx
integer :: lx
IF ( NUML == LMAX ) THEN
KX = 1.2*NUMK ; LX = 1.2*NUML
CALL INCREASENETW(KX, LX)
ENDIF
NUML = NUML + 1
LNU = NUML
RETURN
END SUBROUTINE GIVENEWLINKNUM
SUBROUTINE OGIVENEWNODENUM(KNU)
use m_netw
use gridoperations
implicit none
integer :: KNU
integer :: k
integer :: kx
integer :: lx
DO K = 1,NUMK
IF (KC(K) .EQ. 0) THEN
KNU = K
RETURN
ENDIF
ENDDO
IF (NUMK .LT. SIZE(XK)) THEN
NUMK = NUMK + 1
KNU = NUMK
ELSE
KX = 1.2*NUMK ; LX = 1.2*NUML
CALL INCREASENETW(KX, LX)
ENDIF
RETURN
END SUBROUTINE OGIVENEWNODENUM
SUBROUTINE GIVELINKNUM(K1,K2,L)
use m_netw
implicit none
integer :: K1, K2, L
L = 0
DO L = NUML, 1, -1
IF (KN(1,L) .EQ. K1 .AND. KN(2,L) .EQ. K2 .OR. &
KN(1,L) .EQ. K2 .AND. KN(2,L) .EQ. K1 ) THEN
RETURN
ENDIF
ENDDO
RETURN
END SUBROUTINE GIVELINKNUM
SUBROUTINE ADDELEM(K1,K2,JA)
USE M_AFMETING
implicit none
integer :: K1,K2,JA
double precision :: a0
double precision :: ag
double precision :: cdflow
double precision :: cfl
double precision :: cfric
double precision :: e0
double precision :: eps
double precision :: fbouy
double precision :: fdyn
integer :: janet
integer :: moments
double precision :: pi
double precision :: r0
double precision :: rho
double precision :: rhow
DOUBLE PRECISION DLENGTH
COMMON /SETTINGS/ FDYN, FBOUY, CDFLOW, CFRIC, MOMENTS, JANET
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
IF (JANET .EQ. 1) THEN
A0 = PI*RDIAM*RDIAM/4
ELSE
A0 = 1E6*RWIDTH*RTHICK
ENDIF
R0 = DLENGTH(K1,K2)
CALL CONNECT(K1,K2,1,A0,R0)
RETURN
END SUBROUTINE ADDELEM
SUBROUTINE MERGENODES(K1,K2,JA) ! KNOOP 1 WORDT OPGENOMEN IN KNOOP 2
use m_netw
use m_missing
use gridoperations
implicit none
integer :: K1,K2,JA, L2, NN, K22, NM22, L2A, K22A, N1
integer :: l
integer :: l12
integer :: n
integer :: nm
integer :: nm1
integer :: nm2
INTEGER :: NODLIN(200)
JA = 0
NM1 = NMK(K1)
NM2 = NMK(K2)
CALL GIVELINKNUM(K1,K2,L12)
if (L12 .ne. 0) then
kn(1,L12) = 0 ; kn(2,L12) = 0; kn(3,L12) = 0
endif
DO NM = 1,NM1 ! CHECK OF JE NIET VIA EEN ANDER PAD OOK BIJ K2 UIT KAN KOEMN. ZO JA, VERWIJDER LINK
L2 = NOD(K1)%LIN(NM)
CALL OTHERNODE(K1,L2,K22)
IF (K22 .NE. 0 .AND. K22 .NE. K2) THEN
NM22 = NMK(K22)
DO NN = 1,NM22
L2A = NOD(K22)%LIN(NN)
CALL OTHERNODE(K22,L2A,K22A)
IF (K22A == K2) THEN
kn(1,L2A) = 0 ; kn(2,L2A) = 0; kn(3,L2A) = 0
ENDIF
ENDDO
ENDIF
ENDDO
N = 0
DO NM = 1,NM2
L = NOD(K2)%LIN(NM)
IF (KN(1,L) .NE. 0) THEN
N = N + 1 ; NODLIN(N) = L
ENDIF
ENDDO
DO NM = 1,NM1
L = NOD(K1)%LIN(NM)
IF (KN(1,L) .NE. 0) THEN
N = N + 1 ; NODLIN(N) = L
IF (KN(1,L) == K1) KN(1,L) = K2
IF (KN(2,L) == K1) KN(2,L) = K2
ENDIF
ENDDO
NMK(K2) = N
! call setnodadm(0); return
DEALLOCATE(NOD(K2)%LIN)
ALLOCATE ( NOD(K2)%LIN(NMK(K2)) )
NOD(K2)%LIN(1:NMK(K2)) = NODLIN(1:NMK(K2))
if ( allocated(nod(k1)%lin) ) deallocate (NOD(K1)%lin) ! %LIN = 0 ! SPvdP: added check
KC (K1) = 0
NMK(K1) = 0
XK (K1) = dxymis
ja = 1 ! nepcheck
RETURN
END SUBROUTINE MERGENODES
SUBROUTINE MERGEUNCONNECTEDNODES(K1,K2,JA) ! KNOOP 1 WORDT OPGENOMEN IN KNOOP 2
use m_netw
use m_missing
implicit none
integer :: K1,K2,JA
integer :: l
integer :: n
integer :: nm
integer :: nm1
integer :: nm2
INTEGER :: NODLIN(200)
JA = 0
NM1 = NMK(K1)
NM2 = NMK(K2)
N = 0
DO NM = 1,NM2
L = NOD(K2)%LIN(NM)
IF (KN(1,L) .NE. 0) THEN
N = N + 1 ; NODLIN(N) = L
ENDIF
ENDDO
DO NM = 1,NM1
L = NOD(K1)%LIN(NM)
IF (KN(1,L) .NE. 0) THEN
N = N + 1 ; NODLIN(N) = L
IF (KN(1,L) == K1) KN(1,L) = K2
IF (KN(2,L) == K1) KN(2,L) = K2
ENDIF
ENDDO
NMK(K2) = N
if (allocated(nod(k2)%lin)) deallocate(NOD(K2)%LIN)
ALLOCATE ( NOD(K2)%LIN(NMK(K2)) )
NOD(K2)%LIN(1:NMK(K2)) = NODLIN(1:NMK(K2))
if ( allocated(nod(k1)%lin) ) deallocate (NOD(K1)%lin) ! %LIN = 0 ! SPvdP: added check
KC (K1) = 0
NMK(K1) = 0
XK (K1) = dxymis
ja = 1 ! nepcheck
RETURN
END SUBROUTINE MERGEUNCONNECTEDNODES
SUBROUTINE ONELINE(K,RD) ! TWEE LIJNTJES WORDEN 1
use m_netw
use gridoperations
implicit none
integer :: K
double precision :: RD
double precision :: a0
double precision :: ag
double precision :: cdflow
double precision :: cfl
double precision :: cfric
double precision :: e0
double precision :: eps
double precision :: fbouy
double precision :: fdyn
integer :: ja
integer :: janet
integer :: k1
integer :: k2
integer :: l1
integer :: l2
integer :: lfa
integer :: moments
integer :: nm
double precision :: pi
double precision :: r0
double precision :: rho
double precision :: rhow
COMMON /SETTINGS/ FDYN, FBOUY, CDFLOW, CFRIC, MOMENTS, JANET
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
JA = 0
NM = NMK(K)
IF (NM .EQ. 2) THEN
L1 = NOD(K)%LIN(1)
L2 = NOD(K)%LIN(2)
! IF (RL(L1) .LT. RD .OR. RL(L2) .LT. RD) THEN
CALL OTHERNODE(K,L1,K1)
CALL OTHERNODE(K,L2,K2)
R0 = 0 ! RL(L1) + RL(L2)
A0 = 0 !(EA(L1) + EA(L2)) / 2d0
LFA = 1
CALL DELNODE(K)
CALL CONNECT(K1,K2,LFA,A0,R0)
! ENDIF
ENDIF
RETURN
END SUBROUTINE ONELINE
SUBROUTINE LESSNODES()
use m_netw
USE M_AFMETING
implicit none
integer :: k
DO K = 1,NUMK
CALL ONELINE(K,RLMIN) ! TWEE LIJNTJES WORDEN 1
ENDDO
RETURN
END SUBROUTINE LESSNODES
subroutine cutcell_list(n12,FILNAM,lenf,jamasks) ! filnam = mask
USE M_NETW
USE M_FLOWGEOM
use m_missing
use unstruc_messages
use kdtree2Factory
use m_sferic
use m_tpoly
use m_cutcells
use gridoperations
use unstruc_model
IMPLICIT NONE
integer, intent(in) :: n12, lenf !< type of operation (1, 2, 3, 4, 5), see docs below.
CHARACTER(LEN=lenf), intent(in) :: FILNAM
integer, intent(in) :: jamasks !< store masks and polygons (1), use stored masks and polygons (2), use stored masks masks and polygons and clear masks and polygons (3), do not use stored masks and polygons at all (0)
LOGICAL JAWEL
double precision :: xplmax, xplmin
double precision :: t0, t1
INTEGER N, MPOL, MLIST, KEY, JADEL, NN, L, K, IN, NUMFIL, ierror
CHARACTER(LEN=132), ALLOCATABLE :: FILIST(:)
character(len=128) :: mesg
integer, dimension(:), allocatable :: kc_bak ! backup of kc
integer :: Lf
integer :: ipoly
integer :: ipol_stored
integer :: NMAX
integer, parameter :: jaalltogether = 1 !< all polygons at once (1) or not (0)
jastored = 0
INQUIRE (FILE = md_cutcelllist, EXIST = JAWEL)
NUMFIL = 0
IF (JAWEL) THEN
CALL OLDFIL(MLIST, md_cutcelllist)
777 READ (MLIST,*, END = 888)
NUMFIL = NUMFIL+1
GOTO 777
888 ALLOCATE ( FILIST(NUMFIL) ) ; filist = ' '
REWIND (MLIST)
DO N = 1,NUMFIL
READ(MLIST,'(A)') FILIST(N)
ENDDO
CALL DOCLOSE(MLIST)
ELSE
RETURN
ENDIF
CALL mess (LEVEL_INFO, 'cutcell_list; nr of *.cut files found = ' , numfil, n12)
do n = 1,numfil
call message ('cutcell ', filist(n), ' ')
enddo
! store kc
allocate(kc_bak(numk))
do k=1,numk
kc_bak(k) = kc(k)
end do
!IF (N12 == 3) THEN
CALL SAVEPOL()
CALL DELPOL()
!ENDIF
KC = 0 ! VOOR NU EVEN, ALLE NET NODES DOEN MEE
if (N12 >= 3) then !prepare for cutcellwu
if ( jamasks.eq.0 .or. jamasks.eq.1 ) then
call build_kdtree( treeglob, numk, xk, yk, ierror, jsferic, dmiss)
end if
end if
ipol_stored = 0
if ( jaalltogether.eq.1 .and. ( jamasks.eq.0 .or. jamasks.eq.1 ) ) then
call dealloc_tpoly(pli) ! safety
DO N = 1,NUMFIL
CALL OLDFIL(MPOL,TRIM(FILIST(N)))
CALL REAPOL(MPOL, 0)
if (jsferic == 1) then
call fix_global_polygons(1,0)
endif
! add polygon to all tpoly-type polygons
call pol_to_tpoly(numpols, pli, keepExisting=.true.)
end do
end if
if ( jaalltogether.eq.1 ) then
NMAX = 1 ! all polygons stored as tpoly-type polygons
! call realloc(idxL, 1)
! call realloc(jdxL, 1)
! call realloc(pdxL, 1)
! call find_intersecting_polysections(numpols, pli, idxL, jdxL, pdxL)
else
NMAX = NUMFIL
end if
do N=1,NMAX
if ( jaalltogether.ne.1 ) then
! read polygons from file
CALL OLDFIL(MPOL,TRIM(FILIST(N)))
CALL REAPOL(MPOL, 0)
if (jsferic == 1) then
call fix_global_polygons(1,0)
end if
call pol_to_tpoly(numpols, pli, keepExisting=.false.)
end if
do ipoly=1,numpols
call klok(t0)
ipol_stored = ipol_stored + 1
call delpol()
call tpoly_to_pol(pli,iselect=ipoly)
if ( jaalltogether.eq.1 ) then
write(mesg, "('cutcells: processing polygon ', I0, ' of ', I0, '...')") ipoly, numpols
call mess(LEVEL_INFO, trim(mesg))
end if
if (n12 == 1) then
CALL CUTCELLS(n12)
else if (N12 == 2) then ! DELETE NEtNODES IF INSIDE POLYGON
call delnet(key,0,0)
! else if (N12 == 3) then ! DELETE NETCELLS IF NETCELLS ENTIRELY INSIDE POLYGONS
! IN = -1
! DO K = 1,NUMK
! CALL DBPINPOL( XK(K), YK(K), IN)
! IF (IN == 1) THEN
! KC(K) = 0 ! ZIT IE IN POL DAN DOET IE NIET MEE
! ENDIF
! ENDDO
else if (N12 >= 3) then ! 3, 4 and 5
CALL CUTCELWU(n12, jamasks, ipol_stored) ! calls SAVEPOL via split_pol
endif
call klok(t1)
write(mesg, "('done in ', F12.5, ' sec.')") t1-t0
call mess(LEVEL_INFO, trim(mesg))
end do
ENDDO
if (N12 >= 3) then ! cleanup after cutcellwu
if ( jamasks.eq.0 .or. jamasks.eq.1 ) then
call delete_kdtree2(treeglob)
end if
end if
IF (N12 == 3) THEN
kc = 1-kc ! 1: active, 0: inactive
NPL = 0
DO N = 1,NUMP
JADEL = 1
DO NN = 1,NETCELL(N)%N
K = NETCELL(N)%NOD(NN)
IF (KC(K) == 1) THEN ! ER HOEFT ER MAAR 1 OP 1 TE STAAN OF WE DELETEN NIET
JADEL = 0
ENDIF
ENDDO
IF (JADEL == 1) THEN
DO NN = 1,NETCELL(N)%N
L = NETCELL(N)%LIN(NN)
IF (LNE(1,L) == N ) THEN
LNE(1,L) = 0
ELSEIF (LNE(2,L) == N ) THEN
LNE(2,L) = 0
ENDIF
ENDDO
ENDIF
ENDDO
DO L = 1,NUML
IF (LNE(1,L) == 0 .AND. LNE(2,L) == 0 ) THEN
KN(1,L) = 0 ; KN(2,L) = 0; KN(3,L) = -1
ENDIF
ENDDO
! mark original netboundary (setnodadm will make lnn invalid)
do L=1,numL
if ( lnn(L).eq.1 .and. kn(3,L).gt.0 ) then
kc(kn(1,L)) = -abs(kc(kn(1,L))) ! 0 or -1
kc(kn(2,L)) = -abs(kc(kn(2,L))) ! 0 or -1
end if
end do
CALL SETNODADM(0)
! output newly created cells that are no cells as polygons
call write_illegal_cells_to_pol(1)
! clean
call dealloc_tpoly(pli)
ENDIF
if ( n12.eq.5 ) then
! SPvdP: disable flow-links that are associated to disabled net-links
do Lf=1,Lnx
if (kcu(Lf) .ne. 2) cycle
L = iabs(ln2lne(Lf))
if ( L.gt.0 ) then
if ( lnn(L).eq.0 ) then
wu(Lf) = 0d0
end if
end if
end do
end if
if ( n12.eq.6 ) then
call realloc(cellmask, nump, fill=1, keepExisting=.false.)
! disable cells with only "lnn<0" links
do L=1,numL
if (kn(3,L) .ne. 2) cycle
if ( lnn(L).gt.0 ) then
! unmask neighboring cell(s)
cellmask(lne(1,L)) = 0
if ( lnn(L).gt.1 ) cellmask(lne(2,L)) = 0
else if ( lnn(L).lt.0 ) then
! reset lnn
lnn(L) = -lnn(L)
end if
end do
call remove_masked_netcells()
if ( allocated(cellmask) ) deallocate(cellmask)
end if
! call restorepol() ! initial SAVEPOL no longer valid due to CUTCELWU call
CALL DELPOL() ! don't keep the cutcell polygons since they will clip the bed levels
if ( jaalltogether.ne.1 ) then
call dealloc_tpoly(pli)
end if
! restore kc
if ( allocated(kc_bak) ) then
do k=1,numk
kc(k) = kc_bak(k)
end do
deallocate(kc_bak)
end if
if ( jamasks.eq.3 ) then
call dealloc_cutcellmasks()
call dealloc_tpoly(pli)
end if
DEALLOCATE ( filist )
return
contains
!> determine for each netlink if it is intersected by the polygon
subroutine find_intersecting_polysections(numpols, pli, idxL, jdxL, pdxL)
use network_data
! use m_polygon
use kdtree2Factory
use m_alloc
use m_missing
use m_tpoly
implicit none
integer, intent(in) :: numpols !< number of tpoly-type polygons
type(tpoly), dimension(numpols), intent(in) :: pli !< tpoly-type polygons
integer, dimension(:), allocatable, intent(out) :: idxL, jdxL ! intersecting polygon sections per netlink in CRS
integer, dimension(:), allocatable, intent(out) :: pdxL ! intersecting polygon numbers per netlink in CRS
type(kdtree_instance) :: kdtree
double precision, dimension(:), allocatable :: x, y
double precision, dimension(:), allocatable :: dsL
integer, dimension(:), allocatable :: iLink, iPol
integer, dimension(:), allocatable :: numcrossed
integer, dimension(:), allocatable :: polynum
integer, dimension(:), allocatable :: polysec
integer :: numcrossedlinks
integer :: i, j, L, num
integer :: ierror
double precision :: t0, t1
! count total number of polygon nodes, including missing and closures
num = numpols-1 ! missing values as seperators
do i=1,numpols
num = num + pli(i)%len + 1 ! 1: closure
end do
! allocate
allocate(iLink(numL))
allocate(iPol(numL))
allocate(dSL(numL))
allocate(x(num))
allocate(y(num))
allocate(polynum(num))
allocate(polysec(num))
call klok(t0)
num = 0
do i=1,numpols
! copy i-the tpoly-type polygon
do j=1,pli(i)%len
num = num+1
x(num) = pli(i)%x(j)
y(num) = pli(i)%y(j)
! add identifier
polynum(num) = i
polysec(num) = j
end do
! add closure
num = num+1
x(num) = pli(i)%x(1)
y(num) = pli(i)%y(1)
! add identifier
polynum(num) = i
polysec(num) = pli(i)%len+1
if ( i.lt.numpols) then
! add seperator
x(num) = DMISS
y(num) = DMISS
! add identifier
polynum(num) = 0
polysec(num) = 0
end if
end do
! find crossed links
call find_crossed_links_kdtree2(kdtree, num, x, y, 3, numL, 1, numcrossedlinks, iLink, iPol, dsL, ierror)
deallocate(x,y)
if ( ierror.ne.0 ) goto 1234
! (re)alloc
call realloc(idxL, numL+1, keepExisting=.false., fill=0)
call realloc(jdxL, numcrossedlinks+1, keepExisting=.false., fill=0)
call realloc(pdxL, numcrossedlinks+1, keepExisting=.false., fill=0)
! count number of intersections per netlink
allocate(numcrossed(numL))
numcrossed = 0
do i=1,numcrossedlinks
L = iLink(i)
numcrossed(L) = numcrossed(L) + 1
end do
! construct CRS of polygon sections that cross the links
idxL(1) = 1
do L=1,numL
idxL(L+1) = idxL(L) + numcrossed(L)
end do
numcrossed = 0
do i=1,numcrossedlinks
L = iLink(i)
num = idxL(L)+numcrossed(L)
j = iPol(i)
jdxL(num) = polysec(j)
pdxL(num) = polynum(j)
numcrossed(L) = numcrossed(L) + 1
end do
1234 continue
call klok(t1)
write(mesg,"('cutcell with kdtree2, elapsed time: ', G15.5, 's.')") t1-t0
call mess(LEVEL_INFO, trim(mesg))
! deallocate
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(iPol) ) deallocate(iPol)
if ( allocated(dsL) ) deallocate(dsL)
if ( allocated(numcrossed) ) deallocate(numcrossed)
if ( allocated(polynum) ) deallocate(polynum)
if ( allocated(polysec) ) deallocate(polysec)
return
end subroutine find_intersecting_polysections
END SUBROUTINE cutcell_list
!> add polygon and fill cutcell mask with "kc"
subroutine store_cutcellmasks(numk, kc, numL, Lmask, xmL, ymL)
use m_cutcells
! use network_data, only: kc, numk
use m_alloc
use unstruc_messages
implicit none
integer, intent(in) :: numk
integer, dimension(numk), intent(in) :: kc
integer, intent(in) :: numL
integer, dimension(numL), intent(in) :: Lmask
double precision, dimension(numL), intent(in) :: xmL, ymL
integer :: istart, k, L, num, i, iL, iR
integer :: numcur, numnew
jastored = 1
if ( NPOL.eq.0 ) then
! initialize
call realloc(ik, NPOL+1, keepexisting=.false., fill=0)
ik(1) = 1
end if
! increase number of polygons
NPOL = NPOL+1
! get startpointer
istart = ik(NPOL)
! count number of new data
num = 0
do k=1,numk
if ( kc(k).eq.1 ) then
num = num+1
end if
end do
! reallocate ik
call realloc(ik, NPOL+1, keepexisting=.true., fill=0)
! add to ik
ik(NPOL+1) = istart + num
! reallocate jk
call realloc(jk, ik(NPOL+1)-1, keepexisting=.true., fill=0)
! add to jk
num = 0
do k=1,numk
if ( kc(k).eq.1 ) then
jk(ik(NPOL)+num) = k
num = num+1
end if
end do
! count number of new intersections
num = 0
do L=1,numL
if ( Lmask(L).eq.1 ) then
num = num+1
end if
end do
! get current number of intersections
if ( allocated(idxL) .and. NPOL.gt.1 ) then
numcur = idxL(numL+1)-1
else
numcur = 0
end if
numnew = numcur+num
! reallocate idxL, jdxL, xdxL, ydxL, pdxL
if ( NPOL.eq.1 ) then
call realloc(idxL, numL+1, keepExisting=.true., fill=1)
end if
call realloc(xdxL, numnew, keepExisting=.true., fill=0d0)
call realloc(ydxL, numnew, keepExisting=.true., fill=0d0)
call realloc(pdxL, numnew, keepExisting=.true., fill=0)
! shift pointers and data
iL = idxL(numL+1)
do L=numL,1,-1
iR = iL-1
iL = idxL(L)
idxL(L+1) = idxL(L+1) + num
if ( Lmask(L).eq.1 ) then
xdxL(iR+num) = xmL(L)
ydxL(iR+num) = ymL(L)
pdxL(iR+num) = NPOL
num = num-1
end if
do i=iL,iR
xdxL(i+num) = xdxL(i)
ydxL(i+num) = ydxL(i)
pdxL(i+num) = pdxL(i)
end do
end do
if ( num.ne.0 ) then
call mess(LEVEL_ERROR, 'store_cutcellmasks: numbering error')
end if
! shift and add to idxL, jdxL, xdxL, ydxL, pdxL
return
end subroutine store_cutcellmasks
subroutine delnetzkabovezkuni()
use m_netw
USE M_MISSING
use gridoperations
implicit none
integer :: k, kk, L, k2, jaweg
do k = 1,numk
if (zk(k) .ne. dmiss) then
if (zk(k) > zkuni) then
jaweg = 0
do kk = 1,nmk(k)
L = nod(k)%lin(kk)
k2 = kn(1,L) + kn(2,L) - k
if (zk(k2) > zkuni .or. zk(k2) == dmiss) then
jaweg = jaweg + 1
endif
enddo
if (jaweg == nmk(k) ) then
xk(k) = dmiss ; yk(k) = dmiss; zk(k) = dmiss
endif
endif
else if (zk(k) == dmiss) then
xk(k) = dmiss ; yk(k) = dmiss; zk(k) = dmiss
endif
enddo
call setnodadm(0)
end subroutine delnetzkabovezkuni
SUBROUTINE DELNET(KEY, jacheckcells, JASAVE)
use m_netw
USE m_missing
use m_sferic, only: jsferic, jasfer3D
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, half
use gridoperations
implicit none
integer :: KEY, jacheckcells, JASAVE
integer :: inhul, inall, ip, ic, n, k, nn, nzero
integer :: ja
integer :: k1
integer :: k2
integer :: l
integer, allocatable :: Lc2(:)
! delete grid
DOUBLE PRECISION :: XL, YL
inhul = -1 ; inall = 1
IF (JASAVE .EQ. 1) CALL SAVENET()
KEY = 3
IF (NPL .LE. 2) THEN
CALL CONFRM('NO POLYON, SO DELETE all NET POINTS ? ',JA)
IF (JA .EQ. 0) THEN
KEY = 0
RETURN
ENDIF
ENDIF
if (jadelnetlinktyp > 0) then
do L = 1,numL
if (kn(3,L) == jadelnetlinktyp) then
k1 = kn(1,L) ; k2 = kn(2,L)
call half(xk(k1),yk(k1),xk(k2),yk(k2),xL,yL, jsferic, jasfer3D)
CALL DBPINPOL( XL, YL, INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
if (inhul == 1) then
kn(1,L) = 0 ; kn(2,L) = 0
endif
endif
enddo
CALL SETNODADM(0)
CALL DELPOL()
return
endif
if (jacheckcells == 1) then
call savepol()
NPL = 0
call findcells(0)
call restorepol()
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
! Delete links IF all of the cells they participate in are in pol.
IF (jacheckcells == 1 .and. (kn(3,L) == 0 .or. kn(3,L) == 2)) then
if (lnn(L) > 0) THEN
inall = 1 ! todo: check als LNN(L) == 0
DO ip = 1,LNN(L)
n = netcell(LNE(ip,L))%n
XL = 0d0 ; YL = 0d0
DO ic = 1,n
XL = XL + XK(netcell(LNE(ip,L))%nod(ic))
YL = YL + YK(netcell(LNE(ip,L))%nod(ic))
end do
XL = XL / n
YL = YL / n
CALL DBPINPOL( XL, YL, INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
IF (INALL == 1) then
inall = INHUL
end if
end do
else
! Rare case: 2D link without surrounding cells.
XL = 0.5D0*( XK(K1) + XK(K2) )
YL = 0.5D0*( YK(K1) + YK(K2) )
CALL DBPINPOL( XL, YL, inall,dmiss, JINS, NPL, xpl, ypl, zpl)
end if
IF (inall .EQ. 1) THEN
KN(1,L) = 0 ; KC(K1) = 0
KN(2,L) = 0 ; KC(K2) = 0
ENDIF
ELSE ! Old behaviour: just check by link mids.
XL = 0.5D0*( XK(K1) + XK(K2) )
YL = 0.5D0*( YK(K1) + YK(K2) )
CALL DBPINPOL( XL, YL, INHUL,dmiss, JINS, NPL, xpl, ypl, zpl)
IF (INHUL .EQ. 1) THEN
KN(1,L) = 0 ; KC(K1) = 0
KN(2,L) = 0 ; KC(K2) = 0
ENDIF
END IF
ELSE IF (K1 .NE. 0) THEN
XL = XK(K1)
YL = YK(K1)
CALL DBPINPOL( XL, YL, INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
IF (INHUL .EQ. 1) THEN
KN(1,L) = 0 ; KC(K1) = 0
KN(2,L) = 0 ; KC(K2) = 0
ENDIF
ELSE IF (K2 .NE. 0) THEN
XL = XK(K2)
YL = YK(K2)
CALL DBPINPOL( XL, YL, INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
IF (INHUL .EQ. 1) THEN
KN(1,L) = 0 ; KC(K1) = 0
KN(2,L) = 0 ; KC(K2) = 0
ENDIF
ENDIF
ENDDO
else if (jacheckcells == 0) then ! netnodes inside
do k = 1,numk
CALL DBPINPOL( Xk(k), Yk(k), INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
if (inhul == 1) then
xk(k) = dmiss ; yk(k) = dmiss
endif
enddo
else if (jacheckcells == 2) then
call savepol()
NPL = 0
call findcells(0)
call restorepol()
kc = 0
do k = 1,numk
CALL DBPINPOL( Xk(k), Yk(k), INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
if (inhul == 1) then
kc(k) = 1
endif
enddo
Lc = 0
do L = 1,numL
k1 = kn(1,L) ; k2 = kn(2,L)
if (kc(k1) == 1 .and. kc(k2) == 1) then
Lc(L) = 1
endif
enddo
allocate (LC2(numL) ) ; Lc2(1:numL) = Lc(1:numL)
do n = 1, nump
nzero = 0
do nn = 1,size(netcell(n)%lin) ! check if any link should be kept for cell n
L = iabs(netcell(n)%lin(nn))
if (L > 0) then
if (Lc(L) == 0) then
nzero = 1 ; exit
endif
endif
enddo
if (nzero == 1) then ! if it should be kept, flag all links of that cell to be kept.
do nn = 1,size(netcell(n)%lin)
L = iabs(netcell(n)%lin(nn))
if (L > 0) then
LC2(L) = 0
endif
enddo
endif
enddo
do L = 1,numL
if (LC2(L) == 1) then
kn(1,L) = 0 ; kn(2,L) = 0
endif
enddo
deallocate (LC2)
end if
CALL SETNODADM(0)
if ( jacheckcells == 0 .or. jacheckcells == 2) then
do k = 1,numk
if ( nmk(k) == 1 ) then
L = nod(k)%lin(1)
if (kn(3,L) == 2) then
xk(k) = dmiss ; yk(k) = dmiss
endif
endif
enddo
CALL SETNODADM(0)
endif
CALL DELPOL()
RETURN
END SUBROUTINE DELNET
SUBROUTINE REMZEROS()
use m_netw
use gridoperations
implicit none
integer :: k
integer :: k1
integer :: k2
integer :: l
integer :: ll
integer :: n
INTEGER, ALLOCATABLE :: NN(:)
ALLOCATE (NN(NUMK)); NN = 0
KC = 0
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDDO
N = 0
DO K = 1,NUMK
IF (KC(K) .NE. 0) THEN
N = N + 1
XK(N) = XK(K)
YK(N) = YK(K)
ZK(N) = ZK(K)
KC(N) = KC(K)
KC(K) = 0
NN(K) = N
ENDIF
ENDDO
LL = 0
DO L = 1,NUML
IF (KN(1,L) .NE. 0 .AND. KN(2,L) .NE. 0) THEN
LL = LL + 1
K1 = KN(1,L)
K2 = KN(2,L)
KN(1,LL) = NN(K1)
KN(2,LL) = NN(K2)
ENDIF
ENDDO
NUML = LL
KC = 0
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDDO
DO L = 1,NUML
IF (KN(1,L) == 0 .OR. KN(2,L) == 0) THEN
N = N
ENDIF
ENDDO
CALL SETNODADM(0)
DEALLOCATE (NN)
RETURN
END SUBROUTINE REMZEROS
SUBROUTINE DELNODE(KP)
use m_netw
use m_missing
implicit none
integer :: KP
double precision :: ag
double precision :: cfl
double precision :: e0
double precision :: eps
integer :: k1
integer :: k2
integer :: l1
integer :: lnu
integer :: nm1
double precision :: pi
double precision :: rho
double precision :: rhow
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
DO NM1 = NMK(KP),1,-1
L1 = NOD(KP)%LIN(NM1)
K1 = KN(1,L1)
K2 = KN(2,L1)
CALL DELELEM(K1,K2,LNU)
ENDDO
NMK(KP) = 0
KC(KP) = 0
XK(KP) = dmiss
YK(KP) = dmiss
ZK(KP) = dmiss
! RM(KP) = 0
RETURN
END SUBROUTINE DELNODE
SUBROUTINE DELLINK(LL)
use m_netw
implicit none
integer :: LL
integer :: k1
integer :: k2
integer :: lnu
IF (LL .NE. 0) THEN
K1 = KN(1,LL) ; K2 = KN(2,LL)
CALL DELELEM(K1,K2,LNU)
LL = 0
ENDIF
RETURN
END SUBROUTINE DELLINK
SUBROUTINE DELELEM(K1,K2,LNU)
use m_netw
implicit none
integer :: K1,K2,LNU
double precision :: ag
double precision :: cfl
double precision :: e0
double precision :: eps
integer :: l1
integer :: l2
integer :: nm1
integer :: nm2
double precision :: pi
double precision :: rho
double precision :: rhow
double precision :: rmas
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
LNU = 0
DO L1 = 1,NMK(K1)
DO L2 = 1,NMK(K2)
IF ( LNU .EQ. 0 .AND. NOD(K1)%LIN(L1) .EQ. NOD(K2)%LIN(L2) ) THEN
LNU = NOD(K1)%LIN(L1)
NOD(K1)%LIN(L1) = 0
NOD(K2)%LIN(L2) = 0
ENDIF
ENDDO
ENDDO
IF (LNU .EQ. 0) THEN
! KN(1,LNU) = 0
! KN(2,LNU) = 0
RETURN
ENDIF
DO L1 = 1,NMK(K1)
IF (NOD(K1)%LIN(L1) .EQ. 0) THEN
NMK(K1) = NMK(K1) - 1
DO NM1 = L1,NMK(K1)
NOD(K1)%LIN(NM1) = NOD(K1)%LIN(NM1+1)
ENDDO
EXIT
ENDIF
ENDDO
IF (NMK(K1) == 0) KC(K1) = 0
DO L2 = 1,NMK(K2)
IF (NOD(K2)%LIN(L2) .EQ. 0) THEN
NMK(K2) = NMK(K2) - 1
DO NM2 = L2,NMK(K2)
NOD(K2)%LIN(NM2) = NOD(K2)%LIN(NM2+1)
ENDDO
EXIT
ENDIF
ENDDO
IF (NMK(K2) == 0) KC(K2) = 0
KN(1,LNU) = 0
KN(2,LNU) = 0
! RMAS = RHO*RL(LNU)*EA(LNU)*1D-6
! RM(K1) = RM(K1) - RMAS/2
! RM(K2) = RM(K2) - RMAS/2
! EA(LNU) = 0
! RL(LNU) = 0
RETURN
END SUBROUTINE DELELEM
SUBROUTINE REMZERONODE(KP)
use m_netw
implicit none
integer :: KP
integer :: k
integer :: l
NUMK = NUMK -1 ! Administratie aanschuiven
DO K = KP,NUMK
XK(K) = XK(K+1)
YK(K) = YK(K+1)
ZK(K) = ZK(K+1)
! IF (NETFLOW .EQ. 1)
KC(K) = KC(K+1)
NMK(K) = NMK(K+1)
DO L = 1,NMK(K)
NOD(K)%LIN(L) = NOD(K+1)%LIN(L)
ENDDO
ENDDO
DO L = 1,NUML
IF (KN(1,L) .GT. KP) KN(1,L) = KN(1,L) - 1
IF (KN(2,L) .GT. KP) KN(2,L) = KN(2,L) - 1
ENDDO
RETURN
END SUBROUTINE REMZERONODE
SUBROUTINE REMZEROELEM(LNU)
use m_netw
implicit none
integer :: LNU
integer :: k
integer :: l
NUML = NUML - 1 ! Administratie aanschuiven
DO L = LNU,NUML
KN(1,L) = KN(1,L+1)
KN(2,L) = KN(2,L+1)
KN(3,L) = KN(3,L+1)
ENDDO
DO K = 1,NUMK
DO L = 1,NMK(K)
IF (NOD(K)%LIN(L) .GT. LNU) NOD(K)%LIN(L) = NOD(K)%LIN(L) - 1
ENDDO
ENDDO
RETURN
END SUBROUTINE REMZEROELEM
SUBROUTINE FAILSAVE()
implicit none
integer :: MSAV
CALL NEWFIL(MSAV,'asave.net')
CALL WRINET(MSAV)
RETURN
END SUBROUTINE FAILSAVE
! SPvdP: TIELDB never called
SUBROUTINE TIELDB()
use m_netw
USE m_missing
use geometry_module, only: dpinpok, cross
use m_sferic, only: jsferic
use gridoperations
implicit none
double precision :: crp
integer :: in1, in2, ja, jacros, k, k1, k2, k3, ku, L, Lnu
double precision :: sl, sm, xcr, ycr, z, zcr, x1, x2, y1, y2
DO L = 1,NUML
K1 = KN(1,L)
K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
CALL DPINPOK( XK(K1), YK(K1), ZK(K1), NPL, XPL, YPL, IN1, jins, dmiss)
CALL DPINPOK( XK(K2), YK(K2), ZK(K2), NPL, XPL, YPL, IN2, jins, dmiss)
IF (IN1 .EQ. 1 .AND. IN2 .EQ. 1) THEN
CALL DRIETWEE(XK(K1),YK(K1),ZK(K1),x1, y1 ,Z)
CALL DRIETWEE(XK(K2),YK(K2),ZK(K2),x2, y2,Z)
K = 0
10 K = K + 1
KU = K + 1 ; IF (KU == MXLAN+1) KU = 1
IF (XLAN(K) .NE. XYMIS .AND. XLAN(K+1) .NE. XYMIS) THEN
CALL CROSS(x1,y1,x2,y2,XLAN(K),YLAN(K),XLAN(K+1),YLAN(K+1),&
JACROS,SL,SM,XCR,YCR,CRP,jsferic, dmiss)
IF (JACROS .EQ. 1) THEN
LNU = L
NUMK = NUMK + 1
K3 = NUMK
ZCR = SL*ZK(K2) + (1-SL)*ZK(K1)
CALL SETPOINT(XCR,YCR,ZCR,K3)
CALL ADDELEM(K1,K3,JA)
CALL ADDELEM(K2,K3,JA)
ENDIF
ENDIF
IF (K .LT. MXLAN) GOTO 10
ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE TIELDB
SUBROUTINE NODEMASS()
use m_netw
USE M_AFMETING
use m_missing, only: jins, dmiss
use geometry_module, only: dpinpok
implicit none
double precision :: ag
double precision :: cfl
double precision :: e0
double precision :: eps
integer :: in1
integer :: in2
integer :: k
integer :: k1
integer :: k2
integer :: l
double precision :: pi
double precision :: rho
double precision :: rhow
double precision :: rmas
COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
! DO K = 1,NUMK
! RM(K) = 0
! ENDDO
DO L = 1,NUML
K1 = KN(1,L)
K2 = KN(2,L)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
CALL DPINPOK( XK(K1), YK(K1), ZK(K1), NPL, XPL, YPL, IN1, jins, dmiss)
CALL DPINPOK( XK(K2), YK(K2), ZK(K2), NPL, XPL, YPL, IN2, jins, dmiss)
! IF (IN1 .EQ. 1 .AND. IN2 .EQ. 1) THEN
! RMAS = RHO*RL(L)*EA(L)*1D-6
! RM(K1) = RM(K1) + RMAS/2
! RM(K2) = RM(K2) + RMAS/2
! ENDIF
ENDIF
ENDDO
RETURN
END SUBROUTINE NODEMASS
SUBROUTINE COPYPOLTOLDB()
use m_polygon
USE M_LANDBOUNDARY
USE M_MISSING
implicit none
integer :: k
integer :: l
L = MXLAN
if ( L.gt.0) then
if (xlan(L).ne.XYMIS ) then
L = L + 1
endif
end if
CALL INCREASELAN(L+NPL)
if ( L.gt.0 ) then
XLAN(L) = XYMIS ; YLAN(L) = XYMIS ; ZLAN(L) = XYMIS
end if
DO K = 1,NPL
L = L + 1
XLAN(L) = XPL(K)
YLAN(L) = YPL(K)
ZLAN(L) = ZPL(K)
ENDDO
MXLAN = L
CALL DELPOL()
RETURN
END SUBROUTINE COPYPOLTOLDB
SUBROUTINE COPYLDBTOPOL()
use m_polygon
use m_missing
use m_landboundary
use geometry_module, only: dbpinpol
implicit none
integer :: k
integer :: mx
integer :: in, num, isnew
double precision, allocatable, dimension(:) :: xdum, ydum, zdum
MX = MAXLAN
! call increasepol(maxlan, 0)
! allocate
allocate(xdum(maxlan), ydum(maxlan), zdum(maxlan))
! initialize
xdum = DMISS
ydum = DMISS
zdum = DMISS
num = 0
isnew = 0
in = -1 ! for initialization of dbpinpol
DO K = 1,MXLAN
if ( xlan(k).ne.DMISS ) then
CALL DBPINPOL(xlan(k), ylan(k), in, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.eq.1 ) then
num = num+1
xdum(num) = XLAN(K)
ydum(num) = YLAN(K)
zdum(num) = zLAN(K)
isnew = isnew+1
else if ( isnew.gt.1 ) then ! add one DMISS at most
num = num+1
xdum(num) = DMISS
ydum(num) = DMISS
zdum(num) = DMISS
isnew = 0 ! no new DMISS will be stored directly hereafter
else if ( isnew.eq.1 .and. num.gt.0 ) then ! do not add a single point
num = num-1
isnew = 0
end if
else
if ( isnew.gt.1 ) then ! add one DMISS at most
num = num+1
xdum(num) = DMISS
ydum(num) = DMISS
zdum(num) = DMISS
isnew = 0 ! no new DMISS will be stored directly hereafter
else if ( isnew.eq.1 .and. num.gt.0 ) then ! do not add a single point
num = num-1
end if
end if
ENDDO
! NPL = MXLAN
! copy to polygon
if ( num.gt.1 ) then
call savepol()
! delete original polygon
NPL = 0
if ( NPL.gt.1 ) then
call increasepol(npl+num+1, 0)
XPL(NPL+1) = DMISS
YPL(NPL+1) = DMISS
zPL(NPL+1) = DMISS
XPL(NPL+2:num+1) = xdum
YPL(NPL+2:num+1) = ydum
zPL(NPL+2:num+1) = zdum
NPL = num+1
else
call increasepol(num, 0)
XPL(1:num) = xdum
YPL(1:num) = ydum
zPL(1:num) = zdum
NPL = num
end if
end if
! deallocate
deallocate(xdum, ydum, zdum)
RETURN
END SUBROUTINE COPYLDBTOPOL
SUBROUTINE COPYLDBPIECETOPOL(M1,M2)
USE M_POLYGON
use m_missing
USE M_LANDBOUNDARY
implicit none
integer :: M1,M2
integer :: m
NPL = M2-M1+1
call increasepol(npl, 0)
DO M = M1,M2
XPL(M-M1+1) = XLAN(M)
YPL(M-M1+1) = YLAN(M)
ENDDO
RETURN
END SUBROUTINE COPYLDBPIECETOPOL
!> copy polygon to spline
SUBROUTINE COPYPOLTOSPLINE()
use m_polygon
use m_splines
use m_missing
use geometry_module, only: get_startend
implicit none
integer :: k
integer :: jstart, jend, jpoint
jpoint = 1
do while ( jpoint.le.NPL )
call get_startend(NPL-jpoint+1,xpl(jpoint:NPL),ypl(jpoint:NPL),jstart,jend, dmiss)
jstart = jstart+jpoint-1
jend = jend+jpoint-1
if ( jend-jstart+1.gt.1 ) then
call addSplinePoints(mcs+1, xpl(jstart:jend), ypl(jstart:jend))
end if
jpoint = jend+1
end do
CALL delpol()
RETURN
END SUBROUTINE COPYPOLTOSPLINE
!> copy spline to resampled polygon
subroutine copySplinesToFinePol(numk)
USE M_SPLINES
use m_polygon
use m_missing
implicit none
integer, intent(in) :: numk !< resample factor
integer :: i, k, m, numpi, Numnew, ierror
double precision :: tn, xk, yk, xh2(500), yh2(500)
! NUMK = 11
do m = 1,mcs
CALL NUMP(m,NUMPI)
IF (NUMPI .GT. 1) THEN
Numnew = 1+(NUMPI-1)*numk
if ( NPL.gt.0 .and. xpl(max(NPL,1)).ne.DMISS ) then
call increasepol(Numnew+2, 1)
NPL = NPL+1
xpl(NPL) = DMISS
else
call increasepol(Numnew+1,1)
end if
do
call sample_spline(NUMPI, xsp(m,1:NUMPI), ysp(m,1:NUMPI), numk-1, Numnew, xpl(NPL+1:NPL+Numnew), ypl(NPL+1:NPL+Numnew), ierror)
if ( ierror.eq.2 ) then
call increasepol(Numnew+1,1)
else
exit
end if
end do
NPL = NPL + Numnew
ENDIF
! add DMISS
NPL = NPL+1
xpl(NPL) = DMISS
ypl(NPL) = DMISS
zpl(NPL) = DMISS
enddo
end subroutine copySplinesToFinePol
SUBROUTINE MIRROR()
use m_netw
implicit none
integer :: k
integer :: k0
integer :: kk
integer :: l
integer :: l0
integer :: ll
integer :: n
K0 = NUMK
L0 = NUML
IF (K0+NUMK .GT. KMAX) THEN
CALL QNERROR('TOO MANY NODES: CALL KERN',' ',' ')
RETURN
ENDIF
IF (L0+NUML .GT. LMAX) THEN
CALL QNERROR('TOO MANY ELEMENTS: CALL KERN',' ',' ')
RETURN
ENDIF
DO K = K0+1, K0+NUMK
KK = K - NUMK
CALL MIRR(XK(KK), YK(KK), ZK(KK), XK(K), YK(K), ZK(K))
! RM(K) = RM(KK)
KC(K) = KC(KK)
NMK(K) = NMK(KK)
DO N = 1,NMK(K)
NOD(K)%LIN(N) = NOD(KK)%LIN(N) + L0
ENDDO
ENDDO
NUMK = K0 + NUMK
DO L = L0+1, L0+NUML
LL = L - NUML
! EA(L) = EA(LL)
! RL(L) = RL(LL)
KN(:,L) = KN(:,LL) + K0
ENDDO
NUML = L0 + NUML
RETURN
END SUBROUTINE MIRROR
SUBROUTINE COPYTRANS()
use m_netw
use m_alloc
use m_missing, only: jins, dmiss
use geometry_module, only: get_startend, dpinpok
implicit none
integer :: ierr
integer :: in
integer :: k
integer :: k0
integer :: k1
integer :: k2
integer :: l
integer :: l0
integer :: lo
integer :: n
double precision :: xoff
double precision :: yoff
double precision :: zoff
INTEGER, ALLOCATABLE :: KC2 (:) , LC2 (:)
ALLOCATE(KC2(NUMK), LC2(NUML), STAT=IERR)
KC2 = 0
LC2 = 0
XOFF = 0
YOFF = 30
ZOFF = 0
K0 = NUMK
L0 = NUML
DO K = 1, NUMK
CALL DPINPOK( XK(K), YK(K), ZK(K), NPL, XPL, YPL, IN, jins, dmiss)
IF (IN .EQ. 1) THEN
K0 = K0 + 1
KC(K0) = K
KC2(K) = K0
XK(K0) = XK(K) + XOFF
YK(K0) = YK(K) + YOFF
ZK(K0) = ZK(K) + ZOFF
! RM(K0) = RM(K)
ENDIF
ENDDO
DO L = 1, NUML
K1 = KN(1,L)
K2 = KN(2,L)
IF (KC2(K1) .NE. 0 .AND. KC2(K2) .NE. 0) THEN
L0 = L0 + 1
! EA(L0) = EA(L)
! RL(L0) = RL(L)
KN(1,L0) = KC2(K1)
KN(2,L0) = KC2(K2)
LC(L0) = L
LC2(L) = L0
KN(3,L0) = L
ENDIF
ENDDO
DO K = NUMK + 1, K0
NMK(K) = 0
DO N = 1,NMK(KC(K)) ! NIEUWE NRS POINTEREN NAAR OUD
L = NOD(KC(K))%LIN(N)
LO = LC2(L)
IF (LO .NE. 0) THEN
K1 = KN(1,LO)
K2 = KN(2,LO)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
NMK(K) = NMK(K) + 1
call realloc(NOD(K)%LIN, NMK(K))
NOD(K)%LIN(NMK(K)) = LO
ENDIF
ENDIF
ENDDO
ENDDO
DO K = NUMK + 1, K0
KC(K) = KC(KC(K))
ENDDO
DO L = NUML + 1, L0
KN(3,L) = KN3TYP
ENDDO
NUMK = K0
NUML = L0
DEALLOCATE(KC2,LC2)
! CALL REMZEROS()
RETURN
END SUBROUTINE COPYTRANS
SUBROUTINE CLOSENODES(K,KK,JA) ! ARE THESE NODES CLOSE, BUT UNCONNECTED?
use m_netw
use m_wearelt
use gridoperations
implicit none
INTEGER :: K,KK,JA
integer :: k2
integer :: l1
integer :: n
integer :: nx
DOUBLE PRECISION :: R0, R1, R2, DLENGTH, SHORTESTLINK
JA = 0
R0 = DLENGTH(K,KK)
IF (R0 > 6d0*RCIR ) RETURN
L1 = NOD(K)%LIN(1)
R1 = SHORTESTLINK(K) ; R2 = SHORTESTLINK(KK); R1 = MIN(R1,R2)*0.4d0
CALL CLOSEENOUGH(XK(K), YK(K), XK(KK), YK(KK), R1, JA)
IF (JA == 0) RETURN
JA = 0
NX = SIZE(NOD(K)%LIN)
DO N = 1, NX
L1 = NOD(K)%LIN(N)
CALL OTHERNODE(K,L1,K2)
IF (K2 == KK) THEN
JA = 0 ; RETURN
ENDIF
ENDDO
NX = SIZE(NOD(KK)%LIN)
DO N = 1, NX
L1 = NOD(KK)%LIN(N)
CALL OTHERNODE(KK,L1,K2)
IF (K2 == K) THEN
JA = 0 ; RETURN
ENDIF
ENDDO
JA = 1 ! KENNELIJK UNCONNECTED
RETURN
END SUBROUTINE CLOSENODES
DOUBLE PRECISION FUNCTION SHORTESTLINK(K)
use m_netw
implicit none
INTEGER :: K
integer :: k1
integer :: k2
integer :: l1
double precision :: r1
INTEGER :: KK, L, NX
DOUBLE PRECISION :: DLENGTH
SHORTESTLINK = 1D9
NX = SIZE(NOD(K)%LIN)
DO KK = 1, NX
L1 = NOD(K)%LIN(KK)
IF (L1 .NE. 0) THEN
K1 = KN(1,L1) ; K2 = KN(2,L1)
IF (K1 .NE. 0 .AND. K2 .NE. 0) THEN
R1 = DLENGTH( K1, K2 )
SHORTESTLINK = MIN(SHORTESTLINK, R1)
ENDIF
ENDIF
ENDDO
RETURN
END FUNCTION SHORTESTLINK
SUBROUTINE MIRR(X,Y,Z,X2,Y2,Z2)
USE M_LANDBOUNDARY
implicit none
DOUBLE PRECISION X,Y,Z,X2,Y2,Z2
double precision :: ym
YM = (YLAN(1) + YLAN(2)) / 2
X2 = X
Y2 = 2*YM - Y
Z2 = Z
RETURN
END SUBROUTINE MIRR
subroutine NEWklok(cpu)
implicit none
double precision :: cpu
real :: currentcpu
call cpu_time(currentcpu)
cpu = currentcpu
end subroutine NEWklok
subroutine org_klok(cpu) ! for true performance monitoring, wallclock gives more meaningfull information than cpuclock
implicit none
INTEGER, DIMENSION(8) :: IV
double precision :: cpu
CALL DATE_AND_TIME(VALUES=IV)
cpu = 3600*iv(5) + 60*iv(6) + iv(7) + 0.001d0*iv(8)
end subroutine org_klok
!> wall clock timer
subroutine klok(t)
use unstruc_messages
implicit none
double precision :: t
character(len=8) :: date
character(len=10) :: time
character(len=5) :: zone
integer :: timing(8)
character(len=128) :: mesg
integer, save :: ndays=0
integer, save :: dayprev=-999
call date_and_time(date, time, zone, timing)
! check for new day
if ( dayprev.eq.-999 ) then
dayprev = timing(3) ! initialization to
else if ( timing(3).ne.dayprev ) then
ndays = ndays+1
write(mesg, "('new wall clock day: previous day=', I2, ', new day=', I2)") dayprev, timing(3)
call mess(LEVEL_INFO, trim(mesg))
dayprev = timing(3)
end if
t = ndays*3600d0*24d0 + timing(5)*3600d0 + timing(6)*60d0 + timing(7) + dble(timing(8))/1000d0
end subroutine klok
SUBROUTINE DRIEEEN(XD,YD,ZD,Z)
implicit none
integer :: jav
integer :: jview
double precision :: xyz
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
DOUBLE PRECISION :: XD,YD,ZD,Z
IF (JVIEW .EQ. 1) THEN ! TEGEN Z-AS
Z = ZD
ELSE IF (JVIEW .EQ. 2) THEN ! VAN LINKS
Z = XD
ELSE IF (JVIEW .EQ. 3) THEN ! NORMAAL
Z = YD
ELSE IF (JVIEW .EQ. 4) THEN
Z = XYZ
ENDIF
RETURN
END SUBROUTINE DRIEEEN
SUBROUTINE NODTOALL()
use m_netw
use gridoperations
implicit none
integer :: ja
integer :: k
integer :: k1
integer :: n1
double precision :: XX,YY,ZZ
N1 = NUMK
XX = 0.5d0 ; YY = 0.5d0 ; ZZ = 0d0
CALL GIVENEWNODENUM(K1)
CALL SETPOINT(XX,YY,ZZ,K1)
DO K = 1,N1
CALL ADDELEM(K1,K,JA)
ENDDO
RETURN
END SUBROUTINE NODTOALL
SUBROUTINE MINMAXPOL(XMIN, YMIN, XMAX, YMAX)
USE M_POLYGON
USE M_MISSING
implicit none
double precision :: XMIN, YMIN, XMAX, YMAX
integer :: k
XMAX = -1E30; XMIN = -XMAX
YMAX = -1E30; YMIN = -YMAX
DO K = 1,NPL
IF (XPL(K) .NE. XYMIS) THEN
XMAX = MAX(XPL(K),XMAX)
YMAX = MAX(YPL(K),YMAX)
XMIN = MIN(XPL(K),XMIN)
YMIN = MIN(YPL(K),YMIN)
ENDIF
ENDDO
END SUBROUTINE MINMAXPOL
SUBROUTINE DSELECTINP(X,Y,N,KIN)
USE M_POLYGON
use m_missing, only: dmiss, jins
use geometry_module, only: dpinpok
implicit none
integer :: N
DOUBLE PRECISION :: X(N), Y(N), ZK
INTEGER :: KIN(N)
integer :: in
integer :: k
double precision :: xmaxp
double precision :: xminp
double precision :: ymaxp
double precision :: yminp
ZK = 1D0
IF (NPL < 3) THEN
KIN = 1
ELSE
CALL MINMAXPOL(XMINp, YMINp, XMAXp, YMAXp)
DO K = 1,N
IN = 0
IF (X(K) >= XMINp .AND. X(K) <= XMAXp .AND. Y(K) >= YMINp .AND. Y(K) <= YMAXp ) THEN
CALL DPINPOK(X(K), Y(K), ZK, NPL, XPL, YPL, IN, jins, dmiss)
ENDIF
KIN(K) = IN
ENDDO
ENDIF
END SUBROUTINE DSELECTINP
SUBROUTINE SELLLINKSINPOL(LIN,N)
use m_netw
use m_missing, only: dmiss, jins
use geometry_module, only: pinpok
implicit none
integer :: N
INTEGER :: LIN(N)
integer :: in
integer :: in2
integer :: k1
integer :: k2
integer :: l
double precision :: xp1
double precision :: xp2
double precision :: xplmax
double precision :: xplmin
double precision :: yp1
double precision :: yp2
double precision :: yplmax
double precision :: yplmin
IF (NPL < 3) THEN
LIN = 1
ELSE
CALL MINMAXPOL(XplMIN, YplMIN, XplMAX, YplMAX)
DO L = 1,NUML
K1 = KN(1,L) ; Xp1 = XK(K1) ; Yp1 = yK(K1)
K2 = KN(2,L) ; Xp2 = XK(K2) ; Yp2 = yK(K2)
IF (Xp1 >= XplMIN .AND. Xp1 <= XplMAX .AND. Yp1 >= YplMIN .AND. Yp1 <= YplMAX .AND. &
Xp2 >= XplMIN .AND. Xp2 <= XplMAX .AND. Yp2 >= YplMIN .AND. Yp2 <= YplMAX ) THEN
CALL PINPOK(Xp1, Yp1, NPL, XPL, YPL, IN, jins, dmiss)
CALL PINPOK(Xp2, Yp2, NPL, XPL, YPL, IN2, jins, dmiss)
LIN(L) = in*in2
ELSE
LIN(L) = 0
ENDIF
ENDDO
ENDIF
END SUBROUTINE SELLLINKSINPOL
SUBROUTINE DELLINKSINPOL()
use m_netw
use m_missing, only: dmiss, jins
use geometry_module, only: pinpok
implicit none
integer :: in
integer :: in2
integer :: k1
integer :: k2
integer :: l
double precision :: xp1
double precision :: xp2
double precision :: xplmax
double precision :: xplmin
double precision :: yp1
double precision :: yp2
double precision :: yplmax
double precision :: yplmin
IF (NPL == 0) THEN
RETURN
ELSE
CALL MINMAXPOL(XplMIN, YplMIN, XplMAX, YplMAX)
DO L = 1,NUML
K1 = KN(1,L) ; Xp1 = XK(K1) ; Yp1 = XK(K1)
K2 = KN(2,L) ; Xp2 = XK(K2) ; Yp2 = XK(K2)
IF (Xp1 >= XplMIN .AND. Xp1 <= XplMAX .AND. Yp1 >= YplMIN .AND. Yp1 <= YplMAX .AND. &
Xp2 >= XplMIN .AND. Xp2 <= XplMAX .AND. Yp2 >= YplMIN .AND. Yp2 <= YplMAX ) THEN
CALL PINPOK(Xp1, Yp1, NPL, XPL, YPL, IN, jins, dmiss)
CALL PINPOK(Xp2, Yp2, NPL, XPL, YPL, IN2, jins, dmiss)
if (in*in2 > 0) then
KN(1,L) = 0 ; KN(2,L) = 0
endif
ENDIF
ENDDO
ENDIF
END SUBROUTINE DELLINKSINPOL
SUBROUTINE RELINK()
use m_netw
use m_ec_triangle
use gridoperations
use m_polygon
use gridoperations
use m_ec_basic_interpolation, only: dlaun
implicit none
double precision :: af
integer :: ierr
integer :: ja
integer :: k
integer :: k1
integer :: k1l
integer :: k2
integer :: k2l
integer :: ki
integer :: l
integer :: ll
integer :: n
integer :: n1
integer :: n2
integer :: new
integer :: nn
INTEGER, ALLOCATABLE :: KIN(:)
double precision, ALLOCATABLE :: X(:), Y(:)
ALLOCATE ( KIN(NUMK), X(NUMK), Y(NUMK) , STAT=IERR)
CALL AERR('KIN(NUMK), X(NUMK), Y(NUMK)', IERR, 3*NUMK)
CALL DSELECTINP(XK,YK,NUMK,KIN)
KI = 0
DO K = 1,NUMK
IF (KIN(K) > 0) THEN
KI = KI + 1
X(KI) = XK(K)
Y(KI) = YK(K)
KIN(KI) = K
ENDIF
ENDDO
CALL READYY('TRIANGULATING', 0d0)
CALL DLAUN(X,Y,KI,1,ierr)
CALL READYY('TRIANGULATING', 0.3d0)
CALL DELLINKSINPOL()
L = NUML
DO N = 1,NUMTRI
AF = 0.3d0 + 0.7d0*dble(N)/dble(NUMTRI)
CALL READYY('TRIANGULATING', AF)
JA = 1
! CALL CHECKTRIANGLE(N,JA)
IF (JA == 0) THEN
CYCLE
ENDIF
DO NN = 1,3
N1 = NN ; N2 = N1 + 1 ; IF (N1 == 3) N2 = 1
K1 = INDX(N1,N) ; K2 = INDX(N2,N)
K1 = KIN(K1) ; K2 = KIN(K2)
NEW = 1
DO LL = NUML, 1, -1
K1L = KN(1,LL) ; K2L = KN(2,LL)
IF (K1 .EQ. K1L .AND. K2 .EQ. K2L .OR. &
K2 .EQ. K1L .AND. K1 .EQ. K2L ) THEN
NEW = 0 ; EXIT
ENDIF
ENDDO
IF (NEW .EQ. 0) CYCLE
L = L + 1 ;
IF (L > LMAX) THEN
CALL INCREASENETW(INT(1.2*NUMK), INT(1.2*NUML) )
ENDIF
NUML = L
KN(1,L) = K1 ; KN(2,L) = K2
ENDDO
ENDDO
DEALLOCATE (KIN)
CALL SETNODADM(1)
CALL READYY('TRIANGULATING', -1d0)
RETURN
END SUBROUTINE RELINK
SUBROUTINE ALLOCXZ()
use m_netw
USE M_FLOWGEOM
implicit none
integer :: mxp
INTEGER :: IERR
IF (ALLOCATED(XZ) ) DEALLOCATE (XZ, YZ)
MXP = MAX(NUMP, NDX)
ALLOCATE ( XZ(MXP), YZ(MXP) , STAT=IERR)
CALL AERR('XZ(MXP), YZ(MXP)', IERR, 2*MXP)
END SUBROUTINE ALLOCXZ
SUBROUTINE ORTHOGONISENET_old()
use m_netw
USE M_FLOWGEOM
USE M_POLYGON
USE M_SFERIC
use m_orthosettings
use m_missing
use geometry_module, only: dbdistance, cross, normaloutchk, GETCIRCUMCENTER, dlinedis
use gridoperations
IMPLICIT NONE
DOUBLE PRECISION :: X0, Y0, X1, Y1, W0, XL, YL, XR, YR, ZZZ
DOUBLE PRECISION :: X2, Y2, X3, Y3, X4, Y4, A, B, DIS, DIS2,DIS3,XN,YN
integer :: JACROS
double precision :: SL,SM,XCR,YCR,CRP
DOUBLE PRECISION :: R01, R23
double precision, ALLOCATABLE :: WW(:,:)
INTEGER, ALLOCATABLE :: KK1(:,:)
INTEGER :: I, N,NO,NN,L,LL,K,KK,K0,K1,K2,K3,KL,KR,kprev,knext,kdone,NMKX,NR,K1L,JA, JA2,JA3,NNI
double precision :: ATPF1
INTEGER, SAVE :: NUMKO = 0, NUMLO = 0
double precision :: area, areatot, xzwr, yzwr, rout, din
double precision, external :: dprodin
double precision :: relaxin, relax1
integer :: JSFERICold
double precision, allocatable :: xbd(:,:), ybd(:,:), xv(:), yv(:)
integer, allocatable :: KC00(:)
integer, allocatable :: kccell(:), lnnl(:)
ATPF1 = 1 - ATPF
allocate(xv(4), yv(4), lnnl(4))
CALL FINDCELLS(0)
! Mark flow geometry as reset to prevent any crashes on redrawing with incomplete xz/yz arrays:
! Moreover: xz ordering is here still by netcell order, and *before* the flow node renumbering.
ndx = 0
lnx = 0
JSFERICold = JSFERIC
! NMKX is max nr of neighbouring netnodes for any node.
NMKX = 0
DO K = 1,NUMK
NMKX = MAX(NMKX, NMK(K))
ENDDO
NMKX = NMKX+1 ! Possibly one additional dummy point at boundary nodes.
IF (ALLOCATED (XK1) ) DEALLOCATE (XK1, YK1)
IF (ALLOCATED (WW) ) DEALLOCATE (WW, KK1 )
ALLOCATE ( XK1( NUMK), YK1( NUMK) )
ALLOCATE ( WW (NMKX , NUMK), KK1(NMKX,NUMK) ) !< Relative attraction weight of all neighbour nodes for all numk nodes.
allocate (xbd(2,numk), ybd(2,numk)) !< Fake nodes attached to bd nodes (inefficient mem usage, but fast access)
!< One per edge node, two for a corner node
allocate (kccell(nump), KC00(NUMK))
kccell = 0
K1 = 0
DO K = 1,NUMK ! KK ADMIN
IF (KC(K) == 1) THEN
DO KK = 1,NMK(K)
L = NOD(K)%LIN(KK)
CALL OTHERNODE (K,L,KK1(KK,K))
ENDDO
ENDIF
ENDDO
KC00 = KC
A = 0.95D0 ; B = 1D0 - A
CALL MAKENETNODESCODING() ! No relinking at the moment: makenetnodescoding outside of numortho loop
! Orthogonalization consists of 3 steps (see below). All three are done itatp times.
! The actual moving of points (step 3) is done (itatp*)itbnd*itin times.
CALL READYY('Orthogonise net',0d0)
DO NO = 1,ITATP
WW = 0
! CALL REMOVESMALLLINKS()
NUMKO = NUMK ; NUMLO = NUML
XK1(1:NUMK) = XK(1:NUMK) ; YK1(1:NUMK) = YK(1:NUMK)
!
! 0. Simple smoothing
!
!DO K0 = 1, 0 ! NUMK
! IF (NB(K0) == 1) THEN
! X0 = XK1(K0) ; Y0 = YK1(K0)
! X1 = 0 ; Y1 = 0
! DO KK = 1,NMK(K0)
! K1L = KK1(KK,K0)
! X1 = X1 + XK1(K1L) ; Y1 = Y1 + YK1(K1L)
! ENDDO
! X1 = X1/NMK(K0) ; Y1 = Y1/NMK(K0)
! XK(K0) = A*X0 + B*X1
! YK(K0) = A*Y0 + B*Y1
! ENDIF
!ENDDO
!
! 1. Create mirrored points for all boundary points (including corner points)
!
KC00 = 0 ! KC00 is used here to mark which boundary points have been mirrorred so far.
DO K0=1,numk ! Loop over K0: the current netnode
if (kc00(K0) == 1) cycle ! was already mirrored
if (nb(k0) == 2 .or. nb(k0) == 3) then ! Edge or corner point
kprev = 0 ! Previous boundary point (used to detect and prevent overlap of two mirrored nodes)
K = K0 ! Current boundary point
DO ! Determine mirrored point for current node ...
! ... and start looping connected boundary points
if (K == 0) then
exit ! No further boundary nodes connected to this chain
end if
X0 = XK1(K) ; Y0 = YK1(K)
NR = 0 ! Nr. of boundary nodes connected to node K that were found already
kccell = 0 ! Marks whether each cell (nump) was already included in areatot for current node K
areatot = 0d0 ! Cumulative area of all internal 2D cells that contain netnode K
knext = 0
kdone = 0
DO KK = 1,NMK(K) ! Consider netlink L between current node K and node K1L
L = NOD(K)%LIN(KK)
IF (LNN(L) == 0) CYCLE
K1L = KK1(KK,K)
X1 = XK(K1L) ; Y1 = YK(K1L)
R01 = DBDISTANCE(X0, Y0, X1, Y1, jsferic, jasfer3D, dmiss)
! Sum up all cell areas (also for corner nodes, may have multiple internal links connected)
if (lne(1,L) > 0) then
if (kccell(lne(1,L)) == 0) then
call getcellsurface ( lne(1,L), area, xzwr, yzwr)
areatot = areatot + area
kccell(lne(1,L)) = 1
end if
end if
IF (LNN(L) == 2 .and. lne(2,L) > 0) THEN ! INTERN
if (kccell(lne(2,L)) == 0) then
call getcellsurface ( lne(2,L), area, xzwr, yzwr)
areatot = areatot + area
kccell(lne(2,L)) = 1
end if
x4 = x1 ! Remember an internal point (#4)
y4 = y1 ! (just an arbitrary one of the nmk-2 total)
ELSE ! RAND
NR = NR + 1
! Remember the two connected boundary points (#2 an #3)
IF (NR == 1) THEN
X2 = X1 ; Y2 = Y1 ; K2 = K1L
ELSE IF (NR == 2) THEN
X3 = X1 ; Y3 = Y1 ; K3 = K1L
ENDIF
WW(KK,K) = R01 ! AvD: TODO: onnodig?
ENDIF
ENDDO
if (nb(K) == 3 .and. NMK(K) == 2) then
! Corner point with no internal links (just two edge links)
! Determine area of the single corner cell.
call getcellsurface(lne(1,nod(K)%lin(1)), areatot, xzwr, yzwr)
x4 = xzwr ! Dummy internal point
y4 = yzwr
end if
if (nb(K) == 3) then
! Fake point at one side of corner:
R01 = DBDISTANCE(X0, Y0, X2,Y2, jsferic, jasfer3D, dmiss)
rout = areatot / R01
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x0,y0,x2,y2,x4,y4,xn,yn, JA, jsferic, jasfer3D, dmiss, dxymis)
xn = xn*rout
yn = yn*rout
xbd(1,K) = x0 + xn
ybd(1,K) = y0 + yn
call movabs(x0,y0)
call clnabs(xbd(1,K),ybd(1,K),51)
! Fake point at other side of corner: ! TODO : WAAROM DEZE MIDDELING TUSSEN 2 EN 3
R01 = DBDISTANCE(X0, Y0, X3,Y3, jsferic, jasfer3D, dmiss)
rout = areatot / R01
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x0,y0,x3,y3,x4,y4,xn,yn, JA, jsferic, jasfer3D, dmiss, dxymis)
xn = xn*rout
yn = yn*rout
xbd(2,K) = x0 + xn
ybd(2,K) = y0 + yn
call movabs(x0,y0)
call clnabs(xbd(2,K),ybd(2,K),31)
! Note: xbd(1 and 2,..) are stored in same order as
! the two boundary links in nod(..)%lin(:).
else
! Compute outward edge length 'rout' as:
! total cells' area / distance between two boundary points.
R23 = DBDISTANCE(X2,Y2,X3,Y3, jsferic, jasfer3D, dmiss)
rout = areatot / R23
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x2,y2,x3,y3,x4,y4,xn,yn, JA, jsferic, jasfer3D, dmiss, dxymis) ! AvD: Not 100% safe: x4 is inside wrt x0, but maybe not wrt line 2-3 (seldomly)
xn = xn*rout
yn = yn*rout
! The mirrored boundary point is now bd point + outward vector
xbd(1,K) = x0 + xn
ybd(1,K) = y0 + yn
call movabs(x0,y0)
call clnabs(xbd(1,K),ybd(1,K),211)
end if
! In the two connected boundary points 2 and 3:
! * Pick one that is also edge (not corner) and not handled yet
! and use it as knext (possibly empty/0)
! * Pick one that was already handled and use it as kdone.
if (nb(k2) == 2) then
if (kc00(k2) == 0) then
knext = k2
else
kdone = k2
end if
end if
if (nb(k3) == 2) then
if (kc00(k3) == 0) then
knext = k3
else
kdone = k3
end if
end if
! If there was no prev boundary point in this chain (inner do),
! we just started a new one. Check if it connects to a chain
! that was previously handled. (happens when starting with k0
! somehere in the middle of a boundary, i.e. not in corner, and
! at a later k0 continue the second half).
if (kprev == 0 .and. kdone > 0) then
kprev = kdone
end if
! Check whether the produced mirror edge crosses with the
! neighbouring mirror edge (only for two edge/non-corner points).
if (kprev > 0) then
if (nb(kprev) == 2 .and. nb(K) == 2) then
call CROSS(x0, y0, xbd(1,K), ybd(1,K), xk(kprev), yk(kprev), xbd(1,kprev), ybd(1,kprev), &
JACROS,SL,SM,XCR,YCR,CRP,jsferic, dmiss)
if (jacros == 1) then
! 'Pull back' the TWO mirrored points to the crossing point
call movabs(x0,y0)
call clnabs(xbd(1,K),ybd(1,K),0)
xbd(1,K) = XCR
ybd(1,K) = YCR
call movabs(x0,y0)
call clnabs(xbd(1,K),ybd(1,K),212)
call movabs(xk(kprev),yk(kprev))
call clnabs(xbd(1,kprev),ybd(1,kprev),0)
xbd(1,kprev) = XCR
ybd(1,kprev) = YCR
call movabs(xk(kprev),yk(kprev))
call clnabs(xbd(1,kprev),ybd(1,kprev),212)
end if
end if
end if
! Current point is done, proceed to next connected bd point
KC00(K) = 1 ! Mark netnode K as done
kprev = k
K = knext ! One of the points #2/#3, or none when ready (0)
end do ! loop across connected edge points
end if
end do ! numk
CALL READYY('Orthogonise net',dble(NO-1+.35d0)/ITATP)
!
! 2. Compute attraction parameters for all nodes surrounding each node (incl. mirrored nodes from step 1)
!
numka:DO K0 = 1,NUMK ! ATTRACTION PARAMETERS
X0 = XK1(K0) ; Y0 = YK1(K0)
W0 = 0
IF (NB(K0) == 1) THEN ! INTERNAL
DO KK = 1,NMK(K0)
L = NOD(K0)%LIN(KK)
KL = LNE(1,L)
KR = LNE(2,L)
IF (LNN(L) == 2) THEN
CALL GETCELLWEIGHTEDCENTER(KL, XL, YL, ZZZ)
CALL GETCELLWEIGHTEDCENTER(KR, XR, YR, ZZZ)
XZ(KL) = XL ; YZ(KL) = YL
XZ(KR) = XR ; YZ(KR) = YR
WW(KK,K0) = DBDISTANCE(XL,YL,XR,YR, jsferic, jasfer3D, dmiss)
K1L = KK1(KK,K0)
! If any connected node is unmasked (i.e. outside of polygon), fix this point
if (KC(K1L) /= 1) then
NB(K0) = 0
cycle numka
end if
X1 = XK(K1L) ; Y1 = YK(K1L)
R01 = DBDISTANCE(X0,Y0,X1,Y1, jsferic, jasfer3D, dmiss)
R01 = ATPF1 + ATPF*R01
IF (R01 .NE. 0) THEN
WW(KK,K0) = WW(KK,K0)/R01
IF (JSFERIC == 1) THEN
WW(KK,K0) = WW(KK,K0)/COS( DG2RD*0.5D0*(Y0+Y1) )
ENDIF
W0 = W0 + WW(KK,K0)
ENDIF
ENDIF
ENDDO
ELSE IF (NB(K0) == 2) THEN ! EDGE NODES
NR = 0
DO KK = 1,NMK(K0)
L = NOD(K0)%LIN(KK)
KL = LNE(1,L)
KR = LNE(2,L)
K1L = KK1(KK,K0)
X1 = XK(K1L) ; Y1 = YK(K1L)
! If any connected node is unmasked (i.e. outside of polygon), fix this point
if (KC(K1L) /= 1) then
NB(K0) = 0
cycle numka
end if
IF (LNN(L) == 1) THEN ! Neighbour nodes at boundary
CALL GETCELLWEIGHTEDCENTER(KL, XL, YL, ZZZ)
!call cirr(XL,YL,71)
K1L = kk1(KK, K0)
nn = 0 ! Nr of ghost point at node K1L (1 or 2)
if (nb(K1L) == 3) then
! Determine which ghostpoint this is going to be, the first or second (=index in xbd)
do K=1,NMK(K1L)
LL = nod(K1L)%lin(K)
if (lnn(LL) == 1) then
nn = nn + 1
else
cycle ! No boundary link, try next
end if
call othernode(K1L, LL, K1)
if (K1 == K0) then
exit ! This is the connecting link, NN now has the correct value for use in xbd.
end if
end do
else
nn = 1
end if
! Corrupted networks with overlapping links may contain points with >2 links with lnn=1
nn = min(nn, 2)
xv(1) = XK(K0) ; yv(1) = YK(K0)
xv(2) = XK(K1L) ; yv(2) = YK(K1L)
xv(3) = xbd(1,K0) ; yv(3) = ybd(1,K0)
xv(4) = xbd(NN,K1L) ; yv(4) = ybd(NN,K1L)
lnnl(1:4) = 2
call GETCIRCUMCENTER( 4, xv, yv, lnnl, XR, YR, jsferic, jasfer3D, jglobe, jins, dmiss, dxymis, dcenterinside)
!XR = .25d0*(XK(K0) + XK(K1L) + xbd(K0) + xbd(K1L))
!YR = .25d0*(YK(K0) + YK(K1L) + ybd(K0) + ybd(K1L))
!call cirr(XR,YR,41)
NR = NR + 1
IF (NR == 1) THEN ! Store first bd point (#2)
K2 = K1L
X2 = XR ; Y2 = YR
ELSE IF (NR == 2) THEN ! Store second bd point (#3)
K3 = K1L
X3 = XR ; Y3 = YR
ENDIF
elseIF (LNN(L) == 2) THEN ! Internal neighbouring nodes
CALL GETCELLWEIGHTEDCENTER(KL, XL, YL, ZZZ)
CALL GETCELLWEIGHTEDCENTER(KR, XR, YR, ZZZ)
XZ(KL) = XL ; YZ(KL) = YL
XZ(KR) = XR ; YZ(KR) = YR
ENDIF
WW(KK,K0) = DBDISTANCE(XL,YL,XR,YR, jsferic, jasfer3D, dmiss)
R01 = DBDISTANCE(X0,Y0,X1,Y1, jsferic, jasfer3D, dmiss)
R01 = ATPF1 + ATPF*R01
IF (R01 .NE. 0) THEN
WW(KK,K0) = WW(KK,K0)/R01
W0 = W0 + WW(KK,K0)
ENDIF
ENDDO !KK = 1,NMK(K0)
KK=nmk(K0)+1
XL = X2 ; YL = Y2 ; XR = X3 ; YR = Y3
WW(KK,K0) = DBDISTANCE(XL,YL,XR,YR, jsferic, jasfer3D, dmiss)
X1 = xbd(1,K0) ; Y1 = ybd(1,K0)
R01 = DBDISTANCE(X0,Y0,X1,Y1,jsferic, jasfer3D, dmiss)
R01 = ATPF1 + ATPF*R01
IF (R01 .NE. 0) THEN
WW(KK,K0) = WW(KK,K0)/R01
W0 = W0 + WW(KK,K0)
ENDIF
ENDIF
IF (W0 .NE. 0) THEN ! NORMALISING
DO KK = 1,NMK(K0)
WW(KK,K0) = WW(KK,K0) / W0
ENDDO
IF (NB(K0) == 2) THEN
KK = NMK(K0) + 1
WW(KK,K0) = WW(KK,K0) / W0
end if
ENDIF
ENDDO numka
CALL READYY('Orthogonise net',dble(NO-1+.8d0)/ITATP)
!
! 3. Solve the 'Laplacian' for orthogonalization/Move all points in a few iteration steps.
!
! call toemaar()
relaxin = 0.5d0
relax1 = 1d0-relaxin
DO I = 1,ITBND
DO N = 1,ITIN
ndki:DO K = 1,NUMK
IF (NB(K) == 1) THEN ! Only internal points
X0 = 0D0 ; Y0 = 0D0
DO KK = 1,NMK(K)
IF (WW(KK,K) .NE. 0) THEN
X0 = X0 + WW(KK,K) * XK(KK1(KK,K))
Y0 = Y0 + WW(KK,K) * YK(KK1(KK,K))
ENDIF
ENDDO
XK1(K) = relaxin*X0 + relax1*xk(k) !hk: trying to remove wiggles in high aspect ratio cells
YK1(K) = relaxin*y0 + relax1*yk(k)
ENDIF
ENDDO ndki
XK(1:NUMK) = XK1(1:NUMK) ; YK(1:NUMK) = YK1(1:NUMK)
ENDDO ! ITIN
ndkb:DO K = 1,NUMK
IF (NB(K) == 2 ) THEN ! Only edge points (not corner)
X0 = 0D0 ; Y0 = 0D0 ! was 0
NR = 0
DO KK = 1,NMK(K)
! AvD: TEMP: do not move points connected to a corner.
if (NB(KK1(KK,K)) == 3) then
XK1(K) = XK(K); YK1(K) = YK(K)
cycle ndkb
end if
IF (WW(KK,K) .NE. 0) THEN
X0 = X0 + WW(KK,K) * XK(KK1(KK,K))
Y0 = Y0 + WW(KK,K) * YK(KK1(KK,K))
ENDIF
IF (LNN(NOD(K)%LIN(KK)) == 1) then
! Remember the two boundary neighbours in ORIGINAL net.
NR = NR + 1
IF (NR == 1) THEN
X2 = XK0(KK1(KK,K)) ; Y2 = YK0(KK1(KK,K))
ELSE IF (NR == 2) THEN
X3 = XK0(KK1(KK,K)) ; Y3 = YK0(KK1(KK,K))
ENDIF
end if
ENDDO
! For edge nodes, include attraction by mirrored node xbd too.
KK = NMK(K)+1
IF (WW(KK,K) .NE. 0) THEN
X0 = X0 + WW(KK,K) * xbd(1,K)
Y0 = Y0 + WW(KK,K) * ybd(1,K)
ENDIF
! Project the moved boundary point back onto the closest
! ORIGINAL edge (netlink) (either between 0 and 2 or 0 and 3)
CALL DLINEDIS(X0,Y0,XK0(K),YK0(K),X2,Y2,JA2,DIS2,X2,Y2,jsferic, jasfer3D, dmiss)
CALL DLINEDIS(X0,Y0,XK0(K),YK0(K),X3,Y3,JA3,DIS3,X3,Y3,jsferic, jasfer3D, dmiss)
IF (DIS2 < DIS3) THEN
X0 = X2 ; Y0 = Y2
ELSE
X0 = X3 ; Y0 = Y3
ENDIF
! Smoothing (necessary?)
XK1(K) = X0 ; YK1(K) = Y0
XK1(K) = X0 ; YK1(K) = Y0
ENDIF
ENDDO ndkb
XK(1:NUMK) = XK1(1:NUMK) ; YK(1:NUMK) = YK1(1:NUMK)
ENDDO !ITBND
CALL READYY('Orthogonise net',dble(NO)/ITATP)
ENDDO !ITATP
CALL READYY('Orthogonise net',-1d0)
! CALL REMOVESMALLLINKS()
!IF (JSFERICOLD == 1) THEN
! CALL MAKEY1D(XK,YK,NUMK)
! CALL MAKEY1D(XK0,YK0,NUMK)
! JSFERIC = JSFERICOLD
!ENDIF
call update_cell_circumcenters()
call cosphiunetcheck(0)
!!!
deallocate(xv, yv, lnnl)
deallocate (xbd, ybd)
deallocate (kccell,KC00)
DEALLOCATE ( WW, KK1)
!, NB ) ! AvD: TODO: this is for showing node codes (during ortho), but also introduces memleak.
END SUBROUTINE ORTHOGONISENET_old
!> Make a coding of all net nodes for later use in net orthogonalisation,
!! net coupling and 'poltoland' functionality.
!! network_data::NB values: 1=INTERN, 2=RAND, 3=HOEK, 0/-1=DOET NIET MEE OF 1D
SUBROUTINE MAKENETNODESCODING()
use m_netw
use m_sferic, only: jsferic, jasfer3D
use m_missing, only : dxymis
use geometry_module, only: dcosphi
use gridoperations
implicit none
integer :: k
integer :: k1
integer :: k2
integer :: L, LL
IF (ALLOCATED (NB)) DEALLOCATE (NB)
ALLOCATE (NB(NUMK)) ; NB = 0
DO L = 1,NUML ! NODE BOUNDARY ADMINISTRATION
K1 = KN(1,L) ; K2 = KN(2,L)
if ( k1.lt.1 .or. k2.lt.1 ) cycle ! SPvdP: safety
IF (KN(3,L) == 2 .or. KN(3,L) == 0 ) THEN
IF (NB(K1) .NE. -1 .AND. NB(K2) .NE. -1) THEN
IF (LNN(L) == 0) THEN ! LINK ZONDER BUURCELLEN
NB(K1) = -1 ; NB(K2) = -1
ELSE IF (LNN(L) == 1) THEN ! LINK MET 1 BUURCEL
NB(K1) = NB(K1) + 1
NB(K2) = NB(K2) + 1
ENDIF
ENDIF
else ! (kn(3,l) == 1 .or. kn(3,l) == 3 .or. kn(3,L) == 4) then ! 1D-links sowieso niet meenemen.
nb(k1) = -1
nb(k2) = -1
ENDIF
ENDDO
! INTERNE PUNTEN BLIJVEN OP NUL STAAN
DO K = 1, NUMK
IF (KC(K) == 1) THEN
IF (NB(K) == 1 .OR. NB(K) == 2) THEN
IF (NMK(K) == 2) THEN
NB(K) = 3 ! HOEKPUNT 'bolle hoek'
ELSE
! NMK(K) > 2: find the two edge links (and connected neighbour nodes K1 and K2)
K1 = 0 ; K2 = 0
do L=1,NMK(K)
LL = nod(K)%lin(L)
if (LNN(LL) == 1) then
if (K1 == 0) then
call othernode(K, LL, K1)
else
call othernode(K, LL, K2)
end if
end if
end do
if (K1 /= 0 .and. K2 /= 0) then
if (dcosphi(xk(k),yk(k),xk(k1),yk(k1), &
xk(k),yk(k),xk(k2),yk(k2), jsferic, jasfer3D, dxymis) > -CORNERCOS) then ! cos(90+15) = -.25
NB(K) = 3 ! HOEKPUNT 'holle hoek'
else
NB(K) = 2 ! RANDPUNT
end if
else
NB(K) = 2 ! RANDPUNT
end if
ENDIF
ELSE IF (NB(K) .gt. 2) THEN
NB(K) = 3 ! 'HOEKPUNT' tussen disjuncte cellen.
ELSE IF (NB(K) .NE. -1) THEN
NB(K) = 1 ! INTERN PUNT
ENDIF
ELSE
NB(K) = 0 ! DOET NIET MEE
ENDIF
ENDDO
do k = 1,numk
! if (kc(k) == 0) nb(k) = 0
if ( nmk(k) .lt. 2 ) nb(k) = -1 ! hanging node
enddo
END SUBROUTINE MAKENETNODESCODING
SUBROUTINE REMOVESMALLLINKS() ! 1 REMOVES IF FLOW LINK DISTANCES ARE SMALL RELATIVE TO CONNECTED CELL SIZES
use m_netw ! 2 REMOVES SMALL TRIANGLES NEXT TO
use M_FLOWGEOM
use unstruc_messages
use geometry_module, only: dbdistance, dcosphi, dlinedis
use m_missing, only: dmiss, dxymis
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use gridoperations
implicit none
integer :: minp
DOUBLE PRECISION :: R01, R02, AN1, AN2, XL, YL, XR, YR, XZWr, YZWr, ZZZ
INTEGER :: KL1, KL2, KN1a, KN2a, L, jaremove
DOUBLE PRECISION :: AREA, TAREA, COSMIN, COSPHI, FRAC, DIS, XN, YN
INTEGER :: NAAST, N, NN, NUMT, LL, K0, K1, K2, KHOEK, LU, LD, KA, KB, KH, K, JA, KNEW, IERR, NW
INTEGER :: LLA, LLB, LLC, L0, L1, L2, LT, LI, KK, NL, NR
DOUBLE PRECISION, ALLOCATABLE :: XNW(:), YNW(:)
INTEGER , ALLOCATABLE :: NNW(:,:)
CALL SAVENET()
CALL SETNODADM(0) !
CALL REMOVECOINCIDINGTRIANGLES() !
CALL FINDCELLS(0)
! take dry cells into account (after findcells)
call delete_dry_points_and_areas()
JAREMOVE = 0
DO L = 1, NUML ! REMOVE SMALL CIRCUMCENTRE DISTANCES
IF (LC(L) == 1) THEN
KL1 = KN(1,L) ; KL2 = KN(2,L)
IF (KL1 > 0 .AND. KL2 > 0) THEN
KN1a = LNE(1,L) ; KN2a = LNE(2,L)
IF (KN1a > 0 .AND. KN2a > 0) THEN
NL = netcell(KN1a)%N ; NR = netcell(KN2a)%N
!! SPvdP: only remove small flow links, if adjacent cells are triangles
! IF ( (NL == 3 .or. NL == 4) .and. (NR == 3 .or. NR == 4) ) THEN
IF ( (NL == 3 .and. NR == 3 .and. maxfaceallow == 4) .or. &
(NL == 3 .or. NL == 4) .and. (NR == 3 .or. NR == 4) .and. maxfaceallow == 5 ) THEN
CALL GETCELLSURFACE (KN1a,AN1, XZWr, YZWr)
CALL GETCELLSURFACE (KN2a,AN2, XZWr, YZWr)
CALL GETCELLWEIGHTEDCENTER(KN1a, XL, YL, ZZZ)
CALL GETCELLWEIGHTEDCENTER(KN2a, XR, YR, ZZZ)
R01 = 0.5d0*(SQRT(AN1) + SQRT(AN2)) ! TYPICAL SIDE
R02 = DBDISTANCE (XL, YL, XR, YR,jsferic, jasfer3D, dmiss) ! CIRCUMDISTANCE
IF (R02 < removesmalllinkstrsh*R01) THEN
KN(1,L) = 0 ; KN(2,L) = 0 ; KN(3,L) = -1 ! CALL DELLINK(L)
JAREMOVE = 1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
IF (JAREMOVE == 1) THEN
CALL FINDCELLS(0)
ENDIF
ALLOCATE ( XNW(NUMK),YNW(NUMK),NNW(3,NUMK) , STAT=IERR )
CALL AERR('XNW(NUMK),YNW(NUMK),NNW(3,NUMK)', IERR, NUMK*3)
JAREMOVE = 0 ; NW = 0
DO LT = 1,NUML
N = LNE(1,LT) ; NN = 0
IF (N > 0 ) NN = NETCELL(N)%N
IF (LNN(LT) == 1 .AND. NN == 3) THEN ! SMALL BOUNDARY TRIANGLES
TAREA = 0D0; NUMT = 0
DO LL = 1,3 ! ESTABLISH TYPICAL CELLSIZE ADJACENT QUADS
L = NETCELL(N)%LIN(LL)
IF (LNN(L) == 2 ) THEN
KN1a = LNE(1,L) ; KN2a = LNE(2,L)
IF (KN1A == N) THEN
NAAST = KN2A
ELSE
NAAST = KN1A
ENDIF
IF (NETCELL(NAAST)%N > 3) THEN ! ADJACENT QUADS ETC
CALL GETCELLSURFACE ( NAAST, AREA, XZWr, YZWr)
TAREA = TAREA + AREA; NUMT = NUMT + 1
ENDIF
ENDIF
enddo
IF (NUMT .NE. 0) THEN
TAREA = TAREA / NUMT
ENDIF
IF (TAREA .NE. 0) THEN
CALL GETCELLSURFACE ( N, AREA, XZWr, YZWr)
IF (AREA > 0D0) THEN
FRAC = AREA/TAREA
IF (FRAC < TRIAREAREMFRAC) THEN
COSMIN = 1D0
DO LL = 1,3 ! FIND KHOEK
LU = LL + 1 ; IF (LU == 4) LU = 1
LD = LL - 1 ; IF (LD == 0) LD = 3
K0 = NETCELL(N)%NOD(LD) ; L0 = NETCELL(N)%LIN(LD)
K1 = NETCELL(N)%NOD(LL) ; L1 = NETCELL(N)%LIN(LL)
K2 = NETCELL(N)%NOD(LU) ; L2 = NETCELL(N)%LIN(LU)
COSPHI = ABS( DCOSPHI(XK(K0),YK(K0),XK(K1),YK(K1),XK(K1),YK(K1),XK(K2),YK(K2), jsferic, jasfer3D, dxymis) )
IF (COSPHI < COSMIN) THEN
COSMIN = COSPHI
KA = K0; KH = K1; KB = K2; LLA = L0; LLB = L1; LLC = L2
ENDIF
ENDDO
IF (COSMIN < 0.2 .AND. LNN(LLC) == 1) THEN
CALL dLINEDIS(XK(KH),YK(KH),XK(KA),YK(KA),XK(KB),YK(KB),JA,DIS,XN,YN, jsferic, jasfer3D, dmiss)
NW = NW + 1
XNW (NW) = XN
YNW (NW) = YN
NNW(1,NW) = KH
NNW(2,NW) = KA
NNW(3,NW) = KB
JAREMOVE = 1 ; CYCLE
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
IF (JAREMOVE == 1) THEN
DO K = 1,NW
KH = NNW(1,K)
KA = NNW(2,K)
KB = NNW(3,K)
XK(KH) = XNW( K)
YK(KH) = YNW( K)
LI = 0
DO KK = 1, NMK(KA) ! NOG EVEN CHECKEN OF DE LINK TUSSEN KA EN KH NIET MEER DAN ENKELVOUDIG INTERN VERBONDEN IS
L = NOD(KA)%LIN(KK)
IF (LNN(L) == 2) THEN
LI = LI + 1
ENDIF
ENDDO
IF (LI == 1) THEN
CALL MERGENODES(KA,KH,JA)
ENDIF
LI = 0
DO KK = 1, NMK(KB)
L = NOD(KB)%LIN(KK)
IF (LNN(L) == 2) THEN
LI = LI + 1
ENDIF
ENDDO
IF (LI == 1) THEN
CALL MERGENODES(KB,KH,JA)
ENDIF
ENDDO
CALL SETNODADM(0)
! netcell administration out of date
netstat = NETSTAT_CELLS_DIRTY
ENDIF
DEALLOCATE(XNW,YNW,NNW)
END SUBROUTINE REMOVESMALLLINKS
SUBROUTINE REMOVECOINCIDINGTRIANGLES()
use m_netw ! 2 REMOVES SMALL TRIANGLES NEXT TO
USE M_FLOWGEOM
use unstruc_messages
use m_sferic
use geometry_module, only: getdxdy
use gridoperations
implicit none
DOUBLE PRECISION :: DX2,DY2,DX3,DY3,DEN
INTEGER :: K1, K2, K3, KDUM, N, L, LL, JA, IERR
DOUBLE PRECISION, ALLOCATABLE :: XNW(:), YNW(:)
INTEGER , ALLOCATABLE :: NNW(:,:)
DOUBLE PRECISION, EXTERNAL :: getdx, getdy
CALL FINDCELLS(3)
ALLOCATE ( XNW(NUMP),YNW(NUMP),NNW(3,NUMP) , STAT=IERR )
CALL AERR('XNW(NUMP),YNW(NUMP),NNW(3,NUMP)', IERR, NUMK*3)
NNW = 0
DO N = 1, NUMP ! REMOVE COINCIDING TRIANGLES
K1 = NETCELL(N)%NOD(1); K2 = NETCELL(N)%NOD(2) ; K3 = NETCELL(N)%NOD(3)
! fix for spherical, periodic coordinates
if ( jsferic.eq.1 .and. abs(abs(yk(k1))-90d0).lt.dtol_pole ) then
kdum = k1
k1 = k2
k2 = k3
k3 = kdum
end if
!dx2 = getdx(XK(K1), YK(K1), XK(K2), YK(K2)) ! AvD: TODO: getdx toepassen
!dy2 = getdy(XK(K1), YK(K1), XK(K2), YK(K2))
call getdxdy(XK(K1), YK(K1), XK(K2), YK(K2), dx2,dy2, jsferic)
!dx3 = getdx(XK(K1), YK(K1), XK(K3), YK(K3))
!dy3 = getdy(XK(K1), YK(K1), XK(K3), YK(K3))
call getdxdy(XK(K1), YK(K1), XK(K3), YK(K3), dx3,dy3, jsferic)
den = dy2*dx3-dy3*dx2
IF (DEN == 0D0) THEN
DO LL = 1,3
L = NETCELL(N)%LIN(LL)
KN(1,L) = 0 ; KN(2,L) = 0
ENDDO
NNW(1,N) = K1 ;NNW(2,N) = K2 ; NNW(3,N) = K3
XNW(N) = (XK(K1) + XK(K2) + XK(K3)) / 3D0
YNW(N) = (YK(K1) + YK(K2) + YK(K3)) / 3D0
ENDIF
ENDDO
DO N = 1,NUMP
K1 = NNW(1,N) ; K2 = NNW(2,N) ; K3 = NNW(3,N)
IF (K1 > 0) THEN
XK(K1) = XNW(N)
YK(K1) = YNW(N)
CALL MERGENODES(K2,K1,JA)
CALL MERGENODES(K3,K1,JA)
ENDIF
ENDDO
DEALLOCATE(XNW,YNW,NNW)
END SUBROUTINE REMOVECOINCIDINGTRIANGLES
SUBROUTINE MIRRORLINEPOINT (X0,Y0,X3,Y3,X1,Y1,X2,Y2,JA,DIS,XN,YN)
use geometry_module, only: getdxdy, dlinedis
use m_sferic
use m_missing
implicit none
double precision :: X0,Y0,X3,Y3,X1,Y1,X2,Y2,DIS,XN,YN, dx0, dy0
double precision :: getdx, getdy
integer :: JA
CALL DLINEDIS(X0,Y0,X1,Y1,X2,Y2,JA,DIS,XN,YN,jsferic, jasfer3D, dmiss)
!DX0 = GETDX(X0,Y0,XN,YN)
!DY0 = GETDY(X0,Y0,XN,YN)
call getdxdy(X0,Y0,XN,YN,dx0,dy0, jsferic)
CALL dlinedis(X3,Y3,X1,Y1,X2,Y2,JA,DIS,XN,YN,jsferic, jasfer3D, dmiss)
XN = 2*XN-X3 + DX0
YN = 2*YN-Y3 + DY0
RETURN
END SUBROUTINE MIRRORLINEPOINT
SUBROUTINE MIRRORLINE (X0,Y0,X1,Y1,X2,Y2,JA,DIS,XN,YN)
use geometry_module, only: dlinedis
use m_sferic
use m_missing
implicit none
double precision :: X0,Y0,X1,Y1,X2,Y2,DIS,XN,YN
integer :: JA
CALL dLINEDIS(X0,Y0,X1,Y1,X2,Y2,JA,DIS,XN,YN,jsferic, jasfer3D, dmiss)
XN = 2*XN - X0
YN = 2*YN - Y0
RETURN
END SUBROUTINE MIRRORLINE
SUBROUTINE MIRRORLINE2(X0,Y0,X1,Y1,X2,Y2,JA,DIS,XN,YN) ! 2*ZO VER
use geometry_module, only: dlinedis
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
double precision :: X0,Y0,X1,Y1,X2,Y2,DIS,XN,YN
integer :: JA
CALL dLINEDIS(X0,Y0,X1,Y1,X2,Y2,JA,DIS,XN,YN,jsferic, jasfer3D, dmiss)
XN = 3*XN - 2*X0
YN = 3*YN - 2*Y0
RETURN
END SUBROUTINE MIRRORLINE2
SUBROUTINE GETQUAD(LN,K1,K2,K3N,K4N)
use m_netw
use gridoperations
implicit none
integer :: LN,K1,K2,K3N,K4N
integer :: k
integer :: k1a
integer :: k3
integer :: k4
integer :: kk
integer :: kkk
integer :: l
integer :: ll
integer :: lll
K3N = 0 ; K4N = 0
DO K = 1,NMK(K2)
L = NOD(K2)%LIN(K)
IF (L == LN) CYCLE
CALL OTHERNODE(K2,L,K3)
DO KK = 1,NMK(K3)
LL = NOD(K3)%LIN(KK)
IF (LL == L) CYCLE
CALL OTHERNODE(K3,LL,K4)
DO KKK = 1,NMK(K4)
LLL = NOD(K4)%LIN(KKK)
IF (LLL == LL) CYCLE
CALL OTHERNODE(K4,LLL,K1A)
IF (K1A == K1) THEN
K3N = K3 ; K4N = K4
ENDIF
ENDDO
ENDDO
ENDDO
END SUBROUTINE GETQUAD
!> delete samples
!> jaconfirm=0: do not prompt for confirmation, keep arrays, make copy
!> 1: prompt for confirmation, keep arrays, make copy
!> -1: do not prompt for confirmation, deallocate arrays, do not make copy
SUBROUTINE DELSAM(JACONFIRM) ! SPvdP: need promptless delsam in orthogonalisenet
USE M_SAMPLES
use m_polygon
USE m_missing
use geometry_module, only: dbpinpol
implicit none
integer, intent(in) :: JACONFIRM !< prompt for confirmation (1) or not (0)
integer :: i
integer :: inhul
integer :: ja
integer :: k
integer :: key
integer :: nsol
double precision :: rd
double precision :: xi
double precision :: yi
if (jaconfirm == -1) then
if (nsmax > 0) then
nsmax = 0 ; ns = 0
if ( allocated(xs) ) deallocate (xs, ys, zs)
if ( allocated(ipsam) ) deallocate(ipsam)
endif
return
endif
IF (Npl .LE. 2) THEN
if ( JACONFIRM.eq.1 ) then
CALL CONFRM('NO POLYON, SO DELETE all SAMPLE POINTS ? ',JA)
else
JA = 1
end if
IF (JA .EQ. 0) THEN
KEY = 0
RETURN
ENDIF
CALL SAVESAM()
DO 5 I = 1,NS
XS(I) = DMISS
YS(I) = DMISS
ZS(I) = DMISS
ipsam(i) = 0
5 CONTINUE
NS = 0
RETURN
ENDIF
! Else: check in polygon
CALL SAVESAM()
INHUL = -1
DO 10 I = 1,NS
RD = ZS(I)
XI = XS(I)
YI = YS(I)
CALL DBPINPOL(xI, yI, INHUL, dmiss, JINS, NPL, xpl, ypl, zpl)
IF (INHUL .EQ. 1) ZS(I) = dmiss
10 CONTINUE
K = 0
NSOL = NS
DO 20 I = 1,NS
IF (ZS(I) .NE. dmiss) THEN
K = K + 1
XS(K) = XS(I)
YS(K) = YS(I)
ZS(K) = ZS(I)
ipsam(k) = ipsam(i)
ENDIF
20 CONTINUE
NS = K
DO 30 I = NS+1,NSOL
XS(I) = DMISS
YS(I) = DMISS
ZS(I) = DMISS
ipsam(i) = 0
30 CONTINUE
RETURN
END SUBROUTINE DELSAM
SUBROUTINE WRISAM( MSAM )
USE M_SAMPLES
USE M_ARCINFO
USE M_MISSING, only: DMISS
implicit none
integer :: msam, KMOD
double precision :: af
integer :: i
integer :: jflow
COMMON /PHAROSFLOW/ JFLOW
COMMON /PHAROSLINE/ REC1
CHARACTER REC1*132
CALL READYY('Writing Samples File',0d0)
if ( MCA*NCA.eq.NS ) then
call wriarcsam(MSAM,ZS,MCA,NCA,MCA,NCA,X0,Y0,DXA,DYA,DMISS)
goto 1234
end if
KMOD = MAX(1,NS/100)
DO 10 I = 1,NS
IF (MOD(I,KMOD) == 0) THEN
AF = dble(I) / dble(NS)
CALL READYY('Writing Samples File',AF)
ENDIF
if ( abs(zs(i)).lt.1d6 ) then
WRITE (MSAM,'(3(F16.7))') XS(I), YS(I), ZS(I)
else if ( abs(zs(i)).lt.1d16 ) then
WRITE (MSAM,"(2F16.7, ' ', F26.7)") XS(I), YS(I), ZS(I)
else
call qnerror('wrisam: format error', ' ', ' ')
end if
10 CONTINUE
1234 continue
CALL DOCLOSE(MSAM)
CALL READYY('Writing Samples File',-1d0)
RETURN
END SUBROUTINE WRISAM
SUBROUTINE WRIXYZ(FILNAM,XS,YS,ZS,NS)
implicit none
CHARACTER (LEN=*):: FILNAM
INTEGER :: NS
DOUBLE PRECISION :: XS(NS), YS(NS), ZS(NS)
INTEGER :: I, MOUT
CALL NEWFIL(MOUT , FILNAM)
DO I = 1,NS
WRITE (MOUT,'(3(F16.7))') XS(I), YS(I), ZS(I)
ENDDO
CALL DOCLOSE(MOUT)
END SUBROUTINE WRIXYZ
SUBROUTINE COPYPOLYGONTOSAMPLES()
USE M_SAMPLES
USE M_POLYGON
USE m_missing
USE M_NETW, ONLY : UNIDX1D
USE m_fixedweirs, ONLY : SILLHEIGHTMIN
use geometry_module, only: dbdistance, normalout
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: k, n, KD, KU, KUU, KKN, KK
DOUBLE PRECISION :: RX1, RY1, RX2, RY2, V, R, DDX, A, B, DL, DR, WIDL, WIDR
! interpolate missing zpl values in polylines, if possible
call interpolate_zpl_in_polylines()
N = NS
CALL INCREASESAM(NS+NPL)
DO K = 1, NPL-1
KU = K + 1 ; KUU = MIN(NPL, K+2)
IF (XPL(K) .NE. DMISS .AND. XPL(KU) .NE. DMISS) THEN
if (jakol45 == 0) then
N = N + 1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
XS(N) = XPL(K)
YS(N) = YPL(K)
ZS(N) = ZPL(K) ; IF (ZS(N) == DMISS) ZS(N) = 1D0
endif
IF (JAKOL45 > 0 .AND. ZPL(K) .NE. DMISS) THEN
IF (.NOT. (XPL(K) == XPL(KU) .AND. YPL(K) == YPL(KU) ) ) THEN
call normalout(XPL(K), YPL(K), XPL(KU), YPL(KU), rx1, ry1, jsferic, jasfer3D, dmiss, dxymis)
RX2 = RX1 ; RY2 = RY1
IF (K > 1) THEN
IF (XPL(K-1) .NE. DMISS ) THEN
call normalout(XPL(K-1), YPL(K-1), XPL(K), YPL(K), rx2, ry2, jsferic, jasfer3D, dmiss, dxymis)
RX2 = 0.5D0*(RX1 + RX2)
RY2 = 0.5D0*(RY1 + RY2)
ENDIF
ENDIF
N = N + 1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
WIDL = 0.1D0
WIDR = 0.1D0
IF (DZR(K) > Sillheightmin .AND. DZL(K) > Sillheightmin) THEN
WIDL = 2D0*DZL(K)
WIDR = 2D0*DZR(K)
ENDIF
XS(N) = XPL(K) - RX2*WIDL
YS(N) = YPL(K) - RY2*WIDL
ZS(N) = ZPL(K) - DZL(K)
N = N + 1
XS(N) = XPL(K) + RX2*WIDR
YS(N) = YPL(K) + RY2*WIDR
ZS(N) = ZPL(K) - DZR(K)
ENDIF
ENDIF
V = DBDISTANCE( XPL(K), YPL(K), XPL(KU), YPL(KU), jsferic, jasfer3D, dmiss)
IF (V > 0D0 .AND. UNIDX1D > 0) THEN
R = V/UNIDX1D
IF ( R > 1D0) THEN
KKN = R + 1
DO KK = 1,KKN-1
A = DBLE(KK)/DBLE(KKN) ; B = 1D0 - A
if (jakol45 == 0) then
N = N+1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
XS(N) = B*XPL(K) + A*XPL(KU)
YS(N) = B*YPL(K) + A*YPL(KU)
ZS(N) = B*ZPL(K) + A*ZPL(KU)
IF (ZPL(K) == DMISS .OR. ZPL(KU) == DMISS) THEN
ZS(N) = 1D0
ENDIF
endif
IF (JAKOL45 > 0 .AND. ZPL(K) .NE. DMISS .AND. ZPL(KU) .NE. DMISS) THEN
WIDL = 0.1D0
WIDR = 0.1D0
DL = B*DZL(K) + A*DZL(KU)
DR = B*DZR(K) + A*DZR(KU)
IF (DL > Sillheightmin .AND. DR > Sillheightmin) THEN ! slope assumed
WIDL = 2D0*DL
WIDR = 2D0*DR
ENDIF
N = N + 1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
XS(N) = B*XPL(K) + A*XPL(KU) - RX1*WIDL
YS(N) = B*YPL(K) + A*YPL(KU) - RY1*WIDL
ZS(N) = B*ZPL(K) + A*ZPL(KU)
ZS(N) = ZS(N) - DL
N = N + 1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
XS(N) = B*XPL(K) + A*XPL(KU) + RX1*WIDR
YS(N) = B*YPL(K) + A*YPL(KU) + RY1*WIDR
ZS(N) = B*ZPL(K) + A*ZPL(KU)
ZS(N) = ZS(N) - DR
ENDIF
ENDDO
ENDIF
ENDIF
IF (XPL(KUU) == DMISS .OR. KU == NPL) THEN
if (jakol45 == 0) then
N = N + 1
IF (N > NSMAX) THEN
CALL INCREASESAM(2*N)
ENDIF
XS(N) = XPL(KU)
YS(N) = YPL(KU)
ZS(N) = ZPL(KU) ; IF (ZS(N) == DMISS) ZS(N) = 1D0
endif
IF (JAKOL45 > 0 .AND. ZPL(KU) .NE. DMISS) THEN
WIDL = 0.1D0
WIDR = 0.1D0
DL = DZL(KU)
DR = DZR(KU)
IF (DL > Sillheightmin .AND. DR > Sillheightmin) THEN
WIDL = 2D0*DL
WIDR = 2D0*DR
ENDIF
N = N + 1
XS(N) = XPL(KU) - RX1*WIDL
YS(N) = YPL(KU) - RY1*WIDL
ZS(N) = ZPL(KU) - DZL(KU)
N = N + 1
XS(N) = XPL(KU) + RX1*WIDR
YS(N) = YPL(KU) + RY1*WIDR
ZS(N) = ZPL(KU) - DZR(KU)
ENDIF
ENDIF
ENDIF
ENDDO
NS = N
call delpol()
END SUBROUTINE COPYPOLYGONTOSAMPLES
SUBROUTINE copyPolygonToObservations()
use m_observations
USE M_POLYGON
implicit none
integer :: n
DO N = 1,NPL
call addObservation(XPL(N), YPL(N))
END DO
END SUBROUTINE copyPolygonToObservations
SUBROUTINE deleteSelectedObservations()
use m_observations
USE M_SAMPLES
use M_POLYGON
use m_missing
use geometry_module, only: pinpok
implicit none
integer :: i
integer :: inhul
integer :: ja
integer :: k
integer :: key
integer :: nsol
double precision :: rd
double precision :: xi
double precision :: yi
IF (Npl .LE. 2) THEN
CALL CONFRM('NO POLYGON, SO DELETE all Observation Points? ',JA)
IF (JA .EQ. 0) THEN
KEY = 0
RETURN
ENDIF
call deleteObservations()
RETURN
ENDIF
DO 10 I = 1,numobs
CALL PINPOK(xobs(I), yobs(I), Npl, Xpl, Ypl, INHUL, jins, dmiss)
IF (INHUL .EQ. 1) then
call deleteObservation(I)
end if
10 CONTINUE
call purgeObservations
RETURN
END SUBROUTINE deleteSelectedObservations
SUBROUTINE deleteSelectedSplines()
USE M_SPLINES
use M_POLYGON
USE M_MISSING
use geometry_module, only: pinpok
implicit none
integer :: i, j
integer :: inhul
integer :: ja
integer :: k
integer :: key
integer :: nsol
double precision :: rd
double precision :: xi
double precision :: yi
logical :: jaAllPoints
IF (Npl .LE. 2) THEN
CALL CONFRM('NO POLYGON, SO DELETE all Splines? ',JA)
IF (JA .EQ. 0) THEN
KEY = 0
RETURN
ENDIF
call delSplines()
RETURN
ENDIF
I = 1
DO
if (I > mcs) exit
jaAllPoints = .true.
DO j=1,lensp(I)
CALL PINPOK(xsp(i,j), ysp(i,j), Npl, Xpl, Ypl, INHUL, jins, dmiss)
jaAllPoints = jaAllPoints .and. (INHUL==1)
enddo
if (jaAllPoints) then
call delSpline(I)
! splines are shifted to the left, so don't increment I.
else
I = I+1
end if
enddo
RETURN
END SUBROUTINE deleteSelectedSplines
SUBROUTINE deleteSelectedCrossSections()
USE m_monitoring_crosssections
use M_POLYGON
USE M_MISSING
implicit none
integer :: i, j
integer :: inhul
integer :: ja
integer :: k
integer :: key
integer :: nsol
double precision :: rd
double precision :: xi
double precision :: yi
logical :: jaAllPoints
!IF (Npl .LE. 2) THEN
CALL CONFRM('NO POLYGON will be used, SO DELETE all cross sections? ',JA)
IF (JA .EQ. 0) THEN
KEY = 0
RETURN
ENDIF
call delCrossSections()
RETURN
! ENDIF
I = 1
DO
if (I > ncrs) exit
jaAllPoints = .true.
DO j=1,crs(I)%path%np
CALL PINPOK(crs(i)%path%xp(j), crs(i)%path%yp(j), Npl, Xpl, Ypl, INHUL, jins, dmiss)
jaAllPoints = jaAllPoints .and. (INHUL==1)
enddo
if (jaAllPoints) then
!AvD: Disabled call delCrossSection(I)
! cross sections are shifted to the left, so don't increment I.
else
I = I+1
end if
end do
RETURN
END SUBROUTINE deleteSelectedCrossSections
! copy dots to samples
subroutine copy_dots2sam()
use m_samples
use m_plotdots
implicit none
integer :: i
if ( numdots.lt.1 ) return
call increasesam(Ns+numdots)
do i=1,numdots
Ns = Ns+1
xs(Ns) = xdots(i)
ys(Ns) = ydots(i)
zs(Ns) = zdots(i)
end do
! clear dots
numdots = 0
return
end subroutine copy_dots2sam
! copy samples to dots
subroutine copy_sam2dots()
use m_samples
use m_plotdots
implicit none
integer :: i
if ( NS.lt.1 ) return
do i=1,Ns
call adddot(xs(i),ys(i),zs(i))
end do
! clear samples
Ns = 0
return
end subroutine copy_sam2dots
SUBROUTINE ALLIN(N,JA)
use m_netw
implicit none
integer :: n
integer :: ja
integer :: k
integer :: i
integer :: nn
JA = 1
NN = netcell(N)%N
DO I = 1,NN
K = netcell(N)%NOD(I)
IF ( KC(K) .NE. 1) THEN
JA = 0 ; RETURN
ENDIF
ENDDO
END SUBROUTINE ALLIN
SUBROUTINE Triangulatesamplestonetwork(JADOORLADEN)
use m_netw, only : numk, numl, kn, xk, yk, zk, nb, LMAX, KMAX
USE M_SAMPLES
use m_ec_triangle
USE M_ALLOC
use m_missing, only: dmiss, JINS
use m_ec_basic_interpolation, only: dlaun
use geometry_module, only: pinpok, dbpinpol, get_startend
use gridoperations
use m_polygon ! , only: savepol, restorepol
implicit none
integer :: jadoorladen ! ,npl
!double precision :: xpl(npl),ypl(npl)
double precision :: af
integer :: in
integer :: ja
integer :: k
integer :: k0
integer :: k1
integer :: k1l
integer :: k2
integer :: k2l
integer :: k3
integer :: ksx
integer :: l
integer :: l0
integer :: ll
integer :: n
integer :: n1
integer :: n2
integer :: new
integer :: nn
integer :: nsdl
integer :: nsin
integer :: nmod
integer :: jstart, jend
integer :: IERR
INTEGER, ALLOCATABLE :: KS(:)
DOUBLE PRECISION :: XP, YP, THIRD, phimin,phimax
THIRD = 1D0/3D0
CALL FINDCELLS(0)
CALL MAKENETNODESCODING()
IF (JADOORLADEN .EQ. 0) THEN
K0 = 0
L0 = 0
ELSE
K0 = NUMK
L0 = NUML
ENDIF
! CALL SAVEPOL()
CALL SAVESAM()
N = 0
DO K = 1,NS ! SELECT SAMPLES IN POLYGON
IF (NPL .NE. 0) THEN
CALL PINPOK(XS(K), YS(K), NPL, XPL, YPL, IN, jins, dmiss)
ELSE
IN = 1
ENDIF
IF (IN == 1) THEN
N = N + 1
XS(N) = XS2(K)
YS(N) = YS2(K)
ZS(N) = ZS2(K)
ENDIF
ENDDO
NSIN = N
CALL INCREASENETW(K0+NSIN,L0+6*NSIN)
KSX = 6*NSIN + 100000
ALLOCATE ( KS(KSX) )
N = 0 ! ADD SELECTED SAMPLES TO NETWORK + ADMIN NODE NRS
DO K = K0+1, K0+NSIN
N = N + 1
XK(K) = XS(N)
YK(K) = YS(N)
ZK(K) = ZS(N)
KS(N) = K
ENDDO
N = NSIN ! ADD NETPOINTS IN ORIGINAL NUMK SET TO SAMPLES
IF (NPL > 0) THEN
DO K = 1, K0 ! NUMK of old net
IF (NB(K) == 2 .OR. NB(K) == 3) THEN
N = N + 1
CALL INCREASESAM(N)
XS(N) = XK(K)
YS(N) = YK(K)
ZS(N) = ZK(K)
KS(N) = K
ENDIF
ENDDO
ENDIF
IF (N < 1 .and. NPL > 0 ) THEN ! IF THERE AREN'T ANY SAMPLES YET, USE THE POLYGON
call get_startend(NPL,XPL,YPL,jstart,jend, dmiss)
NSIN = max(jend-jstart+1,0)
call increasesam(NSIN)
CALL INCREASENETW(K0+NSIN,L0+6*NSIN)
KSX = 6*NSIN + 100000
call REALLOC( KS, KSX )
do k=jstart,jend
N = N+1
XS(N) = XPL(K)
YS(N) = YPL(K)
! ZS(N) = ZPL(K)
XK(K) = XS(N)
YK(K) = YS(N)
! ZK(K) = ZS(N)
KS(N) = K
end do
END IF
NSDL = N
CALL READYY('TRIANGULATING', 0d0)
CALL DLAUN(XS,YS,NSDL,3,ierr)
CALL READYY('TRIANGULATING', 0.3d0)
IN = -1
! Check triangles and disable some links if necessary.
NMOD = int(NUMTRI/40.0)+1
DO N = 1,NUMTRI
if (mod(N,NMOD) == 0) then
AF = 0.3d0 + 0.4d0*dble(N)/dble(NUMTRI)
CALL READYY('TRIANGULATING', AF)
end if
JA = 1
CALL CHECKTRIANGLE(N,JA,phimin,phimax)
! Mark an edge with minus sign if triangle is correct!
IF (JA == 0) THEN
CYCLE
ENDIF
K1 = INDX(1,N) ; K2 = INDX(2,N) ; K3 = INDX(3,N)
K1 = KS (K1) ; K2 = KS (K2) ; K3 = KS (K3)
XP = THIRD*( XK(K1) + XK(K2) + XK(K3) )
YP = THIRD*( YK(K1) + YK(K2) + YK(K3) )
CALL DBPINPOL(XP, YP, IN, dmiss, JINS, NPL, xpl, ypl, ypl)
IF (IN == 0) THEN
CYCLE
ELSE
! Mark an edge with minus sign if triangle is correct!
DO NN=1,3
K1 = TRIEDGE(NN,N)
EDGEINDX(1,K1) = -ABS(EDGEINDX(1,K1))
END DO
ENDIF
END DO
! All triangles were just checked, and for all good ones, their edges
! were marked with a minus sign. Add only these to kn array.
NMOD = int(NUMEDGE/30.0)+1
L = L0
DO LL = 1,NUMEDGE
if (mod(N,NMOD) == 0) then
AF = 0.7d0 + 0.3d0*dble(LL)/dble(NUMEDGE)
CALL READYY('TRIANGULATING', AF)
end if
IF (EDGEINDX(1,LL) > 0) then
CYCLE
else
EDGEINDX(1,LL) = abs(EDGEINDX(1,LL))
end if
L=L+1
KN(1,L) = KS(EDGEINDX(1,LL))
KN(2,L) = KS(EDGEINDX(2,LL))
KN(3,L) = 2
call setcol(31)
call movabs(xk(kn(1,L)),yk(kn(1,L)))
call lnabs(xk(kn(2,L)),yk(kn(2,L)))
IF (L > LMAX) THEN
write (*,*) 'INCREASENETW(KMAX, INT(1.2d0*NUML) )', NUML
CALL INCREASENETW(KMAX, INT(1.2d0*NUML) )
ENDIF
END DO
CALL READYY('TRIANGULATING', -1d0)
NUMK = K0 + NSIN
NUML = L
! merge nodes in polygon
!call mergenodesinpolygon()
ns = 0 ! call delsam(1)
npl = 0 ! call delpol()
CALL SETNODADM(0) ! No cross checks for now.
DEALLOCATE (KS,NB)
IF (ALLOCATED(TRIEDGE) ) THEN
DEALLOCATE(TRIEDGE, EDGEINDX)
ENDIF
RETURN
END SUBROUTINE Triangulatesamplestonetwork
SUBROUTINE externaltrianglestoouterquads()
use m_netw
use m_polygon
use m_missing, only: jins, dmiss
use geometry_module, only: dpinpok
use gridoperations
implicit none
integer :: in
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: kp
integer :: l
integer :: lnu
double precision :: xp
double precision :: yp
double precision :: zp
DOUBLE PRECISION :: XL, YL, ZL = 0D0
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (NMK(K1) .LE. 3 .AND. NMK(K2) .LE. 3) THEN
XL = 0.5D0*( XK(K1) + XK(K2) )
YL = 0.5D0*( YK(K1) + YK(K2) )
CALL DPINPOK(XL, YL, ZL, NPL, XPL, YPL, IN, jins, dmiss )
IF (IN .EQ. 1) THEN
CALL GETQUAD(L,K1,K2,K3,K4)
IF (K3 .NE. 0) THEN
XP = 0.5D0*( 2*XK(K1) - XK(K4) + 2*XK(K2) - XK(K3) )
YP = 0.5D0*( 2*YK(K1) - YK(K4) + 2*YK(K2) - YK(K3) )
CALL GIVENEWNODENUM(KP)
CALL SETPOINT(XP,YP,ZP,KP)
CALL CONNECTDB(K2,KP,LNU)
CALL CONNECTDB(KP,K1,LNU)
ENDIF
ENDIF
ENDIF
ENDDO
END SUBROUTINE externaltrianglestoouterquads
SUBROUTINE REFINEPOLYGONUSINGNETWORK()
use m_netw
USE M_SAMPLES
use m_ec_triangle
USE M_POLYGON
use m_ec_basic_interpolation, only: dlaun
use geometry_module, only: pinpok, dpinpok, dbdistance
use m_missing, only: dmiss, jins
use m_sferic, only: jsferic, jasfer3D
use gridoperations
implicit none
double precision :: a
double precision :: af
double precision :: disav, TRIANGLESIZE
integer :: ierr
integer :: in
integer :: innump
integer :: ja
integer :: jadoorladen
integer :: jarand
integer :: k
integer :: k0
integer :: k1
integer :: k1l
integer :: k2
integer :: k2l
integer :: kk
integer :: l
integer :: l0
integer :: ll
integer :: n
integer :: n1
integer :: n2
integer :: nav
integer :: new
integer :: nh
integer :: nkin
integer :: nn
integer :: nn2
integer :: nsdl
integer :: nsin
double precision :: rln, rlp, xa, ya, xkk, ykk, phimin,phimax
DOUBLE PRECISION :: X1, Y1, X2, Y2
double precision, ALLOCATABLE :: XH (:), YH(:)
INTEGER, ALLOCATABLE :: KIN(:), KS(:)
IF (NPL .LE. 2) RETURN
CALL FINDCELLS(0)
JADOORLADEN = 1
IF (JADOORLADEN .EQ. 0) THEN
K0 = 0
L0 = 0
ELSE
K0 = NUMK
L0 = NUML
ENDIF
ALLOCATE ( KIN(NUMK), STAT=IERR) ; KIN = 0
CALL AERR('KIN(NUMK)',IERR,NUMK)
N = 0
DO K = 1,NUMK ! SELECT outer GRIDPOINTS INSIDE POLYGON
JARAND = 0
DO NN = 1,NMK(K)
L = NOD(K)%LIN(NN)
IF (LNN(L) == 1) JARAND = 1
ENDDO
IF (JARAND == 1) THEN
CALL PINPOK(XK(K), YK(K), NPL, XPL, YPL, IN, jins, dmiss)
IF (IN == 1) THEN
N = N + 1
KIN(N) = K
ENDIF
ENDIF
ENDDO
NKIN = N
DISAV = 0; NAV = 0 ! AVERAGE GRIDSIZE SELECTED CELLS
DO N = 1,NKIN
K1 = KIN(N)
DO NN = 1,NMK(K1)
L = NOD(K1)%LIN(NN)
CALL OTHERNODE(K1,L,K2)
DISAV = DISAV + DBDISTANCE (XK(K1),YK(K1),XK(K2),YK(K2), jsferic, jasfer3D, dmiss)
NAV = NAV + 1
ENDDO
ENDDO
IF (NAV .NE. 0) THEN
DISAV = DISAV / dble(NAV)
TRIANGLESIZE = DISAV
ELSE
DISAV = TRIANGLESIZE
ENDIF
RLP = 0D0
DO N = 1,NPL ! COUNT NR OF POINTS ON POLYGON
N1 = N
N2 = N+1 ; IF (N == NPL) N2 = 1
X1 = XPL(N1) ; Y1 = YPL(N1) ; X2 = XPL(N2) ; Y2 = YPL(N2)
RLP = RLP + DBDISTANCE(X1,Y1,X2,Y2, jsferic, jasfer3D, dmiss)
ENDDO
NH = 4*RLP / DISAV
ALLOCATE ( XH(NH), YH(NH) , STAT=IERR )
CALL AERR('XH(NH), YH(NH)', IERR, NH*2)
K = 0
DO N = 1,NPL ! SET NEW POINTS ON POLYGON
N1 = N
N2 = N+1 ; IF (N == NPL) N2 = 1
X1 = XPL(N1) ; Y1 = YPL(N1) ; X2 = XPL(N2) ; Y2 = YPL(N2)
RLN = DBDISTANCE(X1,Y1,X2,Y2,jsferic, jasfer3D, dmiss)
NN = NINT(RLN / DISAV)
CALL INCELLS(X1,Y1,INNUMP)
IF (INNUMP == 0) THEN
K = K + 1
XH(K) = X1 ; YH(K) = Y1
ENDIF
NN2 = 3*NN
DO N2 = 1,NN2
A = dble(N2)/dble(NN2)
XA = (1-A)*X1 + A*X2
YA = (1-A)*Y1 + A*Y2
CALL INCELLS(XA,YA,INNUMP) ! XA, YA ZIT IN CELL NR INNUMP
IF (INNUMP == 0) THEN
IF ( MOD(N2,3) == 0 ) THEN
K = K + 1
XH(K) = XA ; YH(K) = YA
ENDIF
ELSE
CALL CLOSEIN(XA,YA,INNUMP,KIN,NKIN,KK) ! KK IS HET MEEST DICHTBIJ GELEGEN POINT VAN INNUMP
IF (KK .NE. 0) THEN
XKK = XK(KK) ; YKK= YK(KK)
IF (K == 0) THEN
K = K + 1 ; XH(K) = XKK ; YH(K) = YKK
ELSE IF (XKK .NE. XH(K)) THEN
K = K + 1 ; XH(K) = XKK ; YH(K) = YKK
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
NPL = K
XPL(1:NPL) = XH(1:NPL)
YPL(1:NPL) = YH(1:NPL)
DEALLOCATE (XH,YH,KIN)
RETURN
CALL INCREASENETW(K0+NSIN,L0+6*NSIN)
ALLOCATE (KS(6*NSIN) )
N = 0 ! ADD SELECTED SAMPLES TO NETWORK
DO K = K0+1, K0+NSIN
N = N + 1
XK(K) = XS(N)
YK(K) = YS(N)
ZK(K) = ZS(N)
KS(N) = K
ENDDO
N = NSIN ! ADD NETPOINTS IN ORIGINAL NUMK SET TO SAMPLES
IF (NPL > 0) THEN
DO K = 1,NUMK ! NUM STILL OLD
CALL DPINPOK(XK(K), YK(K), ZK(K), NPL, XPL, YPL, IN, jins, dmiss)
IF (IN == 1) THEN
N = N + 1
XS(N) = XK(K)
YS(N) = YK(K)
ZS(N) = ZK(K)
KS(N) = K
ENDIF
ENDDO
ENDIF
NSDL = N
CALL READYY('TRIANGULATING', 0d0)
CALL DLAUN(XS,YS,NSDL,1,ierr)
CALL READYY('TRIANGULATING', 0.3d0)
L = L0
DO N = 1,NUMTRI
AF = 0.3d0 + 0.7d0*dble(N)/dble(NUMTRI)
CALL READYY('TRIANGULATING', AF)
JA = 1
CALL CHECKTRIANGLE(N,JA,phimin,phimax)
IF (JA == 0) THEN
CYCLE
ENDIF
DO NN = 1,3
N1 = NN ; N2 = N1 + 1 ; IF (N1 == 3) N2 = 1
K1 = INDX(N1,N) ; K2 = INDX(N2,N)
K1 = KS(K1) ; K2 = KS(K2)
NEW = 1
DO LL = NUML, 1, -1
K1L = KN(1,LL) ; K2L = KN(2,LL)
IF (K1 .EQ. K1L .AND. K2 .EQ. K2L .OR. &
K2 .EQ. K1L .AND. K1 .EQ. K2L ) THEN
NEW = 0 ; EXIT
ENDIF
ENDDO
IF (NEW .EQ. 0) CYCLE
L = L + 1 ;
IF (L > LMAX) THEN
CALL INCREASENETW(INT(1.2d0*NUMK), INT(1.2d0*NUML) )
ENDIF
NUML = L
KN(1,L) = K1 ; KN(2,L) = K2
ENDDO
ENDDO
DEALLOCATE (KS)
CALL READYY('TRIANGULATING', -1d0)
NUMK = K0 + NSIN
NUML = L
CALL SETNODADM(1)
RETURN
END SUBROUTINE REFINEPOLYGONUSINGNETWORK
SUBROUTINE in_flowcell(xp,yp,kk)
use m_flowgeom
use unstruc_display
use m_missing, only: jins, dmiss
use geometry_module, only: pinpok, dbdistance
implicit none
double precision :: xp, yp, dis
integer :: inn, k, kk, nn
kk = 0
DO K = 1,ndx2D
if (.not. allocated(nd(K)%x)) cycle
NN = size(nd(K)%x)
CALL PINPOK(xp, yp , NN, nd(K)%x, nd(K)%y, inn, jins, dmiss)
IF (inn == 1) THEN
KK = K ; RETURN
ENDIF
ENDDO
END SUBROUTINE in_flowcell
SUBROUTINE isflownode1D2D(xp,yp,kk)
use m_flowgeom
use unstruc_display
use m_missing, only: dmiss, jins
use geometry_module, only: pinpok, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
double precision :: xp, yp, dis
integer :: inn, k, kk, nn
kk = 0
DO K = ndx2D+1, ndx
dis = dbdistance(xz(k), yz(k), xp, yp, jsferic, jasfer3D, dmiss)
if (dis < rcir) then
kk = k ; return
endif
enddo
if ( .not.allocated(nd) ) then
return
end if
DO K = 1,ndx2D
if (.not. allocated(nd(K)%x)) cycle
NN = size(nd(K)%x)
CALL PINPOK(xp, yp , NN, nd(K)%x, nd(K)%y, inn, jins, dmiss)
IF (inn == 1) THEN
KK = K ; RETURN
ENDIF
ENDDO
END SUBROUTINE isflownode1D2D
SUBROUTINE CLOSEIN(XA,YA,INNUMP,KIN,NKIN,KK) ! KK IS HET MEEST DICHTBIJ GELEGEN POINT VAN INNUMP
use m_netw
implicit none
double precision :: xa
double precision :: ya
integer :: innump
INTEGER :: KIN(NKIN)
integer :: nkin
integer :: kk
double precision :: dx
double precision :: dy
integer :: k
integer :: k1
integer :: nn
double precision :: ra
double precision :: ramin
RAMIN = 1E30
KK = 0
DO NN = 1, netcell(INNUMP)%N
K1 = netcell(INNUMP)%NOD(NN)
DO K = 1,NKIN
IF (KIN(K) == K1) THEN
DX = XK(K1) - XA ; DY = YK(K1) - YA
RA = SQRT(DX*DX + DY*DY)
IF ( RA < RAMIN ) THEN
RAMIN = RA
KK = K1
ENDIF
ENDIF
ENDDO
ENDDO
RETURN
END SUBROUTINE CLOSEIN
SUBROUTINE CREATESAMPLESINPOLYGON()
use m_polygon
use m_missing
use m_samples
use geometry_module, only: get_startend ! zijn er nog meer startends zodat dit afgeschermd moet worden?
integer :: jpoint, jstart,jend,jadoall, nplsav
double precision, allocatable :: xplsav(:), yplsav(:)
allocate(xplsav(npl) , yplsav(npl)) ; xplsav = xpl(1:npl) ; yplsav = ypl(1:npl) ; nplsav = npl
jpoint = 1; jadoall = 0
do while ( jpoint.lt.NPLsav )
!get subpolyline
call get_startend(NPLsav-jpoint+1,xplsav(jpoint:NPLsav),yplsav(jpoint:NPLsav),jstart,jend, dmiss)
xpl(1:jend-jstart+1) = xplsav(jstart+jpoint-1:jend+jpoint-1)
ypl(1:jend-jstart+1) = yplsav(jstart+jpoint-1:jend+jpoint-1)
npl = jend-jstart+1
if (nplsav > jend) then
jadoall = 1
endif
jstart = jstart+jpoint-1
jend = jend+jpoint-1
jpoint = jend+2
call CREATESAMPLESINPOLYGON2()
if (jadoall == 1) then
call Triangulatesamplestonetwork(1)
endif
enddo
deallocate (xplsav, yplsav)
END SUBROUTINE CREATESAMPLESINPOLYGON
SUBROUTINE CREATESAMPLESINPOLYGON2()
use m_ec_triangle
!use m_netw
USE M_SAMPLES
use M_MISSING
use m_sferic
use m_alloc
use geometry_module, only: dbpinpol, get_startend
use m_polygon
implicit none
!integer :: NPL
!double precision :: XPL(NPL), YPL(NPL)
integer :: ierr
integer :: in
integer :: n
integer :: nn
integer :: ns1, NPL1
integer :: ntx, I
double precision :: TRIAREA, SAFESIZE
DOUBLE PRECISION :: AREPOL, DLENPOL, DLENAV, DLENMX, XP, YP, xplmin, xplmax, yplmin, yplmax
IF (NPL .LE. 2) RETURN
CALL DAREAN(XPL,YPL,NPL,AREPOL,DLENPOL,DLENMX)
DLENAV = DLENPOL/NPL ! AVERAGE SIZE ON POLBND
! TRIAREA = 0.5d0*DLENAV*DLENAV ! AVERAGE TRIANGLE SIZE
TRIAREA = 0.25d0*sqrt(3d0)*DLENAV*DLENAV ! AVERAGE TRIANGLE SIZE
SAFESIZE = 11 ! SAFETY FACTOR
if (jsferic == 1) then
! DLENPOL and AREPOL are in metres, whereas Triangle gets spherical
! coordinates, so first scale desired TRIAREA back to spherical.
xplmin = 0d0; xplmax = dlenpol/4d0; yplmin = 0d0; yplmax = dlenpol/4d0
call get_startend(NPL,XPL,YPL,n, nn, dmiss)
if (nn > n) then
xplmin = minval(xpl(n:nn))
xplmax = maxval(xpl(n:nn))
yplmin = minval(ypl(n:nn))
yplmax = maxval(ypl(n:nn))
end if
triarea = triarea * (xplmax-xplmin)*(yplmax-yplmin)/arepol
NTX = SAFESIZE * (xplmax-xplmin)*(yplmax-yplmin)/triarea
else
NTX = SAFESIZE * AREPOL / TRIAREA
end if
IF (NTX < 2) THEN
CALL QNERROR('TRISIZE MAYBE TOO LARGE FOR POLYGON?', ' ', ' ')
ENDIF
!NTX = 10
! start pointer
NS1 = NS + 1
numtri=-1
NN=-1
do while ( numtri.lt.0 .or. NN.lt.0 )
IF (ALLOCATED (INDX) ) THEN
DEALLOCATE (INDX)
ENDIF
ALLOCATE (INDX(3,NTX),STAT=IERR) ; INDX = 0
CALL AERR ('INDX(3,NTX)',IERR,INT(3*NTX))
call realloc(EDGEINDX, (/ 2,Ntx /), keepExisting=.false., fill=0, stat=ierr)
call realloc(TRIEDGE , (/ 3,Ntx /), keepExisting=.false., fill=0, stat=ierr)
NN = NTX
CALL increasesam(NS1 + NN)
zs(ns1:ubound(zs,1)) = 0d0 ! zkuni ! SPvdP: used to be DMISS, but then the samples are not plotted
TRIAREA = TRIANGLESIZEFAC*TRIANGLESIZEFAC*TRIAREA
NPL1 = NPL
do I=1,NPL
if (xpl(I) == dmiss) then
NPL1 = I-1
exit
end if
end do
numtri = ntx ! Input value should specify max nr of triangles in indx.
NN = ntx ! used to check array size of xs, ys in tricall
CALL TRICALL(2,XPL,YPL,NPL1,INDX,NUMTRI,EDGEINDX,NUMEDGE,TRIEDGE,XS(NS1),YS(NS1),NN,TRIAREA)
if ( numtri.lt.0 ) ntx =-numtri
if ( nn.lt.0 ) ntx = max(ntx,-nn)
end do
IN = -1 ! EN BIJPLUGGEN
DO N = NS1, NS1 + NN
XP = XS(N) ; YP = YS(N)
CALL DBPINPOL( XP, YP, IN, dmiss, JINS, NPL, xpl, ypl, ypl)
IF (IN == 1) THEN
NS = NS + 1
XS(NS) = XP ; YS(NS) = YP
ENDIF
ENDDO
RETURN
END SUBROUTINE CREATESAMPLESINPOLYGON2
SUBROUTINE REMOVESAMPLESONTOPOFNETPOINTS(XS, YS, NS)
use m_netw
implicit none
double precision :: XS(NS), YS(NS)
integer :: ns
double precision :: dx
double precision :: dy
integer :: jaontop
integer :: k
integer :: ks
integer :: n
double precision :: tolnet
TOLNET = 0.1d0
N = 0
DO KS = 1,NS
JAONTOP = 0
DO K = 1,NUMK
DX = ABS( XK(K) - XS(KS) ) ; DY = ABS( YK(K) - YS(KS) )
IF (DX < TOLNET .AND. DY < TOLNET) THEN
JAONTOP = 1 ; CYCLE
ENDIF
ENDDO
IF (JAONTOP == 0) THEN
N = N + 1
XS(N) = XS(KS) ; YS(N) = YS(KS)
ENDIF
ENDDO
NS = N
END SUBROUTINE REMOVESAMPLESONTOPOFNETPOINTS
SUBROUTINE CHECKTRIANGLE(N,JA,phimin,phimax)
use m_samples
use m_ec_triangle
use m_sferic
use geometry_module, only: dcosphi
use m_missing, only : dmiss, dxymis
implicit none
double precision :: phimin,phimax
integer :: n,ja
integer :: k0, k1, k2, n0, n2, nn
DOUBLE PRECISION :: X0, Y0, X1, Y1, X2, Y2, COSPHI, PHI
IF ( TRIANGLEMINANGLE >= TRIANGLEMAXANGLE ) RETURN
JA = 1
phimin = 1d3 ; phimax = 0d0
DO NN = 1,3
N0 = NN - 1; IF (N0 < 1) N0 = N0 + 3
N2 = NN + 1; IF (N2 > 3) N2 = N2 - 3
K0 = INDX(N0,N) ; K1 = INDX(NN,N) ; K2 = INDX(N2,N)
X0 = XS(K0) ; Y0 = YS(K0)
X1 = XS(K1) ; Y1 = YS(K1)
X2 = XS(K2) ; Y2 = YS(K2)
COSPHI = DCOSPHI(X1,Y1,X0,Y0,X1,Y1,X2,Y2, jsferic, jasfer3D, dxymis)
PHI = ACOS(min(max(COSPHI,-1d0),1d0))*RD2DG
phimin = min(phimin, phi)
phimax = max(phimax, phi)
IF (PHI < TRIANGLEMINANGLE .OR. PHI > TRIANGLEMAXANGLE ) THEN ! TOO SHARP
JA = 0
ENDIF
ENDDO
RETURN
END SUBROUTINE CHECKTRIANGLE
SUBROUTINE CHECKTRIANGLEnetcell(N,JA,phimin,phimax)
USE M_netw
USE M_SFERIC
use m_ec_triangle
use m_missing, only : dxymis
use geometry_module, only: dcosphi
implicit none
double precision :: phimin,phimax
integer :: n,ja
integer :: k0, k1, k2, n0, n2, nn
DOUBLE PRECISION :: X0, Y0, X1, Y1, X2, Y2, COSPHI, PHI
JA = 1
phimin = 1d3 ; phimax = 0d0
DO NN = 1,3
N0 = NN - 1; IF (N0 < 1) N0 = N0 + 3
N2 = NN + 1; IF (N2 > 3) N2 = N2 - 3
K0 = netcell(n)%nod(n0)
K1 = netcell(n)%nod(nn)
K2 = netcell(n)%nod(n2)
! k0 = INDX(N0,N) ; K1 = INDX(NN,N) ; K2 = INDX(N2,N)
X0 = Xk(K0) ; Y0 = Yk(K0)
X1 = Xk(K1) ; Y1 = Yk(K1)
X2 = Xk(K2) ; Y2 = Yk(K2)
COSPHI = DCOSPHI(X1,Y1,X0,Y0,X1,Y1,X2,Y2, jsferic, jasfer3D, dxymis )
PHI = ACOS(min(max(COSPHI,-1d0),1d0))*RD2DG
phimin = min(phimin, phi)
phimax = max(phimax, phi)
IF (PHI < TRIANGLEMINANGLE .OR. PHI > TRIANGLEMAXANGLE ) THEN ! TOO SHARP
JA = 0
ENDIF
ENDDO
RETURN
END SUBROUTINE CHECKTRIANGLEnetcell
subroutine regrid1D(jaregrid) ! based on 1D net itself, 1 = regrid, otherwise 1dgrid to pol
use m_flowgeom
use m_flow
use m_netw
use m_polygon
use m_missing
use gridoperations
implicit none
integer :: jaregrid
double precision :: dxa, dxb, xlb
double precision, allocatable :: xh(:), yh(:), zh(:)
integer :: L, LL, k, n, nh, ibr, LA, k1, k2, ium
if (jaregrid == 1) then
call savepol()
endif
call SAVENET()
npl = 0
CALL SETBRANCH_LC(ium)
numk = 0; numl = 0; n = 0
do ibr = 1,mxnetbr ! SET UP BRANCH DISTANCE COORDINATE
XLB = 0d0
do LL = 1, netbr(ibr)%NX
L = netbr(ibr)%ln(LL); LA = iabs(L)
if (L > 0) then
k1 = kn0(1,La); k2 = kn0(2,LA)
else
k2 = kn0(1,La); k1 = kn0(2,LA)
endif
if (LL == 1) then
if (jaregrid == 1) then
n = 1
else
n = n + 1
endif
xpl(n) = xk0(k1) ; ypl(n) = yk0(k1) ; zpl(n) = zk0(k1)
endif
n = n + 1
if (n > maxpol) then
CALL INCREASEPOL(int(1.5*n), 1)
endif
xpl(n) = xk0(k2) ; ypl(n) = yk0(k2) ; zpl(n) = zk0(k2)
enddo
if (jaregrid == 1) then
call accumulateDistance(XPL,YPL,ZPL,N)
nh = zpl(n)/Unidx1D + 1
dxa = zpl(n)/nh
nh = nh + 1
allocate(xh(nh), yh(nh), zh(nh))
zh(1) = 0d0
do k = 2,nh
zh(k) = zh(k-1) + dxa
enddo
CALL mapToPolyline(XPL, YPL, ZPL, N, XH, YH, ZH, NH) ! HAAL HUIDIGE PUNTEN OP
numk = numk + 1
xk(numk) = xh(1) ; yk(numk) = yh(1)
do k = 2,nh
numk = numk + 1
numL = numL + 1
if (numk > numk0 .or. numL > numL0) then
call increasenetw(2*numk,2*numl)
endif
xk(numk) = xh(k) ; yk(numk) = yh(k)
kn(2,numl) = numk ; kn(1,numl) = numk - 1 ; kn(3,numl) = 1 ! NOTE: regridded 1D now does not have kn(3,L)=4 at end points.
enddo
deallocate (xh,yh,zh)
else
n = n + 1
xpl(n) = dmiss ; ypl(n) = dmiss ; zpl(n) = dmiss
endif
enddo
if (jaregrid == 1) then
CALL SETNODADM(0)
call restorepol()
else
npl = n - 1
call restore()
endif
end subroutine regrid1D
SUBROUTINE SHRINKYZPROF(Y,Z,N,NX)
USE M_MISSING
IMPLICIT NONE
INTEGER :: N, NX, NACT
DOUBLE PRECISION :: Y(N), Z(N)
DOUBLE PRECISION, ALLOCATABLE :: YH(:), ZH(:)
INTEGER :: NH, K, KM
DOUBLE PRECISION :: ZMIN, D01, D02, Z01, AT, ZD, ZDMIN, A,B
ALLOCATE ( YH(N), ZH(N) )
IF (NX > N) THEN
RETURN
ENDIF
NACT = N ! MAX NR
NH = N ; YH(1:N) = Y(1:N) ; ZH(1:N) = Z(1:N)
ZMIN = 9D9
DO K = 1,NACT
ZMIN = MIN(ZMIN, Z(K))
ENDDO
DO K = 1,NACT
Z(K) = Z(K) - ZMIN
ENDDO
AT = 0D0
DO K = 2,NACT
D01 = Y(K) - Y(K-1)
Z01 = 0.5D0*(Z(K) + Z(K-1))
AT = AT + D01*Z01
ENDDO
DO WHILE ( NACT > NX + 1)
ZDMIN = 9D9 ; KM = 0
DO K = 2,NACT - 1
D01 = Y(K) - Y(K-1)
IF (D01 == 0D0) THEN
Y(K) = DMISS
EXIT
ENDIF
D02 = Y(K+1) - Y(K-1)
A = D01/D02 ; B = 1D0 - A
ZD = ( A*Z(K+1) + B*Z(K-1) )*D02
IF ( ABS(ZD) < ZDMIN ) THEN
KM = K ; ZDMIN = ZD
ENDIF
ENDDO
IF (ZDMIN < 0.01*AT) THEN
DO K = 2,NACT - 1
ENDDO
ENDIF
ENDDO
END SUBROUTINE SHRINKYZPROF
!> Find a point on a polyline at a certain distance from the start.
!! The distance is measured along the consecutive polyline segments.
SUBROUTINE interpolateOnPolyline(X,Y,Z,T,MMAX,XP,YP,ZP,TP,JA)
implicit none
DOUBLE PRECISION, intent(in) :: X(MMAX), Y(MMAX), Z(mmax) !< The polyline coordinates.
double precision, intent(in) :: T(MMAX) !< Accumulated segment lengths at all points.
integer, intent(in) :: mmax !< Nr. of polyline points.
double precision, intent(out) :: XP, YP, ZP !< interpolated point coordinates at distance TP.
double precision, intent(in) :: TP !< Distance from polyline start at which to place point XP,YP.
integer, intent(out) :: ja !< Whether distance is within polyline length (1) or not (0).
integer :: i
double precision :: DT, TI
I = 0
10 CONTINUE
I = I + 1
JA = 0
IF (T(I) .LE. TP) THEN
IF (I .LE. MMAX-1) THEN
GOTO 10
ENDIF
ENDIF
JA = 1
DT = T(I) - T(I-1)
TI = 0D0
IF (DT .NE. 0D0) TI = (TP - T(I-1) ) / DT
XP = (1D0 - TI)*X(I-1) + TI*X(I)
YP = (1D0 - TI)*Y(I-1) + TI*Y(I)
ZP = (1D0 - TI)*Z(I-1) + TI*Z(I)
RETURN
END SUBROUTINE interpolateOnPolyline
!> Stop afstand tussen polygoonpunten vanaf begin in array
SUBROUTINE accumulateDistance(X,Y,T,MMAX)
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: mmax
DOUBLE PRECISION, intent(in) :: X(MMAX), Y(MMAX) !< Input polyline coordinates
double precision, intent(out) :: T(MMAX) !< Output accumulated distances along polyline segments.
integer :: k
T(1) = 0d0
DO K = 2,MMAX
T(K) = T(K-1) + dbdistance( x(k), y(k), x(k-1), y(k-1), jsferic, jasfer3D, dmiss)
ENDDO
RETURN
END SUBROUTINE accumulateDistance
!> Refine entire current polyline from start to end.
subroutine refinepolygon()
use m_polygon !, only: npl, dxuni
use m_tpoly
use m_sferic
use m_missing
use geometry_module, only: dbdistance, half
implicit none
integer :: i1, i2
integer :: key
type(tpoly), dimension(:), allocatable :: pli, pliout ! tpoly-type polygons
double precision :: dl, xnew, ynew, znew
integer :: numpols, numpolsout ! number of tpoly-type polygons
integer :: i
integer :: iter, j
integer :: M, NPUT
i1 = 1
i2 = npl
call refinepolygonpart(i1,i2,0)
call TYPEVALUE(dxuni,key)
call pol_to_tpoly(numpols, pli, keepExisting=.false.)
call delpol()
write(6,*) numpols
do i=1,numpols
write(6,*) i
call tpoly_to_pol(pli,iselect=i)
! i1 = 1
! i2 = NPL
! call refinepolygonpart(i1,i2,1)
! loop over polygon points
j = 1
do while ( j.lt.NPL )
! get length
dl = dbdistance(xpl(j), ypl(j), xpl(j+1), ypl(j+1), jsferic, jasfer3D, dmiss)
! check length
if ( dl.gt.dxuni ) then
! compute new point coordinates
call half(xpl(j), ypl(j), xpl(j+1), ypl(j+1),xnew,ynew,jsferic,jasfer3D)
znew = DMISS
if ( zpl(j).ne.DMISS .and. zpl(j+1).ne.DMISS ) then
znew = 0.5*(zpl(j)+zpl(j+1))
end if
! add point
call increasepol(NPL+1, 1)
NPUT = -1
M = j
CALL MODLN2(XPL, YPL, ZPL, MAXPOL, NPL, M, xnew, ynew, NPUT)
ZPL(M) = znew
else
j = j+1
end if
end do
call pol_to_tpoly(numpolsout, pliout, keepExisting=.true.)
call delpol()
end do
call tpoly_to_pol(pliout)
call dealloc_tpoly(pli)
call dealloc_tpoly(pliout)
end subroutine refinepolygon
!> Refine part of a polygon, indicated by start and end index.
!! If the polygon/line ends between i1 and i2 (dmiss), then refinement
!! stops there (i.e. refinement is only within *one* polygon).
SUBROUTINE REFINEPOLYGONpart(i1, i2,jauniform) !DPLA = ACTUELE LENGTECOOR, DXA = ACTUELE GRIDSIZE, DXS = STREEF GRIDSIZE, ALLEN OP POLYGONPOINTS
USE M_POLYGON
USE M_MISSING
use m_ec_triangle
USE M_SAMPLES
use m_alloc
implicit none
integer :: i1, i2
integer, intent(in) :: jauniform !< use uniform spacing (1) or not (0)
double precision :: dxs1
double precision :: dxs2
double precision :: dxsm
integer :: ierr
integer :: ja
integer :: kk
integer :: n, nmid
integer :: nmn
integer :: nmx
integer :: no, nplo
double precision :: rma, rmx
!DPL = IDEM, OORSPRONKELIJK
DOUBLE PRECISION, ALLOCATABLE :: XPLO(:) ,YPLO(:), ZPLO(:), DPL (:)
DOUBLE PRECISION, ALLOCATABLE :: XH (:) , YH(:), ZH(:), DPLA(:), DXA(:), DXS(:)
DOUBLE PRECISION :: TXS, TXA, RMN, THIRD, TWOTHIRD
INTEGER :: NX, JDLA
JDLA = 1
THIRD = 1D0/3D0 ; TWOTHIRD = 1D0 - THIRD
CALL SAVEPOL()
i1 = max(1, min(i1,npl))
i2 = max(1, min(i2,npl))
if (i1 < i2) then
! Check whether *before* i2 there is already a dmiss
NO = i2-i1+1 ! Nr of polygon points between i1 and i2 (including them)
do kk=i1,i2
if (xpl(kk) == dmiss) then
NO = kk-i1 ! Nr of polygon points between i1 and i2 (including them)
exit
end if
enddo
else
! First flip i1<->i2 such that i1 < i2
kk = i1
i1 = i2
i2 = kk
! Now, walk from i2 to i1 (=backwards) and check whether *before* i1 there is already a dmiss
NO = i2-i1+1 ! Nr of polygon points between i1 and i2 (including them)
do kk=i2,i1,-1
if (xpl(kk) == dmiss) then
NO = i2-kk ! Nr of polygon points between i1 and i2 (including them)
exit
end if
end do
end if
if ( jauniform.ne.1 ) then
if (NO < 4 ) return
else
if ( NO.lt.2 ) return
end if
NPLO = NPL ! Back up current poly length
NPL = NO
NX = 10*NO
ALLOCATE ( XPLO(NPLO), YPLO(NPLO), ZPLO(NPLO), DPL(NPLO) , STAT = IERR)
CALL AERR('XPLO(NPLO), YPLO(NPLO), ZPLO(NPLO), DPL(NPLO)', IERR, 3*NPLO)
do kk=i1,NPLO
XPLO(kk-i1+1) = XPL(kk)
YPLO(kk-i1+1) = YPL(kk)
ZPLO(kk-i1+1) = ZPL(kk)
end do
ALLOCATE ( XH(NX), YH(NX) , ZH(NX) , STAT= IERR ) ; XH = DXYMIS ; YH = DXYMIS ; ZH = dxymis
CALL AERR('XH(NX), YH(NX) , ZH(NX)', IERR, 2*NX )
ALLOCATE ( DPLA(NX), DXA(NX), DXS(NX) , STAT = IERR)
CALL AERR('DPLA(NX), DXA(NX), DXS(NX)', IERR, 3*NX)
CALL accumulateDistance(XPLO, YPLO, DPL, NO) ! OORSPRONKELIJKE LENGTECOORDINAAT
CALL averageDiff (DPL , DXA , NO) ! OORSPRONKELIJKE SEGMENTSIZE
if ( jauniform.ne.1 ) then
DXS1 = 1d0*DXA(1) ! Start segment
DXS2 = 1d0*DXA(NO) ! Eind segment
else
DXS1 = min(dxuni, DPL(NO))
DXS2 = DXS1
end if
DPLA(1:NO) = DPL(1:NO)
TXA = DPLA(NO)
JA = 1
DO WHILE (JA == 1)
DO KK = 1,20
CALL mapToPolyline(XPLO, YPLO, DPL, NO, XH, YH, DPLA, NPL) ! HAAL HUIDIGE PUNTEN OP
! CALL DISP2C(dble(XH), dble(YH), NPL, 0.5*RCIR, 50+8*KK)
! CALL WAITESC()
CALL averageDiff(DPLA, DXA , NPL) ! GET ACTUELE GRIDSIZE
DXS = DXYMIS
!IF (NS .GE. 3) THEN ! ALS ER SAMPLES ZIJN, DAN ZIJN ZE HET GRIDSIZE CONTROL FIELD
! NPH = NPL ; NPL = 0
! CALL INTDXSTRI(XH,YH,DXS,NPH,JDLA)
! NPL = NPH ! ROEIEN OMHEEN DE NPL CONSTRUCTIE IN TRIINT
!ELSE
CALL interpOnPolyline(DPLA, DXS, NPL, DXS1, DXS2)! TRIANGLESIZE, TRIANGLESIZE) ! INTERPOLATE STREEFGRIDSIZE ! LATER TRIANGULATIE
!ENDIF
DO N = 1,NPL ! EN VOOR DE VEILIGHEID:
IF (DXS(N) == DXYMIS) THEN
DXS(N) = DXA(N)
ENDIF
ENDDO
TXS = SUM(DXS(1:NPL)) - 0.5D0*( DXS(1)+DXS(NPL) ) ! Som van gewenste delta xjes
CALL SMODPLA(DPLA, DXS, NPL) ! SMOOTH WITH WEIGHTFACTOR DESIRED
ENDDO
RMN = 1E9 ; NMN = 0
RMX = -1E9 ; NMX = 0; DXSM = 1E30
DO N = 1,NPL-1 ! CHECK SMALLEST AND LARGEST RATIOS OF ACTUAL VS DESIRED
DXSM = MIN(DXS(N), DXSM)
RMA = DXA(N)/DXS(N)
IF (N > 1) THEN
IF (RMA < RMN) THEN ! ZOEK BESTE WEGGOOIER
NMN = N ; RMN = RMA ! POTENTIEEL WEGGOOIPUNT, KLEINE GRIDSIZE VS STREEFSIZE
ENDIF
ENDIF
IF (RMA > RMX) THEN
NMX = N ; RMX = RMA ! POTENTIEEL BIJZETPUNT, GROTE GRIDSIZE VS STREEFSIZE
ENDIF
ENDDO
IF (NMN .NE. 0 .AND. TXS-1.5d0*DXS(max(NMN,1)) > TXA) THEN ! TOT STREEFLENGTE MIN KLEINSTE STREEF LENGTE GROTER DAN TOTLENGTE
! => KLEINSTE VERWIJDEREN
NPL = NPL - 1
DO N = NMN, NPL
DPLA(N) = DPLA(N+1)
ENDDO
JA = 1
ELSE IF (TXS + 0.5d0*DXA(NMX) < TXA) THEN ! TOT STREEFLENGTE PLUS HALVE GROOTSTE KLEINER DAN TOTLENGTE
! => BIJZETTEN BIJ DE GROOTSTE
NPL = NPL + 1
IF (NPL > NX) THEN
NX = 1.5*NX
CALL REALLOC(XH , NX)
CALL REALLOC(YH , NX)
CALL REALLOC(ZH , NX)
CALL REALLOC(DPLA, NX)
CALL REALLOC(DXA , NX)
CALL REALLOC(DXS , NX)
ENDIF
DO N = NPL, NMX + 2, -1
DPLA(N) = DPLA(N-1)
ENDDO
DPLA(NMX+1) = 0.5d0*( DPLA(NMX) + DPLA(NMX+2) )
JA = 1
ELSE
JA = 0
ENDIF
ENDDO
IF (NPL+i1-1+nplo-i2 > SIZE(XPL) ) THEN
NX = 1.5*(NPL+i1-1+nplo-i2)
CALL REALLOC(XPL , NX)
CALL REALLOC(YPL , NX)
CALL REALLOC(ZPL , NX)
CALL REALLOC(XPH , NX)
CALL REALLOC(YPH , NX)
CALL REALLOC(ZPH , NX)
MAXPOL = NX
ENDIF
do kk=nplo,i2+1,-1
XPL(i1+npl+kk-i2-1) = XPL(kk)
YPL(i1+npl+kk-i2-1) = YPL(kk)
ZPL(i1+npl+kk-i2-1) = ZPL(kk)
end do
do kk=1,NPL
XPL(i1+kk-1) = XH(kk)
YPL(i1+kk-1) = YH(kk)
ZPL(i1+kk-1) = ZH(kk)
end do
! SPvdP: copy remaining part of original polygon
do kk=1,NPLO-i1-NO+1
XPL(i1+NPL+kk-1) = XPLO(NO+kk)
YPL(i1+NPL+kk-1) = YPLO(NO+kk)
ZPL(i1+NPL+kk-1) = ZPLO(NO+kk)
end do
NPL=NPLO-NO+NPL
DEALLOCATE (XPLO, YPLO, ZPLO, DPL, XH, YH, ZH, DPLA, DXA, DXS)
END SUBROUTINE REFINEPOLYGONpart
SUBROUTINE INTDXSTRI(XH,YH,DXS,NPH,JDLA)
use m_missing
use m_samples
use m_sferic, only: jsferic, jasfer3D
use m_polygon, only: NPL, xpl, ypl, zpl
use m_ec_basic_interpolation, only: triinterp2
use m_flowexternalforcings, only: transformcoef
implicit none
DOUBLE PRECISION :: XH(NPH), YH(NPH), DXS(NPH)
integer :: nph, jdla
double precision :: dxsav
integer :: n
integer :: nn
DXS = DXYMIS
CALL triinterp2(XH,YH,DXS,NPH,JDLA, &
XS, YS, ZS, NS, dmiss, jsferic, jins, jasfer3D, NPL, MXSAM, MYSAM, XPL, YPL, ZPL, transformcoef)
NN = 0
DO N = 1,NPH
IF (DXS(N) .NE. DXYMIS) THEN
DXSAV = DXSAV + DXS(N); NN = NN + 1
ENDIF
ENDDO
IF (NN < NPH) THEN ! TODO, LINEAR INTER- AND EXTRAPOLATION
DXSAV = DXSAV / NN
DO N = 1, NPH
IF (DXS(N) == DXYMIS) THEN
DXS(N) = DXSAV
ENDIF
ENDDO
ENDIF
END SUBROUTINE INTDXSTRI
!> Maps a list of distances to a list of points.
!! The points are placed onto a polyline at the distances measured along
!! the consecutive polyline segments.
SUBROUTINE mapToPolyline(XHO, YHO, DPL, NO, XH, YH, DPLA, NPL) ! HAAL HUIDIGE PUNTEN OP
implicit none
DOUBLE PRECISION, intent(in) :: XHO(NO), YHO(NO) !< Polyline points.
double precision, intent(in) :: DPL(NO) !< Accumulated segment sizes along polyline.
integer, intent(in) :: NO !< Nr. of polyline points.
double precision, intent(out) :: XH(NPL), YH(NPL) !< Output points interpolated on polyline.
double precision, intent(in) :: DPLA(NPL) !< Desired distances for all points.
integer, intent(in) :: npl !< Nr. of points to be interpolated.
integer :: ja
integer :: n
DO N = 1, NPL
CALL interpolateOnPolyline(XHO,YHO,YHO,DPL,NO,XH(N),YH(N),YH(N),DPLA(N),JA)
ENDDO
END SUBROUTINE mapToPolyline
SUBROUTINE SMODPLA(DPLA, DXS, NPL) ! SMOOTH WITH DESIRED
USE M_ALLOC
implicit none
DOUBLE PRECISION :: DPLA(NPL), DXS(NPL)
DOUBLE PRECISION, ALLOCATABLE :: DH(:)
integer :: npl
double precision :: a1
double precision :: a2
integer :: k
integer :: n
CALL REALLOC(DH,NPL)
DO K = 1,5
DH = DPLA
DO N = 2,NPL-1
a1 = 0.5d0*( dxs(n-1) + dxs(N) )
a2 = 0.5d0*( dxs(n+1) + dxs(N) )
DPLA(N) = ( a2*DH(N-1) + a1*DH(N+1) ) / ( a2 + a1 )
ENDDO
ENDDO
DEALLOCATE(DH)
END SUBROUTINE SMODPLA
!> Computes the average segment size at polyline points.
!! by averaging between left and right neighbouring points at each point.
SUBROUTINE averageDiff(DPL, DDX, NPL)
implicit none
DOUBLE PRECISION, intent(in) :: DPL(NPL) !< Accumulated distance at each point
double precision, intent(out) :: DDX(NPL) !< Output average segment size.
integer :: npl !< Nr. of polyline points.
integer :: n
DDX = 0D0
DDX(1) = 1d0*( DPL(2) - DPL(1) )
DDX(NPL) = 1d0*( DPL(NPL) - DPL(NPL-1) )
DO N = 2, NPL-1
DDX(N) = 0.5D0*( DPL(N+1) - DPL(N-1) )
ENDDO
END SUBROUTINE averageDiff
!> Performs linear interpolation between two values along a polyline.
!! The interpolation is done along a polyline at the distances
!! measured along the consecutive polyline segments.
SUBROUTINE interpOnPolyline(DPL, DXS, NPL, DXS1, DXS2)
implicit none
double precision, intent(in) :: DPL(NPL) !< Accumulated distance at each point.
double precision, intent(out) :: DXS(NPL) !< Interpolated values of dxs1--dxs2 on polyline points.
double precision, intent(in) :: dxs1 !< Value at first polyline point.
double precision, intent(in) :: dxs2 !< Value at last polyline point.
integer :: npl
double precision :: f
double precision :: f1
integer :: n
IF (NPL .LE. 1) RETURN
DO N = 1,NPL
F = DPL(N) / DPL(NPL) ; F1 = 1-F
DXS(N) = F1*DXS1 + F*DXS2
ENDDO
END SUBROUTINE interpOnPolyline
SUBROUTINE FINDSPLT(X,Y,X2,Y2,MMAX,MFAC,MCS,TS,DS,XS,YS,JA)
implicit none
integer :: ja
integer :: mcs
integer :: mfac
integer :: mmax
DOUBLE PRECISION :: X(MMAX), Y(MMAX), X2(MMAX), Y2(MMAX), TS, DS, XS, YS
DOUBLE PRECISION :: TA, XA, TB, XB, YA, YB, DMF, DB, DA, DX, DY
! TS is de administratieve start zoekindex tussen 0 en MCS
! DS is de te zoeken afstand vanaf punt TS
JA = 1
DMF = 0.5d0 / dble(MFAC)
DB = 0
DA = 0
TA = TS
CALL SPLINT(X,X2,MCS,TA,XA)
CALL SPLINT(Y,Y2,MCS,TA,YA)
10 CONTINUE
TB = TA + DMF
TB = MIN(TB,dble(MCS-1))
CALL SPLINT(X,X2,MCS,TB,XB)
CALL SPLINT(Y,Y2,MCS,TB,YB)
DX = XB - XA
DY = YB - YA
DB = DB + SQRT(DX*DX + DY*DY)
IF (TB .LT. MCS-1) THEN
IF (DB .LT. DS) THEN
TA = TB
DA = DB
XA = XB
YA = YB
ELSE
TS = TA + DMF*(DS-DA)/(DB-DA)
CALL SPLINT(X,X2,MCS,TS,XS)
CALL SPLINT(Y,Y2,MCS,TS,YS)
JA = 1
RETURN
ENDIF
ELSE
JA = 0
RETURN
ENDIF
GOTO 10
END SUBROUTINE FINDSPLT
SUBROUTINE SPLINE(Y,N,Y2)
implicit none
integer :: i
integer :: k
integer :: n
DOUBLE PRECISION :: Y(N),Y2(N)
DOUBLE PRECISION, ALLOCATABLE :: U(:)
DOUBLE PRECISION :: P
ALLOCATE (U(N))
Y2(1) = 0.D0
U(1) = 0.D0
DO I = 2,N-1
P = 0.5D0*Y2(I-1) + 2D0
Y2(I) = -0.5D0/P
U(I) = (6D0*( (Y(I+1)-Y(I)) - (Y(I)-Y(I-1)) ) / 2D0 - 0.5D0*U(I-1))/P
ENDDO
Y2(N) = 0.D0
DO K = N-1,1,-1
Y2(K) = Y2(K)*Y2(K+1) + U(K)
ENDDO
DEALLOCATE (U)
RETURN
END SUBROUTINE SPLINE
SUBROUTINE SPLINT(YA,Y2A,N,X,Y)
implicit none
integer :: N !< number of control points
double precision, dimension(N) :: ya !< control point values
double precision, dimension(N) :: y2a !< control point second order derivatives
double precision, intent(in) :: x !< spline coordinate
double precision, intent(out) :: y !< interpolated value at prescribed spline coordinate
! AANGEPAST VOOR GEBRUIK BIJ XA IS ENKEL 0,1,2...N-1
! ZOEKEN KAN GESLOOPT DOOR DEFINITIE VAN XA IS 0,1,
double precision :: EPS, A,B, SPLFAC = 1D0
integer :: intx
integer :: KLO, KHI
EPS = 0.00001D0
INTX = INT(X)
IF (X-INTX .LT. EPS) THEN
Y = YA(INTX+1)
ELSE
KLO = INTX + 1
KHI = KLO + 1
A = ((KHI-1)-X)
B = (X-(KLO-1))
Y = A*YA(KLO) + B*YA(KHI) + SPLFAC*( (A**3-A)*Y2A(KLO) + (B**3-B)*Y2A(KHI) )/6D0
ENDIF
RETURN
END SUBROUTINE SPLINT
SUBROUTINE POLTONET(L1,L2) ! PULL POLYGON TO NETWORK, KEEPING SUITABLE TRIANGLES TO OUTSIDE
use m_netw
use m_polygon
use m_missing
use m_wearelt
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use gridoperations
implicit none
integer :: l1
integer :: l2
double precision :: d1, d2, xp1, xp2, yp1, yp2
integer :: i
integer :: ja
integer :: k
integer :: k1
integer :: k2
integer :: kk
integer :: kl1
integer :: kl2
integer :: kn1
integer :: knaar
integer :: l
integer :: ll
integer :: n
integer :: n1
integer :: n2
DOUBLE PRECISION :: XR, YR, XN, YN, XR1, YR1, XR2, YR2, AR1, DIS
CALL SAVEPOL()
IF (L1 > L2) THEN
LL = L1 ; L1 = L2 ; L2 = LL
ENDIF
XP1 = XPL(L1) ; YP1 = YPL(L1)
XP2 = XPL(L2) ; YP2 = YPL(L2)
NPL = 4 ! CHANGE POLYGON TO VISIBLE AREA
XPL(1) = X1 ; YPL(1) = Y1
XPL(2) = X2 ; YPL(2) = Y1
XPL(3) = X2 ; YPL(3) = Y2
XPL(4) = X1 ; YPL(4) = Y2
CALL FINDCELLS(0)
CALL MAKENETNODESCODING()
CALL CLOSENETBNDLINK(XP1,YP1,N1)
CALL CLOSENETBNDLINK(XP2,YP2,N2)
IF (N1 == 0 .OR. N2 == 0) THEN
CALL QNERROR('NO CLOSE NET POINT FOUND', ' ',' ')
ENDIF
DO N = 1,L1-1
XPL(N) = XPH(N) ; YPL(N) = YPH(N)
ENDDO
L = N2
K1 = KN(1,L) ; K2 = KN(2,L)
XP1 = 0.5D0*(XK(K1) + YK(K2) )
YP1 = 0.5D0*(YK(K1) + YK(K2) )
! CALL TEKNODE(K1,221)
! CALL TEKNODE(K1,31)
L = N1
K1 = KN(1,L) ; K2 = KN(2,L)
D1 = SQRT( (XK(K1) - XP1)**2 + (YK(K1) - YP1)**2 )
D2 = SQRT( (XK(K2) - XP1)**2 + (YK(K2) - YP1)**2 )
IF (D1 > D2) THEN
K = K1 ; KNAAR = K2
ELSE
K = K2 ; KNAAR = K1
ENDIF
N = L1 - 1
DO WHILE (N < MAXPOL)
JA = 0
DO KK = 1,NMK(K)
LL = NOD(K)%LIN(KK)
CALL OTHERNODE(K,LL,K2)
IF (L == N1 .AND. K2 == KNAAR .OR. LC(LL) .NE. -1 .AND. LNN(LL) == 1) THEN
JA = 1
L = LL
CALL OTHERNODE(K,L,K2)
K = K2; LC(L) = -1
KL1 = KN(1,L) ; KL2 = KN(2,L)
XR1 = XK(KL1) ; XR2 = XK(KL2)
YR1 = YK(KL1) ; YR2 = YK(KL2)
KN1 = LNE(1,L)
CALL GETCELLSURFACE (KN1,AR1, XR, YR)
CALL MIRRORLINE2(XR,YR,XR1,YR1,XR2,YR2,JA,DIS,XN,YN)
N = N + 1
XPL(N) = XN
YPL(N) = YN
! CALL RCIRC( XPL(N), YPL(N) )
! CALL WAIT ()
EXIT
ENDIF
ENDDO
IF (L == N2) EXIT
ENDDO
DO I = L2+1, NPH
N = N + 1
XPL(N) = XPH(I)
YPL(N) = YPH(I)
ENDDO
NPL = N
END SUBROUTINE POLTONET
SUBROUTINE CLOSETO1DORBND(XP1,YP1,N1) ! IF NOT IN FLOWCELL, MAYBE CLOSE TO 1d OF BND
use m_FLOWGEOM ! je moet dwars op een flow liggen, anders doe je niet mee
! misschien is dat soms wat streng
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbdistance, dlinedis
implicit none
integer :: n1
double precision :: XP1, YP1
double precision :: dismin
integer :: ja
integer :: k1
integer :: k2
integer :: l
double precision :: xa,ya,xb,yb,dis,xn,yn
N1 = 0
DISMIN = 9E+33
DO L = 1,LNX
IF (L <= LNX1d .OR. L > LNXI) THEN
K1 = LN(1,L) ; K2 = LN(2,L)
XA = XZ(K1)
YA = YZ(K1)
XB = XZ(K2)
YB = YZ(K2)
CALL dLINEDIS(XP1,YP1,XA,YA,XB,YB,JA,DIS,XN,YN, jsferic, jasfer3D, dmiss)
IF (JA .EQ. 1) THEN
IF (DIS .LT. DISMIN) THEN
N1 = L
DISMIN = DIS
ENDIF
ENDIF
ENDIF
ENDDO ! TODO: HK/AvD: this now ALWAYS returns a cell, even if the boundary cell is far away. Do we want that?
IF (N1 .NE. 0) THEN
K1 = LN(1,n1) ; K2 = LN(2,n1)
IF (dbdistance(XP1,YP1,XZ(K1),YZ(K1),jsferic, jasfer3D, dmiss) < dbdistance(XP1,YP1,XZ(K2),YZ(K2),jsferic, jasfer3D, dmiss) ) THEN
N1 = K1
ELSE
N1 = K2
ENDIF
ENDIF
END SUBROUTINE CLOSETO1DORBND
SUBROUTINE CLOSEdefinedflownode(XP1,YP1,N1) !
use m_flowgeom
use m_flow
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: n1
double precision :: XP1, YP1
double precision :: dismin, dis
integer :: n
N1 = 0
DISMIN = 9d33
DO n = 1,ndxi
if (laydefnr(n) > 0) then
dis = dbdistance(XP1,YP1,XZ(n),YZ(n), jsferic, jasfer3D, dmiss)
IF (dis < dismin) then
n1 = n ; dismin = dis
endif
endif
enddo
end subroutine CLOSEdefinedflownode
SUBROUTINE CLOSENETBNDLINK(XP1,YP1,N1)
use m_netw
use geometry_module, only: dlinedis
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: n1
double precision :: xp1
double precision :: yp1
double precision :: dismin
integer :: ja
integer :: k1
integer :: k2
integer :: l
double precision :: xa,ya,xb,yb,dis,xn,yn
N1 = 0
DISMIN = 9E+33
DO L = 1,NUML
IF (LNN(L) == 1) THEN
K1 = KN(1,L) ; K2 = KN(2,L)
XA = XK(K1)
YA = YK(K1)
XB = XK(K2)
YB = YK(K2)
CALL dLINEDIS(XP1,YP1,XA,YA,XB,YB,JA,DIS,XN,YN, jsferic, jasfer3D, dmiss)
IF (JA .EQ. 1) THEN
IF (DIS .LT. DISMIN) THEN
N1 = L
DISMIN = DIS
ENDIF
ENDIF
ENDIF
ENDDO
END SUBROUTINE CLOSENETBNDLINK
SUBROUTINE CLOSETO1Dnetlink(XP1,YP1,N1,XN1,YN1,DIST) !
use m_netw
use geometry_module, only: dbdistance, dlinedis
use m_missing, only: dmiss, imiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: n1
double precision :: XP1, YP1, XN1,YN1
double precision, intent(out) :: DIST !< distance to 1D link
double precision :: dismin
integer :: ja, k1, k2, L
double precision :: xa,ya,xb,yb,dis,xn,yn
N1 = 0
DISMIN = 9E+33
DO L = 1,numl
IF (kn(3,L) == 1 .or. kn(3,L) == 6 .or. kn(3,L) == 5 .or. kn(3,L) == 7) then ! .or. kn(3,L) == 4) THEN
K1 = kn(1,L) ; K2 = kn(2,L)
XA = Xk(K1)
YA = Yk(K1)
XB = Xk(K2)
YB = Yk(K2)
CALL dLINEDIS(XP1,YP1,XA,YA,XB,YB,JA,DIS,XN,YN, jsferic, jasfer3D, dmiss)
!IF (JA .EQ. 1 .AND. DIS < 0.5D0*DBDISTANCE(XA,YA,XB,YB,jsferic, jasfer3D, dmiss)) THEN
IF (JA .EQ. 1) THEN
IF (DIS .LT. DISMIN) THEN
N1 = L
DISMIN = DIS
XN1 = XN ; YN1 = YN
ENDIF
ENDIF
ENDIF
ENDDO
! IF (N1 .NE. 0) THEN
! K1 = kn(1,n1) ; K2 = kn(2,n1)
! IF (dbdistance(XP1,YP1,Xk(K1),Yk(K1)) < dbdistance(XP1,YP1,Xk(K2),Yk(K2)) ) THEN
! N1 = K1
! ELSE
! N1 = K2
! ENDIF
! ENDIF
DIST = DISMIN
END SUBROUTINE CLOSETO1Dnetlink
SUBROUTINE CLOSETO1Dnetnode(XP1,YP1,N1,dist) !
use m_netw
use geometry_module, only: dbdistance
use m_sferic
use m_missing
implicit none
double precision, intent(in) :: XP1, YP1
double precision, intent(out) :: dist ! find 1D point close to x,y:
integer , intent(out) :: n1 ! 1D point found
double precision :: dismin
integer :: ja, k, k1, k2, L
double precision :: dis,dis1,dis2
N1 = 0
DISMIN = 9E+33
DO L = 1,numl
IF (kn(3,L) == 1 .or. kn(3,L) == 6) then ! .or. kn(3,L) == 4) THEN
K1 = kn(1,L) ; K2 = kn(2,L)
dis1 = dbdistance(XP1,YP1,Xk(K1),Yk(K1),jsferic, jasfer3D, dmiss)
dis2 = dbdistance(XP1,YP1,Xk(K2),Yk(K2),jsferic, jasfer3D, dmiss)
if (dis1 < dis2) THEN
k = k1 ; dis = dis1
else
k = k2 ; dis = dis2
endif
IF (DIS .LT. DISMIN) THEN
N1 = k
DISMIN = DIS
ENDIF
ENDIF
ENDDO
dist = dismin
END SUBROUTINE CLOSETO1Dnetnode
SUBROUTINE POLTOLAND(L1,L2) ! SHIFT POLYGON TO LANDBOUNDARY
USE M_POLYGON
USE M_MISSING
USE M_LANDBOUNDARY
implicit none
integer :: l1
integer :: l2
integer :: in, jn
integer :: l, j
double precision :: xp, yp, xpn, ypn, dis, rL
IN = 1 ; IF (L2 < L1) IN = -1
DO L = L1,L2, IN
XP = XPL(L)
IF (XP .NE. XYMIS) THEN
YP = YPL(L)
CALL TOLAND(XP,YP, 1, MXLAN, 1, xpn, ypn, dis, j, rL)
XPL(L) = xpn ; YPL(L) = ypn
ENDIF
ENDDO
END SUBROUTINE POLTOLAND
!> compute the nearest point on the land boundary
SUBROUTINE TOLAND(XX, YY, JSTART, JEND, JAINVIEW, XV, YV, DISMIN, JOUT, RLOUT) ! SHIFT 1 POINT TO LANDBOUNDARY
USE M_LANDBOUNDARY
USE M_MISSING
USE M_POLYGON
use geometry_module, only: pinpok
use gridoperations
implicit none
double precision, intent(in) :: xx,yy !< coordinates of reference point
integer, intent(in) :: JSTART, JEND !< start end end node of land boundary segment respectively
integer , intent(in) :: JAINVIEW !< nodes in view only (1) or not (0) or in polygon only (2)
double precision, intent(out) :: xv,yv !< coordinates of nearest point on land boundary
double precision, intent(out) :: dismin !< smallest distance to land boundary
integer, intent(out) :: jout !< index of first node of poly segment on which the point is projected
double precision, intent(out) :: rLout !< scaled distance of projected point to node jout
integer :: j,ja, ina, inb, ithread
logical :: Ldoit
double precision :: xa,ya,xb,yb,dis,xn,yn,rL, rLdum
! integer, parameter :: IMISS = -999999
integer, external :: OMP_GET_THREAD_NUM
XV = XX ; YV = YY
jout = -999
rlout = -1d0
IF (MXLAN == 0) RETURN
DISMIN = 9E+33
inb = IMISS
! note to self: parallel only if jend-jstart+1 > number
!
!$OMP PARALLEL DO &
!$OMP PRIVATE(j,ja,ina,inb,Ldoit,xa,ya,xb,yb,dis,xn,yn,rL,rLdum,ithread)
DO J = JSTART,JEND-1
Xa = XLAN(J)
Ya = YLAN(J)
Xb = XLAN(J+1)
Yb = YLAN(J+1)
IF (Xa .NE. dXYMIS .AND. XB .NE. dXYMIS) THEN
if ( JAINVIEW.eq.1 ) then
Ldoit = dINVIEW(Xa,Ya,ya) .OR. dINVIEW(Xb,Yb,yb)
else
Ldoit = .true.
end if
if ( JAINVIEW.eq.2 ) then
call pinpok(xa,ya,NPL,XPL,YPL,ina,jins,dmiss)
call pinpok(xb,yb,NPL,XPL,YPL,inb,jins,dmiss)
if ( ina.eq.1 .and. inb.eq.1 ) then
Ldoit = .true.
else
Ldoit = .false.
end if
end if
IF ( Ldoit ) THEN
CALL dLINEDIS3(XX,YY,Xa,Ya,Xb,Yb,JA,DIS,XN,YN,RL)
RLDUM = RL ! remember the unlimited rL
RL = min(max(RL,0d0),1d0)
IF (JA .EQ. 1) THEN
IF (DIS .LT. DISMIN) THEN
!$OMP CRITICAL
IF (DIS .LT. DISMIN ) THEN
XV = XN
YV = YN
DISMIN = DIS
JOUT = J
RLOUT = RLDUM ! output the unlimited rL
END IF
!$OMP END CRITICAL
ENDIF
ENDIF
! IF (DIS == 0) THEN
! DIS = DIS
! ENDIF
ENDIF
ENDIF
END DO
!$OMP END PARALLEL DO
if ( jout.eq.0 ) then
continue
end if
RETURN
END SUBROUTINE TOLAND
subroutine copynetwtopol( )
use m_polygon
use m_missing
use network_data
implicit none
integer :: n, L, k1, k2
call increasepol(3*numl+1000, 0)
n = 0
do L = 1,numL
n = n + 1 ; k1 = kn(1,L) ; xpl(n) = xk(k1) ; ypl(n) = yk(k1) ; zpl(n) = zk(k1)
n = n + 1 ; k2 = kn(2,L) ; xpl(n) = xk(k2) ; ypl(n) = yk(k2) ; zpl(n) = zk(k2)
n = n + 1 ; k2 = kn(2,L) ; xpl(n) = dmiss ; ypl(n) = dmiss ; zpl(n) = dmiss
enddo
npl = n
end subroutine copynetwtopol
!> copy the network boundaries to polygon
!! The polygon will be placed in global m_polygon::XPL, etc.
!! Multiple polygons ('segments') will be separated with a single DMISS in the arrays.
!! For each polygon, the first two points will contain in ZPL the original net node numbers.
!! The makecounterclockwise option will orient the polygon CCW if it encloses the grid,
!! and CW if it represents a hole in the grid.
!! NOTE: when using the makecounterclockwise=1 option, the two net node numbers in ZPL may
!! have been flipped to the last two indices for the polygons that were re-oriented.
subroutine copynetboundstopol(inpol, needfindcells, makecounterclockwise, setnetstat)
use m_alloc
use m_polygon
use m_missing
use network_data
use m_sferic, only: jsferic
use geometry_module, only: dbpinpol, pinpok, cross, get_startend
use gridoperations
implicit none
integer, intent(in) :: inpol !< net boundaries in polygon only (1) or not (0)
integer, intent(in) :: needfindcells !< call findcells (1) or not (0)
integer, intent(in) :: makecounterclockwise !< Return outer polygons in counterclockwise orientation (1) or not (0) (default: 0). NOTE: for 'holes' in the grid, the polygon will be made clockwise.
integer, intent(in) :: setnetstat !< set netstat (1), may induce findcells, or not (0)
integer :: L, LI, LL, kstart, kcur, kp, kr, maxpolh, nph0, nphstart, &
inhul1, inhul2, jasecondtail, iseg, iseg0, isegc, nseg, iorient, &
JACROS, jacros1, jacros2, &
i1, i2, i3, ia, ib, ic, idir, ia0, ib0, ic0, idir0, &
npn, inland, ifindtailcross, jstart, jend, &
jinside
integer, allocatable :: jalinkvisited(:)
integer, allocatable :: isegstart(:)
double precision :: xkb, ykb, zkb, SL,SL0,sl1, sl2,SM,XCR,YCR,CRP,xcg, ycg, area
double precision, allocatable :: xpn(:), ypn(:), zpn(:)
if ( numL.lt.1 ) return ! nothing to do
allocate(jalinkvisited(numl))
allocate(isegstart(numl)) ! (much less than numl needed, generally)
allocate(xpn(numl), ypn(numl), zpn(numL))
npn = 0
inland = 1 ! Require from user first poly point is on land.
idir = 0 ! SPvdP: initialization
jalinkvisited = 0 ! SPvdP: initialization
if ( inpol.eq.0 ) then
call savepol()
npl = 0
xpl = dmiss
ypl = dmiss
zpl = dmiss
if ( needfindcells.eq.1 ) call findcells(0)
call restorepol()
else
if ( needfindcells.eq.1 ) call findcells(0)
end if
inhul1 = -1; inhul2 = -1
! Construct the new polygon set in XPH (backup pol is not used anway during this operation)
XPH=dmiss
NPH = 0
maxpolh = size(xph)
nseg = 0
do L=1,numl
if (jalinkvisited(L)==1) cycle
if (kn(3,L) /= 2 .and. kn(3,L) /= 0) cycle ! No 1D nor 1D2D
if (lnn(L) /= 1) cycle
if ( kn(1,L).lt.1 .or. kn(2,L).lt.1 ) cycle ! safety
call dbpinpol(XK(kn(1,L)), YK(kn(1,L)), inhul1, dmiss, JINS, NPL, xpl, ypl, zpl)
call dbpinpol(XK(kn(2,L)), YK(kn(2,L)), inhul2, dmiss, JINS, NPL, xpl, ypl, zpl)
if (inhul1 /= 1 .and. inhul2 /= 1) cycle
if (NPH+3 > maxpolh) then
maxpolh = max(NPH+3,ceiling(maxpolh*1.2))
call realloc(xph, maxpolh)
call realloc(yph, maxpolh)
call realloc(zph, maxpolh)
end if
! Start a new polyline
if (NPH>0) then ! Separate from existing polylines
NPH = NPH+1
XPH(NPH) = dmiss
YPH(NPH) = dmiss
ZPH(NPH) = dmiss
end if
! This a new link, so start walking its first tail
jasecondtail = 0
! start point
NPH = NPH+1
nseg = nseg + 1
isegstart(nseg) = nph
nphstart = nph
kstart = kn(1,L)
XPH(NPH) = XK(kstart)
YPH(NPH) = YK(kstart)
ZPH(NPH) = dble(kstart)
! CALL CIRR(XK(kstart), YK(kstart), 71)
! Add second point and then...
kcur = kn(2,L)
NPH = NPH+1
XPH(NPH) = XK(kcur)
YPH(NPH) = YK(kcur)
ZPH(NPH) = dble(kcur)
! CALL CIRR(XK(kcur), YK(kcur), 81)
jalinkvisited(L) = 1
! ... start walking connected netlinks
10 continue
! If current point is not within user-polygon, then finish this segment directly.
! This way, for a crossing netlink both netnodes are put in xph, but no further than that.
call dbpinpol(XK(kcur), YK(kcur), inhul2, dmiss, JINS, NPL, xpl, ypl, zpl)
if (inhul2 /= 1) then
goto 11
end if
do LI=1,NMK(kcur)
LL = NOD(kcur)%lin(LI)
if (jalinkvisited(LL)==1) cycle
if (LNN(LL)==1) then
if (kn(2,LL) == kcur) then
kcur = kn(1,LL)
else
kcur = kn(2,LL)
end if
NPH = NPH+1
if (NPH > maxpolh) then
maxpolh = ceiling(maxpolh*1.2)
call realloc(xph, maxpolh)
call realloc(yph, maxpolh)
call realloc(zph, maxpolh)
end if
XPH(NPH) = XK(kcur)
YPH(NPH) = YK(kcur)
ZPH(NPH) = dble(kcur)
jalinkvisited(LL) = 1
! CALL CIRR(XK(kcur), YK(kcur), 31)
goto 10
end if
end do
11 continue
if (kcur == kstart) then ! polyline closed itself
!...
else if (jasecondtail /= 1) then
! Now grow a polyline starting at the other side of the original link L, i.e., the second tail
kcur = kstart
nph0 = nph
jasecondtail = 1
goto 10
else
! Completed a second tail for netlink L, concat with previous
if (nph > nph0) then
! There *is* a nonempty second tail, so reverse the first tail, so that they connect.
do KP=nphstart+ceiling((nph0-nphstart+1)/2.),nph0
xkb = xph(kp)
ykb = yph(kp)
zkb = zph(kp)
kr = nph0-KP+nphstart
xph(kp) = xph(kr)
yph(kp) = yph(kr)
zph(kp) = zph(kr)
xph(kr) = xkb
yph(kr) = ykb
zph(kr) = zkb
end do
end if
end if
! Finished current link L (either closed or two tails), proceed with next L
end do
isegstart(nseg+1) = nph+2
! Now check for all begin and end segments of the new polygon whether they
! intersect with user-polygon. If so,
!call polorientation(xpl, ypl, npl, iorient)
!
inland = 1 ! Assume (i.e., require from user) that first poly point lies on land.
ifindtailcross = 0
do i1=1,npl
i2 = mod(i1, npl)+1
if (ifindtailcross == 1) then
call CROSS(xpl(i1), ypl(i1), xpl(i2), ypl(i2), xpn(npn-1), ypn(npn-1), xpn(npn), ypn(npn), JACROS,SL,SM,XCR,YCR,CRP, jsferic, dmiss)
if (jacros == 1) then
npn = npn-1 ! Remove last netbd point (was outside user poly, temp. needed for this cross check)
npn = npn+1 !eigenlijk hier ook multiple isects checken? of nee
xpn(npn) = xpl(i2)
ypn(npn) = ypl(i2)
zpn(npn) = zpl(i2)
! CALL CIRR(xpn(npn), ypn(npn), 61)
ifindtailcross = 0
inland = abs(inland-1)
end if
cycle
end if
ia0 = -999 ! Reset 'previous crossing' indicator
do iseg=1,nseg
isegc = iseg
ia = abs(isegstart(iseg))
ib = ia+1
crp = 0d0
call CROSS(xpl(i1), ypl(i1), xpl(i2), ypl(i2), xph(ia), yph(ia), xph(ib), yph(ib), JACROS1,SL1,SM,XCR,YCR,CRP, jsferic, dmiss)
ia = abs(isegstart(iseg+1))-2
ib = ia-1
call CROSS(xpl(i1), ypl(i1), xpl(i2), ypl(i2), xph(ia), yph(ia), xph(ib), yph(ib), JACROS2,SL2,SM,XCR,YCR,CRP,jsferic, dmiss)
if (jacros1 == 1 .and. (jacros2 == 0 .or. jacros2 == 1 .and. sl1 < sl2)) then
ia = abs(isegstart(iseg))
ib = ia+1
ic = abs(isegstart(iseg+1))-2 ! End of segment
idir = 1 ! Walk segment in forward direction
sl = sl1
elseif (jacros2 == 1 .and. (jacros1 == 0 .or. jacros1 == 1 .and. sl2 < sl1)) then
ic = abs(isegstart(iseg)) ! 'End' of segment
idir = -1 ! Walk segment in reverse direction
sl = sl2
end if
if (jacros1 == 1 .and. jacros2==1) then
! both head and tail of iseg cross with a single poly segment, include it directly.
goto 20
end if
jacros = max (jacros1, jacros2)
if (jacros == 1) then
inland = abs(inland-1)
if (ia0 == -999 .and. iseg < nseg) then
ia0 = ia; ib0 = ib; ic0 = ic; idir0 = idir; sl0 = sl
iseg0 = iseg
cycle ! Allow a second crossing
else
if (ia0 /= -999 .and. sl0 > sl) then
ia = ia0; ib = ib0; ic = ic0; idir = idir0; sl = sl0
isegc = iseg0
end if
end if
else ! jacross == 0
if (iseg == nseg) then
if (ia0 /= -999) then
ia = ia0; ib = ib0; ic = ic0; idir = idir0; sl = sl0
isegc = iseg0
jacros = 1
end if
else
cycle ! No crossing with segment iseg, try next one
end if
end if
20 if (inland == 0) then ! on water, so include this user-poly point in new poly
npn = npn+1
xpn(npn) = xpl(i2)
ypn(npn) = ypl(i2)
zpn(npn) = zpl(i2)
! CALL CIRR(xpn(npn), ypn(npn), 61)
elseif (isegstart(isegc) > 0) then
! isegstart(.) > 0 when not yet crossed this segment
! so include it in the growing new polygon (possibly reversed)
! do not include first point (it's outside of user polygon)
! do include last point (for checking tail crossing, will be removed later)
if ( idir.gt.0 ) then ! SPvdP: check added, this gave problems in snap-to-land with polygon
do i3=ia+idir,ic,idir
npn = npn+1
xpn(npn) = xph(i3)
ypn(npn) = yph(i3)
zpn(npn) = zph(i3)
! CALL CIRR(xpn(npn), ypn(npn), 61)
ifindtailcross = 1
isegstart(isegc) = -isegstart(isegc)
end do
end if
end if
exit ! If we got this far, no further segments need to be checked in iseg loop
end do
end do
if (ifindtailcross == 1) then
npn = npn-1
end if
do iseg=1,nseg
if (isegstart(iseg) > 0) then
npn = npn + 1
xpn(npn) = dmiss
ypn(npn) = dmiss
zpn(npn) = dmiss
ia = abs(isegstart(iseg))
ic = abs(isegstart(iseg+1))-2 ! End of segment
idir = 1
if (makecounterclockwise == 1) then
! Detect whether this polygon encloses the grid, or is a hole in the grid.
call findel(int(zph(ia)), int(zph(ia+1)), L) ! zph still contains the first two net node numbers where this pol started.
if (L /= 0) then ! safety, should always hold
if (LNN(L) == 1) then ! safety, should always hold
! Use center of mass of this first neighbouring grid cell, for "inside/outside" check.
xcg = xzw(lne(1,L))
ycg = yzw(lne(1,L))
call pinpok(xcg, ycg, ic-ia+1, xph(ia:ic), yph(ia:ic), jinside, jins, dmiss) ! is pol enclosing the grid or a hole in the grid.
call polorientation(xph(ia:ic), yph(ia:ic), ic-ia+1, ic-ia+1, iorient) ! current pol may be CCW or CW
! Check polygon type: outer ring enclosing the grid, should be counterclockwise. A hole in the grid should be clockwise.
if ((jinside == 1 .and. iorient == -1) .or. (jinside == 0 .and. iorient == 1)) then
! Polygon needs to be reversed, simply copy points in reverse order:
ib = ia
ia = ic
ic = ib
idir = -1
else
! Polygon already ok.
idir = 1
end if
end if
end if
end if
do i2=ia,ic,idir
npn = npn+1
xpn(npn) = xph(i2)
ypn(npn) = yph(i2)
zpn(npn) = zph(i2)
end do
isegstart(iseg) = -isegstart(iseg)
end if
end do
call savepol() ! put user-poly in undo buffer
! remove leading DMISS values from polygon
call get_startend(npn,xpn,ypn,jstart,jend,dmiss)
npl = npn-(jstart-1)
call increasepol(npl, 0)
do i1=1,npl
xpl(i1) = xpn(i1-1+jstart)
ypl(i1) = ypn(i1-1+jstart)
zpl(i1) = zpn(i1-1+jstart)
end do
!zpl = dmiss ! AvD: TODO: netbound zk values in zpl
! SPvdP: stored pointer to netnode in zk
deallocate(jalinkvisited, isegstart, xpn, ypn, zpn)
if ( setnetstat.eq.1 ) then
! polygon changed: set netstat to dirty
netstat = NETSTAT_CELLS_DIRTY
end if
end subroutine copynetboundstopol
!> Copy the original polygons that define the current cross sections
!! to the active polygons in xpl,...
subroutine copyCrossSectionsToPol()
use m_monitoring_crosssections
use m_polygon
use m_alloc
implicit none
integer :: i, ip
npl = 0
call realloc(nampli, ncrs, fill=' ')
do i=1,ncrs
nampli(i) = crs(i)%name
call appendCRSPathToPol(crs(i)%path)
end do
end subroutine copyCrossSectionsToPol
!> Copy the original polygons that define the current thin dams
!! to the active polygons in xpl,...
subroutine copyThinDamsToPol()
use m_thindams
use m_polygon
implicit none
integer :: i, ip
npl = 0
do i=1,nthd
call appendCRSPathToPol(thd(i))
end do
end subroutine copyThinDamsToPol
!> Copy the original polygons that define the current fixed weirs
!! to the active polygons in xpl,...
subroutine copyFixedWeirsToPol()
use m_fixedweirs
use m_polygon
implicit none
integer :: i, ip
npl = 0
do i=1,nfxw
call appendCRSPathToPol(fxw(i))
end do
end subroutine copyFixedWeirsToPol
!> Appends the polyline of a cross section path to the current global
!! polyline. Useful for converting cross sections, thin dams or thin
!! dykes back to editable polylines.
subroutine appendCRSPathToPol(path)
use m_crspath
use m_polygon
use m_alloc
use m_missing
implicit none
type(tcrspath), intent(in) :: path
integer :: i, ip
call increasepol(npl+1+path%np, 1)
! Insert dmiss seperator behind existing polylines, if any.
if (npl > 0) then
npl = npl+1
xpl(npl) = dmiss
xpl(npl) = dmiss
zpl(npl) = dmiss
end if
do ip=1,path%np
npl = npl+1
xpl(npl) = path%xp(ip)
ypl(npl) = path%yp(ip)
zpl(npl) = path%zp(ip)
end do
end subroutine appendCRSPathToPol
!!> Converts the current polylines to flux cross sections.
!!! This means, finding shortest path of connected netlinks
!!! between the active polyline points. The latter are first
!!! snapped to the closest net nodes.
!!!
!!! Set jaExisting to 1, if the existing polylines in crs()%xp
!!! have to be used (when called from flow flow_modelinit/obsinit)
!subroutine poltocrs(jaExisting, jaKeepPol)
!use m_polygon
!use m_crosssections
!use m_missing
!use network_data
!use unstruc_colors
!use m_alloc
!use unstruc_messages
!implicit none
!
!integer :: jaExisting !< Use existing crs%xp instead of active polygon in xpl
!integer :: jaKeepPol !< Leave the CRS polylines active on screen (only useful in interactive mode, i.e., jaExisting==0)
!
!integer :: i, i1, ip, ip0, IPL, np, k, k1, k2, kmin, L, ja, ntrc, numnam
!integer, allocatable :: kp(:), kk(:), crstp(:)
!double precision :: dis, rmin, x0, y0, xx1, yy1, xkn, ykn, xn, yn, dpr, dprmin, sl
!double precision :: dbdistance, dprodin
!double precision, allocatable :: xtrc(:), ytrc(:) !< The cross sections that are traced along netnodes
!character(len=64) :: namcrs
!
!if (allocated(nampli)) then
! numnam = size(nampli)
!else
! numnam = 0
!end if
!
!! for jaExisting, copy existing cross section polylines to active polylines in xpl
!if (jaExisting == 1) then
! call savepol() ! xph now contains the onscreen polylines
! allocate(crstp(ncrs))
! ! Back up types of existing crss
! do i=1,ncrs
! crstp(i) = crs(i)%type
! end do
! call copycrosssectionstopol(1) ! overwrite existing crs
!end if
!
!! No crss to be traced, return
!if (npl == 0) then
! if (jaExisting == 1) then
! ! Restore original onscreen polylines when needed.
! call restorepol()
! end if
! return
!end if
!
!! xpl contains the polylines that need to be traced as a crs.
!! xtrc will contain the traced crs path after each iteration
!allocate(kp(npl))
!allocate(kk(maxpol)) ! Save net node nrs of traversed sequence (same pace as xk, yk).
!allocate(xtrc(maxpol), ytrc(maxpol)) ! Save net node nrs of traversed sequence (same pace as xk, yk).
!kp = -1
!! First, snap the polyline points to the closest net nodes.
!do i=1,npl
! if (xpl(i) == dmiss .or. ypl(i) == dmiss) cycle
!
! rmin = huge(rmin)
! kmin = -1
! do k=1,numk
! ! AvD: todo, disable/skip 1D nodes?
! dis = dbdistance(xk(k), yk(k), xpl(i), ypl(i))
! if (dis < rmin) then
! rmin = dis
! kmin = k
! end if
! end do
! kp(i) = kmin
! !call cirr(xk(kmin), yk(kmin), ncolcrs)
!end do
!
!ntrc = 0 ! xtrc(:) is used as placeholder for crs(ncrs)%xk(:), ntrc is growing nr of nodes
!ip = 0 ! position in array of coarse polylines xpl, if xpl(ip+1)==dmiss, start a new crs.
!ipl = 0 ! Nr of current polyline (to acces nampol)
!do ! Loop across polylines.
! ip0 = ip
!
! ip = ip+1
! if (ip > npl) exit ! Last polyline was finished
! if (kp(ip) < 0) cycle ! Superfluous dmiss separator, skip to next point
!
! kc = 0 ! Mark which net nodes are in the new crs.
! IPL = IPL + 1
! ntrc = 1
!
! if (ipl > numnam) then
! namcrs = ' '
! else
! namcrs = nampli(ipl)
! end if
!
! k = kp(ip)
! kc(k) = 1
! xtrc(ntrc) = xk(k)
! ytrc(ntrc) = yk(k)
! kk(ntrc ) = k
! ! For each polyline segment, find closest connected path of net links.
!pli:do ! Loop across the segments of current polyline. i=1,np-1
! if (ip == npl) exit
! k = kp(ip)
! k1 = kp(ip+1)
! if (k1 <= 0) exit ! End of current polyline, jump to next
!
! x0 = xk(k) ! Segment's start point
! y0 = yk(k)
! xx1 = xk(k1) ! Segment's end point
! yy1 = yk(k1)
!
! path: do ! Loop until path of net links has reached node k1 (k==k1).
! if (k==k1) exit
!
! ! Search line from current point to next polyline point.
! dis = dbdistance(xk(k), yk(k), xk(k1), yk(k1))
! dis = dis*dis
!
! ! Next, find the link with smallest angle to line towards xx1,yy1
! dprmin = huge(dprmin)
! kmin = 0
! ! Projected the current point k on line 0-1, that is the start of new search axis.
! call dlinedis(xk(k), yk(k), x0, y0, xx1, yy1,ja,dpr,xkn,ykn)
! do L=1,nmk(k)
! call othernode(k, nod(k)%lin(L), k2)
! if (kc(k2) == 1) then
! if (ip == npl-1 .and. k2 == kk(1)) then
! continue ! Point was used before, but allow it anyway (closing point of close polygon)
! else
! cycle ! Node already in crs
! end if
! end if
!
! ! Distance to line between projected previous point xkn and
! ! endpoint xx1 should be small, i.e., close to original polyline segment.
! call dlinedis2(xk(k2), yk(k2), xkn, ykn, xx1, yy1,ja,dpr,xn,yn, sl)
!
! if (sl < -.01d0 .or. sl > 1.01d0) cycle ! Hardly allow backwards or beyond motion.
!
! if (dpr < dprmin) then
! dprmin = dpr
! kmin = k2
! end if
! end do
! if (kmin == 0) then
! ! Could not find a link leading any further towards xx1,yy1,
! ! Discard this entire polyline
! !npl = 0 ! Reset, to detect faulty cross section below
! do ! Traverse current polyline to end, after that, exit to outer loop.
! ip = ip + 1
! if (ip == npl) exit pli
! if (kp(ip) < 0) exit pli
! end do
! end if
!
! ! Select the best direction.
! k = kmin
! kc(k) = 1
! ! Add the current node to the new polyline.
! ntrc = ntrc+1
! xtrc(ntrc) = xk(k)
! ytrc(ntrc) = yk(k)
! kk(ntrc) = k
! !call cirr(xk(kmin), yk(kmin), ncolcrs)
! end do path ! net link path for a single polyline segment
! ! AvD: TODO: xtrc etc are now allocated at maxpol, potential overflow.
!
! ip = ip + 1
! end do pli ! one polyline becomes one cross section
!
! ! Create the new rai
! if (ntrc <= 1) then
! write(msgbuf, '(a,i2,a,a,a)') 'Cross section path incomplete or too short. Discarding #', ipl, ' (''', trim(namcrs), ''').'
! call msg_flush()
! else
! np = ip-ip0
! call newCrossSection(namcrs, np=np)
! if (jaExisting == 1) then
! crs(ncrs)%type = crstp(ipl)
! end if
!
! crs(ncrs)%xp(1:np) = xpl(ip0+1:ip)
! crs(ncrs)%yp(1:np) = ypl(ip0+1:ip)
! crs(ncrs)%np = np
!
! call allocCRSLinks(ncrs, ntrc-1)
! crs(ncrs)%xk = xtrc(1:ntrc)
! crs(ncrs)%yk = ytrc(1:ntrc)
! crs(ncrs)%kk = kk(1:ntrc)
! crs(ncrs)%len = ntrc-1
! end if
! xtrc = dmiss
! ytrc = dmiss
! ntrc = 0
! mp = 0
! mps = 0
!
! ! Proceed to next polyline/next cross section
!end do ! multiple polylines/cross sections possible
!
!! Restore original onscreen polylines if existing crs's plis had overwritten them.
!if (jaExisting == 1) then
! deallocate(crstp)
!end if
!if (jaKeepPol /= 1) then
! call restorepol()
!end if
!
!nampli = ' ' ! Reset names (to prevent them from being reused in subsequent interactive polylines)
!deallocate(kp, kk, xtrc, ytrc)
!
!end subroutine poltocrs
!> Put the polyline cross sections on flow links.
!! The resulting link administration in the crspath structures is later
!! used when computing cumulative data across the cross sections.
!!
!! \see updateValuesOnCrossSections, fixedweirs_on_flowgeom, thindams_on_netgeom
subroutine crosssections_on_flowgeom()
use m_monitoring_crosssections
use m_flowgeom, only: Lnx
use m_missing
use kdtree2Factory
use unstruc_messages
use dfm_error
use unstruc_channel_flow
use m_inquire_flowgeom
use unstruc_caching, only: copyCachedCrossSections, saveLinkList
implicit none
integer :: ic, icmod
double precision, dimension(:), allocatable :: xx, yy
double precision, dimension(:), allocatable :: dSL
integer, dimension(:), allocatable :: iLink, ipol, istartcrs, numlist
integer, dimension(:,:), allocatable :: linklist
integer, dimension(:), allocatable :: idum
integer :: i, num, numcrossedlinks, ierror
integer :: istart, iend
integer :: jakdtree=1
double precision :: t0, t1
character(len=128) :: mesg
integer :: linknr, ii, branchIdx
type(t_observCrossSection), pointer :: pCrs
logical :: success
if ( ncrs.lt.1 ) return
numcrossedlinks = 0
! allocate
allocate(istartcrs(ncrs+1))
istartcrs = 1
allocate(idum(1))
idum = 0
if ( jakdtree.eq.1 ) then
call klok(t0)
call copyCachedCrossSections( iLink, ipol, success )
if ( success ) then
numcrossedlinks = size(iLink)
ierror = 0
else
num = 0
! determine polyline size
do ic=1,ncrs
if (crs(ic)%loc2OC == 0) then ! only for crs which are polyline-based
num = num+crs(ic)%path%np+1 ! add space for missing value
istartcrs(ic+1) = num+1
end if
end do
! allocate
allocate(xx(num), yy(num))
! determine paths to single polyline map
num = 0
do ic=1,ncrs
if (crs(ic)%loc2OC == 0) then
do i=1,crs(ic)%path%np
num = num+1
xx(num) = crs(ic)%path%xp(i)
yy(num) = crs(ic)%path%yp(i)
end do
! add missing value
num = num+1
xx(num) = DMISS
yy(num) = DMISS
end if
end do
! allocate
allocate(iLink(Lnx))
iLink = 0
allocate(ipol(Lnx))
ipol = 0
allocate(dSL(Lnx))
dSL = 0d0
call find_crossed_links_kdtree2(treeglob,num,xx,yy,2,Lnx,1,numcrossedlinks, iLink, ipol, dSL, ierror)
call saveLinklist( numcrossedlinks, iLink, ipol )
endif
if ( ierror.eq.0 .and. numcrossedlinks.gt.0 ) then
! determine crossed links per cross-section
allocate(numlist(ncrs))
numlist = 0
allocate(linklist(numcrossedlinks,ncrs))
linklist = 0
do i=1,numcrossedlinks
do ic=1,ncrs
if (crs(ic)%loc2OC == 0) then
istart = istartcrs(ic)
iend = istartcrs(ic+1)-1
if ( ipol(i).ge.istart .and. ipol(i).le.iend ) then
numlist(ic) = numlist(ic)+1
linklist(numlist(ic),ic) = iLink(i)
end if
end if
end do
end do
else
! disable kdtree
jakdtree = 0
! allocate(idum(1))
! idum = 0
! deallocate
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(ipol) ) deallocate(ipol)
if ( allocated(dSL) ) deallocate(dSL)
end if
! deallocate
if ( allocated(istartcrs) ) deallocate(istartcrs)
if ( allocated(xx) ) deallocate(xx,yy)
call klok(t1)
write(mesg,"('cross sections with kdtree2, elapsed time: ', G15.5, 's.')") t1-t0
call mess(LEVEL_INFO, trim(mesg))
end if
icMOD = MAX(1,ncrs/100)
call realloc(numlist, ncrs, keepExisting = .true., fill = 0) ! In case pli-based cross sections have not allocated this yet.
call realloc(linklist, (/ max(numcrossedlinks, 1), ncrs /), keepExisting = .true., fill = 0) ! In addition to pli-based cross sections (if any), also support 1D branchid-based cross sections.
call copyCachedCrossSections( iLink, ipol, success )
CALL READYY('Enabling cross sections on grid', 0d0)
do ic=1,ncrs
if (mod(ic,icMOD) == 0) then
CALL READYY('Enabling cross sections on grid', dble(ic)/dble(ncrs))
end if
if (crs(ic)%loc2OC == 0) then
if ( .not. success ) then
if ( jakdtree.eq.0 ) then
call crspath_on_flowgeom(crs(ic)%path,0,0,1,idum, 0)
else
call crspath_on_flowgeom(crs(ic)%path,0,1,numlist(ic),linklist(1,ic), 0)
end if
end if
else ! snap to only 1d flow link
ii = crs(ic)%loc2OC
pCrs => network%observcrs%observcross(ii)
branchIdx = pCrs%branchIdx
if (branchIdx > 0) then
ierror = 1
ierror = findlink(branchIdx, pCrs%chainage, linknr) ! find flow link given branchIdx and chainage
if (ierror == DFM_NOERR) then
numlist(ic) = 1
linklist(1,ic) = linknr
call crspath_on_flowgeom(crs(ic)%path,0,1,numlist(ic),linklist(1,ic), 1)
else
call SetMessage(LEVEL_ERROR, 'Error occurs when snapping Observation cross section '''//trim(crs(ic)%name)//''' to a 1D flow link.')
end if
else
write(msgbuf, '(a)') "Observation cross section "//trim(crs(ic)%name)//" does not have a valide branch index."
call mess(LEVEL_ERROR, msgbuf)
end if
end if
end do
CALL READYY('Enabling cross sections on grid', -1d0)
1234 continue
! deallocate
if ( jakdtree.eq.1 ) then
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(iPol) ) deallocate(iPol)
if ( allocated(dSL) ) deallocate(dSL)
if ( allocated(numlist) ) deallocate(numlist)
if ( allocated(linklist) ) deallocate(linklist)
endif
if ( allocated(idum) ) deallocate(idum)
return
end subroutine crosssections_on_flowgeom
!> Put the polyline thin dams on the network links.
!! All crossed net links are set to kn(3,L) = 0, such that flow_geominit
!! does not even create a flow link across is.
subroutine thindams_on_netgeom()
use m_thindams
use network_data
use unstruc_messages
use m_alloc
use kdtree2Factory
implicit none
double precision, dimension(:), allocatable :: dSL
integer, dimension(:), allocatable :: iLink, ipol, idum
double precision :: xza, yza, xzb, yzb
double precision :: t0, t1
character(len=128) :: mesg
integer :: ierror ! error (1) or not (0)
integer :: numcrossedLinks
integer :: isactive
integer :: ic, iL, L, LL, NPL_prev
integer :: jakdtree = 1 ! use kdtree (1) or not (0)
if (nthd == 0) return
ierror = 1
if ( jakdtree.eq.1 ) then
call klok(t0)
! determine set of links that are connected by a path
allocate(iLink(numL))
allocate(iPol(numL))
allocate(dSL(numL))
allocate(idum(3*nthd))
call delpol()
! copy all paths to a DMISS-separated polyline
do ic=1,nthd
NPL_prev = NPL ! previous end pointer in polyline array
call appendCRSPathToPol(thd(ic))
if ( NPL.gt.0 ) then
if ( NPL.gt.ubound(idum,1) ) then
call realloc(idum, 1+int(1.2d0*dble(NPL)), keepExisting=.true., fill=0)
end if
idum(NPL_prev+1:NPL) = ic
end if
end do
call find_crossed_links_kdtree2(treeglob,NPL,xpl,ypl,1,numL,0,numcrossedlinks,iLink,iPol,dSL,ierror)
if ( ierror.ne.0 ) then
! disable kdtree
jakdtree = 0
! deallocate
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(ipol) ) deallocate(ipol)
if ( allocated(dSL) ) deallocate(dSL)
if ( allocated(idum) ) deallocate(idum)
else
! initialize number of crossed flowlinks in paths
do ic=1,nthd
thd(ic)%lnx = 0
end do
do iL=1,numcrossedlinks
! get link number
L = iLink(iL)
! get thin dam number
ic = idum(iPol(iL))
call get_link_neighboringcellcoords(L,isactive,xza,yza,xzb,yzb)
if ( isactive.eq.1 ) then
call crspath_on_singlelink(thd(ic), L, xk(kn(1,L)), yk(kn(1,L)), xk(kn(2,L)), yk(kn(2,L)), xza, yza, xzb, yzb)
do L=1,thd(ic)%lnx
LL = abs(thd(ic)%ln(L))
if (LL > 0 .and. LL <= numl) then
kn(3,LL) = 0
end if
end do
end if
end do ! do iL=1,numcrossedlinks
end if
call klok(t1)
write(mesg,"('thin dams with kdtree2, elapsed time: ', G15.5, 's.')") t1-t0
call mess(LEVEL_INFO, trim(mesg))
end if
if ( jakdtree.eq.0 ) then ! no kdtree, or kdtree gave error
call klok(t0)
do ic=1,nthd
call crspath_on_netgeom(thd(ic))
do L=1,thd(ic)%lnx
LL = abs(thd(ic)%ln(L))
if (LL > 0 .and. LL <= numl) then
kn(3,LL) = 0
end if
end do
end do
call klok(t1)
write(mesg,"('thin dams without kdtree2, elapsed time: ', G15.5)") t1-t0
call mess(LEVEL_INFO, trim(mesg))
end if ! if ( jakdtree.eq.1 ) then
ierror = 0
1234 continue
if ( allocated(iLink) ) deallocate(iLink)
if ( allocated(iPol) ) deallocate(iPol)
if ( allocated(dSL) ) deallocate(dSL)
if ( allocated(idum) ) deallocate(idum)
if ( NPL.gt.0 ) call delpol()
return
end subroutine thindams_on_netgeom
!> TODO: update setfixedweirs to use fxw
subroutine fixedweirs_on_flowgeom()
use m_fixedweirs
implicit none
integer, dimension(:), allocatable :: idum
integer :: ic
allocate(idum(1))
idum = 0
do ic=1,nfxw
call crspath_on_flowgeom(fxw(ic),1,0,1,idum, 0)
end do
end subroutine fixedweirs_on_flowgeom
!> Constructs the set of crossed flow links for a single path on the
!! current *flow* geometry.
!!
!! Input is a path with path coordinates in xp,yp.
!! Output path contains additional link numbers in ln and edge
!! coordinates in xk,yk.
!!
!! \see crspath_on_netgeom, crosssections_on_flowgeom, fixedweirs_on_flowgeom
subroutine crspath_on_flowgeom(path,includeghosts,jalinklist,numlinks,linklist, jaloc3)
use m_crspath
use m_flowgeom
use network_data
use m_sferic
use m_partitioninfo
use sorting_algorithms, only: indexx
use geometry_module, only: dbdistance, normalout
use m_missing, only: dmiss, dxymis
implicit none
type(tcrspath), intent(inout) :: path !< Cross section path that must be imposed on flow geometry.
integer, intent(in) :: includeghosts !< include ghost links in path (1) or not (0)
integer, intent(in) :: jalinklist !< use link list (1) or not (0)
integer, intent(in) :: numlinks !< number of links in list
integer, dimension(numlinks), intent(in) :: linklist !< list of flowlinks crossed by path
integer, intent(in ) :: jaloc3 !< If it has locationtype==3, then jaloc3>0, for Crs defined by branchID and chainage
integer :: i, iend, iLf, L, Lf, n1, n2, kint
integer :: jaghost, idmn_ghost
double precision :: x1, y1, x2, y2, xn, yn, af
double precision, allocatable :: dpl(:)
path%lnx = 0 ! Reset link administration for this path.
kint = max(lnx/1000,1)
if ( jalinklist.eq.0 ) then
iend = Lnx
else
iend = numlinks
end if
! Loop across all flow links
do iLf = 1,iend
if ( jalinklist.eq.0 ) then
Lf = iLf
else
Lf = linklist(iLf)
end if
n1 = ln(1,Lf) ; n2 = ln(2,Lf)
L = ln2lne(Lf)
if (n1 <= 0 .or. n2 <= 0 .or. L <= 0 .or. &
n1 > ndx .or. n2 > ndx .or. L > numl) then
cycle
end if
if ( jampi.eq.1 ) then
if ( includeghosts.ne.1 ) then
! exclude ghost links
call link_ghostdata(my_rank,idomain(ln(1,Lf)), idomain(ln(2,Lf)), jaghost, idmn_ghost, ighostlev(ln(1,Lf)), ighostlev(ln(2,Lf)))
if ( jaghost.eq.1 ) cycle
end if
end if
if (abs(kcu(Lf)) == 2) then ! For 2D links: take net nodes of crossed net link.
x1 = xk(lncn(1,Lf))
y1 = yk(lncn(1,Lf))
x2 = xk(lncn(2,Lf))
y2 = yk(lncn(2,Lf))
else ! For 1D links: produce fictious 'cross/netlink'
call normalout(xz(n1), yz(n1), xz(n2), yz(n2), xn, yn, jsferic, jasfer3D, dmiss, dxymis)
xn = -xn; yn = -yn ! flow link should be perpendicular to 'crs', and not vice versa.
xn = wu(Lf)*xn; yn = wu(Lf)*yn
if (jsferic == 1) then
xn = rd2dg*xn/ra
yn = rd2dg*yn/ra
end if
x1 = .5d0*(xz(n1)+xz(n2)) - .5d0*xn
y1 = .5d0*(yz(n1)+yz(n2)) - .5d0*yn
x2 = .5d0*(xz(n1)+xz(n2)) + .5d0*xn
y2 = .5d0*(yz(n1)+yz(n2)) + .5d0*yn
end if
if (jaloc3 > 0) then ! for Crs defined by branchID and chainage
call increaseCrossSectionPath(path, 0, 1)
path%xk(1,1) = x1
path%yk(1,1) = y1
path%xk(2,1) = x2
path%yk(2,1) = y2
path%lnx = 1
path%ln(1) = Lf
else
call crspath_on_singlelink(path, Lf, x1, y1, x2, y2, xz(n1), yz(n1), xz(n2), yz(n2))
end if
enddo
if ( path%lnx.gt.0 .and. jaloc3 == 0) then
! determine permutation array of flowlinks by increasing arc length order
do i=1,path%lnx
path%sp(i) = dble(path%indexp(i)) + (1d0-path%wfp(i))
end do
call indexx(path%lnx,path%sp,path%iperm)
! compute arc length
allocate(dpl(path%np))
dpl(1) = 0d0
do i=2,path%np
dpl(i) = dpl(i-1) + dbdistance(path%xp(i-1),path%yp(i-1),path%xp(i),path%yp(i), jsferic, jasfer3D, dmiss)
end do
do i=1,path%lnx
path%sp(i) = dpl(path%indexp(i)) * path%wfp(i) + &
dpl(path%indexp(i)+1) * (1d0-path%wfp(i))
end do
deallocate(dpl)
end if
end subroutine crspath_on_flowgeom
!> Constructs the set of crossed flow links for a single path on the
!! current *network* geometry. (Used for thin dams.)
!!
!! Input is a path with path coordinates in xp,yp.
!! Output path contains additional link numbers in kn and edge
!! coordinates in xk,yk.
!!
!! \see crspath_on_flowgeom, thindams_on_netgeom
subroutine crspath_on_netgeom(path)
use m_crspath
use network_data
implicit none
type(tcrspath), intent(inout) :: path !< Cross section path that must be imposed on network geometry.
integer :: L, isactive
double precision :: xza, yza, xzb, yzb
path%lnx = 0 ! Reset link administration for this path.
! Loop across all net links
do L = 1,numl
call get_link_neighboringcellcoords(L, isactive, xza, yza, xzb, yzb)
if ( isactive.ne.1 ) cycle
call crspath_on_singlelink(path, L, xk(kn(1,L)), yk(kn(1,L)), xk(kn(2,L)), yk(kn(2,L)), xza, yza, xzb, yzb)
enddo
end subroutine crspath_on_netgeom
!> get neighboring cell center coordinates
subroutine get_link_neighboringcellcoords(L, isactive, xza, yza, xzb, yzb)
use network_data
use m_flowgeom, only: xz, yz ! Note that xz,yz are already filled after findcells.
implicit none
integer, intent(in) :: L !< link number
integer, intent(out) :: isactive !< active link (1) or not (0)
double precision, intent(out) :: xza, yza, xzb, yzb !< left- and right-neighboring cell centers
integer :: n1, n2
isactive = 1
if (kn(3,L) == 1 .or. kn(3,L) == 3 .or. kn(3,L) == 4) then
n1 = kn(1,L)
n2 = kn(2,L)
xza = xk(n1) ; yza = yk(n1)
xzb = xk(n2) ; yzb = yk(n2)
else
n1 = lne(1,L); n2 = lne(2,L)
if (lnn(L) < 2 .or. n1 <= 0 .or. n2 <= 0 .or. n1 > nump .or. n2 > nump) then
isactive = 0
return
end if
xza = xz(n1) ; yza = yz(n1)
xzb = xz(n2) ; yzb = yz(n2)
end if
return
end subroutine get_link_neighboringcellcoords
!> Sums all monitored data on all cross sections, including time-integrated values.
!! for sequential/non-MPI models: stored in crs()%sumvalcur/sumvalcum
!! for parallel/MPI models: stored in sumvalcur_tmp, and needs later mpi_allreduce:
!! @see updateValuesOnCrossSections_mpi
subroutine updateValuesOnCrossSections(tim1)
use m_monitoring_crosssections
use m_missing
use m_transport , only: NUMCONST_MDU
use m_partitioninfo, only: jampi
use m_sediment, only: jased, stmpar
implicit none
double precision, intent(in) :: tim1 !< Current (new) time
double precision, save :: timprev = -1d0
double precision, save :: timstart
double precision :: timstep, timtot
integer :: iv, icrs, numvals
! This routine can now be called any time, but will only do the update
! of sumval* when necessary:
if (tlastupd_sumval == tim1) then
return
end if
numvals = 5 + NUMCONST_MDU
if( jased == 4 .and. stmpar%lsedtot > 0 ) then
numvals = numvals + 1
if( stmpar%lsedsus > 0 ) then
numvals = numvals + 1
endif
endif
if (.not. allocated(sumvalcum_timescale)) then
allocate(sumvalcum_timescale(numvals))
sumvalcum_timescale = 1d0
endif
if (.not. allocated(sumvalcur_tmp)) then
allocate(sumvalcur_tmp(numvals,ncrs))
sumvalcur_tmp = 0d0
if (jampi==1) then
if (.not. allocated(sumvalcumQ_mpi)) then
allocate(sumvalcumQ_mpi(ncrs))
sumvalcumQ_mpi = 0d0
endif
endif
endif
if (timprev == -1d0) then
timstep = 0d0
timstart = tim1 ! Generally tstart_user
timtot = 0d0
else
timstep = tim1 - timprev
timtot = tim1 - timstart
end if
! compute cross-section data for all cross-sections
call sumvalueOnCrossSections(sumvalcur_tmp, numvals)
if (jampi == 0) then
tlastupd_sumval = tim1 ! Only when jampi==0 the sumval arrays are directly correct after filling. See also updateValuesOnCrossSections_mpi()
! NOTE: when jampi==1, the cross section sumvals on GUI screen are *not* correct, except at each ti_his interval.
do icrs=1,ncrs
do iv = 1, numvals ! Nu nog "5+ Numconst" standaard grootheden, in buitenlus
crs(icrs)%sumvalcur(iv) = sumvalcur_tmp(iv,icrs)
crs(icrs)%sumvalcum(iv) = crs(icrs)%sumvalcum(iv) + max(sumvalcum_timescale(iv),1d0)*timstep*sumvalcur_tmp(iv,icrs)
if (timtot > 0d0) then
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcum(iv)/timtot/max(sumvalcum_timescale(iv),1d0)
else
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcur(iv)
end if
end do
end do
else
do icrs=1,ncrs ! Compute time-integrated discharge in current history output interval
sumvalcumQ_mpi(icrs) = sumvalcumQ_mpi(icrs) + max(sumvalcum_timescale(IPNT_Q1C),1d0)*timstep*sumvalcur_tmp(IPNT_Q1C,icrs)
enddo
endif
timprev = tim1
end subroutine updateValuesOnCrossSections
!> compute cross-section data, summed across all flow links for each cross-section.
!! In parallel models, only summed across flow links in own domain.
!! @see updateValuesOnCrossSections @see updateValuesOnCrossSections_mpi
subroutine sumvalueOnCrossSections(resu, numvals)
use m_flow
use m_flowgeom
use m_monitoring_crosssections
use m_partitioninfo
use m_timer
use m_transport, only: NUMCONST_MDU, ISALT, ITEMP, ISED1, ITRA1, constituents
use m_sediment, only: jased, stmpar, sedtra
implicit none
integer, intent(in) :: numvals !< Which values to sum (1=discharge)
double precision, intent(out) :: resu(numvals,ncrs) !< cross-section data, note: ncrs from module m_monitoring_crosssections
integer :: i, Lf, L, k1, k2, IP, num, LL
integer :: icrs
double precision :: val
integer :: lsed
if ( ncrs.lt.1 ) return ! nothing to do
resu = 0d0
do icrs=1,ncrs
do i=1,crs(icrs)%path%lnx
Lf = crs(icrs)%path%ln(i)
if (Lf == 0) cycle ! Closed wall
L = abs(Lf)
k1 = ln(1,L); k2 = ln(2,L)
resu(IPNT_Q1C,icrs) = resu(IPNT_Q1C,icrs) + dble(sign(1, Lf)) * q1(L) ! discharge
resu(IPNT_AUC,icrs) = resu(IPNT_AUC,icrs) + au(L) ! area
! NOTE: IPNT_U1A is now not included.
resu(IPNT_S1A,icrs) = resu(IPNT_S1A,icrs) + 0.5d0*( s1(k1) + s1(k2) ) * au(L) ! weigted waterlevel
resu(IPNT_HUA,icrs) = resu(IPNT_HUA,icrs) + hu(L) * au(L) ! upwind waterdepth
if( jatransportmodule.ne.0 ) then
IP = IPNT_HUA
do num = 1,NUMCONST_MDU
IP = IP + 1
do LL = Lbot(L), Ltop(L)
k1 = ln(1,LL); k2 = ln(2,LL)
resu(IP,icrs) = resu(IP,icrs) + dble(sign(1, Lf)) * ( max(q1(LL),0d0) * constituents(num,k1) &
+ min(q1(LL),0d0) * constituents(num,k2) )
enddo
enddo
endif
if( jased == 4 .and. stmpar%lsedtot > 0 ) then ! todo, loop korter tot lsedsus.
IP = IPNT_HUA + NUMCONST_MDU + 1 ! TODO: mourits/dam_ar: check whether all uses of NUMCONST versus NUMCONST_MDU are now correct.
do lsed = 1,stmpar%lsedtot
resu(IP,icrs) = resu(IP,icrs) + sedtra%e_sbn(L,lsed) * wu_mor(L) * dble(sign(1, Lf))
enddo
if( stmpar%lsedsus > 0 ) then
IP = IP + 1
do lsed = 1,stmpar%lsedsus
resu(IP,icrs) = resu(IP,icrs) + sedtra%e_ssn(L,lsed) * wu(L) * dble(sign(1, Lf))
enddo
endif
endif
end do
end do ! do icrs=1,ncrs
if( jased == 4 .and. stmpar%lsedtot > 0 ) then
IP = IPNT_HUA + NUMCONST_MDU + 1
sumvalcum_timescale(IP) = stmpar%morpar%morfac
if( stmpar%lsedsus > 0 ) then
IP = IP + 1;
sumvalcum_timescale(IP) = stmpar%morpar%morfac
endif
endif
if (jampi == 0 ) then
! NOTE: if jampi==1, it is incorrect to compute quantities that require division by AU values
! since these are not mpi_reduced yet. So, don't compute them at all in parallel runs.
do icrs=1,ncrs
if (resu(IPNT_AUC,icrs) > 0) then
resu(IPNT_U1A,icrs) = resu(IPNT_Q1C,icrs) / resu(IPNT_AUC,icrs) ! average velocity
resu(IPNT_S1A,icrs) = resu(IPNT_S1A,icrs) / resu(IPNT_AUC,icrs) ! average waterlevel
resu(IPNT_HUA,icrs) = resu(IPNT_HUA,icrs) / resu(IPNT_AUC,icrs) ! average waterdepth
endif
end do
endif
!! BEGIN DEBUG
! do icrs=1,ncrs
! write(6,"('icrs=', I0, ', my_rank=', I0, ', Q=', G15.5)") icrs, my_rank, resu(2,icrs)
! end do
!! END DEBUG
end subroutine sumvalueOnCrossSections
!> Sums all monitored data on all cross sections, including time-integrated values.
!! for sequential/non-MPI models: stored in crs()%sumvalcur/sumvalcum
!! for parallel/MPI models: stored in sumvalcur_tmp, and needs later mpi_allreduce:
!! @see updateValuesOnCrossSections_mpi
subroutine updateValuesOnCrossSections_mpi(tim1)
use m_monitoring_crosssections
use m_partitioninfo
use m_timer
use m_transport , only: NUMCONST_MDU
use m_sediment, only: jased, stmpar
use m_alloc
use mpi
use m_flowtimes, only: tstart_user, ti_his
implicit none
double precision :: tim1, timtot
integer :: icrs, iv, numvals, ierror
! This routine can now be called any time, but will only do the update
! of sumval* when necessary:
if (tlastupd_sumval == tim1) then
return
end if
tlastupd_sumval = tim1 ! When jampi==1 the sumval arrays are only correct after the reductions below.
numvals = 5 + NUMCONST_MDU
if( jased == 4 .and. stmpar%lsedtot > 0 ) then
numvals = numvals + 1
if( stmpar%lsedsus > 0 ) then
numvals = numvals + 1
endif
endif
timtot = tim1 - tstart_user
! MPI communication between subdomains
if ( jatimer.eq.1 ) call starttimer(IOUTPUTMPI)
call reduce_crs(sumvalcur_tmp,ncrs,numvals)
call reduce_crs(sumvalcumQ_mpi, ncrs, 1)
if ( jatimer.eq.1 ) call stoptimer(IOUTPUTMPI)
! Update values
do icrs=1,ncrs
if (sumvalcur_tmp(IPNT_AUC, icrs) > 0) then
sumvalcur_tmp(IPNT_U1A, icrs) = sumvalcur_tmp(IPNT_Q1C, icrs) / sumvalcur_tmp(IPNT_AUC, icrs)
sumvalcur_tmp(IPNT_S1A, icrs) = sumvalcur_tmp(IPNT_S1A, icrs) / sumvalcur_tmp(IPNT_AUC, icrs)
sumvalcur_tmp(IPNT_HUA, icrs) = sumvalcur_tmp(IPNT_HUA, icrs) / sumvalcur_tmp(IPNT_AUC, icrs)
endif
crs(icrs)%sumvalcur(1:numvals) = sumvalcur_tmp(1:numvals,icrs)
enddo
do icrs=1,ncrs
do iv = 1, numvals ! Nu nog "5+ Numconst" standaard grootheden, in buitenlus
if (iv == IPNT_Q1C) then
crs(icrs)%sumvalcum(iv) = crs(icrs)%sumvalcum(iv) + sumvalcumQ_mpi(icrs)
else
! TODO: AvD/JZ: UNST-1281: cumulative Q fort MPI runs is now correct, but:
! * jampi==1 code is quite different from jampi==0 for the sumvalcum.
! * And: sumvalcum for all other quantities than Q1C are wrong:
crs(icrs)%sumvalcum(iv) = crs(icrs)%sumvalcum(iv) + max(sumvalcum_timescale(iv),1d0)*ti_his*sumvalcur_tmp(iv, icrs)
end if
if (timtot > 0d0) then
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcum(iv)/timtot/max(sumvalcum_timescale(iv),1d0)
else
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcur(iv)
endif
end do
end do
! Total sums are now correctly in crs(:)%sumval*. Prepare for a new ti_his time interval with partial sums:
sumvalcur_tmp = 0d0
sumvalcumQ_mpi= 0d0
end subroutine updateValuesOnCrossSections_mpi
subroutine obs_on_flowgeom(iobstype)
use m_observations
use unstruc_messages
use m_partitioninfo
use m_flowgeom, only : xz,yz,ndx2D,ndxi
use unstruc_caching
implicit none
integer, intent(in) :: iobstype !< Which obs stations to update: 0=normal, 1=moving, 2=both
integer :: i, k, n, n1, n2, k1b, iobs
double precision :: d1, d2
logical :: cache_success
integer :: jakdtree
jakdtree = 1 ! use kdtree (1) or not (other)
! Include normal stations?
if (iobstype == 0 .or. iobstype == 2) then
n1 = 1
else
n1 = numobs+1
end if
! Include moving stations?
if (iobstype == 1 .or. iobstype == 2) then
n2 = numobs+nummovobs
else
n2 = numobs
end if
if ( cacheRetrieved() ) then
call copyCachedObservations( cache_success )
else
cache_success = .false.
endif
if ( .not. cache_success ) then
call find_flownode_for_obs(n1, n2)
endif
if (loglevel_StdOut == LEVEL_DEBUG) then
do iobs = n1,n2
if (kobs(iobs) Finds the flow nodes/cell numbers for each given x,y point (e.g., an observation station)
subroutine find_flownode(N, xobs, yobs, namobs, kobs, jakdtree, jaoutside, iLocTp)
use unstruc_messages
use m_partitioninfo
use m_flowgeom
use m_GlobalParameters, only: INDTP_1D, INDTP_2D, INDTP_ALL
use kdtree2Factory
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: N !< number of points
double precision, dimension(N), intent(in) :: xobs, yobs !< points coordinates
character(len=40), dimension(N), intent(in) :: namobs !< names of points
integer, dimension(N), intent(inout) :: kobs !< associated flow nodes, if found.
integer, intent(inout) :: jakdtree !< use kdtree (1) or not (other)
integer, intent(in) :: jaoutside !< allow outside cells (for 1D) (1) or not (0)
integer, intent(in) :: iLocTp !< Node type, one of INDTP_1D/2D/ALL.
integer :: ierror ! error (1) or not (0)
integer :: i, k, k1b
integer, dimension(1) :: idum
double precision :: d1, d2
ierror = 1
if ( jakdtree.eq.1 ) then
call find_flowcells_kdtree(treeglob,N,xobs,yobs,kobs,jaoutside,iLocTp, ierror)
if ( jampi.eq.1 ) then
! globally reduce ierror
idum(1) = ierror
call reduce_int_max(1, idum)
ierror = idum(1)
end if
if ( ierror.ne.0 ) then
jakdtree = 0 ! retry without kdtree
end if
! disable observation stations without attached flowlinks
do i=1,N
k=kobs(i)
if ( k.gt.0 ) then
if ( nd(k)%lnx.lt.1 ) then
kobs(i) = 0
end if
end if
end do
end if
if ( jakdtree.ne.1 ) then
do i=1,N
call inflowcell(xobs(i),yobs(i),k,jaoutside, iLocTp)
if ( jaoutside.eq.1 .and. (iLocTp == INDTP_1D .or. iLocTp == INDTP_ALL)) then
call CLOSETO1DORBND(xobs(i),yobs(i),k1B)
IF (K .ne. 0 .and. k1b .ne. 0) THEN
D1 = DBDISTANCE(XZ(K1B), YZ(K1B), XOBS(I), YOBS(I), jsferic, jasfer3D, dmiss)
D2 = DBDISTANCE(XZ(K ), YZ(K ), XOBS(I), YOBS(I), jsferic, jasfer3D, dmiss)
IF ( D1 < D2 ) THEN
K = K1B
ENDIF
ELSE IF (K1B .NE. 0) THEN
K = K1B
ENDIF
end if
kobs(i) = 0
if ( k.ne.0 ) then
if ( nd(k)%lnx.gt.0 ) then
kobs(i) = k
end if
end if
end do
end if
if ( jampi.eq.1 .and. N.gt.0 ) then
! check if this subdomain owns the observation station
call reduce_kobs(N,kobs,xobs,yobs,jaoutside)
end if
do i=1,N
if ( kobs(i).eq.0 ) then
write(msgbuf, '(a,i0,a,a,a)') 'Could not find flowcell for point #', i, ' (', trim(namobs(i)), '). Discarding.'
call msg_flush()
endif
end do
ierror = 0
1234 continue
return
end subroutine find_flownode
!> Finds the flow nodes/cell numbers for all observation points. There are four kinds of obs, treated differently:
!! obs that are defined in *.xyn file, to be snaped to 1D+2D flow nodes (Locationtype == 0), use kdtree
!! obs that are defined in *.ini file by xy coordinate, to be snaped to only 1D flow node (Locationtype == 1), use kdtree
!! obs that are defined in *.ini file by xy coordinate, to be snaped to only 2D flow node (Locationtype == 2), use kdtree
!! obs that are defined in *.ini file by branchID and chainage, to be snaped to only 1D flow node (Locationtype == 3), do not use kdtree
subroutine find_flownode_for_obs(nstart, nend)
use MessageHandling
use m_network
use m_ObservationPoints
use m_observations
use unstruc_channel_flow
use m_inquire_flowgeom
use m_GlobalParameters, only: INDTP_1D, INDTP_2D, INDTP_ALL
use dfm_error
use m_alloc
use m_flowgeom
implicit none
integer, intent(in) :: nstart ! starting index of obs for snapping to a flow node
integer, intent(in) :: nend ! ending index of obs for snapping to a flow node
integer :: i, nodenr, branchIdx, ntotal, nobsini, ierr, jakdtree, jabybranch
integer, allocatable :: ixy2obs0(:), ixy2obs1(:), ixy2obs2(:)
integer, allocatable :: kobs_tmp0(:), kobs_tmp1(:), kobs_tmp2(:)
double precision, allocatable :: xobs_tmp0(:), xobs_tmp1(:), xobs_tmp2(:)
double precision, allocatable :: yobs_tmp0(:), yobs_tmp1(:), yobs_tmp2(:)
character(len=40), allocatable :: namobs_tmp0(:), namobs_tmp1(:), namobs_tmp2(:)
integer :: nloctype1D, nloctype2D, nloctypeAll
type(t_ObservationPoint), pointer :: pOPnt
ntotal = nend - nstart + 1
if (ntotal <= 0) then
return
end if
! realloc temperary arrays for searching
call realloc(ixy2obs0, ntotal, keepExisting=.false.)
call realloc(xobs_tmp0, ntotal, keepExisting=.false.)
call realloc(yobs_tmp0, ntotal, keepExisting=.false.)
call realloc(kobs_tmp0, ntotal, keepExisting=.false.)
call realloc(namobs_tmp0, ntotal, keepExisting=.false.)
nobsini = network%obs%Count
call realloc(ixy2obs1, nobsini, keepExisting=.false.)
call realloc(xobs_tmp1, nobsini, keepExisting=.false.)
call realloc(yobs_tmp1, nobsini, keepExisting=.false.)
call realloc(kobs_tmp1, nobsini, keepExisting=.false.)
call realloc(namobs_tmp1, nobsini, keepExisting=.false.)
call realloc(ixy2obs2, nobsini, keepExisting=.false.)
call realloc(xobs_tmp2, nobsini, keepExisting=.false.)
call realloc(yobs_tmp2, nobsini, keepExisting=.false.)
call realloc(kobs_tmp2, nobsini, keepExisting=.false.)
call realloc(namobs_tmp2, nobsini, keepExisting=.false.)
nloctype1D = 0
nloctype2D = 0
nloctypeAll = 0
! loop over obs
do i = nstart, nend
if (locTpObs(i) == INDTP_ALL) then ! obs to be snapped to a nearest 1D or 2D flow node (obs that are defined in *.xyn file)
if (ndx <= 0) then
write(msgbuf, '(a)') "Observation point "//trim(namobs(i))//" requires to snap to a flow node, but there is no flow node to be snapped to."
call mess(LEVEL_ERROR, msgbuf)
end if
nloctypeAll = nloctypeAll + 1
ixy2obs0(nloctypeAll) = i
xobs_tmp0(nloctypeAll) = xobs(i)
yobs_tmp0(nloctypeAll) = yobs(i)
namobs_tmp0(nloctypeAll) = namobs(i)
else if (locTpObs(i) == INDTP_1D) then ! obs to be snapped to only 1D flow node (obs that are defined in *.ini file (either by branchid+chainage, or xy coordinate), and locationtype ==1)
if (ndx - ndx2d <= 0) then
write(msgbuf, '(a)') "Observation point "//trim(namobs(i))//" requires to snap to a 1D flow node, but there is no 1D flow node to be snapped to."
call mess(LEVEL_ERROR, msgbuf)
end if
jabybranch = 0
! 1D, option a: Try to handle branchid+chainage input directly:
if (obs2OP(i) > 0) then
pOPnt => network%obs%OPnt(obs2OP(i))
branchIdx = pOPnt%branchIdx
if (branchIdx > 0) then
jabybranch = 1
ierr = findnode(branchIdx, pOPnt%chainage, nodenr) ! find flow node given branchIDx and chainage
if (ierr == DFM_NOERR) then
kobs(i) = nodenr
else
call SetMessage(LEVEL_ERROR, 'Error when snapping Observation Point '''//trim(namobs(i))//''' to a 1D flow node.')
end if
end if
end if
! 1D, option b: via x/y coords, prepare input
if (jabybranch == 0) then
nloctype1D = nloctype1D + 1
ixy2obs1(nloctype1D) = i
xobs_tmp1(nloctype1D) = xobs(i)
yobs_tmp1(nloctype1D) = yobs(i)
namobs_tmp1(nloctype1D) = namobs(i)
end if
else if (locTpObs(i) == INDTP_2D) then ! obs to be snapped to only 2D flow node (obs that are defined in *.ini file by xy coordinate, and locationtype ==2)
if (ndx2d <= 0) then
write(msgbuf, '(a)') "Observation point "//trim(pOPnt%name)//" requires to snap to a 2D flow node, but there is no 2D flow node to be snapped to."
call mess(LEVEL_ERROR, msgbuf)
end if
nloctype2D = nloctype2D + 1
ixy2obs2(nloctype2D) = i
xobs_tmp2(nloctype2D) = xobs(i)
yobs_tmp2(nloctype2D) = yobs(i)
namobs_tmp2(nloctype2D) = namobs(i)
end if
end do
! find flow nodes
jakdtree = 1
if (nloctypeAll > 0) then
call find_flownode(nloctypeAll, xobs_tmp0(1:nloctypeAll), yobs_tmp0(1:nloctypeAll), namobs_tmp0(1:nloctypeAll), kobs_tmp0(1:nloctypeAll), jakdtree, 1, INDTP_ALL)
do i = 1, nloctypeAll
kobs(ixy2obs0(i)) = kobs_tmp0(i)
end do
end if
jakdtree = 1
if (nloctype1D > 0) then
call find_flownode(nloctype1D, xobs_tmp1(1:nloctype1D), yobs_tmp1(1:nloctype1D), namobs_tmp1(1:nloctype1D), kobs_tmp1(1:nloctype1D), jakdtree, 0, INDTP_1D)
do i = 1, nloctype1D
kobs(ixy2obs1(i)) = kobs_tmp1(i)
end do
end if
jakdtree = 1
if (nloctype2D > 0) then
call find_flownode(nloctype2D, xobs_tmp2(1:nloctype2D), yobs_tmp2(1:nloctype2D), namobs_tmp2(1:nloctype2D), kobs_tmp2(1:nloctype2D), jakdtree, 0, INDTP_2D)
do i = 1, nloctype2D
kobs(ixy2obs2(i)) = kobs_tmp2(i)
end do
end if
if (allocated(ixy2obs0)) deallocate(ixy2obs0)
if (allocated(xobs_tmp0)) deallocate(xobs_tmp0)
if (allocated(yobs_tmp0)) deallocate(yobs_tmp0)
if (allocated(yobs_tmp0)) deallocate(yobs_tmp0)
if (allocated(namobs_tmp0)) deallocate(namobs_tmp0)
if (allocated(ixy2obs1)) deallocate(ixy2obs1)
if (allocated(xobs_tmp1)) deallocate(xobs_tmp1)
if (allocated(yobs_tmp1)) deallocate(yobs_tmp1)
if (allocated(yobs_tmp1)) deallocate(yobs_tmp1)
if (allocated(namobs_tmp1)) deallocate(namobs_tmp1)
if (allocated(ixy2obs2)) deallocate(ixy2obs2)
if (allocated(xobs_tmp2)) deallocate(xobs_tmp2)
if (allocated(yobs_tmp2)) deallocate(yobs_tmp2)
if (allocated(yobs_tmp2)) deallocate(yobs_tmp2)
if (allocated(namobs_tmp2)) deallocate(namobs_tmp2)
return
end subroutine find_flownode_for_obs
SUBROUTINE curvilinearGRIDfromsplines()
USE M_SPLINES
implicit none
IF (MCS .EQ. 0) THEN
CALL QNERROR('First Create or Open Splines',' ',' ')
!NUM = 0
RETURN
ENDIF
CALL SPLRGFR()
end subroutine curvilinearGRIDfromsplines
!SUBROUTINE SPLINESFROMLANDBOUNDARY()
!USE M_SPLINES
!USE M_GRIDSETTINGS
!use m_missing
!
!END SUBROUTINE SPLINESFROMLANDBOUNDARY
SUBROUTINE curvilinearGRIDinpolygon()
USE M_POLYGON
USE M_SAMPLES
USE M_GRID
USE M_GRIDSETTINGS
use m_orthosettings
use m_missing
use m_netw
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dcosphi
implicit none
double precision :: atpfo
double precision :: dp
double precision :: dpok1
double precision :: ff
integer :: ierr
integer :: jam
integer :: jan
integer :: k
integer :: k1
integer :: ka
integer :: km
integer :: mfo
integer :: mout
integer :: n
integer :: n1
integer :: n2
integer :: ndraw
integer :: ndraw8org
integer :: nfo
integer :: npo
integer :: nr
common /drawthis/ ndraw(50)
double precision :: dprodin
DOUBLE PRECISION, ALLOCATABLE :: XH(:,:), YH(:,:)
DOUBLE PRECISION, ALLOCATABLE :: XPA(:), YPA(:), DPA(:)
DOUBLE PRECISION, ALLOCATABLE :: XPO(:), YPO(:), DPO(:)
DOUBLE PRECISION :: TXO, DXO, PRIN
INTEGER :: MNX, MAXP
integer :: npc(5)
integer :: ierror
if (npl < 4) return
! create O-type pillar grid if the pillar radius .ne. 0d0
if ( pil_rad.ne.0d0 ) then
call pillargrid(ierror)
if ( ierror.eq.0 ) return ! otherwise, generate non-pillar grid
end if
CALL SAVEPOL()
DO K = 1,NPL
IF (XPL(K) .NE. xymis) THEN
KM = K
ELSE
EXIT
ENDIF
ENDDO
NPL = KM
IF ( XPL(1) .NE. XPL(NPL) ) THEN
NPL = NPL + 1
XPL(NPL) = XPL(1)
YPL(NPL) = YPL(1)
ENDIF
NPO = NPL
ALLOCATE ( DPO(NPO) , XPO(NPO), YPO(NPO) , STAT = IERR) ; DPO =0D0
CALL AERR('DPO(NPO) , XPO(NPO), YPO(NPO)', IERR, NPO)
XPO(1:NPO) = XPL(1:NPO)
YPO(1:NPO) = YPL(1:NPO)
NR = 1 ! FIRST
NPC(NR) = 1
!CALL SETCOL(31)
!CALL RCIRC ( XPL(1), YPL(1) )
DO N = 2,NPL - 1
prin = dcosphi(XPO(N-1), YPO(N-1), XPO(N) , YPO(N) , &
XPO(N) , YPO(N) , XPO(N+1), YPO(N+1), jsferic, jasfer3D, dxymis)
prin = dabs(prin)
IF (PRIN < 0.5d0) THEN
CALL RCIRC ( XPL(1), YPL(1) )
NR = NR + 1
IF (NR <= 4) THEN
NPC(NR) = N
ENDIF
ENDIF
ENDDO
IF (NR < 4) THEN
CALL QNERROR('LESS THAN FOUR CORNERS FOUND',' ',' ')
CALL RESTOREPOL()
DEALLOCATE (DPO, XPO, YPO)
RETURN
ELSE IF (NR > 4) THEN
CALL QNERROR('MORE THAN 4 CORNERS FOUND',' ',' ')
CALL RESTOREPOL()
DEALLOCATE (DPO, XPO, YPO)
RETURN
ENDIF
NR = NR + 1
NPC(NR) = NPL
MFO = MFAC ; NFO = NFAC
MC = MFAC + 1
NC = NFAC + 1
IF (MFO == 0) THEN
MC = NPC(2) - NPC(1) + 1 ; MFAC = MC - 1
JAM = 1
ENDIF
IF (NFO == 0) THEN
NC = NPC(5) - NPC(4) + 1 ; NFAC = NC - 1
JAN = 1
ENDIF
call INCREASEGRID(MC,NC)
MNX = 5*MAX(MC,NC)
ALLOCATE ( XH(MNX,4), YH(MNX,4) )
ALLOCATE ( DPA(MNX) , XPA(MNX), YPA(MNX) , STAT = IERR) ; DPA =0D0
CALL AERR('DPA(MNX) , XPA(MNX), YPA(MNX)', IERR, MNX)
CALL accumulateDistance(XPO, YPO , DPO, NPO) ! OORSPRONKELIJKE LENGTECOORDINAAT
KA = 1
DO N = 1,4
N1 = NPC(N)
N2 = NPC(N + 1)
MAXP = NC
IF (N == 1 .OR. N == 3) MAXP = MC
TXO = DPO(N2) - DPO(N1) ; DXO = TXO/(MAXP-1)
DP = DPO(N1) ; DPA = 0D0
DO K = 1,MAXP
DPA(K) = DP
DP = DP + DXO
ENDDO
IF (N == 3 .OR. N == 4) THEN
CALL ANDERSOM(DPA, MAXP)
ENDIF
IF (MFO == 0) THEN
IF (N == 1) THEN ! COPY FROM FIRST SEGMENT
DPA(1:MAXP) = DPO(1:MAXP)
ELSE IF (N == 3) THEN ! REVERSED COPY FROM ALSO FIRST SEGMENT
FF = TXO / ( DPO(NPC(2)) - DPO(NPC(1)) )
DPA(1) = DPO(N2)
DO K = 2,MAXP
DPOK1 = DPO(K) - DPO(1)
DPA(K) = DPA(1) - DPOK1*FF
ENDDO
K = K
ENDIF
ENDIF
IF (NFO == 0) THEN
IF (N == 2) THEN ! REVERSED COPY FROM FOURTH SEGMENT
K1 = NPC(5)
FF = TXO / ( DPO(NPC(5)) - DPO(NPC(4)) )
DPA(1) = DPO(N1)
DO K = 2,MAXP
K1 = K1 - 1
DPOK1 = DPO(K1) - DPO(NPC(5))
DPA(K) = DPA(1) - DPOK1*FF
ENDDO
K = K
ELSE IF (N == 4) THEN ! REVERSED FOURTH SEGMENT
DO K = 1,MAXP
DPA(K) = DPO(NPC(5) - K + 1)
ENDDO
K = K
ENDIF
ENDIF
CALL maptoPolyline(XPO, YPO, DPO, NPO, XH(1,N), YH(1,N), DPA, MAXP) ! HAAL HUIDIGE PUNTEN OP
CALL maptoPolyline(XPO, YPO, DPO, NPO, XPA(KA), YPA(KA), DPA, MAXP) ! HAAL HUIDIGE PUNTEN OP
KA = KA + MAXP
ENDDO
! NPA = KA-1
! XPL(1:NPA) = XPA(1:NPA)
! YPL(1:NPA) = YPA(1:NPA)
! NPL = NPA
! RETURN
! POLYG TRANSF
CALL TRANFN2( XH(1,4), XH(1,2), XH(1,1), XH(1,3), & ! . 3 . . 4 .
YH(1,4), YH(1,2), YH(1,1), YH(1,3), & ! 4 2 1 2
MNMAX, MMAX, NMAX, XC, YC) ! . 1 . . 3 .
zc = 0d0 !zkuni
NDRAW8ORG = NDRAW(8) ; NDRAW(8) = 0
IF (MFO .NE. 0 .AND. NFO .NE. 0) THEN
ATPFO = ATPF ; ATPF = 0.
ENDIF
! CALL ORTHOGRID(1,1,MC,NC)
NDRAW(8) = NDRAW8ORG
IF (MFO .NE. 0 .AND. NFO .NE. 0) THEN
ATPF = ATPFO
ENDIF
MFAC = MFO ; NFAC = NFO
call newfil(mout, 'gridnow.grd')
call WRIRGF(mout, 'gridnow.grd')
!CALL GRIDTONET()
!XC = DXYMIS; YC = DXYMIS; MC = 0 ; NC = 0
CALL RESTOREPOL()
DEALLOCATE (DPA, XPA, YPA, DPO, XPO, YPO, XH, YH)
END SUBROUTINE curvilinearGRIDinpolygon
!> create pillar grid in polygon
subroutine pillargrid(ierror)
use m_grid
use m_gridsettings
use m_polygon
use m_missing
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbdistance, get_startend
implicit none
integer, intent(out) :: ierror ! error (1) or not (0)
integer :: i, j, jstart, jend, num, ipol
double precision :: R0, R1, R, x0, y0, x1, y1, alpha, beta
ierror = 1
if ( NPL.lt.3 ) goto 1234
! get the first polygon
call get_startend(NPL,XPL,YPL,jstart,jend, dmiss)
! number of points in the polygon
num = jend-jstart+1
if ( num.lt.2 ) goto 1234 ! we need at least two points in the polygon
! set the grid sizes
mc = num+1
nc = nfac+1
call increasegrid(mc,nc)
xc = DMISS
yc = DMISS
! construct the grid
R0 = pil_rad
x0 = pil_x
y0 = pil_y
do i=1,mc
! get the coordinates of the point on the polyline
ipol = jstart+i-1
if ( ipol.gt.jend ) ipol = ipol-num
x1 = xpl(ipol)
y1 = ypl(ipol)
! make the gridline from the pillar to the polygon point
do j=1,nc
R1 = dbdistance(x0, y0, x1, y1, jsferic, jasfer3D, dmiss)
! determine relative position on the gridline
! uniform:
alpha = dble(j-1)/dble(nc-1)
beta = (1d0-alpha)*R0/R1 + alpha
xc(i,j) = x0 + beta*(x1-x0)
yc(i,j) = y0 + beta*(y1-y0)
end do ! do j=1,nc
end do ! do i=1,mc
ierror = 0
! error handling
1234 continue
return
end subroutine pillargrid
!> generate curvi-linear grid from net, growing from (xp,yp)
subroutine netw2curv(xp,yp)
use m_netw
use m_grid
use m_alloc
use m_missing
use unstruc_messages
use gridoperations
implicit none
double precision :: xp, yp !< coordinates of starting point
integer :: ierr
integer, dimension(:), allocatable :: ic, jc ! indices (i,j) of the nodes
! integer, parameter :: IMISS = -999999
integer :: in, link, iexit
logical :: lremovelink
!---------------------------------------------------------
! get the cells
!---------------------------------------------------------
call findcells(0)
!---------------------------------------------------------
! allocate and initialize indices arrays
!---------------------------------------------------------
allocate(ic(numk), stat=ierr)
call aerr('ic(numk)', ierr, numk)
allocate(jc(numk), stat=ierr)
call aerr('jc(numk)', ierr, numk)
ic = IMISS
jc = IMISS
in = 0
maindo:do
if ( nump.lt.1 ) exit maindo
! allocate and initialize cellmask array
call realloc(cellmask, numP)
! allocate and initialize ijc array
if ( allocated(ijc) ) deallocate(ijc)
call realloc(ijc, (/ 3, 3 /), (/ 0, 0 /), fill=IMISS)
!---------------------------------------------------------
! assigns node-based indices (ic,jc)
!---------------------------------------------------------
call assign_icjc(xp,yp, ic, jc, iexit)
if (iexit.ne.1) exit maindo
!---------------------------------------------------------
! generate the curvi-grid
!---------------------------------------------------------
call makecurvgrid(ic, jc)
!---------------------------------------------------------
! remove curvi-grid nodes from net
! firstly, disable links that do not neighbor a
! non-curvi-grid cell: set kn to 0
! secondly, rely on setnodadm to remove the proper nodes
!---------------------------------------------------------
do link=1,numL
lremovelink = .false.
if ( lnn(link).gt.0) &
lremovelink = ( cellmask(lne(1,link)).eq. -1 )
if ( lnn(link).gt.1) &
lremovelink = lremovelink .and. ( cellmask(lne(2,link)).eq. -1 )
if ( lremovelink) kn(1:2, link) = 0
end do
call setnodadm(0)
exit
end do maindo
!---------------------------------------------------------
! done, clean up
!---------------------------------------------------------
deallocate(ic)
deallocate(jc)
!set network status
netstat = NETSTAT_CELLS_DIRTY
end subroutine netw2curv
!> assign node-based indices (ic,jc) in the net
subroutine assign_icjc(xp,yp, ic, jc, iexit)
use m_netw
use m_grid
use m_alloc
use m_missing
use unstruc_messages
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: pinpok, dbpinpol, get_startend
implicit none
double precision :: xp, yp !< coordinates of starting point
integer, dimension(numk) :: ic, jc !< node indices (i,j)
integer :: iexit !< 1 on success, 0 otherwise
integer :: ierr, k, kk, in
integer :: L1, L2, L3, L4
double precision :: xh(4), yh(4)
!integer, parameter :: IMISS = -999999
integer :: knode, ik, lowold(2), uppold(2)
logical :: linpoly
iexit = 0
!---------------------------------------------------------
! allocate and initialize indices arrays
!---------------------------------------------------------
ic = IMISS
jc = IMISS
in = 0
! allocate and initialize cellmask array
call realloc(cellmask, numP)
! allocate and initialize ijc array
if ( allocated(ijc) ) deallocate(ijc)
call realloc(ijc, (/ 3, 3 /), (/ 0, 0 /), fill=IMISS)
if ( nump.lt.1 ) return
!---------------------------------------------------------
! find first cell k from input (xh, yh)
!---------------------------------------------------------
do k = 1,nump
if ( netcell(k)%n .eq. 4 ) then
do kk = 1,4
xh(kk) = xk(netcell(k)%nod(kk))
yh(kk) = yk(netcell(k)%nod(kk))
enddo
call pinpok(xp,yp,4,xh,yh,in, jins, dmiss)
if ( in .eq. 1 ) then
in = k
if ( netcell(k)%n .ne. 4 ) in = 0
exit
endif
end if
enddo
if ( in .eq. 0 ) return
!---------------------------------------------------------
! initialize cellmask
!---------------------------------------------------------
cellmask = 1; ! init active
! remove netcells that have one or more nodes outside the polygon
ik = -1
do k=1,nump
linpoly = .true.
do kk = 1,netcell(k)%n
knode = netcell(k)%nod(kk)
call dbpinpol(xk(knode), yk(knode), ik, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( ik.eq.0 ) then
linpoly = .false.
exit
end if
end do
if ( .not.linpoly ) cellmask(k) = 0
end do
!---------------------------------------------------------
! start with first cell
!---------------------------------------------------------
k = in
L1 = netcell(k)%lin(1)
L2 = netcell(k)%lin(2)
L3 = netcell(k)%lin(3)
L4 = netcell(k)%lin(4)
! assign (i,j)=(1,1) to common node of links 1 and 1
call find_common_node(L1,L2,kk)
ic( kk ) = 1
jc( kk ) = 1
ijc(1,1) = kk
! assign (i,j)=(2,1) to common node of links 2 and 3
call find_common_node(L2,L3,kk)
ic( kk ) = 2
jc( kk ) = 1
ijc(2,1) = kk
! assign (i,j)=(2,2) to common node of links 3 and 4
call find_common_node(L3,L4,kk)
ic( kk ) = 2
jc( kk ) = 2
ijc(2,2) = kk
! assign (i,j)=(1,2) to common node of links 4 and 1
call find_common_node(L4,L1,kk)
ic( kk ) = 1
jc( kk ) = 2
ijc(1,2) = kk
lowold = lbound(ijc)
uppold = ubound(ijc)
call grow_ijc( lowold, uppold, lbound(ijc)-1, ubound(ijc)+1, 1) ! check, compileert bij mij niet
!---------------------------------------------------------
! proceed with remaining cells
!---------------------------------------------------------
call assignijgrid(k, ic, jc)
iexit = 1
end subroutine assign_icjc
!> grow ijc with blocksize to satisfy objective lower- and upperbound
subroutine grow_ijc(lowold, uppold, lowobj, uppobj, init)
use m_alloc
use m_grid
use m_missing
implicit none
integer, dimension(2), intent(inout) :: lowold, uppold !< current array sizes
integer, dimension(2), intent(in) :: lowobj, uppobj !< objective array sizes
integer :: init !< init=1: set blocksizes to initial values
integer, dimension(2) :: lownew, uppnew
integer :: i
! integer, parameter :: IMISS = -999999
integer, parameter :: IJCBLOCK = 100 ! block size in ijc
logical :: ldoit
integer, dimension(2), save :: blocklow ! lower blocksizes in ijc
integer, dimension(2), save :: blockupp ! upper blocksizes in ijc
double precision, parameter :: FAC = 1.2 ! growfactor of blocksizes
if ( init.eq. 1 ) then
blocklow = (/ 1, 1 /)
blockupp = (/ 1, 1 /)
end if
lownew = lowold
uppnew = uppold
if ( (lownew(1) .gt. lowobj(1)) .or. (uppnew(1) .lt. uppobj(1)) .or. &
(lownew(2) .gt. lowobj(2)) .or. (uppnew(2) .lt. uppobj(2)) ) then
do i=1,2
do while ( lownew(i) .gt. lowobj(i) )
lownew(i) = lownew(i) - blocklow(i)
end do
do while ( uppnew(i) .lt. uppobj(i) )
uppnew(i) = uppnew(i) + blockupp(i)
end do
end do
do i=1,2
if ( lownew(i).ne.lowold(i) ) &
blocklow(i) = ceiling( dble(blocklow(i)) * FAC )
if ( uppnew(i).ne.uppold(i) ) &
blockupp(i) = ceiling( dble(blockupp(i)) * FAC )
end do
call realloc(ijc, uppnew, lownew, fill=IMISS)
lowold = lownew
uppold = uppnew
end if
end subroutine grow_ijc
!> return common node of links L1 and L2
subroutine find_common_node(L1, L2, node)
use m_netw
use m_missing
implicit none
integer, intent(in) :: L1, L2 !< links
integer, intent(out) :: node !< common node
integer, dimension(4) :: a ! dummy array with nodes of L1 and L2
! integer, parameter :: IMISS = -999999
a(1:2) = kn(1:2, L1)
a(3:4) = kn(1:2, L2)
do
node = IMISS
if ( a(1).eq.a(3) .or. a(1).eq.a(4) ) node = a(1)
if ( a(2).eq.a(3) .or. a(2).eq.a(4) ) node = a(2)
if ( node.ne.IMISS ) exit
write(6,*) 'find_common_node: no common node found'
exit
end do
end subroutine find_common_node
SUBROUTINE copylandboundaryto1Dnetwork()
use m_polygon
use m_landboundary
use m_netw
use m_missing
use gridoperations
implicit none
INTEGER :: MX = 1000000
integer :: k, kk, k1, k2, n, LL, NL, ierr, nh
DOUBLE PRECISION :: D, D1D, DTOT
DOUBLE PRECISION, ALLOCATABLE :: DLan(:), XH(:), YH(:), DH(:)
if (mxlan == 0 .and. numl > 0) then
call regrid1D(1) ! based on 1D net
return
endif
ALLOCATE ( DLan(MXLAN) ,STAT=IERR)
CALL aerr ('DLan(MXLAN)',IERR,mxlan)
ALLOCATE ( XH(MX),YH(MX),DH(MX) ,STAT=IERR)
CALL AERR ('XH(MX),YH(MX),DH(MX)',IERR,MX)
CALL INCREASENETW(100000,100000)
k1 = 0 ; k2 = 0
do k = 1,mxlan
if (xlan(k) == dmiss) then
k2 = -k2
else
if (k1 == 0) then
k1 = k
endif
k2 = k
endif
if (k1 .ne. 0 .and. k2 < 0) then
k2 = - k2
nL = k2 - k1 + 1
CALL accumulateDistance(Xlan(k1:k2), Ylan(k1:k2), DLan(k1:k2), NL)
DTOT = DLAN(K2)
NH = max(1, ceiling(DTOT / unidx1D))
IF (NH > SIZE(DH)) THEN
DEALLOCATE (XH,YH,DH)
ALLOCATE ( XH(NH),YH(NH),DH(NH) ,STAT=IERR)
CALL AERR ('XH(NH),YH(NH),DH(NH)',IERR,MX)
ENDIF
IF (NH >= 1) THEN
D1D = DTOT / NH
D = 0
do N = 1,NH
D = D + D1D
DH(N) = D
enddo
call mapToPolyline(Xlan(k1:k2), Ylan(k1:k2), DLAN(k1:k2), NL, XH, YH, DH, NH) ! HAAL HUIDIGE PUNTEN OP
KK = NUMK+1 ; LL = NUML
CALL INCREASENETW(KK+nh,LL+nh)
XK(KK) = Xlan(k1) ; YK(KK) = Ylan(k1)
DO N = 1, NH
KK = KK + 1
XK(KK) = XH(N) ; YK(KK) = YH(N); ZK(KK) = dmiss
LL = LL + 1
KN(1,LL) = KK-1 ; KN(2,LL) = KK ; KN(3,LL) = 1 ! NOTE: 1D endpoints now don't have KN(3,L)=4 automatically.
ENDDO
NUMK = KK ; NUML = LL
ENDIF
k1 = 0 ; k2 = 0
endif
enddo
deallocate(DLan, xh, yh, dh)
call setnodadm(0)
end SUBROUTINE copylandboundaryto1Dnetwork
!> assign indices (i,j) to the curvi-linear grid
subroutine assignijgrid(k, ic, jc)
use m_netw
use m_grid
use m_missing
implicit none
integer :: k !< current cell
integer, dimension(numk) :: ic, jc !< indices (i,j) of the nodes
integer :: kcell, kneighbor, kdir, kdirdum
integer :: icount, iter, lowold(2), uppold(2)
integer, parameter :: MAXITER = 1000000
! integer, parameter :: IMISS = -999999
integer :: i, numiter_guess
!---------------------------------------------------------
! cellmask
! -1 : inactive, in curvi-grid
! 0 : inactive, not in curvi-grid
! 1 : active, not in front
! >1 : active, in front
!---------------------------------------------------------
! mask current cell as frontcell
cellmask(k) = 10
lowold = lbound(ijc)
uppold = ubound(ijc)
numiter_guess = sqrt(dble(nump)) * 10
call readyy('creating curvilinear grid', 0d0 )
do iter = 1,MAXITER
call readyy('creating curvilinear grid', min(dble(iter-1)/dble(numiter_guess-1), 1d0) )
icount = 0
do kcell = 1,nump
if ( cellmask(kcell) .eq. iter+9 ) then
! done with cell kcell - unmask cell
cellmask(kcell) = -1
do kdir = 1,4
call assignij(kcell, kdir, kneighbor, ic, jc)
if ( kneighbor.ne.0 ) then
if ( cellmask(kneighbor).eq.1 ) then
cellmask(kneighbor) = iter + 10
icount = icount + 1
end if
end if
end do
end if
end do
! only one layer of cells will be added during the next iteration at maximum
call grow_ijc( lowold, uppold, &
(/ minval(ic, ic.ne.IMISS)-1, minval(jc, jc.ne.IMISS)-1 /), &
(/ maxval(ic, ic.ne.IMISS)+1, maxval(jc, jc.ne.IMISS)+1 /), 0)
if ( icount .eq.0 ) exit
end do
if ( iter.eq.MAXITER ) write(6,*) 'assignijgrid: iter=MAXITER'
call readyy('creating curvilinear grid', -1d0 )
end subroutine assignijgrid
!> assign indices to the nodes of the cell neighboring cell kcell in kdir direction
subroutine assignij(kcell, kdir, kneighbor, ic, jc)
!---------------------------------------------------------
! kdir: direction of neighboring cell
! 1 : -i, left
! 2 : -j, bottom
! 3 : +i, right
! 4 : +j, top
!---------------------------------------------------------
use m_netw
use m_grid
use unstruc_messages
use m_missing
implicit none
integer :: kcell !< cell number
integer :: kdir !< direction
integer :: kneighbor !< neighboring cell number
integer, dimension(*) :: ic, jc ! indices (i,j) of the nodes
integer :: i, j, L, k, kk
integer :: kself, kkneighbor, kkself, klink
integer :: Lneighbor1, Lneighbor2, Lneighbor3
integer :: inew1, inew2, inew3, jnew1, jnew2, jnew3
integer :: k1, k2, icnew1, icnew2, jcnew1, jcnew2
integer, dimension(4), parameter :: Di = (/ -1, 0, 1, 0 /)
integer, dimension(4), parameter :: Dj = (/ 0, -1, 0, 1 /)
integer :: icell, jcell, nodes(4)
integer :: ilink, link
integer :: node1, node2, othernode
! integer, parameter :: IMISS = -999999
logical :: lconflict
!---------------------------------------------------------
! find the active link based on node indices
!---------------------------------------------------------
nodes = netcell(kcell)%nod
icell = minval(ic(nodes))
jcell = minval(jc(nodes))
select case (kdir)
case (1)
node1 = ijc(icell, jcell)
node2 = ijc(icell, jcell+1)
case (2)
node1 = ijc(icell, jcell)
node2 = ijc(icell+1, jcell)
case (3)
node1 = ijc(icell+1, jcell)
node2 = ijc(icell+1, jcell+1)
case (4)
node1 = ijc(icell+1, jcell+1)
node2 = ijc(icell, jcell+1)
end select
do ilink=1,nmk(node1)
L = nod(node1)%lin(ilink)
othernode = kn(1,L) + kn(2,L) - node1
if ( othernode.eq.node2 ) exit
end do
if ( lnn(L) .ne. 2 .or. node2.ne.othernode) then
kneighbor = 0
return
end if
!---------------------------------------------------------
! find neighboring cell kneighbor for link L w.r.t. cell k
!---------------------------------------------------------
kneighbor = lne(1,L) + lne(2,L) - kcell
if ( netcell(kneighbor)%n .ne. 4 .or. cellmask(kneighbor).eq.0 ) then ! only consider quads
cellmask(kneighbor) = 0
kneighbor = 0
return
end if
!---------------------------------------------------------
! find active link kkself w.r.t. neighboring cell
!---------------------------------------------------------
kkself = minloc( abs(netcell(kneighbor)%lin - L), 1 )
!---------------------------------------------------------
! Find links numbers in neighboring cell
!---------------------------------------------------------
kkneighbor = 1 + mod( kkself, 4)
Lneighbor1 = netcell(kneighbor)%lin(kkneighbor)
kkneighbor = 1 + mod( kkself + 2, 4)
Lneighbor3 = netcell(kneighbor)%lin(kkneighbor)
!---------------------------------------------------------
! determine new node indices
!---------------------------------------------------------
call find_common_node(L, Lneighbor1, kself)
k1 = sum(kn(1:2, Lneighbor1)) - kself
icnew1 = ic(kself) + Di(kdir)
jcnew1 = jc(kself) + Dj(kdir)
call find_common_node(L, Lneighbor3, kself)
k2 = sum(kn(1:2, Lneighbor3)) - kself
icnew2 = ic(kself) + Di(kdir)
jcnew2 = jc(kself) + Dj(kdir)
!---------------------------------------------------------
! check for conflicts
!---------------------------------------------------------
if ( (ic(k1).ne.IMISS .and. ic(k1).ne.icnew1) .or. &
(jc(k1).ne.IMISS .and. jc(k1).ne.jcnew1) .or. &
(ic(k2).ne.IMISS .and. ic(k2).ne.icnew2) .or. &
(jc(k2).ne.IMISS .and. jc(k2).ne.jcnew2) ) then
lconflict = .true.
else
lconflict = .false.
end if
if ( .not.lconflict) call checkvalidnode(k1, icnew1, jcnew1, lconflict)
if ( .not.lconflict) call checkvalidnode(k2, icnew2, jcnew2, lconflict)
if ( .not.lconflict) then
!---------------------------------------------------------
! no conflicts: assign indices
!---------------------------------------------------------
ic(k1) = icnew1
jc(k1) = jcnew1
ic(k2) = icnew2
jc(k2) = jcnew2
ijc(icnew1, jcnew1) = k1
ijc(icnew2, jcnew2) = k2
else
!---------------------------------------------------------
! conflicts: do not assign indices and deactive neighbor
!---------------------------------------------------------
cellmask(kneighbor) = 0
kneighbor = 0
end if
end subroutine
!> generate the curvi-grid from the node indices (ic,jc)
subroutine makecurvgrid(ic, jc)
use m_netw
use m_grid
use m_missing
use m_alloc
implicit none
integer, dimension(1:numk) :: ic, jc !< indices (i,j) of the nodes
integer :: imin, jmin ! minimum of the indices
integer :: i, j, node
! integer, parameter :: IMISS = -999999
!---------------------------------------------------------
! compute grid sizes and renumber
!---------------------------------------------------------
imin = minval(ic, ic.ne.IMISS)
jmin = minval(jc, jc.ne.IMISS)
ic = ic - imin + 1
jc = jc - jmin + 1
mc = maxval(ic)
nc = maxval(jc)
!---------------------------------------------------------
! allocate and initialize arrays
!---------------------------------------------------------
call increasegrid(mc, nc)
xc = dmiss
yc = dmiss
zc = dmiss
!---------------------------------------------------------
! compose the grid
!---------------------------------------------------------
do node=1,numk
i = ic(node)
j = jc(node)
if ( i.gt.0 ) then
xc(i,j) = xk(node)
yc(i,j) = yk(node)
zc(i,j) = zk(node)
end if
end do
end subroutine makecurvgrid
!> check if new node is valid
subroutine checkvalidnode(node, i, j, lconflict)
use m_grid
use m_missing
implicit none
integer, intent(in) :: node !< node
integer, intent(in) :: i, j !< indices
logical, intent(out) :: lconflict !< .false. if valid, .true. otherwise
integer :: iL, iR, jB, jT
integer, dimension(2) :: low, upp ! dimensions of ijc
if ( ijc(i,j) .ne. node .and. ijc(i,j).gt.0 ) then ! conflict
lconflict = .true.
return
end if
! check the four possible connections for conflicts
low = lbound(ijc)
upp = ubound(ijc)
iL = i-1
if ( iL.ge.low(1) ) then
if ( ijc(iL,j) .gt. 0 ) call checkgridline(node, ijc(iL,j), lconflict)
if ( lconflict ) return
end if
iR = i+1
if ( iR.le.upp(1) ) then
if ( ijc(iR,j) .gt. 0 ) call checkgridline(node, ijc(iR,j), lconflict)
if ( lconflict ) return
end if
jB = j-1
if ( jB.ge.low(2) ) then
if ( ijc(i,jB) .gt. 0 ) call checkgridline(node, ijc(i,jB), lconflict)
if ( lconflict ) return
end if
jT = j+1
if ( jT.le.upp(2) ) then
if ( ijc(i,jT) .gt. 0 ) call checkgridline(node, ijc(i,jT), lconflict)
if ( lconflict ) return
end if
end subroutine
!> check if a connection from node1 to node2 exists
subroutine checkgridline(node1, node2, lconflict)
use m_netw
use m_grid
use m_missing
implicit none
integer, intent(in ) :: node1, node2 !< nodes
logical, intent(out) :: lconflict !< .false. if connected, .true. otherwise
integer :: ilink, link, othernode1
logical :: doit ! determines whether the link neighbors a quad (.true.) or not (.false.)
! integer, parameter :: IMISS = -999999
lconflict = .true. ! .false. if the (i,j)-connection is a valid connection
do ilink=1,nmk(node1)
link = nod(node1)%lin(ilink)
othernode1 = kn(1,link) + kn(2,link) - node1
! select links adjacent to at least one quad only
doit = .false.
if ( lnn(link).gt.0 ) doit = ( netcell(lne(1,link))%n .eq. 4 )
if ( lnn(link).gt.1 ) doit = doit .or. ( netcell(lne(2,link))%n .eq. 4 )
if ( doit ) then
if ( othernode1 .eq. node2 ) then ! valid connection
lconflict = .false.
return
end if
end if
end do
end subroutine checkgridline
!> network field move
!! Is is assumed that there is a backup copy of the grid.
subroutine netmodfld(xp,yp,zp,kp)
use m_netw
use m_grid
use m_alloc
use m_missing
use m_wearelt
use m_sferic
use geometry_module, only: dbdistance
implicit none
double precision :: xp, yp, zp !< coordinates that determine the influenced region
integer :: kp !< center point index
double precision :: Dx0, Dy0, rsx, xn, yn, dist, frac
double precision :: xcen, ycen
double precision, external :: getDx, getDy
integer :: i
xcen = xk(kp)
ycen = yk(kp)
Dx0 = xp - xcen
Dy0 = yp - ycen
rsx = max(dsix, sqrt(Dx0*Dx0 + Dy0*Dy0))
do i=1,numk
xn = xk(i)
yn = yk(i)
! intentional not in sferical coordinates
dist = sqrt( (xn-xcen)**2 + (yn-ycen)**2 )
frac = 0.5 * (1+ cos(min(max(dist/rsx,-1d0),1d0) * pi))
xk(i) = xk(i) + Dx0*frac
yk(i) = yk(i) + Dy0*frac
end do
end subroutine netmodfld
!> network field rotate
!! It is assumed that there is a backup copy of the grid.
subroutine netrotfld(xp,yp,zp,kp)
use m_netw
use m_grid
use m_alloc
use m_missing
use m_wearelt
use m_sferic
use unstruc_colors, only: ncolhl
use geometry_module, only: dbdistance
implicit none
double precision :: xp, yp, zp !< coordinates that determine the influenced region and rotation angle
integer :: kp !< center point index
double precision :: Dx0, Dy0, rsx, xn, yn, dist, frac
double precision :: Dalpha0, alpha, xcen, ycen
double precision, external :: getDx, getDy
integer :: i, ja, jac
xcen = xk(kp)
ycen = yk(kp)
Dx0 = xp - xcen
Dy0 = yp - ycen
Dalpha0 = atan2(Dy0, Dx0)
do
rsx = max(dsix, sqrt(Dx0*Dx0 + Dy0*Dy0))
! whipe out previous net image
ja = 0
call teknet(0,ja)
do i=1,numk
xn = xk(i)
yn = yk(i)
! intentional not in sferical coordinates
dist = sqrt( (xn-xcen)**2 + (yn-ycen)**2 )
frac = 0.5 * (1+ cos(min(max(dist/rsx,-1d0),1d0) * pi))
alpha = Dalpha0*frac
xk(i) = xcen + (xn-xcen)*cos(alpha) - (yn-ycen)*sin(alpha)
yk(i) = ycen + (xn-xcen)*sin(alpha) + (yn-ycen)*cos(alpha)
end do
call teknet(ncolhl,ja)
jac = 1
call confrm('More? ', jac)
if ( jac.eq.0 ) then
call confrm('Flip rotation?', jac)
if ( jac.eq.1 ) then
Dalpha0 = -Dalpha0
else
exit
end if
end if
end do
end subroutine netrotfld
!> net orthogonalisation and smoothing
SUBROUTINE ORTHOGONALISENET(jarerun)
use m_netw
USE M_FLOWGEOM
USE m_polygon
use m_sferic
use m_orthosettings
use m_missing
use unstruc_messages
use m_samples
use m_alloc
use m_inverse_map
use unstruc_colors, only: ncolhl
use m_ec_basic_interpolation, only: triinterp2
use geometry_module, only: dbpinpol
use m_flowexternalforcings, only: transformcoef
use gridoperations
IMPLICIT NONE
integer :: jarerun !< rerun, no=1, yes=1
double precision, dimension(:,:), allocatable :: ww, rhs ! weights and right-hand sides
double precision, dimension(:), allocatable :: aspect ! aspect ratio of the links
double precision, dimension(:), allocatable :: smp_mu ! coefficients in Laplacian smoother
double precision, dimension(:), allocatable :: smp_mu_smooth ! smoothed coefficients in Laplacian smoother
double precision, dimension(:), allocatable :: xkb, ykb ! copy for original boundary nodes
integer, dimension(:,:), allocatable :: kk1 ! neighboring nodes
integer, dimension(:), allocatable :: k_bc ! maps nodes to nearest initial-boundary node
integer, dimension(:), allocatable :: ic, jc ! netnode indices in the curvi-grid
integer, dimension(2) :: ibounds
double precision :: x0, y0, ATPF1, relaxin, relax1
double precision :: x0_bc, y0_bc, smpmin
! used for sferical
double precision :: x00, y00, x1, y1, DUM(2), w0(2), xadd, yadd
double precision, dimension(2) :: righthandside
integer :: i, k, kk, k1, L, n, no, npl_old
integer :: JSFERICold, ja, ja1, ja2, ja3, jac, iexit
integer, save :: idir = -999 ! direction of mesh adaptation
logical :: Lteknet
double precision, external :: getDx, getDy
! integer, parameter :: IMISS = -999999
double precision, parameter :: EPS = 1D-4
double precision :: mu, mumin, mumax, mumat, wwx, wwy
double precision, allocatable, dimension(:,:) :: ww2, ww2x, ww2y ! weights
integer :: ierror ! 0: no error, 1: error
type(tops), allocatable, dimension(:) :: ops ! array of structure with operators of unique topologies
double precision :: atpf_loc, atpf1_loc
double precision, dimension(2) :: res_sm, res_or ! residuals
double precision, dimension(4) :: J ! Jacobian matrix
logical :: Lcopymu ! copy initial-mesh data to smp_mu (.true.) or not (.false.)
double precision, allocatable, dimension(:) :: zk_bak ! backup copy of zk
double precision :: smpminn, smpmaxx
double precision :: atpf_min
double precision, allocatable, dimension(:) :: atpf_nodes ! atpf at the nodes
logical :: Ltemp
double precision :: circormass_bak
integer :: ik
integer :: ioutfile = 666
! double precision :: xx0, yy0, zz0, xx1, yy1, zz1
double precision :: Dx0, Dy0
double precision, allocatable, dimension(:) :: xloc, yloc ! local coordinates
integer, allocatable, dimension(:) :: iloc ! startpointers in local coordinate arrays, dim(numk+1)
integer :: NN
double precision, dimension(1) :: dumx, dumy
integer :: NDRAW
common /DRAWTHIS/ ndraw(50)
jarerun = 0
! return if the network comprises three nodes or less
if ( numk.lt.4 ) return
if ( jaswan.eq.1 .and. atpf .le. 0.8d0 ) then
call fliplinks()
end if
! store original settings
JSFERICold = JSFERIC
allocate(zk_bak(size(zk)))
zk_bak = zk
circormass_bak = circumormasscenter
! ATPF = 0d0
mumax = (1d0 - smoothorarea) * 0.5d0
mumin = 1d-2
mumin = min(mumin,mumax)
ATPF1 = 1d0 - ATPF
! make the node mask
kc = 0
ik = -1
do k = 1,numk
call dbpinpol(xk(k), yk(k), ik, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( ik.gt.0 ) kc(k) = ik
enddo
! if ( netstat.ne.netstat_OK ) call findcells(100)
! always call findcells
call findcells(100)
! account for folded cells
call sortlinks()
call makenetnodescoding() ! No relinking at the moment: makenetnodescoding outside of numortho loop
! mark nodes outside polygon as stationary
do k=1,numk
if ( kc(k).eq.0 ) nb(k)=3
end do
! snap to nearest land boundary
if ( JAPROJECT.gt.1 ) then
ja = 1
if ( jaswan.ne.1 ) then
call confrm('Refresh net-to-land administration?', ja)
else
ja = 1
end if
! if ( ja.eq.1 ) call find_nearest_meshline(JAPROJECT) ! net boundaries only
if ( ja.eq.1 ) then
call find_nearest_meshline(JAPROJECT)
end if
Ltemp = ( ja.eq.1 )
if ( ja.eq.0 .and. allocated(lanseg_map) ) then
if ( ubound(lanseg_map,1).eq.numk ) then
Ltemp = .true.
end if
end if
if ( .not.Ltemp ) then
call qnerror('net-to-land administration out of date: falling back to ''netbound to orig. netbound''', ' ', ' ')
JAPROJECT = 1
else
!if (japroject <= 4) call snap_to_landboundary()
end if
end if
! Mark flow geometry as reset to prevent any crashes on redrawing with incomplete xz/yz arrays:
! Moreover: xz ordering is here still by netcell order, and *before* the flow node renumbering.
ndx = 0
lnx = 0
! nmkx is max nr of neighbouring netnodes for any node.
nmkx = 0
do k = 1,numk
nmkx = max(nmkx, nmk(k))
endDO
!-------------------------------------------------
! allocate arrays
nmkx = nmkx+1 ! Possibly one additional dummy point at boundary nodes.
if ( allocated(xk1) ) deallocate (xk1, yk1)
if ( allocated(ww) ) deallocate (ww, kk1 )
allocate(xk1( numk), yk1(numk), ww(nmkx,numk), kk1(nmkx,numk))
allocate(rhs(2,numk), aspect(numL), smp_mu(numk), k_bc(numk))
allocate(xkb(numk), ykb(numk))
! allocate(theta_save(nmkx,1), xi_save(nmkx,1), eta_save(nmkx,1), ktopo(numk))
! allocate(nmk_save(1), nmk2_save(1))
allocate(ktopo(numk))
! allocate(atpf_nodes(numk))
!----------------------
! for smoother
!----------------------
allocate(nmk2(numk))
nmk2 = 0
allocate(kk2(nmkx2, numk))
kk2 = 0
allocate(ww2(nmkx2, numk))
ww2 = 0d0
!-------------------------------------------------
! initialise
xkb = xk(1:numk)
ykb = yk(1:numk)
rhs = 0d0
aspect = DMISS
smp_mu = 1d0
ja = 1
ja3 = 0
Lteknet = .true.
mu = mumin
numtopo = 0
ktopo = 0
Lcopymu = .true.
atpf_min = 0.8d0
if ( idir.eq.-999) idir = 0
! k_bc stores nearest original netnode
do k=1,numk
k_bc(k) = k
end do
!-------------------------------------------------
! determine node neighbors
kk1 = 0
do k = 1,numk ! kk admin
if (nb(k) == 1 .or. nb(k) == 2 .or. nb(k) == 3 .or. nb(k) == 4) then ! kc(k) == 1) then
do kk = 1,nmk(k)
L = nod(k)%lin(kk)
call othernode (k,L,kk1(kk,k))
enddo
endif
enddo
!-------------------------------------------------
! get the netnode indices ic and jc in the curvi-grid
! if ( Ns.lt.0 ) then
! allocate(ic(numk), jc(numk))
! ic = IMISS
! jc = IMISS
!
! do k1=1,numk
! if ( kc(k1).ne.1 ) cycle
! x0 = xk(k1)
! y0 = yk(k1)
! call assign_icjc(x0,y0, ic, jc, iexit)
! if ( ic(k1).ne.IMISS .and. jc(k1).ne.IMISS ) exit
! end do
! end if
!-------------------------------------------------
!-------------------------
! for local coordinates
!-------------------------
allocate(iloc(numk+1))
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
if ( ATPF.lt.1D0 ) then
ierror = 1
call orthonet_comp_ops(ops, ierror) ! will make kk2 administration
if ( ierror.ne.0 ) goto 1234
end if
! make startpointers
iloc(1) = 1
do k=1,numk
iloc(k+1) = iloc(k) + max(nmk(k)+1,nmk2(k)) ! include own node
end do
! allocate local coordinate arrays
N = iloc(numk+1)-1
allocate(xloc(N), yloc(N))
end if
!----------------------
! iterations
!----------------------
call readyy('Orthogonalising net',0d0)
tp:do no = 1,itatp
! call removesmalllinks()
xk1(1:numk) = xk(1:numk)
yk1(1:numk) = yk(1:numk)
! compute local coordinates
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
call comp_local_coords(iloc,kk1,xk,yk,iloc(numk+1)-1,xloc,yloc)
end if
call readyy('Orthogonalising net',dble(no-1+.35d0)/itatp)
!------------------------------------------------------------------------
! mesh adaptation
!------------------------------------------------------------------------
if ( Ns.eq.0 .and. Lcopymu .and. ATPF.lt.1d0 .and. adapt_beta.gt.0d0 ) then
! use old mesh data: set smp_mu to 1/(determinant of Jacobian), scaled
! only once, use initial mesh
! compute the operators
if ( .not.allocated(ops) ) then
ierror = 1
call orthonet_comp_ops(ops, ierror)
if ( ierror.ne.0 ) goto 1234
end if
J = 0d0
smpminn = 0d0
smpmaxx = -1d99
! compute Jacobian matrices and assign intended sample values to netnodes
do k=1,Numk
if ( nb(k).ne.1 .and. nb(k).ne.2 .and. nb(k).ne.3 .and. nb(k).ne.4 ) cycle
! if ( nb(k).ne.1 .and. nb(k).ne.2 ) cycle
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
J(1) = sum( ops(ktopo(k))%Jxi( 1:nmk2(k)) * xloc(iloc(k):iloc(k+1)-1) )
J(2) = sum( ops(ktopo(k))%Jxi( 1:nmk2(k)) * yloc(iloc(k):iloc(k+1)-1) )
J(3) = sum( ops(ktopo(k))%Jeta(1:nmk2(k)) * xloc(iloc(k):iloc(k+1)-1) )
J(4) = sum( ops(ktopo(k))%Jeta(1:nmk2(k)) * yloc(iloc(k):iloc(k+1)-1) )
else
J(1) = sum( ops(ktopo(k))%Jxi( 1:nmk2(k)) * xk(kk2(1:nmk2(k),k)) )
J(2) = sum( ops(ktopo(k))%Jxi( 1:nmk2(k)) * yk(kk2(1:nmk2(k),k)) )
J(3) = sum( ops(ktopo(k))%Jeta(1:nmk2(k)) * xk(kk2(1:nmk2(k),k)) )
J(4) = sum( ops(ktopo(k))%Jeta(1:nmk2(k)) * yk(kk2(1:nmk2(k),k)) )
end if
! set z-value at netnodes to intended sample value
zk(k) = abs(J(1)*J(2) - J(3)*J(4))
smpminn = min(zk(k), smpminn)
smpmaxx = max(zk(k), smpmaxx)
end do
if ( smpmaxx.eq.smpminn ) then ! really weird
smpmaxx = smpminn + 1d0
end if
where( zk.ne.DMISS ) zk = (smpmaxx-zk) / (smpmaxx-smpminn)
! create the samples at the netnodes locations
call copynetnodestosam()
! not to be repeated hereafter
Lcopymu = .false.
! recover the original net values
zk = zk_bak
end if
! interpolate samples to network for grid refinement
if ( Ns.gt.0 .and. adapt_beta.gt.0d0 ) then
if ( Ns.gt.kmax ) then
call qnerror('ORTHOGONALISENET: Ns.gt.kmax', ' ', ' ')
goto 1234
end if
smp_mu = dmiss
npl_old = npl
call triinterp2(xk,yk,smp_mu,numk,ja, &
XS, YS, ZS, NS, dmiss, jsferic, jins, jasfer3D, NPL, MXSAM, MYSAM, XPL, YPL, ZPL, transformcoef) ! ,0) hk: 0 is not used
ja = 0 ! hk: triangulation only needed in first cycle
where ( smp_mu.eq.dmiss) smp_mu=0d0
else
smp_mu = 0d0
end if
! for post-processing, copy smp_mu to zk
zk(1:numk) = dble(smp_mu(1:numk))
!-------------------------------------------------
! compute the weights and right-hand sides
ww = 0d0
rhs = 0d0
! orthogonaliser
call orthonet_compute_aspect(aspect)
call orthonet_compweights(nmkx, kk1, aspect, ww, rhs)
! inverse-map smoother
if ( ATPF.lt.1d0 .or. smoothorarea.lt.1d0) then ! we also need administration for volume-based smoother
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
! compute local coordinates
call comp_local_coords(iloc,kk1,xk,yk,iloc(numk+1)-1,xloc,yloc)
end if
call orthonet_compweights_smooth(ops, smp_mu, ww2, ierror)
else
ierror = 0
end if
! for post-processing, copy ktopo to zk
! zk(1:numk) = dble(ktopo(1:numk))
if ( ierror.eq.1 ) then
call qnerror('orthonet: orthonet_compweights_smooth gave error', ' ', ' ')
jarerun = 0
goto 1234
end if
! volume-based smoother
ibounds = (/nmkx2, numk/)
call realloc(ww2x, ibounds, fill=0d0)
call realloc(ww2y, ibounds, fill=0d0)
if ( smoothorarea.ne.1d0 ) then
call orthonet_compweights_vol(nmkx2, nmk2, kk2, ww2x, ww2y, ierror)
if ( ierror.eq.1 ) then
call qnerror('orthonet: orthonet_compweights_vol gave error', ' ', ' ')
jarerun = 0
goto 1234
end if
else
ww2x = 0d0
ww2y = 0d0
end if
call readyy('Orthogonalising net',dble(no-1+.8d0)/itatp)
!-------------------------------------------------
! 3. Solve the 'Laplacian' for orthogonalization/Move all points in a few iteration steps.
relaxin = 0.75d0
relax1 = 1d0-relaxin
do i = 1,itbnd
do n = 1,itin
! ! determine atpf ***INOPERATIVE***
! atpf_nodes = 1d0
! do k=1,numk
! if ( (nb(k).ne.1 .and. nb(k).ne.2) .or. nmk(k).lt.2 ) cycle
!
! ! compute the residuals
! ! res_sm(1) = sum(ww2(1:nmk2(k),k)*xk(kk2(1:nmk2(k),k))) / (maxval(xk(kk2(1:nmk2(k),k)))-minval(xk(kk2(1:nmk2(k),k))))
! ! res_sm(2) = sum(ww2(1:nmk2(k),k)*xk(kk2(1:nmk2(k),k))) / (maxval(yk(kk2(1:nmk2(k),k)))-minval(yk(kk2(1:nmk2(k),k))))
! res_or(1) = (sum(ww(1:nmk(k),k)*(xk(kk1(1:nmk(k),k))-xk(k))) + rhs(1,k)) / (maxval(xk(kk2(1:nmk2(k),k)))-minval(xk(kk2(1:nmk2(k),k))))
! res_or(2) = (sum(ww(1:nmk(k),k)*(yk(kk1(1:nmk(k),k))-yk(k))) + rhs(2,k)) / (maxval(xk(kk2(1:nmk2(k),k)))-minval(xk(kk2(1:nmk2(k),k))))
!
! kk = ktopo(k)
! res_sm(1) = sum(ops(kk)%ww2*xk(kk2(1:nmk2(k),k))) / (maxval(xk(kk2(1:nmk2(k),k)))-minval(xk(kk2(1:nmk2(k),k))))
! res_sm(2) = sum(ops(kk)%ww2*yk(kk2(1:nmk2(k),k))) / (maxval(yk(kk2(1:nmk2(k),k)))-minval(yk(kk2(1:nmk2(k),k))))
!
! ! determine atpf from residuals
!! atpf_nodes(k) = min(max(get_atpf(res_sm), atpf_min),ATPF)
!
! ! for post-processing
! ! zk(k) = sqrt(sum(res_sm**2))
! ! zk(k) = atpf_nodes(k)
! end do
ndki:do k = 1,numk
if ( (nb(k).ne.1 .and. nb(k).ne.2) .or. nmk(k).lt.2 ) cycle ndki
! quadtree refinement
if ( keepcircumcenters.ne.0 .and. (nmk(k).ne.3 .or. nb(k).ne.1) ) cycle ! hanging nodes only
! if ( (nb(k).ne.1) .or. nmk(k).lt.2 ) cycle ndki
! boundary conditions: orthogonal -> set atpf to >0 locally
atpf_loc = ATPF
if ( nb(k).eq.2 ) then
atpf_loc = max(ATPF_B, ATPF) ! we need some smoothing
end if
atpf1_loc = 1d0 - atpf_loc
x0 = 0d0; y0 = 0d0
Dx0 = 0d0; Dy0 = 0d0
x00 = xk1(k); y00 = yk1(k)
w0 = 0d0
DUM = 0d0
! determine atpf ***INOPERATIVE***
! atpf_loc = minval((/ atpf_nodes(kk2(1:nmk2(k),k)) /) )
! atpf_loc = atpf_nodes(k)
! if ( (nb(k).eq.1) .and. (nmk(k).ne.4) ) atpf_loc = ATPF ! only for quads
!
! atpf1_loc = 1d0 - atpf_loc
! for post-processing, set zk to atpf_loc
! zk(k) = atpf_loc
! determine ratio inverse-map/volume-based smoother
if ( ww2x(1,k).ne.0d0 .or. ww2y(1,k).ne.0d0 ) then
mumat = mu * ww2(1,k) / max(ww2x(1,k), ww2y(1,k))
else
mumat = mu
end if
! if ( mumat.eq.0d0 ) mumat = 1d0
do kk = 2,max(nmk2(k),nmk(k)+1) ! do not include center node
! combine the weights
wwx = 0d0
wwy = 0d0
! smoother
if ( ATPF1_loc.gt.0d0 ) then
if ( nb(k).eq.1 ) then ! inner points only
wwx = ATPF1_loc * (mumat*ww2x(kk,k) + ww2(kk,k))
wwy = ATPF1_loc * (mumat*ww2y(kk,k) + ww2(kk,k))
else
wwx = ATPF1_loc * ww2(kk,k)
wwy = ATPF1_loc * ww2(kk,k)
end if
end if
! orthogonaliser
if ( kk.le.nmk(k)+1 ) then
wwx = wwx + ATPF_loc * ww(kk-1,k)
wwy = wwy + ATPF_loc * ww(kk-1,k)
k1 = kk1(kk-1,k)
else
k1 = kk2(kk,k)
end if
! if (ww2(kk,k) .ne. 0) then
if ( JSFERIC.eq.1 ) then
if ( jasfer3D.eq.1 ) then
DUM(1) = wwx * Ra * dg2rd
DUM(2) = wwy * Ra * dg2rd
else
y1 = yk(k1)
DUM(1) = wwx * dcos(0.5d0*(y00+y1)*dg2rd) * Ra * dg2rd
DUM(2) = wwy * Ra * dg2rd
end if
else
DUM(1) = wwx
DUM(2) = wwy
end if
w0 = w0 + DUM
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
Dx0 = Dx0 + DUM(1) * xloc(iloc(k)+kk-1) ! (xk(k1)-x0)
Dy0 = Dy0 + DUM(2) * yloc(iloc(k)+kk-1) ! (yk(k1)-y0)
else
Dx0 = Dx0 + DUM(1) * ( xk(k1)-xk(k)) ! (xk(k1)-x0)
Dy0 = Dy0 + DUM(2) * ( yk(k1)-yk(k)) ! (yk(k1)-y0)
end if
! endif
enddo
! combine the rhs
righthandside = ATPF_loc*rhs(:,k)
!----------------------
if ( (abs(w0(1)).gt.1E-8) .and. (abs(w0(2)).gt.1E-8) ) then
Dx0 = (Dx0 + righthandside(1)) / w0(1)
Dy0 = (Dy0 + righthandside(2)) / w0(2)
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
dumx(1) = relaxin*Dx0
dumy(1) = relaxin*Dy0
call loc2spher(xk(k),yk(k),1,dumx,dumy,xk1(k),yk1(k))
else
x0 = xk(k) + Dx0
y0 = yk(k) + Dy0
xk1(k) = relaxin * x0 + relax1 * xk(k)
yk1(k) = relaxin * y0 + relax1 * yk(k)
end if
else
call cirr(xk1(k), yk1(k), ncolhl)
! call qnerror('orthogonalisenet: w0=0', ' ', ' ')
cycle ndki
! goto 1234
! iexit = 1
end if
enddo ndki
xk(1:numk) = xk1(1:numk)
yk(1:numk) = yk1(1:numk)
! project boundary nodes back to the boundary
if ( JAPROJECT.ge.1 ) then
! call adddot(xk1(11),yk1(11),dble(no))
call orthonet_project_on_boundary(nmkx, kk1, k_bc, xkb, ykb)
end if
! snap to nearest land boundary
if ( JAPROJECT.ge.2 ) call snap_to_landboundary()
! update local coordinates
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
! compute local coordinates
call comp_local_coords(iloc,kk1,xk,yk,iloc(numk+1)-1,xloc,yloc)
end if
enddo
! press left or middle mouse button to toggle net plotting on/off;
! press right mouse button to terminate orthogonizenet
call halt3(ja3)
if ( Lteknet ) then
ja1 = -1234
call teknet(0,ja1) ! whipe out previous net image
! call teknetcells(NDRAW(33), -1234, 0)
! xk(1:numk) = xk1(1:numk)
! yk(1:numk) = yk1(1:numk)
! snap to nearest land boundary
! if ( JAPROJECT.ge.2 ) call snap_to_landboundary() ! JAPROJECT)
ja1 = -1234
call teknet(ncolhl,ja1)
! call teknetcells(NDRAW(33), -1234, 1)
!NDRAW(10) = 1
!CALL PLOT(NDRAW(10))
else
! xk(1:numk) = xk1(1:numk)
! yk(1:numk) = yk1(1:numk)
! snap to nearest land boundary
! if ( JAPROJECT.ge.2 ) call snap_to_landboundary() ! JAPROJECT)
end if
if ( ja3.eq.1 .or. ja3.eq.2) then
call teknet(0,ja1) ! whipe out net image
Lteknet = .not.Lteknet
end if
if ( ja3.eq.3) then
if ( keepcircumcenters.ne.1 ) call update_cell_circumcenters()
call readyy('Orthogonalising net',dble(no)/itatp)
exit tp
end if
enddo !itbnd
mu = min(2d0*mu, mumax)
!-------------------------------------------------
! compute the new cell centers
if ( keepcircumcenters.ne.1 ) call update_cell_circumcenters()
! increase atpf_min for next cycle
atpf_min = 1d0 - (1d0-atpf_min)*0.99d0
call readyy('Orthogonalising net',dble(no)/itatp)
enddo tp !itatp
1234 continue
call readyy('Orthogonalising net',-1d0)
!-------------------------------------------------
! call removesmalllinks()
!-------------------------------------------------
! deallocate dummy arrays
! deallocate(nb) ! AvD: TODO: this is for showing node codes (during ortho), but also introduces memleak.
deallocate(ww, kk1, rhs, aspect, smp_mu, k_bc, xk1, yk1)
deallocate(ktopo)
! deallocate(atpf_nodes)
if ( allocated(ops) ) call orthonet_dealloc_ops(ops)
if ( allocated(ops) ) deallocate(ops)
if ( allocated(nmk2) ) deallocate(nmk2)
if ( allocated(kk2) ) deallocate(kk2)
if ( allocated(ww2) ) deallocate(ww2)
if ( allocated(ww2x) ) deallocate(ww2x, ww2y)
if ( allocated(ic) ) deallocate(ic)
if ( allocated(jc) ) deallocate(jc)
if ( allocated(iloc) ) deallocate(iloc)
if ( allocated(xloc) ) deallocate(xloc)
if ( allocated(yloc) ) deallocate(yloc)
!-------------------------------------------------
! restore original settings
JSFERIC = JSFERICold
circumormasscenter = circormass_bak
if ( allocated(zk_bak) ) then
zk = zk_bak ! this line should be uncommented
deallocate(zk_bak)
end if
! if Lcopy is false, then samples have been created and need to be removed
if ( .not.Lcopymu ) then
call delsam(0)
end if
!-------------------------------------------------
! wrong adaptation direction:
! restore, switch orientation and start over
!-------------------------------------------------
jarerun = 0
! if ( Ns.gt.0 ) then
! jac = 1
! call confrm('Was this the right adaptation direction? ',jac)
! if ( jac .ne. 1 ) then
! call teknet(0,ja1) ! whipe out net image
! idir = 1 - idir
! jarerun = 1
! CALL RESTORE()
! end if
! end if
contains
!> determine atpf from residuals ***INOPERATIVE***
double precision function get_atpf(res)
implicit none
double precision, dimension(2) :: res !< residual
double precision, parameter :: beta = 1.00d0 ! influence parameter
! get_atpf = 1d0/(1d0 + beta*sqrt(sum(res**2)))
! get_atpf = 1d0/(1d0 + beta*maxval(abs(res)))
get_atpf = 1d0 ! disabled
end function get_atpf
subroutine comp_local_coords(iloc,kk1,x,y,Nloc,xloc,yloc)
use m_sferic
use network_data, only: numk, nmk
use m_inverse_map
implicit none
integer, dimension(numk+1), intent(in) :: iloc !< start pointer in local coordinate arrays
integer, dimension(nmkx,numk), intent(in) :: kk1 !< link-connected nodes
double precision, dimension(numk), intent(in) :: x, y !< node coordinates
integer, intent(in) :: Nloc !< size of arrays with local coordinates = iloc(numk+1)-1
double precision, dimension(Nloc), intent(out) :: xloc, yloc !< local coordinates
double precision, dimension(:), allocatable :: xx, yy
integer :: k, k0, kk, N
N = max(nmkx+1,nmkx2)
allocate(xx(N), yy(N))
do k0=1,numk
! store coordinates of nodes in stencil
xx(1) = x(k0)
yy(1) = y(k0)
do kk=1,nmk(k0)
k = kk1(kk,k0)
if ( k.gt.0 ) then
xx(kk+1) = xk(k)
yy(kk+1) = yk(k)
else ! safety
xx(kk+1) = xk(k0)
yy(kk+1) = yk(k0)
end if
end do
do kk=nmk(k0)+2,nmk2(k0)
k = kk2(kk,k0)
if ( k.gt.0 ) then
xx(kk) = xk(k)
yy(kk) = yk(k)
else ! safety
xx(kk) = xk(k0)
yy(kk) = yk(k0)
end if
end do
N = max(nmk(k0)+1,nmk2(k0))
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
call spher2loc(x(k0),y(k0),N,xx,yy,xloc(iloc(k0):),yloc(iloc(k0):))
else
do kk=1,N
xloc(iloc(k0)+k-1) = xx(kk)-x(k0)
yloc(iloc(k0)+k-1) = yy(kk)-y(k0)
end do
end if
end do
if ( allocated(xx) ) deallocate(xx)
if ( allocated(yy) ) deallocate(yy)
return
end subroutine comp_local_coords
!> compute weights ww and right-hand side rhs in orthogonizer:
!! sum_kk ww(kk,k0) * (x1(kk1(kk,k0)) - x1(k0)) = rhs(1,k0)
!! sum_kk ww(kk,k0) * (y1(kk1(kk,k0)) - y1(k0)) = rhs(2,k0)
subroutine orthonet_compweights(nmkx, kk1, aspect, ww, rhs)
use m_netw
use m_sferic
use m_flowgeom
use m_orthosettings
use m_missing
use geometry_module, only: dbdistance, normaloutchk, dcosphi, getdx, getdy
implicit none
integer, intent(in) :: nmkx !< maximum number of neighboring link-connected nodes
integer, dimension(nmkx,numk), intent(in) :: kk1 !< neighboring link-connected nodes
double precision, dimension( numL), intent(in) :: aspect !< aspect ratio of the links
double precision, dimension(nmkx,numk), intent(inout) :: ww !< weights
double precision, dimension( 2,numk), intent(out) :: rhs !< right-hand sides
double precision :: r01, slr
double precision :: mu
double precision :: x0,y0, x1,y1, x3,y3, xn,yn
double precision :: zzz, dinry, x0_bc, y0_bc, atpf1
double precision, external :: dprodin
integer :: k, kk, k0, k1l, k1r, kl, kr, l, ja
integer :: inode, node, nn
double precision :: dummy ! used for debug purposes only
double precision, dimension(2) :: eA ! aspect ratio unit vector
double precision :: cosphi
double precision :: SfR ! SLR/R01
double precision :: factor
double precision, parameter :: EPS=1D-4
dummy = ATPF
! ATPF needs to be set to 1d0, since smoothing is performed seperately
ATPF = 1d0
ATPF1 = 1D0 - ATPF
rhs = 0d0
ww = 0d0
do k0 = 1,numk ! attraction parameters
if ( (nb(k0) .ne. 1) .and. (nb(k0) .ne. 2)) cycle
x0 = xk(k0)
y0 = yk(k0)
numkk:do kk = 1,nmk(k0) ! loop over all links of node k0
L = nod(k0)%lin(kk) ! link number
SfR = aspect(L)
mu = 1d0
if (SfR.ne.DMISS) then
!-------------------------------------------------------------------------
! internal nodes
ww(kk,k0) = atpf * SfR + atpf1 * mu
!-------------------------------------------------------------------------
if ( lnn(L).eq.1 ) then
!-------------------------------------------------------------------------
! boundary nodes
k1L = kk1(kk,k0)
x1 = xk(k1L)
y1 = yk(k1L)
! compute the link lengths R01 and SLR
R01 = dbdistance(x0,y0,x1,y1, jsferic, jasfer3D, dmiss)
SLR = SfR * R01
! find a point inside cell kL and compute outward normal
kL = lne(1,L) ! left cell w.r.t. link L
nn = netcell(kL)%n
! x3 = SUM( xk(netcell(kL)%nod(1:nn)) ) / nn
! y3 = SUM( yk(netcell(kL)%nod(1:nn)) ) / nn
x3 = xzw(kL)
y3 = yzw(kL)
call normaloutchk(x0, y0, x1, y1, x3, y3, xn, yn, ja, jsferic, jasfer3D, dmiss, dxymis)
if ( JSFERIC.eq.1 .and. jasfer3D.eq.0 ) xn = xn * cos(dg2rd*0.5d0*(y0+y1) ) ! normal vector needs to be in Cartesian coordinates
rhs(1,k0) = rhs(1,k0) + (atpf * R01 * xn / 2 + &
atpf1 * SLR * xn * 0.5d0/mu)
rhs(2,k0) = rhs(2,k0) + (atpf * R01 * yn / 2 + &
atpf1 * SLR * yn * 0.5d0/mu)
ww(kk,k0) = atpf * 0.5d0 * SfR + &
atpf1 * 0.5d0 * mu
!-------------------------------------------------------------------------
end if
else
! R01 -> 0
ww(kk,k0) = 0d0
endif
enddo numkk
! normalise
factor = sum(ww(:,k0))
if ( abs(factor).gt.1E-14 ) then
factor = 1d0/factor
ww(:, k0) = factor*ww(:, k0)
rhs(1,k0) = factor*rhs(1,k0)
rhs(2,k0) = factor*rhs(2,k0)
end if
enddo ! k0
ATPF = dummy
end subroutine orthonet_compweights
!> smoother that strives to optimize the cell area distribution
subroutine orthonet_compweights_vol(nmkx2, nmk2, kk2, ww2x, ww2y, ierror)
use m_netw
use m_sferic
use m_orthosettings
use m_missing
use m_alloc
use unstruc_messages
use unstruc_colors, only: ncolhl
implicit none
integer, intent(in) :: nmkx2 !< maximum number of nodes in stencil
integer, allocatable, dimension(:), intent(in) :: nmk2 !< number of nodes in stencil
integer, allocatable, dimension(:,:), intent(in) :: kk2 !< node administration; first row, i.e. kk2(1,:), points to center nodes
double precision, allocatable, dimension(:,:), intent(inout) :: ww2x, ww2y !< weights
integer, intent(out) :: ierror !< 0: no error, 1: error
double precision, allocatable, dimension(:,:) :: Vx, Vy ! D vol/Dx and D vol/Dy matrices
integer :: icell, ilink, inode
integer :: k0, k1, kL, kR
integer :: icL, icR
integer :: kk0L, kk0R, kk1L, kk1R
integer :: kdum
integer :: N, kk0, kk1, kkk0, kkk1
double precision :: x0, y0, x1, y1, xL, yL, xR, yR
double precision :: DvolL, DvolR, xdum
! Matlab output only
! integer, dimension(Numl) :: lne1, lne2, kn1, kn2
! integer, parameter :: ioutfile=1234
! logical, save :: Lsavematlab = .false.
return
ierror = 1
! allocate
allocate(Vx(nmkx2, Nump), Vy(nmkx2, Nump))
! initialize
Vx = 0d0
Vy = 0d0
! for Matlab output
! lne1 = Nump+1
! lne2 = Nump+1
do ilink = 1,Numl
if ( lnn(ilink).lt.1 ) cycle
k0 = kn(1,ilink) ! first node of link
k1 = kn(2,ilink) ! second node of link
icL = lne(1,ilink) ! left neighboring cell
! find index of nodes k0 and k1 w.r.t. cell kL in netcell: kk0L and kk1L resp.
kk0L = 1; do while ( netcell(icL)%nod(kk0L).ne.k0 ); kk0L=kk0L+1; end do
kk1L = 1; do while ( netcell(icL)%nod(kk1L).ne.k1 ); kk1L=kk1L+1; end do
N = netcell(icL)%N
xL = sum(xk(netcell(icL)%nod(1:N))) / dble(max(N,1))
yL = sum(yk(netcell(icL)%nod(1:N))) / dble(max(N,1))
x0 = xk(k0); y0 = yk(k0);
x1 = xk(k1); y1 = yk(k1);
! contribution to the volume of the left cell
DvolL = 0.5d0*( (x0-xL)*(y1-yL) - (x1-xL)*(y0-yL) )
! Get the (0-1)/(L-R) frame in the right orientation by swapping nodes 0 and 1 if necessary
! the contribution to volume of cell L needs to be positive
if ( DvolL.lt.0d0 ) then ! swap nodes 0 and 1
kdum = k0; k0 = k1; k1 = kdum
kdum = kk0L; kk0L = kk1L; kk1L = kdum
xdum = x0; x0 = x1; x1 = xdum
xdum = y0; y0 = y1; y1 = xdum
DvolL = - DvolL
end if
Vx(kk0L,icL) = Vx(kk0L,icL) + 0.5d0*y1
Vx(kk1L,icL) = Vx(kk1L,icL) - 0.5d0*y0
Vy(kk0L,icL) = Vy(kk0L,icL) - 0.5d0*x1
Vy(kk1L,icL) = Vy(kk1L,icL) + 0.5d0*x0
! for Matlab output
! kn1(ilink) = k0
! kn2(ilink) = k1
! lne1(ilink) = lne(1,ilink)
! same for the left cell, if it exists
if ( lnn(ilink).gt.1 ) then
icR = lne(2,ilink)
N = netcell(icR)%N
xR = sum(xk(netcell(icR)%nod(1:N))) / dble(max(N,1))
yR = sum(yk(netcell(icR)%nod(1:N))) / dble(max(N,1))
! contribution to the volume of the left cell
DvolR = 0.5d0*( (x1-xR)*(y0-yR) - (x0-xR)*(y1-yR) )
! DvolR should be larger then zero
if ( DvolR.lt.0d0 ) then
call qnerror('orthonet_compweights_vol: DvolR<0', ' ', ' ')
call teklink(ilink, ncolhl)
if ( kn(3,ilink) == 2 ) then
call cirr(xk(kn(1,ilink)), yk(kn(1,ilink)), ncolhl)
call cirr(xk(kn(2,ilink)), yk(kn(2,ilink)), ncolhl)
end if
goto 1234
end if
! find index of nodes k0 and k1 w.r.t. cell kL in netcell: kk0L and kk1L resp.
kk0R = 1; do while ( netcell(icR)%nod(kk0R).ne.k0 .and. kk0R.lt.N ); kk0R=kk0R+1; end do
kk1R = 1; do while ( netcell(icR)%nod(kk1R).ne.k1 .and. kk1R.lt.N ); kk1R=kk1R+1; end do
if ( netcell(icR)%nod(kk0R).ne.k0 .or. netcell(icR)%nod(kk1R).ne.k1 ) then
call qnerror('orthonet_compweights_vol: node not found', ' ', ' ')
goto 1234
end if
Vx(kk0R,icR) = Vx(kk0R,icR) - 0.5d0*y1
Vx(kk1R,icR) = Vx(kk1R,icR) + 0.5d0*y0
Vy(kk0R,icR) = Vy(kk0R,icR) + 0.5d0*x1
Vy(kk1R,icR) = Vy(kk1R,icR) - 0.5d0*x0
! for Matlab output
! lne2(ilink) = lne(2,ilink)
end if
end do
! compute the weights:
! [ ww2x 0] = [-Vx'*Vx 0]
! [ 0 ww2y] = [ 0 -Vy' Vy]
ww2x = 0d0
ww2y = 0d0
do icell=1,Nump
N = netcell(icell)%N
do kk0=1,N
k0 = netcell(icell)%nod(kk0)
if ( nmk2(k0).eq.0 ) cycle
! if ( nb(k0).ne.1 ) cycle ! internal nodes only
do kk1=1,N
k1 = netcell(icell)%nod(kk1)
! if ( nb(k1).ne.1 ) cycle ! internal nodes only
kkk1=1
do while( kk2(kkk1,k0).ne.k1 .and. kkk1.lt.nmk2(k0) )
kkk1=kkk1+1
end do
if ( kk2(kkk1,k0).ne.k1 ) then
call qnerror( 'orthonet_compweights_vol: node not found', ' ', ' ')
goto 1234
end if
ww2x(kkk1,k0) = ww2x(kkk1,k0) + Vx(kk0,icell)*Vx(kk1,icell)
ww2y(kkk1,k0) = ww2y(kkk1,k0) + Vy(kk0,icell)*Vy(kk1,icell)
kkk0=1
do while( kk2(kkk0,k0).ne.k0 .and. kkk0.lt.nmk2(k0) )
kkk0=kkk0+1
end do
if ( kk2(kkk0,k0).ne.k0 ) then
call qnerror( 'orthonet_compweights_vol: node not found', ' ', ' ')
goto 1234
end if
ww2x(kkk0,k1) = ww2x(kkk0,k1) + Vx(kk0,icell)*Vx(kk1,icell)
ww2y(kkk0,k1) = ww2y(kkk0,k1) + Vy(kk0,icell)*Vy(kk1,icell)
if ( kkk1.gt.nmk2(k0) .or. kkk0.gt.nmk2(k0) ) then
call qnerror( 'orthonet_compweights_vol: node not found', ' ', ' ')
goto 1234
end if
end do
end do
end do
do k0=1,Numk
if ( nb(k0).eq.1 .or. nb(k0).eq.4 ) cycle ! non-internal cells only
ww2x(1,k0) = 1d0
ww2y(1,k0) = 1d0
ww2x(2:nmk2(k0),k0) = 0d0
ww2y(2:nmk2(k0),k0) = 0d0
end do
ierror = 0
! if ( Lsavematlab) then
! open(ioutfile, file='c:\cygwin\home\pijl\develop\test\testww2x.m')
!
! call matlab_write_int(ioutfile, 'nmkx2', (/ nmkx2 /), 1, 1)
! call matlab_write_int(ioutfile, 'nmk2', (/ nmk2 /), Numk, 1)
! call matlab_write_int(ioutfile, 'kk2', kk2, nmkx2, Numk)
! call matlab_write_double(ioutfile, 'ww2x', ww2x, nmkx2, Numk)
! call matlab_write_double(ioutfile, 'ww2y', ww2y, nmkx2, Numk)
!
! call matlab_write_double(ioutfile, 'xk', xk, Numk, 1)
! call matlab_write_double(ioutfile, 'yk', yk, Numk, 1)
! call matlab_write_int(ioutfile, 'lne1', lne1, Numl, 1)
! call matlab_write_int(ioutfile, 'lne2', lne2, Numl, 1)
! call matlab_write_int(ioutfile, 'kn1', kn1, Numl, 1)
! call matlab_write_int(ioutfile, 'kn2', kn2, Numl, 1)
!
! close(ioutfile)
!
! call qnerror('Matlab file saved', ' ', ' ')
!
! Lsavematlab = .false.
!
!! ierror = 1
! end if
1234 continue
! deallocate
deallocate(Vx, Vy)
end subroutine
!> inverse-mapping elliptic smoother
!! computes weight ww in:
!! sum_kk ww(kk,k0) * x1(kk2(kk,k0)) = 0
!! sum_kk ww(kk,k0) * y1(kk2(kk,k0)) = 0
subroutine orthonet_compweights_smooth(ops, u, ww2, ierror)
use m_netw
use m_sferic
use m_flowgeom
use m_orthosettings
use m_missing
use m_alloc
use m_inverse_map
use unstruc_colors
implicit none
type(tops), allocatable, dimension(:), intent(inout) :: ops !< operators for each unique topology
double precision, allocatable, dimension(:), intent(in) :: u !< 'physcial solution' whose gradient will attract the mesh
double precision, allocatable, dimension(:,:), intent(inout) :: ww2 !< weights
integer, intent(out) :: ierror !< node number that gave error
!---------------------------
! mesh adaptation arrays
!---------------------------
double precision, allocatable, dimension(:,:) :: Ginv ! mesh monitor matrices
double precision, dimension(4) :: Adum
!---------------------------
double precision, allocatable, dimension(:,:) :: J ! Jacobian matrices at the nodes
integer :: k, kk, knode, k0, k1
integer :: nmkx2_old
integer :: L, num
double precision, dimension(2) :: a1, a2 ! contravariant base vectors
double precision :: det
integer, allocatable, dimension(:) :: Mcell ! for matlab output
double precision, allocatable, dimension(:,:) :: x,y ! for matlab output
integer, parameter :: imat=123 ! matlab file unit number
logical, save :: Lsavematlabfile = .false.
double precision :: dalpha, UU(2,2), VV(2,2), S(2), uu1, vv1, uu2, vv2
double precision :: aspect ! Jacobian at link positions
double precision :: dmudxi, dmudeta, mu2, mumax
integer :: ierror_, kcheck
logical :: lisnew ! new topology (.true.) or not (.false.)
type(tops) :: op ! structure with operators
type(tadm) :: adm ! structure with administration
double precision, allocatable, dimension(:) :: xi, eta ! node coordinates (xi,eta)
double precision :: alpha ! used for monotonicity correction
double precision :: beta ! defines the mesh refinement concentration; 0<=beta<=1
double precision :: dcosfac
double precision, dimension(4) :: Gdum
double precision, dimension(4) :: DGinvDxi, DGinvDeta
double precision, parameter :: EPS=1E-8
ierror_ = 1
kcheck = 5
ierror = ierror_
! compute operators
if ( .not.allocated(ops) ) then
call orthonet_comp_ops(ops, ierror_)
if ( ierror_.ne.0 ) goto 1234
end if
allocate(xi(nmkx2), eta(nmkx2))
allocate(J(4,Numk), Ginv(4,Numk))
J = 0d0
! compute Jacobian matrices
do k0=1,Numk
dcosfac = 1d0
if ( jsferic.eq.1 ) then
dcosfac = cos(yk(k0)*dg2rd)
end if
! if ( nb(k0).ne.1 .and. nb(k0).ne.2 .and. nb(k0).ne.3 ) cycle
if ( nb(k0).ne.1 .and. nb(k0).ne.2 .and. nb(k0).ne.4 ) cycle
op = ops(ktopo(k0))
! J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) )
! J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
! J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) )
! J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xloc(iloc(k0):iloc(k0+1)-1) )
J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yloc(iloc(k0):iloc(k0+1)-1) )
J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xloc(iloc(k0):iloc(k0+1)-1) )
J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yloc(iloc(k0):iloc(k0+1)-1) )
else
J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) ) * dcosfac
J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) ) * dcosfac
J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
end if
end do
! compose the inverse monitor matrices for mesh adaptation
if ( Ns.gt.0 ) then
call orthonet_comp_Ginv(u, ops, J, Ginv)
else
Ginv(1,:) = 1d0
Ginv(2:3,:) = 0d0
Ginv(4,:) = 1d0
end if
! reallocate memory for weights ww2 if necessary
if ( ubound(ww2,1).lt.nmkx2 ) call realloc(ww2, (/nmkx2,numk/))
! compose the discretization
do k0 = 1,numk ! attraction parameters
if ( k0.eq. kcheck ) then
continue
end if
if ( nmk(k0) .lt. 2 ) cycle
!-------------------------------------------------------------------------
! internal nodes and boundary nodes
!-------------------------------------------------------------------------
! if ( (nb(k0) .eq. 1) ) then
if ( (nb(k0) .eq. 1) .or. (nb(k0) .eq. 2) ) then
op = ops(ktopo(k0))
if ( nmk(k0).gt.size(op%Divxi) ) then
continue
end if
! compute the Jacobian
! J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) )
! J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
! J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) )
! J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xloc(iloc(k0):iloc(k0+1)-1) )
J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yloc(iloc(k0):iloc(k0+1)-1) )
J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xloc(iloc(k0):iloc(k0+1)-1) )
J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yloc(iloc(k0):iloc(k0+1)-1) )
else
J(1,k0) = sum( op%Jxi( 1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) ) * dcosfac
J(2,k0) = sum( op%Jxi( 1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
J(3,k0) = sum( op%Jeta(1:nmk2(k0)) * xk(kk2(1:nmk2(k0),k0)) ) * dcosfac
J(4,k0) = sum( op%Jeta(1:nmk2(k0)) * yk(kk2(1:nmk2(k0),k0)) )
end if
! compute the contravariant base vectors
det = J(1,k0)*J(4,k0) - J(3,k0)*J(2,k0)
if ( det.eq.0d0 ) then
! call qnerror('orthonet_compweights_smooth: det=0', ' ', ' ')
call cirr(xk(k0), yk(k0), ncolhl)
cycle
! return
end if
a1 = (/ J(4,k0), -J(3,k0) /) / det
a2 = (/ -J(2,k0), J(1,k0) /) / det
!--------------------------------------------------------------
! compute the Singular Value Decomposition of the Jacobian matrix
!--------------------------------------------------------------
if ( Lsavematlabfile ) then
UU(1,:) = (/ J(1,k0), J(3,k0) /)
UU(2,:) = (/ J(2,k0), J(4,k0) /)
call svdcmp(UU, 2, 2, 2, 2, S, VV)
aspect = min( S(1)/(S(2)+EPS), S(2)/(S(1)+EPS) )
uu1 = UU(1,1) * S(1)
vv1 = UU(2,1) * S(1)
uu2 = UU(1,2) * S(2)
vv2 = UU(2,2) * S(2)
end if
!--------------------------------------------------------------
! compose the discretization
!--------------------------------------------------------------
ww2(:, k0) = 0d0
DGinvDxi = matmul(Ginv(:, kk2(1:nmk2(k0),k0)), op%Jxi)
DGinvDeta = matmul(Ginv(:, kk2(1:nmk2(k0),k0)), op%Jeta)
Adum = Ginv(:,k0)
ww2(1:nmk2(k0), k0) = - &
( &
Anorm(a1,a1,DGinvDxi ) * op%Jxi + &
Anorm(a1,a2,DGinvDeta) * op%Jxi + &
Anorm(a2,a1,DGinvDxi ) * op%Jeta + &
Anorm(a2,a2,DGinvDeta) * op%Jeta &
) + &
( &
Anorm(a1,a1,Adum) * matmul(op%Gxi, op%Divxi ) + &
Anorm(a1,a2,Adum) * matmul(op%Gxi, op%Diveta) + &
Anorm(a2,a1,Adum) * matmul(op%Geta, op%Divxi) + &
Anorm(a2,a2,Adum) * matmul(op%Geta, op%Diveta) &
)
! monotonicity: all off-diagonal elements should be >= 0
alpha = 0d0
do k=2,nmk2(k0)
! alpha = max(alpha, -ww2(k,k0))
alpha = max(alpha, -ww2(k,k0)/max(1d0,op%ww2(k)))
end do
! firstly, correct with the node-average with some threshold
! the threshold is intended to prevent mesh folding
! if ( alpha.gt.-ww2(1,k0)/dble(nmk2(k0)) ) then
!! call cirr(xk(k0), yk(k0), ncolhl)
! ww2(:,k0) = ww2(:,k0) + alpha
! end if
! 03-08-11: threshold set to zero
! ww2(2:nmk2(k0),k0) = ww2(2:nmk2(k0),k0)+alpha
! 04-08-11:
ww2(2:nmk2(k0),k0) = ww2(2:nmk2(k0),k0) + alpha * max(op%ww2(2:nmk2(k0)),1d0)
! then, set the remaining negative off-diagonal weights to zero
! do k=2,nmk2(k0)
! if ( ww2(k, k0).lt.0d0 ) ww2(k, k0) = 0d0
! end do
ww2(1,k0) = -sum(ww2(2:nmk2(k0),k0))
! normalise
ww2(:, k0) = -ww2(:,k0)/(ww2(1,k0)+1d-8)
! else if ( nb(k0).eq.2 ) then ! will never be reached
!-------------------------------------------------------------------------
! boundary nodes
!-------------------------------------------------------------------------
! op = ops(ktopo(k0))
!
! ww2(:, k0) = 0d0
! do k=1,nmk(k0)
! do knode=1,nmk2(k0)
! ww2(knode, k0) = ww2(knode, k0) + &
! op%Divxi( k)*op%Gxi( knode, k) + &
! op%Diveta(k)*op%Geta(knode, k)
! end do
! end do
!
! ! normalise
! ww2(:, k0) = -ww2(:,k0)/ww2(1,k0)
!
end if
!-------------------------------------------------------------------------
! boundary nodes
! see W. Huang, 'Practical Aspects of Formulation and Solution of
! Moving Mesh Partial Differential Equations',
! J. of Comp. Phys., 2001, sect. 3.3
!-------------------------------------------------------------------------
! else if ( nb(k0).eq.2 ) then
! num = 1
! kk2(1,k0) = k0
! ww2(:,k0) = 0d0
! do k=1,nmk(k0)
! L = nod(k0)%lin(k)
! kk2(k+1,k0) = kn(1,L) + kn(2,L) - k0
! if ( lnn(L).eq.1 ) then
! num = num+1
! ww2(K+1,k0) = 1d0
! end if
! end do
! if ( nmk2(k0).eq.0 ) nmk2(k0) = nmk(k0)+1
! ww2(1,k0) = -sum(ww2(2:nmk2(k0),k0))
!
! ! normalise
! ww2(:, k0) = -ww2(:,k0)/ww2(1,k0)
! end if
! debug: Matlab output
if ( k0.eq.kcheck .and. Lsavematlabfile) then
call orthonet_admin(k0, adm, ierror)
call orthonet_assign_xieta(k0, adm, xi, eta, ierror_)
allocate(Mcell(nmk(k0)), x(M,nmk2(k0)), y(M,nmk2(k0)))
do kk=1,nmk(k0)
if ( adm%icell(kk).ge.1 ) then
Mcell(kk) = netcell(adm%icell(kk))%n
else
Mcell(kk) = -1234
end if
end do
if ( Lsavematlabfile ) then
open(imat, file='test.m')
call matlab_write_double(imat, 'xi', xi( 1:nmk2(k0)), nmk2(k0), 1)
call matlab_write_double(imat, 'eta', eta(1:nmk2(k0)), nmk2(k0), 1)
call matlab_write_double(imat, 'Gxi', op%Gxi( 1:nmk2(k0),1:nmk(k0)), nmk2(k0), nmk(k0))
call matlab_write_double(imat, 'Geta', op%Geta(1:nmk2(k0),1:nmk(k0)), nmk2(k0), nmk(k0))
call matlab_write_double(imat, 'Divxi', op%Divxi( 1:nmk(k0)) , nmk(k0), 1)
call matlab_write_double(imat, 'Diveta', op%Diveta(1:nmk(k0)) , nmk(k0), 1)
call matlab_write_double(imat, 'a1', a1, 2, 1)
call matlab_write_double(imat, 'a2', a2, 2, 1)
call matlab_write_int( imat, 'kkc', adm%kkc(1:M,1:nmk(k0)), M, nmk(k0))
call matlab_write_int( imat, 'Mcell', Mcell(1:nmk(k0)), nmk(k0), 1)
call matlab_write_double(imat, 'x', xk(adm%kk2(1:nmk2(k0))), nmk2(k0), 1)
call matlab_write_double(imat, 'y', yk(adm%kk2(1:nmk2(k0))), nmk2(k0), 1)
call matlab_write_double(imat, 'ww2', ww2(1:nmk2(k0),k0), nmk2(k0), 1)
call matlab_write_double(imat, 'Az', op%Az(1:nmk2(k0),1:nmk(k0)), nmk2(k0), nmk(k0))
call matlab_write_double(imat, 'Jxi', op%Jxi( 1:nmk2(k0)), nmk2(k0), 1)
call matlab_write_double(imat, 'Jeta', op%Jeta(1:nmk2(k0)), nmk2(k0), 1)
call matlab_write_double(imat, 'u1', (/ uu1, vv1 /), 2, 1)
call matlab_write_double(imat, 'u2', (/ uu2, vv2 /), 2, 1)
call matlab_write_double(imat, 's', S, 2, 1)
close(imat)
call qnerror('Matlab file saved', ' ', ' ')
end if
Lsavematlabfile = .false.
deallocate(Mcell, x, y)
end if
enddo ! k0
ierror_ = 0
1234 continue
! deallocate arrays
if ( allocated(adm%icell) ) then
deallocate(adm%icell, adm%kk2, adm%kkc)
else
continue
end if
if ( allocated(xi) ) deallocate(xi, eta)
if ( allocated(op%Az) ) then
deallocate(op%Az, op%Gxi, op%Geta, op%Divxi, op%Diveta, op%Jxi, op%Jeta)
else
continue
end if
if ( allocated(Ginv) ) deallocate(Ginv)
if ( allocated(J) ) deallocate(J)
ierror = ierror_
end subroutine orthonet_compweights_smooth
!> compute the inverse monitor function for mesh adaptation
!! see W. Huang, 'Practical Aspects of Formulation and Solution of
!! Moving Mesh Partial Differential Equations',
!! J. of Comp. Phys., 2001, sects. 3.4 and 3.5
subroutine orthonet_comp_Ginv(u, ops, J, Ginv)
use m_netw
use m_orthosettings
implicit none
double precision, dimension(:) :: u !< 'physcial solution' whose gradient will attract the mesh
type(tops), dimension(:) :: ops !< array of structure with operators of unique topologies
double precision, dimension(:,:) :: J !< Jacobian matrices at the nodes
double precision, dimension(:,:) :: Ginv !< inverse mesh monitor matrix at net-nodes
double precision, allocatable, dimension(:) :: u_smooth ! smoothed solution
double precision, allocatable, dimension(:,:) :: vdir ! refinement direction vector
double precision, allocatable, dimension(:) :: Phi !
double precision, dimension(2) :: vper ! perpendicular refinement direction vector
double precision, dimension(2) :: a1, a2 ! contravariant base vectors
double precision, allocatable, dimension(:,:) :: G ! mesh monitor matrix at net-nodes
double precision, allocatable, dimension(:,:) :: G_tmp ! temporary mesh monitor matrix at net-nodes
double precision :: det, dudxi, dudeta
double precision :: alpha, lambda1, lambda2, lfac
double precision :: Phi_ave, vol, ww2
integer :: k0, imat=666
logical, save :: Lsavematlab = .false.
! allocate
allocate(u_smooth(Numk), vdir(2,Numk), Phi(Numk), G(4,Numk), G_tmp(4,Numk))
G_tmp = 0d0
Phi = 0d0
vdir = 0d0
Phi_ave = 0d0
vol = 0d0
call orthonet_smooth_u(u, adapt_niter_u, ops, u_smooth) ! <1: no smoothing
! compute Phi
do k0=1,Numk
if ( nb(k0).ne.1 .and. nb(k0).ne.2 .and. nb(k0).ne.4 ) cycle ! internal and boundary nodes only
! compute the contravariant base vectors
det = J(1,k0)*J(4,k0) - J(3,k0)*J(2,k0) + 1d-9
a1 = (/ J(4,k0), -J(3,k0) /) / det
a2 = (/ -J(2,k0), J(1,k0) /) / det
dudxi = sum(ops(ktopo(k0))%Jxi( 1:nmk2(k0)) * u_smooth(kk2(1:nmk2(k0),k0)))
dudeta = sum(ops(ktopo(k0))%Jeta(1:nmk2(k0)) * u_smooth(kk2(1:nmk2(k0),k0)))
! compute the physical gradient of mu
vdir(:,k0) = a1 * dudxi + a2 * dudeta
Phi(k0) = sqrt( sum(vdir(:,k0)**2) ) ! temporarily, will be redefined hereafter
if ( Phi(k0).gt.1d-14 ) then
vdir(:,k0) = vdir(:,k0) / Phi(k0)
else
vdir(:,k0) = (/ 1d0, 0d0 /)
end if
! Phi(k0) = sqrt( 1d0 + Phi(k0)**2 ) - 1d0 ! refinement based on gradients of u
Phi(k0) = sqrt( 1d0 + u_smooth(k0)**2 ) - 1d0 ! refinement based on smoothed u
! Phi(k0) = sqrt( 1d0 + u(k0)**2 ) - 1d0 ! refinement based on u itself
Phi_ave = Phi_ave + Phi(k0)*abs(det)
vol = vol + abs(det)
end do
Phi_ave = Phi_ave/vol
alpha = 1d0
adapt_beta = min(adapt_beta, 0.99d0)
if ( Phi_ave.ne.0d0 ) alpha = adapt_beta / (Phi_ave * (1d0-adapt_beta))
select case (adapt_method)
case (1) ! arc-length
do k0=1,Numk
lambda1 = 1d0 + alpha*Phi(k0)
lambda2 = 1d0
lfac = lambda1/lambda2 - 1d0
G_tmp(1,k0) = 1d0 + lfac*vdir(1,k0)*vdir(1,k0)
G_tmp(2,k0) = lfac*vdir(2,k0)*vdir(1,k0)
G_tmp(3,k0) = lfac*vdir(1,k0)*vdir(2,k0)
G_tmp(4,k0) = 1d0 + lfac*vdir(2,k0)*vdir(2,k0)
G_tmp(:,k0) = G_tmp(:,k0) * lambda2
end do
case (2) ! Harmonic map
do k0=1,Numk
lambda1 = 1d0 + alpha*Phi(k0)
lambda2 = 1d0/lambda1
lfac = lambda1/lambda2 - 1d0
G_tmp(1,k0) = 1d0 + lfac*vdir(1,k0)*vdir(1,k0)
G_tmp(2,k0) = lfac*vdir(2,k0)*vdir(1,k0)
G_tmp(3,k0) = lfac*vdir(1,k0)*vdir(2,k0)
G_tmp(4,k0) = 1d0 + lfac*vdir(2,k0)*vdir(2,k0)
G_tmp(:,k0) = G_tmp(:,k0) * lambda2
end do
case default ! Winslow
do k0=1,Numk
G_tmp(:,k0) = (/ 1d0, 0d0, 0d0, 1d0 /) * (1d0 + alpha*Phi(k0))
end do
end select
! smooth G
do k=1,4
call orthonet_smooth_u(G_tmp(k,:), adapt_niter_G, ops, G(k,:))
end do
do k0=1,Numk
if ( nb(k0).eq.1 .or. nb(k0).eq.2 .or. nb(k0).eq.4 ) then
Ginv(1:4,k0) = (/ G(4,k0), -G(2,k0), -G(3,k0), G(1,k0) /)
Ginv(1:4,k0) = Ginv(:,k0) / (G(1,k0)*G(4,k0) - G(3,k0)*G(2,k0))
else
Ginv(1:4,k0) = (/ 1d0, 0d0, 0d0, 1d0 /)
end if
end do
if ( Lsavematlab) then
open(imat, file='c:\cygwin\home\pijl\develop\refinement.m')
call matlab_write_double(imat, 'xk', xk, Numk, 1)
call matlab_write_double(imat, 'yk', yk, Numk, 1)
call matlab_write_double(imat, 'G_tmp', G_tmp, 4, Numk)
call matlab_write_double(imat, 'G', G, 4, Numk)
call matlab_write_double(imat, 'Ginv', Ginv, 4, Numk)
call matlab_write_double(imat, 'vdir', vdir, 2, Numk)
call matlab_write_double(imat, 'Phi', Phi, Numk, 1)
call matlab_write_double(imat, 'Phi_ave', (/ Phi_ave /), 1, 1)
call matlab_write_double(imat, 'u', u, Numk, 1)
call matlab_write_double(imat, 'u_smooth', u_smooth, Numk, 1)
close(imat)
call qnerror('Matlab file saved', ' ', ' ')
Lsavematlab = .false.
end if
! deallocate
deallocate(u_smooth, vdir, Phi, G, G_tmp)
end subroutine
!> compute the operators for each unique topology in the
!! inverse-map elliptic smoother
subroutine orthonet_comp_ops(ops, ierror)
use m_netw
use m_alloc
use m_inverse_map
use unstruc_colors
implicit none
type (tops), allocatable, dimension(:), intent(out) :: ops !< per-topology operators
integer, intent(out) :: ierror !< 0: no error, 1: error
integer :: k, kk, k0, knode, k1
integer :: nmk_loc, itopo
double precision, allocatable, dimension(:) :: xi, eta ! node coordinates (xi,eta)
logical :: lisnew ! new topology (.true.) or not (.false.)
logical, allocatable, dimension(:) :: lnewtopo
type(tadm) :: adm ! structure with administration
type(ttop) :: top ! structure with topology arrays
ierror = 1
adm%Ncell = 2
allocate(adm%icell(adm%Ncell))
adm%icell = 0
allocate(adm%kk2(nmkx2))
adm%kk2 = 0
allocate(adm%kkc(M,adm%Ncell))
adm%kkc = 0
allocate(xi(nmkx2), eta(nmkx2))
xi = 0d0
eta = 0d0
! allocate saved arrays
allocate(top%nmk(1), top%nmk2(1))
allocate(top%xi(nmkx,1), top%eta(nmkx,1))
if ( .not.allocated(kk2) ) allocate(kk2(nmkx,numk))
! firstly, perform the administration
do k0 = 1,numk
if ( nmk(k0) .lt. 2 ) cycle
! perform the node-to-node-through-cells connectivity administration
call orthonet_admin(k0, adm, ierror)
if ( ierror.eq.1 ) then
call qnerror('orthonet_compweights_smooth: orthonet_admin gave error', ' ', ' ')
goto 1234
end if
! resize kk2 array if necessary
if ( adm%nmk2.gt.nmkx2 ) then
nmkx2 = adm%nmk2
call realloc(kk2, (/ nmkx2, numk /), fill=0)
end if
! fill global administration arrays with local
nmk2(k0) = adm%nmk2
kk2(1:nmkx2,k0) = adm%kk2(1:nmkx2)
! resize xi and eta arrays if necessary
if ( adm%nmk2.gt.ubound(xi,1) ) then
call realloc(xi, adm%nmk2, fill=0d0)
call realloc(eta, adm%nmk2, fill=0d0)
end if
! assign (xi, eta) and find and save the unique topologies
! assign the node indices xi and eta
ierror = 1234
call orthonet_assign_xieta(k0, adm, xi, eta, ierror)
if ( ierror.eq.1 ) then
call qnerror('orthonet_comp_ops: orthonet_assignxieta gave error', ' ', ' ')
goto 1234
end if
! save unique topology, based on xi and eta
call orthonet_save_topo(k0, adm, xi, eta, top, lisnew)
end do
! deallocate memory
deallocate(top%xi, top%eta, top%nmk, top%nmk2)
! allocate memory
allocate(ops(numtopo))
allocate(lnewtopo(numtopo))
lnewtopo = .true.
! compute and save operators for new, unique topologies
do k0=1,numk
if ( nb(k0).ne.1 .and. nb(k0).ne.2 .and. nb(k0).ne.3 .and. nb(k0).ne.4 ) cycle ! we need the adminstration for corner nodes, hence corner nodes are not excluded
itopo = ktopo(k0)
if ( itopo.lt.1 ) cycle ! really needs to be checked
! determine if this node has a new unique topology
if ( lnewtopo(itopo) ) then
lnewtopo(itopo) = .false.
! allocate memory
call orthonet_alloc_op(ops(itopo), nmk(k0), nmk2(k0))
! perform administration
call orthonet_admin(k0, adm, ierror)
! assign node coordinates (xi, eta)
call orthonet_assign_xieta(k0, adm, xi, eta, ierror)
! compute operators
! if ( nb(k0).ne.3 ) then ! corner-node operators are excluded
call orthonet_comp_operators(k0, adm, xi, eta, ops(itopo), ierror)
if ( ierror.eq.1 ) then
call qnerror('orthonet_compweights_smooth: orthonet_comp_operators gave error', ' ', ' ')
goto 1234
end if
! end if
end if
end do
ierror = 0
1234 continue
! error handling
! call cirr(xk(k0), yk(k0), ncolhl)
! deallocate saved arrays
if ( allocated(top%xi) ) deallocate(top%xi, top%eta, top%nmk, top%nmk2)
! deallocate arrays
if ( allocated(adm%icell) ) deallocate(adm%icell, adm%kk2, adm%kkc)
if ( allocated(xi) ) deallocate(xi, eta)
if ( allocated(lnewtopo) ) deallocate(lnewtopo)
end subroutine orthonet_comp_ops
!> allocate operator structure
subroutine orthonet_alloc_op(op, nmkloc, nmk2loc)
use m_inverse_map
implicit none
type(tops) :: op !< structure with operators
integer :: nmkloc !< number of link-connected neighboring nodes
integer :: nmk2loc !< number of nodes in stencil
allocate(op%Az(nmk2loc,nmkloc))
allocate(op%Gxi( nmk2loc,nmkloc))
allocate(op%Geta(nmk2loc,nmkloc))
allocate(op%Divxi( nmkloc))
allocate(op%Diveta(nmkloc))
allocate(op%Jxi( nmk2loc))
allocate(op%Jeta(nmk2loc))
allocate(op%ww2(nmk2loc))
if ( .not.allocated(op%Az) ) then
continue
end if
end subroutine orthonet_alloc_op
!> deallocate op
subroutine orthonet_dealloc_op(op)
use m_inverse_map
implicit none
type(tops) :: op !< structure with operators
if ( allocated(op%Az) ) deallocate(op%Az)
if ( allocated(op%Gxi) ) deallocate(op%Gxi)
if ( allocated(op%Geta) ) deallocate(op%Geta)
if ( allocated(op%Divxi) ) deallocate(op%Divxi)
if ( allocated(op%Diveta) ) deallocate(op%Diveta)
if ( allocated(op%Jxi) ) deallocate(op%Jxi)
if ( allocated(op%Jeta) ) deallocate(op%Jeta)
if ( allocated(op%ww2) ) deallocate(op%ww2)
end subroutine orthonet_dealloc_op
!> deallocate ops
subroutine orthonet_dealloc_ops(ops)
use m_inverse_map
implicit none
type(tops), allocatable, dimension(:) :: ops !< operators for each unique topology
integer itopo, k
if ( .not.allocated(ops) ) return
do itopo=1,size(ops)
call orthonet_dealloc_op(ops(itopo))
end do
end subroutine orthonet_dealloc_ops
!> determine and store unique topologies, based on xi and eta
!! topology is defined by the node angels w.r.t. center node: theta
subroutine orthonet_save_topo(k0, adm, xi, eta, top, lisnew)
use m_netw
use m_missing
use m_inverse_map
implicit none
integer :: k0 !< center node
type(tadm) :: adm !< structure with administration
double precision, allocatable, dimension(:) :: xi, eta !< node coordinates (xi,eta)
type(ttop) :: top !< structure with topology arrays
logical :: lisnew !< new topology (.true.) or not (.false.)
double precision, dimension(adm%nmk2) :: theta ! atan(eta/xi)
double precision :: theta_sav
integer :: ic, kcell, k
integer :: itopo, idum
integer, dimension(2) :: newbound
double precision, parameter :: TOL=1E-4
! compute the angle theta of the nodes connected to center node k0
theta = DMISS
do k=1,nmk2(k0)
theta(k) = atan2(eta(k), xi(k))
end do
! determine if the topology is new
lisnew = .true.
topo:do idum=1,1
if ( adm%nmk2.gt.ubound(top%xi,1) ) cycle topo
do itopo=1,numtopo
if ( adm%nmk.ne.top%nmk(itopo) .or. adm%nmk2.ne.top%nmk2(itopo) ) cycle
lisnew = .false.
do k=2,adm%nmk2 ! center node (k=0) not considered
theta_sav = atan2(top%eta(k,itopo), top%xi(k,itopo))
if ( abs(theta(k) - theta_sav) .gt. TOL ) then
lisnew = .true.
exit
end if
end do
if ( .not.lisnew ) then
! match found
ktopo(k0) = itopo
exit
end if
end do
end do topo
! save the node angles and coordinates (xi,eta)
if ( lisnew ) then
numtopo = numtopo + 1
! check array size and increase if necessary
newbound = ubound(top%xi)
if ( adm%nmk2.gt.newbound(1) .or. numtopo.gt.newbound(2)) then
newbound = (/ max(adm%nmk2, newbound(1)), max(numtopo, newbound(2)) /)
call realloc(top%xi, newbound, fill=DMISS)
call realloc(top%eta, newbound, fill=DMISS)
call realloc(top%nmk, newbound(2))
call realloc(top%nmk2, newbound(2))
end if
! fill arrays
top%xi( 1:adm%nmk2, numtopo) = xi( 1:adm%nmk2)
top%eta(1:adm%nmk2, numtopo) = eta(1:adm%nmk2)
top%nmk(numtopo) = adm%nmk
top%nmk2(numtopo) = adm%nmk2
ktopo(k0) = numtopo
end if
end subroutine orthonet_save_topo
!> Anorm = (Ax,y)
double precision function Anorm(x,y,A)
implicit none
double precision, dimension(2) :: x, y !< 2-dim. vectors
double precision, dimension(2,2) :: A !< 2x2 matrix
Anorm = ( A(1,1)*x(1) + A(1,2)*x(2) ) * y(1) + &
( A(2,1)*x(1) + A(2,2)*x(2) ) * y(2)
end function
!> compute operators
!! compute coefficientmatrix G of gradient at link
!! (d Phi / d xi)_l = sum_{k=1}^nmk2 Gxi_k,l Phi_k
!! (d Phi / d eta)_l = sum_{k=1}^nmk2 Geta_k,l Phi_k
!! compute coefficientmatrix Div of gradient in node
!! d Phi / d xi = sum_{l=1}^nmk Divxi_l Phi_l
!! d Phi / d eta = sum_{l=1}^nmk Diveta_l Phi_l
!! compute coefficientmatrix Az of cell-center in cell
!! Phi_c = sum_{l-1}^nmk Az_l Phi_l
!! Gxi, Geta, Divxi, Diveta and Az are stored in (type tops) op
subroutine orthonet_comp_operators(k0, adm, xi, eta, op, ierror)
use m_netw
use m_sferic
use m_inverse_map
use unstruc_colors
implicit none
integer :: k0 !< center node
type (tadm) :: adm !< structure with administration
double precision, allocatable, dimension(:) :: xi, eta !< node coordinates (xi,eta)
type (tops) :: op !< structure with operaters
integer, optional :: ierror !< 0: no error, 1: error
integer :: ierror_
integer, dimension(nmkx2) :: kknodesL, kknodesR
integer :: kknode1, kknode0
integer :: knode1R
integer :: klink, L, kothercell
integer :: icellL, icellR
integer :: kcellL, kcellR
integer :: NL, NR
integer :: k, k1
double precision :: I_LR_SWAP ! either 1d0 or -1d0
double precision :: xi1, eta1, xiL, etaL, xiR, etaR
double precision :: xi_bc, eta_bc
double precision :: exiLR, eetaLR, exi01, eeta01
double precision :: fac, alpha, alphaL, alphaR, alpha_x
double precision :: facxiL, facxiR, facetaL, facetaR
double precision :: facxi0, facxi1, faceta0, faceta1
double precision :: volxi
double precision, dimension(nmkx2) :: xinodes, etanodes
integer :: ic, N, klinkL, klinkR, kk
double precision, dimension(nmkx) :: xL, yL, xR, yR ! for Jacobian
double precision :: x_bc, y_bc, DxR, DyR, Dx1, Dy1
integer, dimension(2) :: kbound ! boundary links
double precision, dimension(nmkx) :: xis, etas
integer :: kL, kR, linkL, linkR
double precision :: RlinkL, RlinkR, cDPhi
double precision :: facww, ww0, ww1, wwL, wwR, volwwxi
double precision, external :: getdx, getdy
ierror_ = 1
if ( present(ierror) ) ierror = ierror_
! initialize
op%Az = 0d0
op%Gxi = 0d0
op%Geta = 0d0
op%Divxi = 0d0
op%Diveta = 0d0
op%Jxi = 0d0
op%Jeta = 0d0
volxi = 0d0
kbound = 0
xis = 0d0
etas = 0d0
xinodes = 0d0
etanodes = 0d0
volwwxi = 0d0
if ( k0.eq.81 ) then
continue
end if
! fill the averaging matrix
do ic=1,adm%Ncell
if ( adm%icell(ic).lt.1 .or. nb(k0).eq.3 ) cycle
! note: linkL and linkR refer to the directly connected left and right nodes
linkL = ic+1 ! by construction
linkR = linkL+1; if ( linkR.gt.adm%Ncell+1 ) linkR=linkR-adm%Ncell
RlinkL = sqrt( xi(linkL)**2 + eta(linkL)**2 + 1d-16)
RlinkR = sqrt( xi(linkR)**2 + eta(linkR)**2 + 1d-16)
cDPhi = (xi(linkR)*xi(linkL) + eta(linkR)*eta(linkL)) / (RlinkL*RlinkR)
N = netcell(adm%icell(ic))%n
k = 1; do while ( netcell(adm%icell(ic))%nod(k).ne.k0 .and. k.lt.N); k=k+1; end do
kL = k-1; if ( kL.lt.1 ) kL=kL+N
kR = k+1; if ( kR.gt.N ) kR=kR-N
if ( N.eq.3 ) then ! triangles: circumcenter
alpha = 1d0 / ( 1d0 - cDphi**2 + 1E-8)
alphaL = 0.5d0 * (1d0 - RlinkL/RlinkR*cDphi ) * alpha
alphaR = 0.5d0 * (1d0 - RlinkR/RlinkL*cDphi ) * alpha
op%Az(adm%kkc( k, ic), ic) = 1d0-(alphaL+alphaR)
op%Az(adm%kkc(kL, ic), ic) = alphaL
op%Az(adm%kkc(kR, ic), ic) = alphaR
else
op%Az(adm%kkc(1:N, ic), ic) = 1d0/dble(N)
end if
end do
do klink=1,adm%Ncell
! find link
L = nod(k0)%lin(klink)
! find node 1
k1 = kn(1,L)+kn(2,L)-k0
icellL = lne(1,L) ! not necessarily, but only to find (xi,eta) of node1
kcellL = 1
do while ( adm%icell(kcellL).ne.icellL .and. kcellL.lt.adm%Ncell)
kcellL = kcellL+1
end do
if ( adm%icell(kcellL).ne.icellL ) then ! cell not found, this happens when the cell is outside of the polygon
! call qnerror( 'orthonet_comp_operators: cell not found', ' ', ' ')
call cirr(xk(k0), yk(k0), ncolhl)
ierror_ = 0
goto 1234
end if
xi1 = xi( klink+1) ! by construction
eta1 = eta(klink+1)
I_LR_SWAP = 1d0 ! Left and Right are swapped when the boundary is at the left
if (lnn(L).eq.1) then
!-----------------------------------------------------------------------------------
! boundary condition
!-----------------------------------------------------------------------------------
! remember the boundary links
if ( kbound(1).lt.1 ) then ! first boundary link
kbound(1) = klink
else ! second boundary link
kbound(2) = klink
end if
! find the boundary cell in the icell array
! assume boundary at the right
! swap Left and Right if the boundary is at the left with I_SWAP_LR
if ( klink .ne. kcellL ) I_LR_SWAP = -1d0
xiL = sum( xi( 1:adm%nmk2) * op%Az(1:adm%nmk2,kcellL) )
etaL = sum( eta(1:adm%nmk2) * op%Az(1:adm%nmk2,kcellL) )
! compute the cell center coordinates (x, y)
xL(klink) = sum( xk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellL) )
yL(klink) = sum( yk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellL) )
!-----------------------------------------
! boundary conditions appear here
! note: non-orthogonal boundary conditions!
! orthogonal boundary conditions by setting ATPF>0 at the boundary
!-----------------------------------------
alpha = xiL*xi1 + etaL*eta1
alpha = alpha / (xi1**2 + eta1**2)
! Dx1 = getDx(xk(k0), yk(k0), xk(k1), yk(k1))
! Dy1 = getDy(xk(k0), yk(k0), xk(k1), yk(k1))
! DxL = getDx(xk(k0), yk(k0), xL(klink), yL(klink))
! DyL = getDy(xk(k0), yk(k0), xL(klink), yL(klink))
! alpha_x = (Dx1*DxL + Dy1*DyL) / (Dx1**2+Dy1**2 + 1d-16)
! alpha_x = 0.5d0;
alpha_x = alpha;
if ( alpha_x.ne.0.5d0 ) then
continue
end if
xi_bc = alpha*xi1
eta_bc = alpha*eta1
xiR = 2d0*xi_bc - xiL
etaR = 2d0*eta_bc - etaL
! compute the cell center coordinates (x, y)
x_bc = (1d0-alpha_x)*xk(k0) + alpha_x*xk(k1)
y_bc = (1d0-alpha_x)*yk(k0) + alpha_x*yk(k1)
xR(klink) = 2d0*x_bc - xL(klink)
yR(klink) = 2d0*y_bc - yL(klink)
else
! find the left- and right-hand-side cells with respect to the link
kcellL = klink ! by construction
kcellR = kcellL-1
if (kcellR.lt.1) kcellR = kcellR+adm%Ncell
if ( kcellR.lt.1 ) then
continue
end if
icellL = adm%icell(kcellL)
icellR = adm%icell(kcellR)
! check if right cells are found
if ( (icellL.ne.lne(1,L) .and. icellL.ne.lne(2,L)) .or. &
(icellR.ne.lne(1,L) .and. icellR.ne.lne(2,L)) ) then
call teklink(L,ncolhl)
call qnerror( 'orthonet_comp_operators: wrong/no cells found', ' ', ' ')
return
end if
NL = netcell(icellL)%n
NR = netcell(icellR)%n
! compute the cell center coordinates (xi, eta)
xiL = sum( xi( 1:adm%nmk2) * op%Az(1:adm%nmk2,kcellL) )
etaL = sum( eta(1:adm%nmk2) * op%Az(1:adm%nmk2,kcellL) )
xiR = sum( xi( 1:adm%nmk2) * op%Az(1:adm%nmk2,kcellR) )
etaR = sum( eta(1:adm%nmk2) * op%Az(1:adm%nmk2,kcellR) )
! compute the cell center coordinates (x, y)
xL(klink) = sum( xk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellL) )
yL(klink) = sum( yk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellL) )
xR(klink) = sum( xk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellR) )
yR(klink) = sum( yk(adm%kk2(1:adm%nmk2)) * op%Az(1:adm%nmk2,kcellR) )
end if
! compute the halfway link coordinates for Divxi and Diveta
xis( klink) = 0.5d0*( xiL + xiR)
etas(klink) = 0.5d0*(etaL + etaR)
! compute link vectors eLR and e01
exiLR = ( xiR - xiL)
eetaLR = (etaR - etaL)
exi01 = xi1
eeta01 = eta1
fac = 1d0/abs(exi01*eetaLR - eeta01*exiLR + 1d-16)
facxi1 = -eetaLR*fac * I_LR_SWAP
facxi0 = -facxi1
faceta1 = exiLR*fac * I_LR_SWAP
faceta0 = -faceta1
facxiR = eeta01*fac * I_LR_SWAP
facxiL = -facxiR
facetaR = -exi01*fac * I_LR_SWAP
facetaL = -facetaR
! boundary link
if ( lnn(L).eq.1 ) then
facxi1 = facxi1 - facxiL * 2d0 * alpha_x
facxi0 = facxi0 - facxiL * 2d0 * (1-alpha_x)
facxiL = facxiL + facxiL
! note that facxiR does not exist
faceta1 = faceta1 - facetaL * 2d0 * alpha_x
faceta0 = faceta0 - facetaL * 2d0 * (1-alpha_x)
facetaL = facetaL + facetaL
! note that facetaR does not exist
end if
! get the nodes in the kk2 numbering
kknode1 = klink+1
kknode0 = 1
op%Gxi( :,klink) = 0d0
op%Geta(:,klink) = 0d0
! fill the weights
op%Gxi( :, klink) = facxiL * op%Az(:, kcellL)
op%Geta(:, klink) = facetaL * op%Az(:, kcellL)
if ( lnn(L).eq.2) then
op%Gxi( :, klink) = op%Gxi( :, klink) + facxiR * op%Az(:, kcellR)
op%Geta(:, klink) = op%Geta(:, klink) + facetaR * op%Az(:, kcellR)
end if
op%Gxi( kknode1, klink) = op%Gxi( kknode1, klink) + facxi1
op%Geta(kknode1, klink) = op%Geta(kknode1, klink) + faceta1
op%Gxi( kknode0, klink) = op%Gxi( kknode0, klink) + facxi0
op%Geta(kknode0, klink) = op%Geta(kknode0, klink) + faceta0
! fill the node-based gradient matrix
op%Divxi( klink) = -eetaLR * I_LR_SWAP
op%Diveta(klink) = exiLR * I_LR_SWAP
if ( lnn(L).eq.1 ) then ! boundary link
! op%Divxi( klink) = 0.5d0*op%Divxi( klink)
! op%Diveta(klink) = 0.5d0*op%Diveta(klink)
op%Divxi( klink) = 0.5d0*op%Divxi( klink) + eta_bc*I_LR_SWAP
op%Diveta(klink) = 0.5d0*op%Diveta(klink) - xi_bc *I_LR_SWAP
end if
xinodes( klink+1) = xi1
etanodes(klink+1) = eta1
end do
xinodes( 1) = 0d0
etanodes(1) = 0d0
! Add boundary contribution to node-based gradient
! if ( kbound(2).gt.0 ) then
! op%Divxi( kbound) = op%Divxi( kbound) - 0.5d0*sum(op%Divxi)
! op%Diveta(kbound) = op%Diveta(kbound) - 0.5d0*sum(op%Diveta)
! end if
volxi = 0d0
do klink=1,nmk(k0)
volxi = volxi + 0.5*(op%Divxi(klink)*xis(klink) + op%Diveta(klink)*etas(klink))
end do
if ( volxi.eq.0d0 ) volxi = 1d0
op%Divxi = op%Divxi /volxi
op%Diveta = op%Diveta/volxi
! compute the node-to-node gradients
do k=1,adm%Ncell
if ( lnn( nod(k0)%lin(k) ) .eq. 2 ) then ! internal link
kR=k-1 ! right neighboring cell, left one is k by construction
if ( kR.lt.1 ) kR = kR+nmk(k0)
op%Jxi(1:nmk2(k0)) = op%Jxi(1:nmk2(k0)) + op%Divxi(k) * 0.5d0*(op%Az(1:nmk2(k0),k)+op%Az(1:nmk2(k0),kR))
op%Jeta(1:nmk2(k0)) = op%Jeta(1:nmk2(k0)) + op%Diveta(k) * 0.5d0*(op%Az(1:nmk2(k0),k)+op%Az(1:nmk2(k0),kR))
else ! boundary link, 1: center node, k+1: connected node through link k
! op%Jxi( 1) = op%Jxi( 1) + op%Divxi(k) * 0.5d0
! op%Jxi(k+1) = op%Jxi(k+1) + op%Divxi(k) * 0.5d0
! op%Jeta( 1) = op%Jeta( 1) + op%Diveta(k) * 0.5d0
! op%Jeta(k+1) = op%Jeta(k+1) + op%Diveta(k) * 0.5d0
op%Jxi( 1) = op%Jxi( 1) + op%Divxi(k) * 0.5d0
op%Jxi(k+1) = op%Jxi(k+1) + op%Divxi(k) * 0.5d0
op%Jeta( 1) = op%Jeta( 1) + op%Diveta(k) * 0.5d0
op%Jeta(k+1) = op%Jeta(k+1) + op%Diveta(k) * 0.5d0
end if
end do
! compute the weights in the Laplacian smoother
op%ww2(:) = 0d0
do k=1,nmk(k0)
op%ww2(1:nmk2(k0)) = op%ww2(1:nmk2(k0)) + &
op%Divxi(k)*op%Gxi(:,k) + op%Diveta(k)*op%Geta(:,k)
end do
ierror_ = 0
1234 continue
if ( present(ierror) ) ierror = ierror_
end subroutine orthonet_comp_operators
!> assign xi and eta to all nodes in the stencil
subroutine orthonet_assign_xieta(k0, adm, xi, eta, ierror)
use m_netw
use m_sferic
use m_missing
use unstruc_messages
use m_inverse_map
use unstruc_display
use unstruc_colors
implicit none
integer :: k0 !< center node
type(tadm) :: adm !< structure with administration
double precision, allocatable, dimension(:) :: xi, eta !< node coordinates (xi,eta)
integer, optional :: ierror !< 0: no error, 1: error
double precision :: Phi0, DPhi0, DPhitot, Phi ! angles in the (xi,eta) frame
double precision :: theta, Dtheta ! angles in the (xi',eta') frame, attached to a cell
double precision :: xip, etap ! coordinates in (xi', eta') frame, attached to a cell
double precision :: R0, R, dmu, aspect, Rdebug
integer :: k, kk, ic, L, N, kL, kR, k1, kk1, L1, kcell
double precision :: FAC = 1d0 ! part of the full circle that needs to be filled
integer :: Nnodes, Ntri, Ntri_square, Nquad, icL, icR, kcL, kcR
double precision :: DPhi, DPhitri, DPhitri_square, DPhiquad, DPhimin
double precision :: dmutri, dmutri_square, Phidebug
integer :: ilink_first_quad, i, linkL, linkR
integer :: kp1, km1
double precision, dimension(adm%Ncell) :: Philink
double precision, dimension(adm%nmk2) :: theta_square ! 'square' angles
double precision, dimension(adm%nmk2) :: Rlink ! link lengths
logical, dimension(adm%Ncell) :: L_is_square_cell
double precision :: Rloc, alpha, alphaL, alphaR
logical :: L_is_square, L_is_diagonal
integer :: KCHECK, ierror_
logical :: lblink ! boundary link (.true.) or not (.false.)
KCHECK = 93
ierror_ = 1
if ( present(ierror) ) ierror = ierror_
FAC = 1d0
if ( nb(k0).eq.2 ) FAC = 0.5d0 ! boundary node
if ( nb(k0).eq.3 ) FAC = 0.25d0 ! corner node
! initialize xi and eta to zero
xi = 0d0
eta = 0d0
! first, determine the 'skewness' factor dmu
! only skew triangles: discriminate between triangles and non-triangels
DPhimin = 15d0/180d0*pi
DPhitot = 0d0
Dphitri_square = 0d0
Dphitri = 0d0
Dphiquad = 0d0
Ntri = 0
Ntri_square = 0
Nquad = 0
ilink_first_quad = 0
if ( k0.eq.KCHECK ) then
continue
end if
!-------------------------------------------------------------------------------------------------
! find the square angles of the directly connected links, i.e. 2, ..., Ncell+1
theta_square = DMISS
L_is_square_cell = .false.
do kk=1,adm%Ncell
! find node k1 connected to the center node k0 by kk-th link L
L = nod(k0)%lin(kk)
k1 = adm%kk2(kk+1)
! get the cells icL and icR connected to both nodes
icL = lne(1,L)
icR = icL
if ( lnn(L).eq.2 ) icR = lne(2,L)
! if:
! all other cells connected to node k1 are quads, and
! the total numbers of quads attached to the node is less than four,ernal node
! then:
! the angle is 'square' (pi/2, pi or 3pi/2)
L_is_square = .true.
! loop over all cells through links
do kk1=1,nmk(k1)
L1 = nod(k1)%lin(kk1)
do kcell=1,lnn(L1)
ic = lne(kcell,L1)
if ( ic.ne.icL .and. ic.ne.icR ) &
L_is_square = L_is_square .and. (netcell(ic)%n.eq.4)
end do
if ( .not.L_is_square ) exit
end do
! if ( nmk(k1).eq.4 .and. nb(k1).eq.1 ) L_is_square=.true.
! compute the optimal angle theta_square, if applicable
kL = kk-1; if (kL.lt.1) kL=kL+adm%Ncell
! Nquad is the number of quads not connected to k1
if ( L_is_square ) then
if ( nb(k1).eq.1 .or. nb(k1).eq.4 ) then ! inner node
Nquad = nmk(k1)-2
theta_square(kk+1) = (2d0 - dble(Nquad)*0.5d0) * pi
else if ( nb(k1).eq.2 ) then ! boundary node
Nquad = nmk(k1)-1-lnn(L)
theta_square(kk+1) = (1d0 - dble(Nquad)*0.5d0) * pi
else if ( nb(k1).eq.3 ) then ! corner node
theta_square(kk+1) = 0.5d0 * pi
end if
! check the total number of quads connected
! by adding the square cells that are in the stencil
if ( adm%icell(kk).gt.1 ) then
if ( netcell(adm%icell(kk))%n.eq.4 ) Nquad=Nquad+1
end if
if ( adm%icell(kL).gt.1 ) then
if ( netcell(adm%icell(kL))%n.eq.4 ) Nquad=Nquad+1
end if
if ( Nquad.gt.3 ) L_is_square = .false.
end if
! mark the left and right neighboring cells as square
L_is_square_cell(kk) = L_is_square_cell(kk) .or. L_is_square
L_is_square_cell(kL) = L_is_square_cell(kL) .or. L_is_square
end do
! continue with the indirectly connected links, from Ncell+2 to adm&nmk2
! find the 'square' angles belonging to quads
do ic=1,adm%Ncell
if ( adm%icell(ic).lt.1 ) cycle ! fictitious boundary cell
Nnodes = netcell(adm%icell(ic))%n
if ( Nnodes.eq.4) then
do kk=1,Nnodes
if ( adm%kkc(kk,ic).le.adm%Ncell+1 ) cycle ! center and directly-connected cells
theta_square(adm%kkc(kk,ic)) = 0.5d0*pi
end do
end if
end do
if ( k0.eq.KCHECK ) then
continue
end if
!-------------------------------------------------------------------------------------------------
! compute the internal link angle Phi
Nquad = 0
do kk=1,adm%Ncell
if ( adm%icell(kk).lt.1 ) cycle ! fictitious boundary cell
Nnodes = netcell(adm%icell(kk))%n
! DPhi = pi - 2d0*pi/dble(Nnodes)
Dphi = opt_angle(Nnodes)
! account for 'square' angles
if ( L_is_square_cell(kk) .or. Nnodes.eq.4 ) then
kR = kk+2; if (kR.gt.adm%Ncell+1) kR=kR-adm%Ncell
lblink = (lnn(nod(k0)%lin(kk)).eq.1)
Dphi = opt_angle(Nnodes, theta_square(kk+1), theta_square(kR), lblink)
if ( Nnodes.eq.3 ) then
Ntri_square = Ntri_square + 1
DPhitri_square = Dphitri_square + DPhi
else if (Nnodes.eq.4 ) then
Nquad = Nquad + 1
DPhiquad = Dphiquad + DPhi
end if
else
Ntri = Ntri+1
DPhitri = Dphitri + DPhi
end if
DPhitot = DPhitot + DPhi
! if (Nnodes.eq.3) then
! Ntri = Ntri+1
! DPhitri = Dphitri + DPhi
! else if ( Nnodes.eq.4) then
! if (ilink_first_quad.eq.0 ) &
! ilink_first_quad = kk+1; if ( ilink_first_quad.gt.Ncell ) ilink_first_quad = ilink_first_quad - Ncell
! Nquad = Nquad + 1
! end if
end do
dmu = 1d0
dmutri_square = 1d0
dmutri = 1d0
if ( Ntri.gt.0 ) then
! dmutri = ( FAC*2d0*pi - max(DPhitot-DPhitri, dble(Ntri)*DPhimin) ) / DPhitri
dmutri = ( FAC*2d0*pi - (DPhitot-DPhitri) ) / DPhitri
dmutri = max(dmutri, dble(Ntri)*Dphimin/DPhitri)
if ( dmutri.lt.1E-4 ) then
continue
end if
else
if ( Ntri_square.gt.0 ) then
dmutri_square = max( FAC*2d0*pi - (DPhitot-DPhitri_square), dble(Ntri_square)*DPhimin) / DPhitri_square
end if
end if
! if ( (abs(dmutri-0.75d0).lt.1E-2 .or. abs(dmutri-1.5d0).lt.1E-2) ) then
! L_is_square = .true.
! else
!! dmutri = 1d0
! L_is_square = .false.
! end if
L_is_square = .true.
if ( Nquad.lt.2 ) then
! dmutri = 1d0
L_is_square = .false.
end if
! L_is_square = .true.
if ( Dphitot.gt.1E-18 ) then
dmu = FAC*2d0*pi/( Dphitot - (1-dmutri)*DPhitri - (1-dmutri_square)*DPhitri_square )
else if ( adm%Ncell.gt.0 ) then
call qnerror('orthonet_assign_xieta: Dphitot=0', ' ', ' ')
call cirr(xk(k0), yk(k0), ncolhl)
ierror_ = 0
goto 1234
end if
if ( k0.eq.KCHECK ) then
continue
end if
!-------------------------------------------------------------------------------------------------
! loop over the cells
Phi0 = 0d0
Dphi0 = 0d0
Dphi = 0d0
do ic = 1,adm%Ncell
! add half the angle of the previous cell
Phi0 = Phi0 + 0.5d0*Dphi
Philink(ic) = Phi0
if ( adm%icell(ic).lt.1 ) then ! fictitious boundary cell
if ( nb(k0).eq.2 ) then ! boundary node
Dphi = pi
else
if ( nb(k0).eq.3 ) then ! corner node
DPhi = 1.5d0*pi
else ! inappropriate fictitious boundary cell
call qnerror('orthonet_assign_xieta: inappropriate fictitious boundary cell', ' ', ' ')
call cirr(xk(k0), yk(k0), ncolhl)
return
end if
end if
Phi0 = Phi0 + 0.5d0*DPhi
cycle
end if
N = netcell(adm%icell(ic))%n
if (N.gt.M) then
call qnerror('orthonet_assign_xiet: N>M', ' ', ' ')
return
end if
! compute the optimal angle between the next two links
! Dphi0 = pi - 2d0*pi/dble(netcell(icell(ic))%n)
Nnodes = netcell(adm%icell(ic))%n
Dphi0 = opt_angle(Nnodes)
if ( L_is_square_cell(ic) ) then
kR = ic+2; if (kR.gt.adm%Ncell+1) kR=kR-adm%Ncell
lblink = (lnn(nod(k0)%lin(ic)).eq.1)
Dphi0 = opt_angle(Nnodes, theta_square(ic+1), theta_square(kR),lblink)
if ( Nnodes.eq.3 ) Dphi0 = dmutri_square * Dphi0
else if ( Nnodes.eq.3 ) then
Dphi0 = dmutri * Dphi0
end if
! compute the skewed angle
DPhi = dmu*Dphi0
! if ( .not.L_is_square_cell(ic) ) Dphi = dmutri*DPhi
! add half the angle of the current cell
Phi0 = Phi0 + 0.5d0*DPhi
! in this cell: find the node k that corresponds to the center node
k = 1
do while ( netcell(adm%icell(ic))%nod(k).ne.k0 .and. k.lt.N)
k=k+1
end do
if ( netcell(adm%icell(ic))%nod(k).ne.k0 ) then
call qnerror('orthonet_assign_xieta: center node not found in cell', ' ', ' ')
return
end if
! compute the optimal angle
Dtheta = 2d0*pi/dble(netcell(adm%icell(ic))%n)
! determine the orientation of the cell (necessary for folded cells)
kp1 = k+1; if (kp1.gt.Nnodes) kp1=kp1-Nnodes
km1 = k-1; if (km1.lt.1 ) km1=km1+Nnodes
if ( adm%kkc(km1,ic) - adm%kkc(kp1,ic) .eq. -1 .or. &
adm%kkc(km1,ic) - adm%kkc(kp1,ic) .eq. adm%nmk-1 ) then
Dtheta = -Dtheta
end if
! compute the aspect ratio
aspect = (1d0-cos(Dtheta))/sin(abs(Dtheta))*tan(0.5d0*dPhi)
! compute the radius
R0 = cos(0.5d0*dPhi)/(1d0-cos(Dtheta))
! loop over all nodes comprising the netcell
do kk=1,N
theta = Dtheta*(kk-k)
xip = R0 - R0*cos(theta)
etap = - R0*sin(theta)
xi( adm%kkc(kk,ic)) = xip*cos(Phi0) - aspect*etap*sin(Phi0)
eta(adm%kkc(kk,ic)) = xip*sin(Phi0) + aspect*etap*cos(Phi0)
end do
end do
ierror_ = 0
1234 continue
if ( present(ierror) ) ierror = ierror_
end subroutine orthonet_assign_xieta
!> compute the optimal angle between two links
double precision function opt_angle(Nnodes, theta1, theta2, lblink)
implicit none
integer :: Nnodes !< number of nodes in the netcell
double precision, optional :: theta1, theta2 !< optionally: link angles
logical, optional :: lblink !< optionally: is boundary link (.true.) or not (.false.)
logical :: lblink_
lblink_ = .false.
if ( present(lblink) ) lblink_ = lblink
opt_angle = pi * (1 - 2d0/dble(Nnodes))
if ( present(theta1) ) then ! 'square' angle
if ( present(theta2) ) then
if ( Nnodes.eq.3) then
opt_angle = 0.25d0*pi
if ( theta1+theta2.eq.pi .and. .not.lblink_) opt_angle = 0.5d0*pi
else if (Nnodes.eq.4 ) then
opt_angle = 0.5d0*pi
end if
end if
end if
return
end function opt_angle
!> smooth the node-based variable u
subroutine orthonet_smooth_u(u, ITAPSM, ops, u_smooth)
use m_netw
use m_orthosettings
use unstruc_messages
use m_alloc
use m_inverse_map
implicit none
double precision, dimension(:), intent( in) :: u !< node-based solution
integer, intent( in) :: ITAPSM !< number of smoothing iterations
type (tops), dimension(:), intent( in) :: ops !< per-topology operators
double precision, dimension(:), intent(out) :: u_smooth !< smoothed node-based solution
double precision, dimension(nmkx2) :: ww2
double precision, dimension(numk) :: u_temp
double precision, dimension(4) :: J
double precision, dimension(2) :: a1, a2
double precision :: det
integer :: iter, k0, k
double precision :: alpha, alpha1
alpha = 0.5d0
alpha1 = 1d0 - alpha
u_temp = u
u_smooth = u
do iter=1,ITAPSM
do k0=1,Numk
if ( nb(k0).ne.1 .and. nb(k0).ne.2 .and. nb(k0).ne.4 ) cycle
! get the Laplacian weights
ww2 = 0d0
! ww2(1:nmk2(k0)) = ops(ktopo(k0))%ww2(1:nmk2(k0))
ww2(1:nmk2(k0)) = 1d0;
ww2(1) = - sum(ww2(2:nmk2(k0)))
u_temp(k0) = -sum(ww2(2:nmk2(k0))*u_smooth(kk2(2:nmk2(k0),k0)))/ww2(1)
end do
u_smooth = alpha * u_temp + alpha1 * u_smooth
end do
end subroutine orthonet_smooth_u
end subroutine orthogonalisenet
!> perform the adminstration:
!! determine the netcells and nodes in the stencil
subroutine orthonet_admin(k0, adm, ierror)
use m_netw
use m_missing
use m_alloc
use m_inverse_map
implicit none
integer, intent(in) :: k0 !< center node
type(tadm), intent(inout) :: adm !< structure with administration
integer, intent(out) :: ierror !< 0: no error, 1: error
integer :: k1, k2, L1, L2, i1, i2, L
integer :: N, Nsize, Ksize
integer :: ic, kcell, knode
integer :: i, inewcell
logical :: lisnew
if ( k0.eq.42 ) then
continue
end if
ierror = 1
if ( .not.allocated(adm%icell) ) allocate(adm%icell(nmkx))
if ( .not.allocated(adm%kk2) ) allocate(adm%kk2(nmkx2))
if ( .not.allocated(adm%kkc) ) allocate(adm%kkc(M, nmkx))
Nsize = ubound(adm%icell,1) ! array size of icell
Ksize = ubound(adm%kk2,1) ! array size of adm%kk2
adm%icell = 0
adm%Ncell = 0
if ( nmk(k0) .lt. 2 ) then
call qnerror('orthonet_admin: nmk(k0) .lt. 2)', ' ', ' ')
return
end if
inewcell = -1234
do k1 = 1,nmk(k0)
L1 = nod(k0)%lin(k1)
k2 = k1+1
if ( k2.gt.nmk(k0) ) k2=1
! do while ( k2.ne.k1 ) ! try to find a common cell and the shared link (no folds: the next link)
L2 = nod(k0)%lin(k2)
if ( (lnn(L1).lt.1) .or. (lnn(L2).lt.1) ) then
cycle
end if
! find the cell that links L1 and L2 share
i1 = max( min(lnn(L1),2), 1)
i2 = max( min(lnn(L2),2), 1)
if ( (lne(1,L1).eq.lne(1,L2) .or. lne(1,L1).eq.lne(i2,L2)) .and. lne(1,L1).ne.inewcell ) then
inewcell = lne(1,L1)
! exit
else if ( (lne(i1,L1).eq.lne(1,L2) .or. lne(i1,L1).eq.lne(i2,L2)) .and. lne(i1,L1).ne.inewcell ) then
inewcell = lne(i1,L1)
! exit
else
inewcell = -1234 ! fictitious boundary cell
end if
! k2 = k2+1
! if ( k2.gt.nmk(k0) ) k2=1
! end do
if ( nmk(k0).eq.2 .and. k1.eq.2 .and. nb(k0).eq.3 ) then
if ( inewcell.eq.adm%icell(1) ) inewcell = -1234 ! cornercell
end if
adm%Ncell = adm%Ncell+1
! reallocate icell array if necessary
if (adm%Ncell .gt. Nsize) then
Nsize = adm%Ncell
call realloc(adm%icell, Nsize)
end if
adm%icell(adm%Ncell) = inewcell
end do
! check if any cells are found and terminate otherwise
if ( adm%Ncell.lt.1 ) goto 1234
! reallocate kkc if necessary
if ( adm%Ncell.gt.ubound(adm%kkc,2) ) call realloc(adm%kkc, (/ M, adm%Ncell /))
! make the node administration kk2 and kkc
adm%kk2 = 0
! start with center node
adm%kk2(1) = k0
adm%nmk2 = 1
adm%nmk = nmk(k0)
! continue with the link-connected nodes
do ic=1,nmk(k0)
L = nod(k0)%lin(ic)
knode = kn(1,L)+kn(2,L)-k0
adm%nmk2 = adm%nmk2 + 1
! check array size
if (adm%nmk2.gt.Ksize) then
Ksize = Ksize+1
call realloc(adm%kk2, Ksize, fill=0)
end if
adm%kk2(adm%nmk2) = knode
end do
! continue with other nodes and fill kkc
do ic=1,adm%Ncell
kcell = adm%icell(ic)
if ( kcell.lt.1 ) cycle ! for fictitious boundary cells
! forward to center node
k1 = 0
do while ( netcell(kcell)%nod(k1+1).ne.k0 )
k1 = k1+1
end do
! loop over the other nodes
N = netcell(kcell)%n
do i=1,N
k1 = k1+1
if ( k1.gt.N ) k1 = k1-N
knode = netcell(kcell)%nod(k1)
! check if node is already administered and exclude center node
lisnew = .true.
do i2=1,adm%nmk2
if ( knode.eq.adm%kk2(i2) ) then
lisnew = .false.
adm%kkc(k1,ic) = i2 ! position of the node in adm%kk2
exit
end if
end do
! administer new node
if ( lisnew) then
adm%nmk2 = adm%nmk2 + 1
! check array size
if (adm%nmk2.gt.Ksize) then
Ksize = Ksize+1
call realloc(adm%kk2, Ksize, fill=0)
end if
adm%kk2(adm%nmk2) = knode
adm%kkc(k1,ic) = adm%nmk2 ! position of the node in adm%kk2
end if
end do
end do
1234 continue
ierror = 0
end subroutine orthonet_admin
!> project boundary-nodes back to the boundary of an original net
subroutine orthonet_project_on_boundary(nmkx, kk1, k_bc, xkb, ykb)
use m_netw
IMPLICIT NONE
integer :: nmkx !< maximum number of link-connected neighboring nodes
integer, dimension(numk) :: k_bc !< maps nodes to nearest original boundary nodes
double precision, dimension(numk) :: xkb, ykb !< copy of the original net
integer, dimension(nmkx,numk) :: kk1 !< link-connected neighboring nodes
double precision :: x0, y0, xl, yl, xr, yr
double precision :: x2, y2, x3, y3, xn2, yn2, xn3, yn3
double precision :: dis2, dis3, r2, r3
integer :: k, kk, k0, kL, kR, nr, ja2, ja3
do k0 = 1,numk
if ( nb(k0).eq.2 .and. nmk(k0).gt.0) then
k = k_bc(k0) ! the nearest node in the original net, in previous iteration
if ( nmk(k).eq.0 ) cycle
x0 = xk(k0)
y0 = yk(k0)
nr = 0
kr = -999
do kk = 1,nmk(k)
if (lnn(nod(k)%lin(kk)) == 1) then
! remember the two boundary neighbours in original net.
nr = nr + 1
if (nr == 1) then
kL = kk1(kk,k)
if ( kL.eq.0 ) then
return ! should not happen
end if
x2 = xkb(kl) ; y2 = ykb(kl)
else if (nr == 2) then
kR = kk1(kk,k)
if ( kR.eq.0 ) then
return ! should not happen
end if
x3 = xkb(kr) ; y3 = ykb(kr)
endif
end if
enddo
! Project the moved boundary point back onto the closest
! ORIGINAL edge (netlink) (either between 0 and 2 or 0 and 3)
call dlinedis3(x0,y0,xkb(k),ykb(k),x2,y2,ja2,dis2,xn2,yn2,r2)
call dlinedis3(x0,y0,xkb(k),ykb(k),x3,y3,ja3,dis3,xn3,yn3,r3)
if (dis2 < dis3) then
x0 = xn2 ; y0 = yn2
if ( (r2.gt.0.5d0) .and. (nb(kL).ne.3) ) k_bc(k0) = kL
else
x0 = xn3 ; y0 = yn3
if ( (r3.gt.0.5d0) .and. (nb(kR).ne.3) ) k_bc(k0) = kR
endif
xk(k0) = x0 ; yk(k0) = y0
endif
enddo
end subroutine orthonet_project_on_boundary
!> compute link-based aspect ratios
subroutine orthonet_compute_aspect(aspect)
use m_netw
use m_flowgeom
use m_missing
use m_orthosettings
use geometry_module, only: dbdistance
use m_sferic, only: jsferic, jasfer3D
IMPLICIT NONE
double precision, dimension(numL) :: aspect !< aspect-ratios at the links
double precision :: x0, y0, x1, y1, x0_bc, y0_bc
double precision :: xL, yL, xR, yR
double precision :: SLR, R01, dinRy
double precision :: xc, yc
double precision, allocatable, dimension(:,:) :: R ! averaged netlink length at both sides of the netlink
double precision, allocatable, dimension(:) :: S ! flowlink lengths
integer :: k, kk, kkm1, kkp1, kkp2
integer :: klink, klinkm1, klinkp1, klinkp2, N
integer :: k0, k1, kL, kR, L, ja
logical, allocatable, dimension(:) :: Liscurvi ! node-based curvi-like indicator
double precision :: ortho1
double precision, external :: dprodin
double precision, parameter :: EPS=1D-4
allocate(R(2,numL), S(numL), Liscurvi(numk))
R = DMISS
S = DMISS
! compute parallel length S
do L = 1,numL
! nodes connected by the link
k0 = kn(1,L)
k1 = kn(2,L)
if ( k0.eq.0 .or. k1.eq.0 ) then ! safety
continue
cycle
end if
x0 = xk(k0)
y0 = yk(k0)
x1 = xk(k1)
y1 = yk(k1)
! compute the link length R01
R01 = dbdistance(x0,y0,x1,y1, jsferic, jasfer3D, dmiss)
! find left cell center, if it exists
kL = lne(1,L) ! left cell center w.r.t. link L
if ( lnn(L).gt.0 ) then
xL = xz(kL)
yL = yz(kL)
else
xL = x0
yL = y0
end if
! find right cell center, if it exists
if (lnn(L) == 2) then
kR = lne(2,L)
xR = xz(kR)
yR = yz(kR)
else
!---------------------------------------------------------------------
! otherwise, make ghost node by imposing boundary condition
dinry = dprodin(x0,y0, x1,y1, x0,y0, xL,yL) / max(R01*R01, EPS)
x0_bc = (1-dinRy) * x0 + dinRy * x1
y0_bc = (1-dinRy) * y0 + dinRy * y1
xR = 2d0 * ( x0_bc ) - xL
yR = 2d0 * ( y0_bc ) - yL
!---------------------------------------------------------------------
end if
SLR = dbdistance(xL,yL,xR,yR,jsferic, jasfer3D, dmiss)
! if ( R01.ne.0d0 ) then
! aspect(L) = SLR/R01
! else
! aspect(L) = DMISS
! end if
! store length S (normal)
S(L) = SLR
! debug: plot circumcenters
! call cirr(xL,yL,31)
! if ( lnn(L).eq.1 ) then
! call cirr(xR,yR,31)
! call cirr(x0_bc, y0_bc, 191)
! call hitext(kL, xL, yL)
! call movabs(xL,yL)
! call lnabs(x0_bc, y0_bc)
! end if
enddo
! call confrm(' ', ja)
!---------------------------------------------------------------------
! quads -> mimic the curvi-grid discretization
! node-based curvi-like indicator; initialization
Liscurvi = .true.
! compute normal length R
do k=1,nump
N = netcell(k)%N
if ( N.lt.3 ) cycle ! safety
! repeat for all links
do kk=1,N
! node-based curvi-like indicator
if ( N.ne.4 ) Liscurvi(netcell(k)%nod(kk)) = .false.
klink = netcell(k)%lin(kk)
if ( lnn(klink).ne.1 .and. lnn(klink).ne.2 ) cycle
! get the other links in the right numbering
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
kkp2 = kk+2; if ( kkp2.gt.N ) kkp2=kkp2-N
klinkm1 = netcell(k)%lin(kkm1)
klinkp1 = netcell(k)%lin(kkp1)
klinkp2 = netcell(k)%lin(kkp2)
R01 = dblinklength(klink)
if ( R01.ne.0d0 ) then
aspect(klink) = S(klink) / R01
end if
! store length R (parallel)
! if ( N.eq.4 .and. lnn(klink).ne.1 ) then ! inner quads
if ( N.eq.4 ) then ! quads
R01 = 0.5d0*(dblinklength(klink ) + dblinklength(klinkp2))
else
R01 = dblinklength(klink)
end if
if ( R(1,klink).eq.DMISS ) then ! link visited for the first time
R(1,klink) = R01
else ! link visited for the second time
R(2,klink) = R01
end if
end do
end do
if ( ortho_pure.eq.1d0 ) goto 1234 ! no curvi-like discretization
ortho1 = 1d0 - ortho_pure
! compute aspect ratio in the quadrilateral part of the mesh
do klink=1,numL
if ( kn(1,klink).eq.0 .or. kn(2,klink).eq.0 ) cycle ! safety
if ( lnn(klink).ne.2 .and. lnn(klink).ne.1 ) cycle
! quads-only
if ( .not.Liscurvi(kn(1,klink)) .or. .not.Liscurvi(kn(2,klink)) ) cycle
! if ( netcell(lne(1,klink))%N.ne.4 .or. netcell(lne(min(2,lnn(klink)),klink))%N.ne.4 ) cycle ! quad-quad links only
if ( lnn(klink).eq.1 ) then
if (R(1,klink).ne.0d0 .and. R(1,klink).ne.DMISS ) then
aspect(klink) = S(klink) / R(1,klink)
else
continue
end if
else
if (R(1,klink).ne.0d0 .and. R(2,klink).ne.0d0 .and. R(1,klink).ne.DMISS .and. R(2,klink).ne.DMISS ) then
aspect(klink) = ortho_pure * aspect(klink)+ ortho1 * S(klink) / ( 0.5d0*(R(1,klink)+R(2,klink)) )
else
continue
end if
end if
end do
1234 continue
deallocate(R, S, Liscurvi)
contains
! compute link length
double precision function dblinklength(kk)
use m_netw
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: kk !< link number
dblinklength = dbdistance(xk(kn(1,kk)), yk(kn(1,kk)), xk(kn(2,kk)), yk(kn(2,kk)), jsferic, jasfer3D, dmiss)
end function dblinklength
end subroutine orthonet_compute_aspect
!> smooth the link-based aspect ratios (SLR/R01) along parallel and perpendicular mesh lines (obsolete)
subroutine orthonet_smooth_aspect(aspect, iexit)
use m_netw
use m_orthosettings
use unstruc_messages
use m_alloc
use geometry_module, only: dcosphi
use m_sferic, only: jsferic, jasfer3D
use m_missing, only : dxymis
IMPLICIT NONE
double precision, dimension(numL) :: aspect !< aspect ratio at the links
integer :: iexit !< 1 if no errors have occured
integer, save :: NMKMAX = 4 ! maximum of neighbors considered
integer, dimension(:) , allocatable :: nmkx ! number of neighbors considered
integer, dimension(:,:), allocatable :: kkL ! neighboring link
integer, dimension(:,:), allocatable :: ww ! weights of neighboring links
double precision :: ATPF1, cosphi, maxcosphi
double precision :: x1, y1, x2, y2, x3, y3
double precision :: dum, ww1
character(len=51) :: numstr
double precision, parameter :: COSMIN = 0.5d0, COSMAX=0.0d0, EPS = 1D-8
integer :: k, kk, num, iL, iR, k1, k2, k3, nn, kk1, L1, nummax
integer, parameter :: ITAPSM = 2
iexit = 1
if (ATPF.eq.1d0) return ! no smoothing
if (ITAPSM.lt.1) then ! set aspect=1d0
aspect = 1d0
return
end if
iexit = 0
allocate(nmkx(numL), kkL(NMKMAX, numL), ww(NMKMAX, numL))
nmkx = 0
kkL = 0
ww = 0
ATPF1 = 1 - ATPF
!-----------------------------------------------------------
! determine connected links that have the same orientation
nummax = 0 ! maximum of connected links
chsz:do ! while array size not exceeded
do kk=1,numL
! find nodes 1 and 2
k1 = kn(1,kk)
k2 = kn(2,kk)
x1 = xk(k1)
y1 = yk(k1)
x2 = xk(k2)
y2 = yk(k2)
! find neighboring link connected to node k1
maxcosphi = COSMIN
nn = nmk(k1)
do kk1=1,nn
num = 0
L1 = nod(k1)%lin(kk1)
k3 = sum( kn(1:2,L1) ) - k1
if ( (k3.eq.k2) .or. (kc(k3).eq.0) ) cycle
x3 = xk(k3)
y3 = yk(k3)
cosphi = dcosphi(x2,y2, x1,y1, x1,y1, x3,y3, jsferic, jasfer3D, dxymis)
! find parallel links connected to node 1
! set weight ww1 > 0
if ( cosphi.gt.COSMIN ) then
nmkx(kk) = nmkx(kk)+1
num = nmkx(kk)
! check array size
if ( num.gt.NMKMAX ) then
NMKMAX = num
call realloc(kkL, (/ NMKMAX, numL /))
call realloc(ww, (/ NMKMAX, numL /))
end if
kkL(num,kk) = L1
! ww(num, kk) = 1d0
ww(num, kk) = 1d0
! find perpendicular links connected to node 1
! set weight ww1 < 0
else if ( abs(cosphi).lt.COSMAX ) then
nmkx(kk) = nmkx(kk)+1
num = nmkx(kk)
! check array size
if ( num.gt.NMKMAX ) then
NMKMAX = num
call realloc(kkL, (/ NMKMAX, numL /))
call realloc(ww, (/ NMKMAX, numL /))
end if
kkL(num,kk) = L1
ww(num, kk) = -1d0
end if
end do
! find neighboring link connected to node k2
maxcosphi = COSMIN
nn = nmk(k2)
do kk1=1,nn
L1 = nod(k2)%lin(kk1)
k3 = sum( kn(1:2,L1) ) - k2
if ( (k3.eq.k1) .or. (kc(k3).eq.0) ) cycle
x3 = xk(k3)
y3 = yk(k3)
cosphi = dcosphi(x1,y1, x2,y2, x2,y2, x3,y3, jsferic, jasfer3D, dxymis)
! find parallel links connected to node 2
! set weight ww1 > 0
if ( cosphi.gt.COSMIN ) then
nmkx(kk) = nmkx(kk)+1
num = nmkx(kk)
! check array size
if ( num.gt.NMKMAX ) then
NMKMAX = num
call realloc(kkL, (/ NMKMAX, numL /))
call realloc(ww, (/ NMKMAX, numL /))
end if
kkL(num,kk) = L1
ww(num, kk) = 1d0
! find perpendicular links connected to node 2
! set weight ww1 < 0
else if ( abs(cosphi).lt.COSMAX ) then
nmkx(kk) = nmkx(kk)+1
num = nmkx(kk)
! check array size
if ( num.gt.NMKMAX ) then
NMKMAX = num
call realloc(kkL, (/ NMKMAX, numL /))
call realloc(ww, (/ NMKMAX, numL /))
end if
kkL(num,kk) = L1
ww(num, kk) = -1d0
end if
nummax = max(nummax, num)
end do
end do
!-----------------------------------------------------------
! smooth aspect ratio
do num=1,ITAPSM
do kk=1,numL
dum = aspect(kk) ! summed contribution
nn = 1 ! number of links used
do kk1=1,nmkx(kk)
ww1 = ww(kk1,kk)
L1 = kkL(kk1,kk)
! parallel link: ww1>0
if ( ww1.gt.0d0) then
nn = nn+1
dum = dum + ww1 * aspect(L1)
! perpendicular link: ww1<0
else if ( aspect(L1).gt.EPS ) then
nn = nn+1
dum = dum - ww1 / aspect(L1)
end if
end do
! partial smoothing/orthogonalization
aspect(kk) = ATPF*aspect(kk) + ATPF1 * dum/nn
end do
end do
if ( nummax.lt.NMKMAX) then
write(numstr, "('orthonet_smooth_aspect: NMKMAX may be reduced to ', I2)") nummax
call ktext(numstr, 1,3,11)
end if
iexit = 1
exit
end do chsz
if ( iexit.ne.1 ) then
write(MSGBUF,'(A)') 'orthonet_smooth_aspect: nmkx > NMKMAX'
write(numstr, "('orthonet_smooth_aspect: nmkx =', I2, ' > NMKMAX =', I2)") num, NMKMAX
call msg_flush()
! call qnerror('orthonet_smooth_aspect: nmkx > NMKMAX', ' ', ' ')
call qnerror(numstr(1:45), ' ', ' ')
end if
deallocate(nmkx, kkL, ww)
end subroutine
!> prescribe link-based aspect ratios in curvi-grids for mesh refinement (obsolete)
subroutine orthonet_prescribe_aspect(smp_mu, idir, aspect, ic, jc)
use m_netw
use m_sferic
use m_missing
use geometry_module, only: dbdistance, dcosphi
IMPLICIT NONE
double precision, dimension(numk) :: smp_mu !< mesh attractor
integer :: idir !< mesh adaptation direction
double precision, dimension(numL) :: aspect !< aspect ratio at the links
integer, dimension(numk) :: ic, jc !< start indices on curvi-grid
double precision, dimension(2) :: orient ! prescribed orientation
! integer, parameter :: IMISS = -999999
double precision :: x1,y1, x2,y2, x3,y3
double precision :: R01, cosphi, cos2phi, sin2phi
double precision :: A, A2, fA2, mu
integer :: L, k1, k2, imin, jmin, mc, nc
! orient = (/ 0d0, 1d0 /)
! orient = orient / sqrt(sum(orient**2))
!
! imin = minval(ic, ic.ne.IMISS)
! jmin = minval(jc, jc.ne.IMISS)
!
! ic = ic - imin + 1
! jc = jc - jmin + 1
!
! mc = maxval(ic)
! nc = maxval(jc)
do L=1,numL
! compute the angle of link L with the prescribed orientation
k1 = kn(1,L)
k2 = kn(2,L)
if ( kc(k1).ne.1 .or. kc(k2).ne.1 ) cycle
! determine orientation based on node indices
cosphi = DMISS
if ( abs(ic(k2)-ic(k1)).eq.1 ) then
cosphi = 1d0
else if ( abs(jc(k2)-jc(k1)).eq.1 ) then
cosphi = 0d0
end if
if ( idir.eq.1 ) cosphi = 1d0 - cosphi
if ( cosphi.ne.DMISS .and. cosphi.ne.1d0-DMISS) then
if ( kc(k2).ne.1 ) smp_mu(k2) = smp_mu(k1)
if ( kc(k1).ne.1 ) smp_mu(k1) = smp_mu(k2)
mu = 0.5d0*(smp_mu(k1) + smp_mu(k2))
A = mu
A2 = A**2
fA2 = 1d0/A2
cos2phi = cosphi**2
sin2phi = 1d0 - cos2phi
aspect(L) = aspect(L) * sqrt( (cos2phi + fA2 * sin2phi) / (cos2phi + A2 * sin2phi) ) * A
end if
end do
end subroutine orthonet_prescribe_aspect
!> prescribe link-based aspect ratios in nets for mesh refinement (obsolete)
subroutine orthonet_prescribe_aspect_net(smp_mu, idir, aspect)
use m_netw
use m_sferic
use m_missing
use geometry_module, only: dbdistance, dcosphi
IMPLICIT NONE
double precision, dimension(numk) :: smp_mu !< mesh attractor
integer :: idir !< mesh adaptation direction
double precision, dimension(numL) :: aspect !< aspect ratio at the links
double precision, dimension(2) :: orient ! prescribed orientation
! integer, parameter :: IMISS = -999999
double precision :: x1,y1, x2,y2, x3,y3
double precision :: R01, cosphi, cos2phi, sin2phi
double precision :: A, A2, fA2, mu
integer :: L, k1, k2, imin, jmin, mc, nc
do L=1,numL
! compute the angle of link L with the prescribed orientation
k1 = kn(1,L)
k2 = kn(2,L)
if ( kc(k1).ne.1 .or. kc(k2).ne.1 ) cycle
mu = 0.5d0*(smp_mu(k1) + smp_mu(k2))
A = mu
aspect(L) = aspect(L) * A
end do
end subroutine orthonet_prescribe_aspect_net
!> compute the orientation of a cell by SVD
subroutine orthonet_compute_orientation(aspect, uu1, vv1, uu2, vv2, i)
use m_netw
use m_sferic
use m_alloc
! use m_flow ! for visualisation only
IMPLICIT NONE
integer, intent(in) :: i !< netcell number
double precision, intent(out) :: aspect !< aspect ratio
double precision, intent(out) :: uu1, uu2 !< components of first orientation vector
double precision, intent(out) :: vv1, vv2 !< components of second orientation vector
double precision, dimension(2,2) :: B, Jacobian ! Jacobian matrix
double precision :: lambda1, lambda2 ! eigen values of J
double precision, dimension(2) :: L1, L2, R1, R2 ! left and right eigen vectors of J
integer, parameter :: M=6 ! maximum nodes in cell
double precision, dimension(M, 2) :: A, R ! coefficient matrix
double precision, dimension(M) :: xi, eta, xminx0, yminy0, theta
double precision :: x0, y0, D
integer, dimension(M) :: knodes ! indices of the nodes
double precision, dimension(2,2) :: C
double precision, dimension(2,2) :: UU, VV ! left and right singular vectors
double precision, dimension(2) :: S ! singular values
double precision :: xx, yy, zz
integer :: j, k, link, N
double precision, parameter :: EPS=1D-4
!--------------------------------------------------------------
! compute the Jacobian matrix J of net cell i
!--------------------------------------------------------------
N = netcell(i)%n
if ( N.gt.M ) then
call qnerror('orthonet_compute_orientation: N > M', ' ', ' ')
return
end if
knodes = 0
knodes(1:N) = (/ (netcell(i)%nod(j), j=1,N) /)
!--------------------------------------------------------------
! Assume (x,y)' = (x0,y0)' + Jacobian*(xi,eta)'
! and do a least-square fit through the nodes
! (x0,y0)' is the mean of the node coordinates
!--------------------------------------------------------------
if ( jsferic.eq.1 .and. jasfer3D.eq.1 ) then
x0 = xzw(i)
y0 = yzw(i)
call spher2loc(x0,y0,N,xk(knodes(1:N)),yk(knodes(1:N)),xminx0(1:N),yminy0(1:N))
else
xminx0(1:N) = (/ (xk(knodes(j)), j=1,N) /)
yminy0(1:N) = (/ (yk(knodes(j)), j=1,N) /)
x0 = sum(xminx0(1:N)) / N
y0 = sum(yminy0(1:N)) / N
xminx0 = xminx0 - x0
yminy0 = yminy0 - y0
end if
theta(1:N) = (/ (k-1, k=1,N) /)
theta(1:N) = theta(1:N) / N * 2d0*pi
xi(1:N) = cos(theta(1:N))
eta(1:N) = sin(theta(1:N))
A = 0d0
A(1:N,1) = xi(1:N)
A(1:N,2) = eta(1:N)
R = 0d0
R(1:N,1) = xminx0
R(1:N,2) = yminy0
! B = A'A
B = matmul(transpose(A(1:N,:)), A(1:N,:))
! C = inv(A'A) = inv(B)
D = B(1,1)*B(2,2) - B(1,2)*B(2,1) ! determinant
if ( D.eq.0d0 ) then
call qnerror('orthonet_compute_orientation: D==0', ' ', ' ')
return
end if
B = B / D
C(1,1) = B(2,2)
C(2,2) = B(1,1)
C(1,2) = -B(1,2)
C(2,1) = -B(2,1)
! Jacobian = (inv(A'A)*A'*R)' = (C*A'*R)'
Jacobian = transpose( &
matmul( &
matmul( &
C, &
transpose(A(1:N,:)) &
), &
R &
) &
)
!--------------------------------------------------------------
! compute the Singular Value Decomposition of the Jacobian matrix
!--------------------------------------------------------------
UU = Jacobian
call svdcmp(UU, 2, 2, 2, 2, S, VV)
aspect = min( S(1)/(S(2)+EPS), S(2)/(S(1)+EPS) )
uu1 = UU(1,1) * S(1)
vv1 = UU(2,1) * S(1)
uu2 = UU(1,2) * S(2)
vv2 = UU(2,2) * S(2)
end subroutine orthonet_compute_orientation
!> Singular value Decomposition
!! from: Numerical Recipes in Fortran 77
SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
implicit none
double precision :: A, W, V
integer, intent(in) :: m, n, mp, np
double precision :: ANORM, C, F, G, H, RV1, S, SCALE, X, Y, Z
integer :: I, ITS, J, K, L, NM, NMAX
PARAMETER (NMAX=100)
DIMENSION A(MP,NP),W(NP),V(NP,NP),RV1(NMAX)
G=0.0
SCALE=0.0
ANORM=0.0
DO 25 I=1,N
L=I+1
RV1(I)=SCALE*G
G=0.0
S=0.0
SCALE=0.0
IF (I.LE.M) THEN
DO 11 K=I,M
SCALE=SCALE+ABS(A(K,I))
11 CONTINUE
IF (SCALE.NE.0.0) THEN
DO 12 K=I,M
A(K,I)=A(K,I)/SCALE
S=S+A(K,I)*A(K,I)
12 CONTINUE
F=A(I,I)
G=-SIGN(SQRT(S),F)
H=F*G-S
A(I,I)=F-G
IF (I.NE.N) THEN
DO 15 J=L,N
S=0.0
DO 13 K=I,M
S=S+A(K,I)*A(K,J)
13 CONTINUE
F=S/H
DO 14 K=I,M
A(K,J)=A(K,J)+F*A(K,I)
14 CONTINUE
15 CONTINUE
ENDIF
DO 16 K= I,M
A(K,I)=SCALE*A(K,I)
16 CONTINUE
ENDIF
ENDIF
W(I)=SCALE *G
G=0.0
S=0.0
SCALE=0.0
IF ((I.LE.M).AND.(I.NE.N)) THEN
DO 17 K=L,N
SCALE=SCALE+ABS(A(I,K))
17 CONTINUE
IF (SCALE.NE.0.0) THEN
DO 18 K=L,N
A(I,K)=A(I,K)/SCALE
S=S+A(I,K)*A(I,K)
18 CONTINUE
F=A(I,L)
G=-SIGN(SQRT(S),F)
H=F*G-S
A(I,L)=F-G
DO 19 K=L,N
RV1(K)=A(I,K)/H
19 CONTINUE
IF (I.NE.M) THEN
DO 23 J=L,M
S=0.0
DO 21 K=L,N
S=S+A(J,K)*A(I,K)
21 CONTINUE
DO 22 K=L,N
A(J,K)=A(J,K)+S*RV1(K)
22 CONTINUE
23 CONTINUE
ENDIF
DO 24 K=L,N
A(I,K)=SCALE*A(I,K)
24 CONTINUE
ENDIF
ENDIF
ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
25 CONTINUE
DO 32 I=N,1,-1
IF (I.LT.N) THEN
IF (G.NE.0.0) THEN
DO 26 J=L,N
V(J,I)=(A(I,J)/A(I,L))/G
26 CONTINUE
DO 29 J=L,N
S=0.0
DO 27 K=L,N
S=S+A(I,K)*V(K,J)
27 CONTINUE
DO 28 K=L,N
V(K,J)=V(K,J)+S*V(K,I)
28 CONTINUE
29 CONTINUE
ENDIF
DO 31 J=L,N
V(I,J)=0.0
V(J,I)=0.0
31 CONTINUE
ENDIF
V(I,I)=1.0
G=RV1(I)
L=I
32 CONTINUE
DO 39 I=N,1,-1
L=I+1
G=W(I)
IF (I.LT.N) THEN
DO 33 J=L,N
A(I,J)=0.0
33 CONTINUE
ENDIF
IF (G.NE.0.0) THEN
G=1.0/G
IF (I.NE.N) THEN
DO 36 J=L,N
S=0.0
DO 34 K=L,M
S=S+A(K,I)*A(K,J)
34 CONTINUE
F=(S/A(I,I))*G
DO 35 K=I,M
A(K,J)=A(K,J)+F*A(K,I)
35 CONTINUE
36 CONTINUE
ENDIF
DO 37 J=I,M
A(J,I)=A(J,I)*G
37 CONTINUE
ELSE
DO 38 J= I,M
A(J,I)=0.0
38 CONTINUE
ENDIF
A(I,I)=A(I,I)+1.0
39 CONTINUE
DO 49 K=N,1,-1
DO 48 ITS=1,30
DO 41 L=K,1,-1
NM=L-1
IF ((ABS(RV1(L))+ANORM).EQ.ANORM) GO TO 2
IF ((ABS(W(NM))+ANORM).EQ.ANORM) GO TO 1
41 CONTINUE
1 C=0.0
S=1.0
DO 43 I=L,K
F=S*RV1(I)
IF ((ABS(F)+ANORM).NE.ANORM) THEN
G=W(I)
H=SQRT(F*F+G*G)
W(I)=H
H=1.0/H
C= (G*H)
S=-(F*H)
DO 42 J=1,M
Y=A(J,NM)
Z=A(J,I)
A(J,NM)=(Y*C)+(Z*S)
A(J,I)=-(Y*S)+(Z*C)
42 CONTINUE
ENDIF
43 CONTINUE
2 Z=W(K)
IF (L.EQ.K) THEN
IF (Z.LT.0.0) THEN
W(K)=-Z
DO 44 J=1,N
V(J,K)=-V(J,K)
44 CONTINUE
ENDIF
GO TO 3
ENDIF
! IF (ITS.EQ.30) PAUSE 'No convergence in 30 iterations'
IF (ITS.EQ.30) then ! SPvdP: error handling
A = 0d0
W = 0d0
V = 0d0
return
end if
X=W(L)
NM=K-1
Y=W(NM)
G=RV1(NM)
H=RV1(K)
F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
G=SQRT(F*F+1.0)
F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
C=1.0
S=1.0
DO 47 J=L,NM
I=J+1
G=RV1(I)
Y=W(I)
H=S*G
G=C*G
Z=SQRT(F*F+H*H)
RV1(J)=Z
C=F/Z
S=H/Z
F= (X*C)+(G*S)
G=-(X*S)+(G*C)
H=Y*S
Y=Y*C
DO 45 NM=1,N
X=V(NM,J)
Z=V(NM,I)
V(NM,J)= (X*C)+(Z*S)
V(NM,I)=-(X*S)+(Z*C)
45 CONTINUE
Z=SQRT(F*F+H*H)
W(J)=Z
IF (Z.NE.0.0) THEN
Z=1.0/Z
C=F*Z
S=H*Z
ENDIF
F= (C*G)+(S*Y)
X=-(S*G)+(C*Y)
DO 46 NM=1,M
Y=A(NM,J)
Z=A(NM,I)
A(NM,J)= (Y*C)+(Z*S)
A(NM,I)=-(Y*S)+(Z*C)
46 CONTINUE
47 CONTINUE
RV1(L)=0.0
RV1(K)=F
W(K)=X
48 CONTINUE
3 CONTINUE
49 CONTINUE
RETURN
END
!> snap network meshlines to nearest land boundary
subroutine nettoland()
use M_netw
use M_MISSING
use m_observations
use gridoperations
implicit none
integer :: ja
call findcells(100)
call makenetnodescoding()
ja = 1
call confrm('Do you want to snap net boundary to the land boundary only?', ja)
if ( ja.eq.1) then
call find_nearest_meshline(2) ! net boundaries only
call snap_to_landboundary
else
ja = 1
call confrm('Do you want to snap inner net to the land boundary too?', ja)
if ( ja.eq.1) then
call find_nearest_meshline(3)
call snap_to_landboundary
else
ja = 1
call confrm('Do you want to snap all net to the land boundary?', ja)
if ( ja.eq.1) then
call find_nearest_meshline(4)
call snap_to_landboundary
end if
end if
end if
if ( ja.eq.1 ) then
call confrm('Are you satisfied?', ja)
if ( ja.ne.1 ) call restore()
end if
return
end subroutine nettoland
!> "Casulli"-type refinement of quads
subroutine refinequads_casulli
use m_netw
use m_inverse_map
use m_missing
use gridoperations
implicit none
integer, allocatable, dimension(:,:) :: newnodes ! four new nodes per existing link
integer, allocatable, dimension(:) :: kc_old ! copy of kc
type (tadm) :: adm ! structure with administration
double precision :: xc, yc, x3, y3, x4, y4, xp, yp
integer :: Lstart
integer :: ierror
integer :: k, k0, k1, k2, k3, k4, kstart, kend
integer :: kk, kkm1, kkp1, kkp2, kkk, L, L1, L2, Lm1
integer :: link1, link2
integer :: kcell, knode, knew, Lnew
integer :: N, Ncell, NL, NR, node1, node2
integer :: numL_old, numk_old
integer :: jatolan, NPL_bak
integer :: idirectional
integer, parameter :: Mmax = 4 ! maximum number of nodes in newly created cells
call confrm('Directional?', idirectional)
call findcells(100)
call makenetnodescoding()
numL_old = numL
numk_old = numk
! new nodes have kc<0
! new boundary nodes have kc=-1
! active original boundary nodes have kc=1234
! active original nodes that need to be kept and will be connected to other new nodes have kc=1235
! active original nodes that need to be kept have kc=1236
!
! first new nodes are created, then the new links
! hereafter, old nodes and links are disabled
!
! new nodes are created in two step:
! -firstly the inner nodes
! -secondly the boundary nodes
!
! new links are created in four steps:
! -firsty the links that can be associated to the old links, both normal and parallel to them
! -secondly the "corner-quad" links, which are diagonal links in quadrilaterals that connect new nodes to the old ones
! -thirdly the missing boundary links that aren't associated with the original netcells, but with the original nodes
! -fourthly the original-node to new-node links when there are more then Mmax links connected to an original node, Mmax being the maximum numbers of nodes in newly created cells
! here we go
if ( idirectional.eq.1 ) then
! user interaction
call getlink_GUI(xp, yp, Lstart)
if ( Lstart.lt.1 ) goto 1234
end if
! perform the administration and node masking
call admin_mask()
!
! resize network
! NEEDS TO BE MORE ACCURATE
call increasenetw(4*numk, 6*numL)
! allocate
allocate(newnodes(4, numL))
newnodes = 0
! create the new nodes
if ( idirectional.eq.0 ) then
call makenodes()
else
call makenodes_directional(xp, yp, Lstart, ierror)
if ( ierror.ne.0 ) goto 1234
end if
! make the new links
call makelinks()
! disable old nodes
do k0=1,numk_old
if ( kc(k0).gt.0 .and. kc(k0).lt.1235 ) xk(k0) = DMISS
end do
! disable old links
do L=1,numL_old
node1 = kn(1,L)
node2 = kn(2,L)
if ( kc(node1).gt.0 .and. kc(node2).gt.0 .or. (kc(node1).eq.1235 .and. kc(node2).eq.1235) .or. &
( kc(node1).eq.0 .and. kc(node2).eq.1235) .or. ( kc(node1).eq.1235 .and. kc(node2).eq.0) .or. &
( kc(node1).eq.0 .and. kc(node2).eq.1236) .or. ( kc(node1).eq.1236 .and. kc(node2).eq.0) .or. &
( kc(node1).eq.-1 .and. kc(node2).eq.-1 ) .or. ( kc(node1).eq.-2 .and. kc(node2).eq.-2 ) ) then ! last two lines for directional refinement
if ( lnn(L).eq.0 .or. kn(3,L).eq.0 ) cycle ! a 1D-link: keep it
kn(1,L) = 0
kn(2,L) = 0
kn(3,L) = -1
end if
end do
call setnodadm(0)
jatolan = 1
call confrm('Copy refinement border to polygon?', jatolan)
if ( jatolan.eq.1 ) then
! store original node mask
allocate(kc_old(numk))
! kc_old = min(kc,1) ! see admin_mask
kc_old = kc
where ( kc_old.ne.0 ) kc_old = 1
! deative polygon
call savepol()
call delpol()
call findcells(100)
! reactivate polygon
call restorepol()
! mark cells crossed by polygon, by setting lnn of their links appropriately
! kc_old(numk_old+1:numk) = 1
call mark_cells_crossed_by_poly(numk,kc_old)
call delpol()
call copynetboundstopol(0, 0, 0, 1)
deallocate(kc_old)
end if
1234 continue ! error handling
! deallocate
if ( allocated(newnodes) ) deallocate(newnodes)
! set network status
netstat = NETSTAT_CELLS_DIRTY
contains
!> perform the administration and node masking in refinequads_casulli
subroutine admin_mask()
implicit none
integer :: icell
! mark active boundary nodes (1234)
do L=1,numL
node1 = kn(1,L)
node2 = kn(2,L)
if ( lnn(L).eq.1 ) then
if ( kc(node1).ne.0 ) kc(node1) = 1234
if ( kc(node2).ne.0 ) kc(node2) = 1234
end if
end do
! set nodes with disjunct cells to kc=1235, i.e. keep them
do k=1,numk
do kk=1,nmk(k) ! loop over the cells connected to this node
link1 = nod(k)%lin(kk)
if ( lnn(link1).ne.1 ) cycle ! we are looking for disjunct cells
icell = lne(1,link1)
N = netcell(icell)%N
! if ( N.ne.4 ) cycle ! quads only
! find the other link in this cell connected to the node
kkk = 1
link2 = netcell(icell)%lin(kkk)
do while ( ( ( kn(1,link2).ne.k .and. kn(2,link2).ne.k ) .or. link2.eq.link1 ) .and. kkk.lt.N )
kkk = kkk+1
link2 = netcell(icell)%lin(kkk)
end do
if ( lnn(link2).eq.1 ) then ! disjunct cell found
if ( kc(k).gt.0 ) kc(k) = 1235
exit
end if
end do
end do
! keep corner nodes
do k=1,numk
if ( nb(k).eq.3 ) then
kc(k) = 1235
end if
end do
! determine the maximum number of links connected to a node
nmkx = 0
kp:do k0=1,numk
if ( kc(k0).eq.0 ) cycle
if ( nmk(k0).gt.1 ) then
call orthonet_admin(k0, adm, ierror)
if ( ierror.ne.0 ) then
kc(k0) = 0 ! weird node -> deactivated
cycle
end if
else ! hanging node -> deactivated
kc(k0) = 0
cycle
end if
! mask the nodes that are are connected to non-quads *update: deactivated, non-quads are refined too*
Ncell = 0 ! the number of valid cells counted
do kk=1,adm%Ncell
kcell = adm%icell(kk)
if ( kcell.gt.0 ) then
Ncell = Ncell+1
! if ( netcell(kcell)%N.ne.4 ) then
! kc(k0) = 0
! cycle kp
! end if
end if
end do
if ( Ncell.eq.0 ) kc(k0) = 0 ! no cells connected to node -> deactivated
! weird boundary nodes -> keep them
if ( Ncell.lt.nmk(k0)-1 .and. kc(k0).eq.1234) kc(k0) = 1235
!! boundary nodes with more than two cells connected -> keep them !DEACTIVED (triangular meshes)
! if ( Ncell.gt.2 .and. kc(k0).eq.1234 ) kc(k0) = 1235
! inner nodes with more than Mmax links connected -> keep them
if ( nmk(k0).gt.Mmax .and. kc(k0).gt.0 .and. kc(k0).lt.1234 ) kc(k0) = 1235
nmkx = max(nmkx, nmk(k0))
end do kp
end subroutine admin_mask
!> create and store the new nodes in refinequads_casulli
subroutine makenodes()
implicit none
! create and store inner nodes
klp:do k=1,nump
N = netcell(k)%N
if ( sum(kc(netcell(k)%nod(1:N))).eq.0 ) cycle ! no active nodes in cell
! compute cell center
xc = sum( xk(netcell(k)%nod(1:N)) ) / dble(N)
yc = sum( yk(netcell(k)%nod(1:N)) ) / dble(N)
! loop over the nodes
do kk=1,N
knode = netcell(k)%nod(kk)
! find the links connected to this node in the cell
link1 = 0
link2 = 0
do kkk=1,N
L = netcell(k)%lin(kkk)
if ( kn(1,L).eq.knode .or. kn(2,L).eq.knode ) then
if ( link1.eq.0 ) then
link1 = L
else
link2 = L
exit
end if
end if
end do
if ( link1.eq.0 .or. link2.eq.0 ) cycle klp ! no links found
! create new node
if ( kc(knode).gt.0 ) then
call dsetnewpoint(0.5d0*(xk(knode)+xc), 0.5d0*(yk(knode)+yc), knew)
call cirr(xk(knew),yk(knew),31)
kc(knew) = -2 ! mark as inactive, non-boundary, so it will not be disabled later on
else ! original node not active, let knew point to original node for mesh connection later
knew = knode
end if
! store new node for both links
call store_newnode(knode, link1, link2, knew, newnodes)
! end if
end do
end do klp
! create and store boundary nodes
do L=1,numL_old
if ( lnn(L).ne.1 ) cycle
node1 = kn(1,L)
node2 = kn(2,L)
if ( kc(node1).eq.0 .and. kc(node2).eq.0 ) cycle ! no active nodes in link
! compute link center
xc = 0.5d0*( xk(node1) + xk(node2) )
yc = 0.5d0*( yk(node1) + yk(node2) )
! create new node near node1
if ( kc(node1).ne.0 ) then
call dsetnewpoint(0.5d0*(xk(node1)+xc), 0.5d0*(yk(node1)+yc), knew)
kc(knew) = -1 ! mark as inactive and on the boundary
else ! original node not active, let knew point to original node for mesh connection later
knew = node1
end if
! store new node
call store_newnode(node1, L, L, knew, newnodes)
! create new node near node2
if ( kc(node2).ne.0 ) then
call dsetnewpoint(0.5d0*(xk(node2)+xc), 0.5d0*(yk(node2)+yc), knew)
kc(knew) = -1 ! mark as inactive and on the boundary
else ! original node not active, let knew point to original node for mesh connection later
knew = node2
end if
! store new node
call store_newnode(node2, L, L, knew, newnodes)
end do
end subroutine makenodes
!> create and store the new nodes in directional refinequads_casulli
subroutine makenodes_directional(xp,yp,Lstart,ierror)
! use m_grid
use unstruc_colors, only: ncolln
implicit none
double precision, intent(in) :: xp, yp !> coordinates of clicked point
integer, intent(in) :: Lstart !> clicked link number
integer, intent(out) :: ierror !> error (1) or not (0)
integer, dimension(:), allocatable :: linkmask
integer, dimension(:), allocatable :: ic, jc
double precision :: x0, y0, xnew, ynew, xc, yc
integer :: k1, k2, L, Link, iSE, iexit, idiff, jdiff
ierror = 1
! make linkmask
allocate(linkmask(numL))
linkmask = 0
!---------------------------------------------------
! get the netnode indices ic and jc in the curvi-grid
x0 = xk(50)
y0 = yk(50)
allocate(ic(numk), jc(numk))
ic = 0
jc = 0
call assign_icjc(xp,yp, ic, jc, iexit)
if ( iexit.ne.1 ) goto 1234
!---------------------------------------------------
! deselect nodes that are members of non-quads
do k=1,nump
if ( netcell(k)%N.ne.4 ) then
do kk=1,netcell(k)%N
kc(netcell(k)%nod(kk)) = 0
end do
end if
end do
!---------------------------------------------------
! make the linkmask
idiff = abs(ic(kn(2,Lstart))-ic(kn(1,Lstart)))
jdiff = abs(jc(kn(2,Lstart))-jc(kn(1,Lstart)))
if ( idiff.eq.jdiff ) then ! no valid link clicked
goto 1234
end if
do L=1,numL
k1 = kn(1,L)
k2 = kn(2,L)
if ( abs(ic(k2)-ic(k1)).eq.idiff .and. abs(jc(k2)-jc(k1)).eq.jdiff ) then
linkmask(L) = 1
if ( kc(k1).ne.0 .and. kc(k2).ne.0 ) call teklink(L, ncolln)
end if
end do
call confrm('Refine these links?', iexit)
if ( iexit.ne.1 ) goto 1234
!---------------------------------------------------
! create and store inner nodes
klp:do k=1,nump
N = netcell(k)%N
if ( sum(kc(netcell(k)%nod(1:N))).eq.0 ) cycle ! no active nodes in cell
! compute cell center
xc = sum( xk(netcell(k)%nod(1:N)) ) / dble(N)
yc = sum( yk(netcell(k)%nod(1:N)) ) / dble(N)
! loop over the nodes
do kk=1,N
knode = netcell(k)%nod(kk)
! find the links connected to this node in the cell
link1 = 0
link2 = 0
do kkk=1,N
L = netcell(k)%lin(kkk)
if ( kn(1,L).eq.knode .or. kn(2,L).eq.knode ) then
if ( link1.eq.0 ) then
link1 = L
else
link2 = L
exit
end if
end if
end do
if ( link1.eq.0 .or. link2.eq.0 ) cycle klp ! no links found
if ( linkmask(link1).eq.1 .or. linkmask(link2).eq.1 ) then
! create new node
if ( kc(knode).gt.0 ) then
! compute active-link center
if ( linkmask(link1).eq.1 ) then
! only one link may be active
if ( linkmask(link2).ne.1 ) then
Link = link1
else
call qnerror('makenodes_directional: more than one active link', ' ', ' ')
goto 1234
end if
else
Link = link2
end if
xc = 0.5d0*(xk(kn(1,Link))+xk(kn(2,Link)))
yc = 0.5d0*(yk(kn(1,Link))+yk(kn(2,Link)))
! in this case: Left and Right node must be the same on a link
! first check if a node already exists on this link (from the other side)
iSE = isstartend(knode, Link)
if ( iSE.ge.0 .and. newnodes(max(1+iSE,1), Link).gt.0 ) then
knew = newnodes(1+iSE, Link)
else if ( iSE.ge.0 .and. newnodes(max(1+iSE+2,1), Link).gt.0 ) then
knew = newnodes(1+iSE+2, Link)
else
xnew = 0.5d0*( xk(knode)+xc )
ynew = 0.5d0*( yk(knode)+yc )
call dsetnewpoint(xnew, ynew , knew)
call cirr(xk(knew),yk(knew),31)
kc(knew) = -2 ! mark as inactive, non-boundary, so it will not be disabled later on
end if
else ! original node not active, let knew point to original node for mesh connection later
knew = knode
end if
! store new node for both links
call store_newnode(knode, link1, link2, knew, newnodes)
else
if ( kc(knode).gt.0 ) then
knew = knode
kc(knew) = 1236 ! mark as persistent node, so it will not be disabled later on
else ! original node not active, let knew point to original node for mesh connection later
knew = knode
end if
! store new node for both links
call store_newnode(knode, link1, link2, knew, newnodes)
end if
end do
end do klp
! create and store boundary nodes
do L=1,numL_old
if ( lnn(L).ne.1 ) cycle
node1 = kn(1,L)
node2 = kn(2,L)
if ( kc(node1).eq.0 .and. kc(node2).eq.0 ) cycle ! no active nodes in link
if ( linkmask(L).eq.1 ) then
! compute link center
xc = 0.5d0*( xk(node1) + xk(node2) )
yc = 0.5d0*( yk(node1) + yk(node2) )
! create new node near node1
if ( kc(node1).ne.0 ) then
! in this case: Left and Right node must be the same on a link
! first check if a node already exists on this link (from the other side)
iSE = isstartend(node1, L) ! should be 0
if ( iSE.ge.0 .and. newnodes(max(1+iSE,1), L).gt.0 ) then
knew = newnodes(1+iSE, L)
else if ( iSE.ge.0 .and. newnodes(max(1+iSE+2,1), L).gt.0 ) then
knew = newnodes(1+iSE+2, L)
else
call dsetnewpoint(0.5d0*(xk(node1)+xc), 0.5d0*(yk(node1)+yc), knew)
call cirr(xk(knew),yk(knew),31)
kc(knew) = -1
end if
else ! original node not active, let knew point to original node for mesh connection later
knew = node1
end if
! store new node
call store_newnode(node1, L, L, knew, newnodes)
! create new node near node2
if ( kc(node2).ne.0 ) then
! in this case: Left and Right node must be the same on a link
! first check if a node already exists on this link (from the other side)
iSE = isstartend(node2, L) ! should be 1
if ( iSE.ge.0 .and. newnodes(max(1+iSE,1), L).gt.0 ) then
knew = newnodes(1+iSE, L)
else if ( iSE.ge.0 .and. newnodes(max(1+iSE+2,1), L).gt.0 ) then
knew = newnodes(1+iSE+2, L)
else
call dsetnewpoint(0.5d0*(xk(node2)+xc), 0.5d0*(yk(node2)+yc), knew)
call cirr(xk(knew),yk(knew),31)
kc(knew) = -1
end if
else ! original node not active, let knew point to original node for mesh connection later
knew = node2
end if
! store new node
call store_newnode(node2, L, L, knew, newnodes)
else
! node near node1
if ( kc(node1).ne.0 ) then
knew = node1
kc(knew) = 1236
else ! original node not active, let knew point to original node for mesh connection later
knew = node1
end if
! store new node
call store_newnode(node1, L, L, knew, newnodes)
! node near node2
if ( kc(node2).ne.0 ) then
knew = node2
kc(knew) = 1236
else ! original node not active, let knew point to original node for mesh connection later
knew = node2
end if
! store new node
call store_newnode(node2, L, L, knew, newnodes)
end if
end do
ierror = 0
! error handling
1234 continue
! deallocate
if ( allocated(linkmask) ) deallocate(linkmask)
end subroutine makenodes_directional
!> make links in refinequads_casulli
subroutine makelinks()
implicit none
integer, dimension(nmkx) :: node, link ! nodes and links connected to boundary node resp.
integer, dimension(nmkx) :: oldn, newn ! old and new nodes in quad resp.
integer :: numlinks
! make the original-link based new links
do L=1,numL_old
k1 = newnodes(1,L)
k2 = newnodes(2,L)
k3 = newnodes(3,L)
k4 = newnodes(4,L)
! parallel links: these are the start-end connections
if ( k1.gt.0 .and. k2.gt.0 .and. k1.ne.k2 ) call newlink(k1,k2,Lnew)
if ( k3.gt.0 .and. k4.gt.0 .and. k3.ne.k4 ) call newlink(k3,k4,Lnew)
! normal links: these are the left-right connections
if ( k1.gt.0 .and. k3.gt.0 .and. k1.ne.k3 ) call newlink(k1,k3,Lnew)
if ( k2.gt.0 .and. k4.gt.0 .and. k2.ne.k4 ) call newlink(k2,k4,Lnew)
end do
! create the diagonal links in quads that connect the new mesh with the old mesh
do k=1,nump
N = netcell(k)%N
if ( N.ne.4 ) cycle ! quads only
if ( sum(kc(netcell(k)%nod(1:N))).eq.0 ) cycle ! no active nodes in cell
! find the old and new nodes
oldn = 0
newn = 0
do kk=1,N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
L = netcell(k)%lin(kk)
Lm1 = netcell(k)%lin(kkm1)
oldn(kk) = kn(1,L)
newn(kk) = newnodes(3,L)
if ( oldn(kk).ne.kn(1,Lm1) .and. oldn(kk).ne.kn(2,Lm1) ) then
oldn(kk) = kn(2,L)
newn(kk) = newnodes(2,L)
end if
end do
do kk=1,N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1 = kkp1-N
kkp2 = kk+2; if ( kkp2.gt.N ) kkp2 = kkp2-N
k1 = newn(kk)
k2 = oldn(kkm1)
k3 = oldn(kkp1)
k4 = oldn(kkp2)
! only one new node: new diagonal link connects new node with one old node
if ( kc(k1).lt.0 .and. kc(k2).eq.0 .and. kc(k3).eq.0 .and. kc(k4).eq.0 ) then
call newlink(k1,k4,Lnew)
exit
end if
! only one old node: new diagonal link connects new nodes only (i.e. perpendicular to previous one)
if ( kc(k1).lt.0 .and. kc(k2).gt.0 .and. kc(k3).gt.0 .and. kc(k4).eq.0 ) then
call newlink(newn(kkm1),newn(kkp1),Lnew)
exit
end if
! two new and opposing nodes: new diagonal link connects the new nodes
if ( kc(k1).lt.0 .and. kc(k2).eq.0 .and. kc(k3).eq.0 .and. kc(k4).eq.1 ) then
call newlink(k1,newn(kkp2),Lnew)
exit
end if
end do
end do
! make the missing boundary links
do k=1,numk_old
if ( kc(k).lt.1234) cycle ! boundary and kept nodes only
! find the links connected
numlinks = 0
link = 0
do kkk=1,nmk(k)
L = nod(k)%lin(kkk)
if ( lnn(L).eq.1 ) then
numlinks = numlinks+1
link(numlinks) = L
else ! non-boundary link connected to boundary node -> create links
if ( kn(1,L).eq.k ) then
call newlink(k, newnodes(1,L), Lnew)
call newlink(k, newnodes(3,L), Lnew)
else
call newlink(k, newnodes(2,L), Lnew)
call newlink(k, newnodes(4,L), Lnew)
end if
end if
end do
if ( numlinks.eq.0 ) cycle ! no links found
! find the two new boundary nodes
node = 0
do kk=1,numlinks
if ( kn(1,link(kk)).eq.k .and. kc(newnodes(1,link(kk))).eq.-1 ) node(kk) = newnodes(1,link(kk))
if ( kn(1,link(kk)).eq.k .and. kc(newnodes(3,link(kk))).eq.-1 ) node(kk) = newnodes(3,link(kk))
if ( kn(2,link(kk)).eq.k .and. kc(newnodes(2,link(kk))).eq.-1 ) node(kk) = newnodes(2,link(kk))
if ( kn(2,link(kk)).eq.k .and. kc(newnodes(4,link(kk))).eq.-1 ) node(kk) = newnodes(4,link(kk))
! for directional refinement (1236 are persistent nodes)
if ( kn(1,link(kk)).eq.k .and. kc(newnodes(1,link(kk))).eq.1236 ) node(kk) = newnodes(1,link(kk))
if ( kn(1,link(kk)).eq.k .and. kc(newnodes(3,link(kk))).eq.1236 ) node(kk) = newnodes(3,link(kk))
if ( kn(2,link(kk)).eq.k .and. kc(newnodes(2,link(kk))).eq.1236 ) node(kk) = newnodes(2,link(kk))
if ( kn(2,link(kk)).eq.k .and. kc(newnodes(4,link(kk))).eq.1236 ) node(kk) = newnodes(4,link(kk))
end do
! make the new links
if ( kc(k).ne.1235 .and. kc(k).ne.1236 ) then ! node is not kept
if ( numlinks.ne.2 ) then
call qnerror('refinequads_casulli, makelinks: boundary link error', ' ', ' ')
else
if ( node(1).gt.0 .and. node(2).gt.0 .and. node(1).ne.node(2) ) then
call newlink(node(1), node(2), Lnew)
end if
end if
else ! node is kept
do kk=1,numlinks
if ( node(kk).gt.0 .and. node(kk).ne.k ) call newlink(k, node(kk), Lnew)
end do
end if
end do
! make the original-node to new-node links for the kept original nodes, which have more than Mmax links attached
do k=1,numk_old
if ( kc(k).ne.1235 .or. nmk(k).le.Mmax ) cycle
do kk=1,nmk(k)
L = nod(k)%lin(kk)
if ( kn(1,L).eq.k ) then
call newlink(k, newnodes(1,L), Lnew)
call newlink(k, newnodes(3,L), Lnew)
else
call newlink(k, newnodes(2,L), Lnew)
call newlink(k, newnodes(4,L), Lnew)
end if
end do
end do
end subroutine makelinks
!> administer the new node by figuring out the start/end and left/right position w.r.t. corresponding link
!! the order is as follows:
!! 1: right, start
!! 2: right, end
!! 3: left, start
!! 4: left, end
!!
!! important: first store the non-boundary nodes
subroutine store_newnode(k0, L1_, L2_, knew, newnodes)
implicit none
integer, intent(in) :: k0 ! center node
integer, intent(in) :: L1_, L2_ ! link numbers
integer :: knew ! new node
integer, dimension(:,:), intent(inout) :: newnodes ! new-node administration
integer :: L1, L2
integer :: k1, k2, kk, kk1, kk2, L, N
integer :: iLR1, iLR2, iSE1, iSE2, ipoint1, ipoint2
integer :: i, j, icell
double precision :: xc, yc
double precision :: vecprod, dx1, dx2
integer, external :: icommon
! if L1.eq.0 or L2.eq.0 or L1.eq.L2 and L1 or L2 is a boundary link, store at the "ghost"-side
L1 = L1_
L2 = L2_
if ( L1.gt.0 ) then
if ( L2.eq.0 ) then
L2 = L1
end if
else
if ( L2.gt.0 ) then
L1 = L2
else
call qnerror('store_newnode: no links specified', ' ', ' ')
return
end if
end if
! find common cell
icell = icommon(L1,L2)
if ( icell.lt.1 ) then
call qnerror('store_newnode: no cell found', ' ', ' ')
end if
! determine the orientations
iLR1 = isleftright(icell,L1)
iLR2 = isleftright(icell,L2)
iSE1 = isstartend(k0, L1)
iSE2 = isstartend(k0, L2)
! select other side if only one link is specified
if ( L1.eq.L2 ) then
iLR1 = 1-iLR1
iLR2 = 1-iLR2
end if
ipoint1 = 1 + iSE1 + 2*(1-iLR1)
ipoint2 = 1 + iSE2 + 2*(1-iLR2)
if ( newnodes(ipoint1,L1).lt.1 ) newnodes(ipoint1,L1) = knew
if ( newnodes(ipoint2,L2).lt.1 ) newnodes(ipoint2,L2) = knew
end subroutine store_newnode
!> determine if a node is at the start (0) or end (1) of a link or not in the link at all (-1)
integer function isstartend(k, L)
implicit none
integer, intent(in) :: k !> node number
integer, intent(in) :: L !> link number
isstartend = -1
if ( kn(1,L).eq.k ) isstartend = 0
if ( kn(2,L).eq.k ) isstartend = 1
return
end function isstartend
!> determine if a cell is at the left (0) or right (1) of a link or not neighboring a link at all (-1)
!> note: it is assumed that the links in a cell are in counterclockwise order
integer function isleftright(icell, L)
implicit none
integer, intent(in) :: icell !> cell number
integer, intent(in) :: L !> link number
integer :: kend, kk, kself, knext, L1, N
isleftright = -1
! find a neighbor of link L: a link in the cell that is connected to the endpoint of link L
N = netcell(icell)%N
kend = kn(2,L)
kself = 0
knext = 0
do kk=1,N
L1 = netcell(icell)%lin(kk)
if ( L1.eq.L ) then
kself = kk
else if ( kn(1,L1).eq.kend .or. kn(2,L1).eq.kend ) then
knext = kk
end if
end do
if ( knext-kself.eq.1 .or. knext+N-kself.eq.1 ) then ! cell at the left
isleftright = 0
else if ( kself-knext.eq.1 .or. kself+N-knext.eq.1 ) then ! cell at the right
isleftright = 1
end if
return
end function isleftright
end subroutine refinequads_casulli
!> find common neighboring cell of two links (0: no cell found)
integer function icommon(L1, L2)
use network_data, only: lnn, lne
implicit none
integer, intent(in) :: L1, L2 !< link numbers
integer :: icell, i, j, kk
icommon = 0
do i=1,lnn(L1)
do j=1,lnn(L2)
if ( lne(i,L1).eq.lne(j,L2) ) then
icommon = lne(i,L1)
exit
end if
end do
end do
return
end function icommon
!> mark the cells that are crossed by the polygon
subroutine mark_cells_crossed_by_poly(ksize,kmask)
use m_netw
implicit none
integer, intent(in) :: ksize !< size of kmask array
integer, dimension(ksize), intent(in) :: kmask !< original node mask, with new nodes set to 1
integer, allocatable, dimension(:) :: Lmask
integer :: k, kk, k1, k2, L, N, lnn_orig
logical :: Lcrossedcell
! allocate node mask arrays
if ( allocated(cellmask) ) deallocate(cellmask)
allocate(Lmask(numL),cellmask(nump))
! make the linkmask
Lmask = 0
do L=1,numL
k1 = kn(1,L)
k2 = kn(2,L)
if ( k1.lt.1 .or. k2.lt.1 .or. k1.gt.numk .or. k2.gt.numk) cycle
if ( kmask(k1).ne.kmask(k2) ) then
Lmask(L) = 1
else
Lmask(L) = 0
end if
end do
! make the cellmask
cellmask = 0
do k=1,nump
N = netcell(k)%N
do kk=1,N
L = netcell(k)%lin(kk)
if ( Lmask(L).eq.1 ) then
cellmask(k) = 1
exit
end if
end do
end do
! set lnn to 0 (deactivated, not a member of a crossed cell), 1 (member of one crossed cell) or 2 (member of two adjacent crossed cells)
do L=1,numL
lnn_orig = lnn(L)
if ( lnn_orig.ge.1 ) then
k1 = lne(1,L)
if ( cellmask(k1).eq.1 ) then
lnn(L) = 1
lne(1,L) = k1
else
lnn(L) = 0
end if
if ( lnn_orig.eq.2 ) then
k2 = lne(2,L)
if ( cellmask(k2).eq.1 ) then
lnn(L) = lnn(L)+1
lne(lnn(L),L) = k2
else
continue
end if
end if
end if
end do
! deallocate
deallocate(Lmask, cellmask)
return
end subroutine mark_cells_crossed_by_poly
!> link-based mesh-topology information
double precision function topo_info(L)
use m_netw
use m_landboundary
use m_missing
implicit none
integer :: L !< link number
integer :: k1, k2, kL, kR
integer :: icellL, icellR
integer :: k, n
integer :: jalandbound ! take landboundary into account (1) or not (0)
logical :: Lproceed
integer, external :: nmk_opt ! optimal nmk for the for nodes involved
! default
topo_info = DMISS
! check if administration is in order
if ( L.gt.ubound(lnn,1) ) goto 1234
! check if the landboundary can be taken into account (not necessarily the up-to-date)
if ( ubound(lanseg_map,1).ge.numk ) then
jalandbound = 1
else
jalandbound = 0
end if
call comp_ntopo(L, jalandbound, k1, k2, kL, kR, icellL, icellR, n)
topo_info = -dble(n)
if ( topo_info.le.0d0 ) topo_info=DMISS
return
1234 continue ! error handling
return
end function topo_info
!> flip links in quads, when appropriate
!> note: we look for a local optimum, which is not necessarily the global one
subroutine fliplinks()
use m_netw
use m_alloc
use unstruc_colors, only: ncolhl
use m_orthosettings, only: japroject
use geometry_module, only: cross
use m_sferic, only: jsferic
use m_missing, only: dmiss
use gridoperations
implicit none
integer :: L ! link number
integer, allocatable, dimension(:) :: inodemask ! node mask
integer :: k1, k2, kL, kR
integer :: icellL, icellR
integer :: k, kk, LL
integer :: x1, x2, xL, xR ! deviation from optimal nmk
logical :: Lproceed
integer :: ntopo ! change in topology functional
! integer, dimension(4) :: nmk_opt ! optimal nmk for the for nodes involved
integer :: numchanged ! number of linkes flipped
integer :: iter ! iteration
integer :: MAXITER ! maximum number of iterations
integer :: L1L, L1R, L2L, L2R ! other links in triangles connected to link L
integer :: jacross ! check if two diagonals of a quadrilateral cross
integer :: irerun
integer :: jatriangulate ! triangulate all cells prior to link flippingz
integer :: jalandbound ! take land boundaries into account or not
integer :: maxlin
double precision, allocatable :: arglin(:) ! dummy array
integer, allocatable :: linnrs(:), inn(:) ! dummy arrays
double precision :: sl, sm, xcr, ycr, crp ! used in cross check
double precision :: beta, Etot, Emin ! Monte-Carlo parameters
logical :: Lflip
integer, external :: nmk_opt
double precision, external :: rand
integer :: ja
if ( jaswan.ne.1 ) then
jatriangulate = 1
call confrm('triangulate all cells prior to link flipping?', jatriangulate)
jalandbound = 1
call confrm('take land boundaries into account?', jalandbound)
else
jatriangulate = 1
jalandbound = 0
if ( japroject.eq.3 .or. japroject.eq.4 ) jalandbound = 1
end if
call findcells(100)
call makenetnodescoding()
if ( jatriangulate.eq.1 ) then
call triangulate_cells()
call findcells(100)
call makenetnodescoding()
end if
if ( jalandbound .eq. 1 ) then
call find_nearest_meshline(4)
end if
! Monte-Carlo settings
MAXITER = 10
beta = 2d0
Etot = 0d0
Emin = Etot
! allocate
allocate(inodemask(numk))
maxlin = maxval(nmk(1:numk)) + 10 ! safety
allocate(linnrs(maxlin),arglin(maxlin),inn(maxlin))
! open(666, file='test.m')
! write(666, "('data=[')")
it:do iter=1,MAXITER
inodemask = 0
numchanged = 0
do L=1,numL
call comp_ntopo(L, jalandbound, k1, k2, kL, kR, icellL, icellR, ntopo)
! check and see if the nodes are masked
if ( inodemask(k1).ne.0 .or. inodemask(k2).ne.0 ) cycle
if ( lnn(L).ne.2 ) cycle ! inner links only
!
if ( netcell(icellL)%N.ne.3 .or. netcell(icellR)%N.ne.3 ) cycle ! triangles only
! check and see if the nodes are masked
if ( inodemask(kL).ne.0 .or. inodemask(kR).ne.0 ) cycle
Lflip = ( ntopo.lt.0 )
! Monte-Carlo
! if( abs(beta*dble(ntopo)).lt.5d0 ) then
! Lflip = ( rand(0).lt.dexp(-beta*dble(ntopo)) )
! else
! Lflip = ( ntopo.lt.0 )
! end if
if ( Lflip ) then
! whipe out link
call teklink(L, 0)
! check if the quadrilateral composed by the two adjacent triangles is concave,
! in which case the diagonals cross
call cross(xk(k1), yk(k1), xk(k2), yk(k2), xk(kL), yk(kL), xk(kR), yk(kR), jacross, sl, sm, xcr, ycr, crp, jsferic, dmiss)
if ( jacross.eq.0 ) then ! concave: mesh fold ahead
cycle
end if
! Monte-Carlo: modify total energy
! Etot = Etot + ntopo
! flip link
kn(1,L) = kL
kn(2,L) = kR
! mask nodes
! inodemask(k1) = 1
! inodemask(k2) = 1
! inodemask(kL) = 1
! inodemask(kR) = 1
numchanged = numchanged+1
! find the other links
do kk=1,netcell(icellL)%N
LL = netcell(icellL)%lin(kk)
if ( LL.eq.L ) cycle
if ( kn(1,LL).eq.k1 .or. kn(2,LL).eq.k1 ) L1L = LL
if ( kn(1,LL).eq.k2 .or. kn(2,LL).eq.k2 ) L2L = LL
end do
do kk=1,netcell(icellR)%N
LL = netcell(icellR)%lin(kk)
if ( LL.eq.L ) cycle
if ( kn(1,LL).eq.k1 .or. kn(2,LL).eq.k1 ) L1R = LL
if ( kn(1,LL).eq.k2 .or. kn(2,LL).eq.k2 ) L2R = LL
end do
! change cells
! orientation, i.e. clockwise vs. counterclockwise, not sorted out here
! tiangles only
netcell(icellL)%nod(1:3) = (/ kL, kR, k1 /)
netcell(icellL)%lin(1:3) = (/ L, L1R, L1L /)
netcell(icellR)%nod(1:3) = (/ kL, kR, k2 /)
netcell(icellR)%lin(1:3) = (/ L, L2R, L2L /)
if ( lne(1,L1R).eq.icellR ) then
lne(1,L1R) = icellL
else
lne(2,L1R) = icellL
end if
if ( lne(1,L2L).eq.icellL ) then
lne(1,L2L) = icellR
else
lne(2,L2L) = icellR
end if
! update nmk
nmk(k1) = nmk(k1) - 1
nmk(k2) = nmk(k2) - 1
nmk(kL) = nmk(kL) + 1
nmk(kR) = nmk(kR) + 1
! update nod
! delete link from nod(k1)
kk=1; do while( nod(k1)%lin(kk).ne.L .and. kk.le.nmk(k1) ); kk=kk+1; end do
if ( nod(k1)%lin(kk).ne.L ) goto 1234
nod(k1)%lin(1:nmk(k1)) = (/ nod(k1)%lin(1:kk-1), nod(k1)%lin(kk+1:nmk(k1)+1) /)
call realloc(nod(k1)%lin,nmk(k1))
! delete link from nod(k2)
kk=1; do while( nod(k2)%lin(kk).ne.L .and. kk.le.nmk(k2) ); kk=kk+1; end do
if ( nod(k2)%lin(kk).ne.L ) goto 1234
nod(k2)%lin(1:nmk(k2)) = (/ nod(k2)%lin(1:kk-1), nod(k2)%lin(kk+1:nmk(k2)+1) /)
call realloc(nod(k2)%lin,nmk(k2))
! add link to nod(kL)
call realloc(nod(kL)%lin,nmk(kL))
nod(kL)%lin = (/ nod(kL)%lin(1:nmk(kL)-1), L /)
call sort_links_ccw(kL,maxlin,linnrs,arglin,inn)
! add link to nod(kR)
call realloc(nod(kR)%lin,nmk(kR))
nod(kR)%lin = (/ nod(kR)%lin(1:nmk(kR)-1), L /)
call sort_links_ccw(kR,maxlin,linnrs,arglin,inn)
! highlight new link
call teklink(L, ncolhl)
! ja = 1
! call confrm('continue', ja)
! if ( ja.eq.0 ) then
! exit it
! end if
end if
end do
! write(666,*) iter, numchanged, Etot, Emin
! if ( numchanged.eq.0 ) exit ! done
! Monte-Carlo
! if ( mod(iter, 1000) .eq. 0) then
! call orthogonalisenet(irerun)
! beta = beta * 1.1d0
! end if
! if ( Etot.lt.Emin ) then ! new minimum
! call setnodadm(0)
! call SAVENET()
! Emin = Etot
! end if
end do it
! Monte-Carlo: minimum
! if ( Etot.gt.Emin) then
! call restore()
! end if
if ( numchanged.ne.0 ) then ! not converged
call qnerror('fliplinks: not converged', ' ', ' ')
end if
1234 continue ! error handling
! deallocate
if ( allocated(inodemask) ) deallocate(inodemask)
if ( allocated(linnrs) ) deallocate(linnrs,arglin,inn)
! write(666, "('];')")
! close(666)
! update administration
call findcells(100) ! also find folded cells
call makenetnodescoding()
return
end subroutine fliplinks
!> sort flowlinks in nd%ln counterclockwise (copy-paste and modified from above)
subroutine sort_flowlinks_ccw()
use m_flowgeom, only: xz, yz, nd, Ndx, ln
use m_sferic
use m_alloc
use geometry_module, only: getdxdy, dcosphi, getdx, getdy
use sorting_algorithms, only: indexx
implicit none
integer :: k ! node number
integer :: maxlin ! array size
double precision, dimension(:), allocatable :: arglin ! dummy array
integer, dimension(:), allocatable :: linnrs, inn ! dummy arrays
integer :: k1, k2, L, LL
integer :: jDupLinks, jOverlapLinks, jSmallAng
double precision :: sl, sm, xcr, ycr, phi0
double precision :: phi, dx, dy, dmaxcosp, dcosp, costriangleminangle
integer :: lnxx
maxlin = 6
allocate(linnrs(maxlin), arglin(maxlin), inn(maxlin))
do k=1,Ndx
lnxx = nd(k)%lnx
if ( lnxx.le.1 ) cycle
if ( lnxx.gt.maxlin ) then
maxlin = lnxx
call realloc(linnrs, maxlin, keepExisting=.true.)
call realloc(arglin, maxlin, keepExisting=.true.)
call realloc(inn, maxlin, keepExisting=.true.)
end if
do L=1,lnxx
K1 = ln(1,iabs(nd(K)%ln(L))); K2 = ln(2,iabs(nd(K)%ln(L)))
if (K2 == K) then
K2 = K1
K1 = K
end if
call getdxdy(xz(k1), yz(k1), xz(k2), yz(k2),dx,dy,jsferic)
if (abs(dx) < 1d-14 .and. abs(dy) < 1d-14) then
if (dy < 0) then
phi = -pi/2
else
phi = pi/2
end if
else
phi = atan2(dy, dx)
end if
if ( L.eq.1 ) then
phi0 = phi
end if
arglin(L) = phi-phi0
if ( arglin(L).lt.0d0 ) arglin(L) = arglin(L) + 2d0*pi
end do
call indexx(lnxx, arglin(1:lnxx), inn(1:lnxx))
linnrs(1:lnxx) = nd(k)%ln(1:lnxx)
do L=1,lnxx
nd(k)%ln(L) = linnrs(inn(L))
end do
end do ! do k=1,Ndx
if ( allocated(linnrs) ) deallocate(linnrs)
if ( allocated(arglin) ) deallocate(arglin)
if ( allocated(inn) ) deallocate(inn)
return
end subroutine sort_flowlinks_ccw
!> compute change in topology functional and get the nodes and cells involved
subroutine comp_ntopo(L, jalandbound, k1, k2, kL, kR, icellL, icellR, ntopo)
use m_netw
use m_alloc
use m_missing
implicit none
integer, intent(in) :: L !< link number
integer, intent(in) :: jalandbound !< take land boundary into account
integer, intent(out) :: k1, k2, kL, kR !< nodes involved
integer, intent(out) :: icellL, icellR !< cells involved
integer, intent(out) :: ntopo !< change in topology functional
integer :: k, kk
integer :: n1, n2, nL, nR
integer :: n1L, n1R, n2L, n2R, nL1, nL2, nR1, nR2
integer, dimension(4) :: nopt, nnow, naft !< optimal and before and after flip
logical :: Lproceed
! integer, parameter :: IMISS = -999
integer, external :: nmk_opt
! debug
! if ( allocated(zk) ) deallocate(zk)
! call realloc(zk, numk)
! zk = 0d0
ntopo = 0
k1 = 0
k2 = 0
kL = 0
kR = 0
! get the begin and end node of link L
k1 = kn(1,L)
k2 = kn(2,L)
if ( lnn(L).ne.2 ) goto 1234 ! inner links only
icellL = lne(1,L)
icellR = lne(2,L)
if ( netcell(icellL)%N.ne.3 .or. netcell(icellR)%N.ne.3 ) goto 1234 ! triangles only
! find the nodes that are connected to both k1 and k2
kL = sum(netcell(icellL)%nod(1:3)) - k1 - k2
kR = sum(netcell(icellR)%nod(1:3)) - k1 - k2
if ( kL.lt.1 .or. kR.lt.1 ) goto 1234
! check if right nodes were found
! this might not be the case when the cell administration is out of date
Lproceed = .false.
do k=1,netcell(icellL)%N
if ( netcell(icellL)%nod(k).eq.kL ) then
Lproceed = .true.
exit
end if
end do
if ( .not.Lproceed ) goto 1234
Lproceed = .false.
do k=1,netcell(icellR)%N
if ( netcell(icellR)%nod(k).eq.kR ) then
Lproceed = .true.
exit
end if
end do
if ( .not.Lproceed ) goto 1234
! compute the change in functional
n1 = nmk(k1)- nmk_opt(k1)
n2 = nmk(k2)- nmk_opt(k2)
nL = nmk(kL)- nmk_opt(kL)
nR = nmk(kR)- nmk_opt(kR)
ntopo = (n1-1)**2 + (n2-1)**2 + (nL+1)**2 + (nR+1)**2 - &
(n1**2+n2**2 + nL**2 + nR**2)
if ( jalandbound.eq.1 ) then
! take land boundary into account
if ( lanseg_map(k1).gt.0 .and. lanseg_map(k2).gt.0 ) then
! link is associated with a land boundary -> keep it
ntopo = 1000
else
call comp_nnow(k1,k2,kL,n1L)
call comp_nnow(k1,k2,kR,n1R)
call comp_nnow(k2,k1,kL,n2R)
call comp_nnow(k2,k1,kR,n2L)
call comp_nnow(kL,k1,k2,nL)
call comp_nnow(kR,k1,k2,nR)
ntopo = (n1L-1)**2 + (n1R-1)**2 + (n2L-1)**2 + (n2R-1)**2 + 2d0*((nL+1)**2 + (nR+1)**2) - &
(n1L**2 + n1R**2 + n2L**2 + n2R**2 + 2d0*(nL**2 + nR**2) )
if ( n1L.ne.n1R .or. n2L.ne.n2R ) then
continue
end if
end if
end if
1234 continue
return
end subroutine comp_ntopo
!> compute the difference with the optimal number of links by counting the numbers of links that:
!> connect nodes k1 and k2, and
!> are at the same side of the land boundary path through node k, or
!> are on the land boundary path
subroutine comp_nnow(k,k1in,k2in,n)
use m_netw
use m_landboundary
implicit none
integer, intent(in) :: k !< center node
integer, intent(in) :: k1in, k2in !< connected nodes
integer, intent(out) :: n !< difference from optimum
integer :: num !< number of links at one side of the path
integer :: numopt !< optimal number of links
integer :: k1, k2
integer :: kother
integer :: kk, kk1, kk2
integer :: L, Lp1, Lp2
logical :: Lfound
integer, external :: nmk_opt
logical, external :: rechtsaf_active
if ( lanseg_map(k).lt.1 ) then
n = nmk(k)-nmk_opt(k)
return
end if
! links connected to k1 and k2 need to be counterclockwise
if ( rechtsaf_active(k, k1in, k2in ) ) then
k1 = k2in
k2 = k1in
else
k1 = k1in
k2 = k2in
end if
num = 0
numopt = 0
n = 0
Lp1 = 0 ! first link in path
Lp2 = 0 ! second link in path
! find the link that connects node k1
Lfound = .false.
do kk=1,nmk(k)
L = nod(k)%lin(kk)
if ( kn(1,L).eq.k1 .or. kn(2,L).eq.k1 ) then
kk1 = kk
Lfound = .true.
exit
end if
end do
if ( .not.Lfound ) goto 1234
if ( kn(1,L).ne.k .and. kn(2,L).ne.k ) then ! something wrong
goto 1234
end if
! find the link that connects node k2
Lfound = .false.
do kk=1,nmk(k)
L = nod(k)%lin(kk)
if ( kn(1,L).eq.k2 .or. kn(2,L).eq.k2 ) then
kk2 = kk
Lfound = .true.
exit
end if
end do
if ( .not.Lfound ) goto 1234
if ( kn(1,L).ne.k .and. kn(2,L).ne.k ) then ! something wrong
goto 1234
end if
! start counting
! count the numbers of links clockwise from the one connecting k1 that are not in a land/net boundary path
kk=kk1
L = nod(k)%lin(kk)
kother = kn(1,L)+kn(2,L)-k
num = 1
do while ( lanseg_map(kother).lt.1 .and. kk.ne.kk2 .and. lnn(L).gt.1 )
kk=kk-1
if ( kk.lt.1 ) kk=kk+nmk(k)
L = nod(k)%lin(kk)
kother = kn(1,L)+kn(2,L)-k
num = num+1
end do
if ( lanseg_map(kother).gt.0 .or. lnn(L).lt.2 ) Lp1 = L ! first link in path
! if not all links are visited, count counterclockwise from the one connecting k2
if ( kk.ne.kk2 ) then
kk=kk2
L = nod(k)%lin(kk)
kother = kn(1,L)+kn(2,L)-k
num = num+1
do while( lanseg_map(kother).lt.1 .and. kk.ne.kk1 .and. L.ne.Lp1 .and. lnn(L).gt.1)
kk=kk+1
if ( kk.gt.nmk(k) ) kk=kk-nmk(k)
L = nod(k)%lin(kk)
kother = kn(1,L)+kn(2,L)-k
if ( kk.ne.kk1 .and. L.ne.Lp1 ) num = num+1 ! kk1 already visited
end do
if ( (lanseg_map(kother).gt.0 .or. lnn(L).lt.2) .and. L.ne.lp1 ) Lp2 = L ! second link in path
end if
if ( num.gt.nmk(k) ) then ! should not happen
call qnerror('comp_nnow: num>nmk', ' ', ' ')
end if
if ( Lp1.gt.0 .and. Lp2.gt.0 ) then ! internal boundary
numopt = 4
else
numopt = 6
end if
n = num-numopt
return
1234 continue
return
end subroutine comp_nnow
!> determine optimum nmk in fliplinks, depending on link L
integer function nmk_opt(k)
use m_netw
implicit none
integer, intent(in) :: k !< node number
! default value
nmk_opt = 6
if( nb(k) .eq. 2 ) nmk_opt = 4
if( nb(k) .eq. 3 ) nmk_opt = 3
return
end function nmk_opt
!> sort per-node link administration (nod()%lin), based on connectivity
subroutine sortlinks()
use m_netw
use m_inverse_map
use unstruc_colors
implicit none
integer :: k0 ! node number
integer :: k, k1, k2, knext
integer :: kk
integer :: L1, L2
integer :: N, Ncell
integer :: i1, i2
integer :: numerror ! number of nodes with errors
numerror = 0
! integer, allocatable, dimension(:) :: kmask(:)
! allocate(kmask(numk))
! kmask = 0
!
! do k=nump_firstrun+1,nump
! Ncell = netcell(k)%N
! do kk=1,Ncell
! k0 = netcell(k)%nod(kk)
k0lp:do k0=1,numk
! if ( kmask(k0).ne.0 ) cycle ! already visited
N = nmk(k0)
do k1=1,N-1 ! loop over the links and reorder the remaining links
L1 = nod(k0)%lin(k1)
knext = 0 ! next link
! 1D-links are fine: proceed ! is .or. necessary? all 1D has lnn==0
if ( lnn(L1).lt.1 .or. kn(3,L1).eq.1 .or. kn(3,L1).eq.3 .or. kn(3,L1).eq.4 .or. kn(3,L1).eq.5 .or. kn(3,L1).eq.6 .or. kn(3,L1).eq.7 ) cycle
! find the next link
! first try to find a link with a common cell
i1 = min(lnn(L1), 2)
do k2=k1+1,N ! loop over remaining links
L2 = nod(k0)%lin(k2)
if ( lnn(L2).lt.1 .or. kn(3,L2).eq.1 .or. kn(3,L2).eq.3 .or. kn(3,L2).eq.4 .or. kn(3,L1).eq.5 .or. kn(3,L1).eq.6 .or. kn(3,L1).eq.7 ) cycle ! 1D-link
i2 = min(lnn(L2), 2)
if ( i2.lt.1 ) then
continue
end if
if ( lne( 1,L1).eq.lne(1,L2) .or. lne( 1,L1).eq.lne(i2,L2) .or. &
lne(i1,L1).eq.lne(1,L2) .or. lne(i1,L1).eq.lne(i2,L2) ) then
! next link found
knext = k2
exit
end if
end do
if ( k1.eq.1 .and. knext.eq.N .and. N.gt.2 ) then ! wrong direction
knext = 0
L2 = 0
end if
! if no next link bounding a common cell is found: find next non-internal link
if ( knext.eq.0 ) then
if ( lnn(L1).eq.2 ) then
! call qnerror('sortlinks: error', ' ', ' ')
! goto 1234
else
! find next non-internal link
do k2=k1+1,N
L2 = nod(k0)%lin(k2)
if ( lnn(L2).lt.2 .or. kn(3,L2).eq.1 .or. kn(3,L2).eq.3 .or. kn(3,L2).eq.4 ) then ! .or. kn(3,L1).eq.5 .or. kn(3,L1).eq.6 .or. kn(3,L1).eq.7) then ! found
knext = k2
exit
end if
end do
end if
end if
if ( knext.eq.0 ) then ! no next link found
! error: deactivate node
kc(k0) = 0
numerror = numerror + 1
call cirr(xk(k0), yk(k0), ncolhl)
cycle k0lp
end if
! swap links
if ( nod(k0)%lin(k1+1).ne.L2 ) then ! fold
nod(k0)%lin(k1+2:knext) = nod(k0)%lin(k1+1:knext-1)
nod(k0)%lin(k1+1) = L2
end if
end do
! ! mask node
! kmask(k0) = 1
!
! end do
end do k0lp
1234 continue
if ( numerror.gt.0 ) then
call qnerror('sortlinks: unrecoverable folds', ' ', ' ')
end if
! if ( allocated(kmask) ) deallocate(kmask)
end subroutine sortlinks
!> convert quadrilaterals, pentagons and hexagons to triangles
subroutine triangulate_cells()
use m_netw
use m_inverse_map
use unstruc_colors
implicit none
integer :: k, k0, k1, kk, Lnew, N
do k=1,nump ! loop over the cells
N = netcell(k)%n
if ( N.lt.4 ) cycle
! make the triangles by connecting the 3rd, 4th, etc. node to the first one
k0 = netcell(k)%nod(1)
do kk=3,N-1
k1 = netcell(k)%nod(kk)
call newlink(k0, k1, Lnew)
end do
end do
end subroutine triangulate_cells
!> netcell-based cell-coarsening information
double precision function coarsening_info(k)
use m_netw
use m_missing
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use gridoperations
implicit none
integer :: k !< netcell number
integer, parameter :: NMAX = 100 !< maximum of directly or indirectly connected netcells
integer :: ndirect, nindirect
integer, dimension(NMAX) :: kdirect, kindirect
integer, dimension(2,nmax) :: kne
double precision :: xc, yc
double precision :: area, area_tot, Darea
double precision :: funct
double precision :: area_opt = 1d5
integer :: kk
coarsening_info = DMISS
call find_surrounding_cells(k, NMAX, ndirect, nindirect, kdirect, kindirect, kne)
if ( ndirect.lt.1 .or. nindirect.lt.1 ) return
area_tot = 0d0
funct = 0d0
call getcellsurface(k,area,xc,yc)
area_tot = area_tot + area
funct = funct - (area-area_opt)**2
do kk=1,ndirect
call getcellsurface(kdirect(kk),area,xc,yc)
area_tot = area_tot + area
funct = funct - (area-area_opt)**2
end do
! compute the area increase of the indirectly connected cells
Darea = area_tot / dble(nindirect)
! compute the change in the functional
do kk=1,nindirect
call getcellsurface(kindirect(kk),area,xc,yc)
funct = funct - (area-area_opt)**2
area = area + Darea
funct = funct + (area-area_opt)**2
end do
coarsening_info = -funct
if ( coarsening_info.le.0d0 ) coarsening_info = DMISS
return
end function
!> find cells that are directly and indirectly connected to cell k
subroutine find_surrounding_cells(kcell, nmax, ndirect, nindirect, kdirect, kindirect, kne)
use m_netw
implicit none
integer, intent(in) :: kcell !< cell number
integer, intent(in) :: nmax !< array size
integer, intent(out) :: ndirect !< number of directly connected cells (=netcell()%N)
integer, intent(out) :: nindirect !< number of indirectly connected cells
integer, dimension(nmax), intent(out) :: kdirect !< directly connected cells
integer, dimension(nmax), intent(out) :: kindirect !< indirectly connected cells
integer, dimension(2,nmax), intent(out) :: kne !< two indirectly connected cells that are adjacent to a directly connected cell
integer :: nneighbors
integer :: i, j, kk, kkk, kkkk, kcell1, kcell2, k1, L
ndirect = 0
kdirect = 0
nindirect = 0
kindirect = 0
kne = 0
! find the directly connected cells
kklp:do kk=1,netcell(kcell)%N
L = netcell(kcell)%lin(kk)
if ( lnn(L).lt.2 ) cycle
kcell2 = lne(1,L) + lne(2,L) - kcell ! other cell
! check and see if the cell is already administered
do kkk=1,ndirect
if ( kcell2.eq.kdirect(kkk) ) cycle kklp
end do
ndirect = ndirect+1
if ( ndirect.gt.nmax ) then
ndirect = ndirect-1
call qnerror('find_surrounding_cells: array too small', ' ', ' ')
return
end if
kdirect(ndirect) = kcell2
end do kklp
! find the cells indirectly connected cells
do kk=1,netcell(kcell)%N
k1 = netcell(kcell)%nod(kk)
do kkk=1,nmk(k1)
L = nod(k1)%lin(kkk)
ilp:do i=1,lnn(L)
kcell2 = lne(i,L)
! check and see if the cell is new
if ( kcell2.eq.kcell ) cycle ilp
do kkkk=1,ndirect
if ( kcell2.eq.kdirect(kkkk) ) cycle ilp
end do
do kkkk=1,nindirect
if ( kcell2.eq.kindirect(kkkk) ) cycle ilp
end do
! add new cell
nindirect = nindirect + 1
if ( nindirect.gt.nmax ) then
nindirect = nindirect-1
call qnerror('find_surrounding_cells: array size too small', ' ', ' ')
return
end if
kindirect(nindirect) = kcell2
end do ilp
end do
end do
! find the adjacent cells
do i=1,ndirect
kcell1 = kdirect(i)
do j=1,netcell(kcell1)%N
L = netcell(kcell1)%lin(j)
if ( lnn(L).lt.2 ) cycle
kcell2 = lne(1,L) + lne(2,L) - kcell1
! check and see if this cell is administered
do kk=1,ndirect
if ( kdirect(kk).eq.kcell2 ) then
if ( kne(1,i).eq.0 ) then
kne(1,i) = -kcell2
kcell2 = -1234
else
kne(2,i) = -kcell2
kcell2 = -1234
end if
end if
end do
if ( kcell2.eq.-1234 ) cycle
do kk=1,nindirect
if ( kindirect(kk).eq.kcell2 ) then
if ( kne(1,i).eq.0 ) then
kne(1,i) = kcell2
else
kne(2,i) = kcell2
end if
end if
end do
end do
end do
return
end subroutine find_surrounding_cells
!> coarsen the net
subroutine coarsen_mesh()
use m_netw
use unstruc_colors, only: ncolhl
use sorting_algorithms, only: indexx
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use gridoperations
implicit none
integer, parameter :: NMAX=100 !< array size
integer :: ndirect !< number of directly connected cells
integer :: nindirect !< number of indirectly connected cells
integer, dimension(NMAX) :: kdirect !< directly connected cells, i.e. cells sharing a link with cell k
integer, dimension(NMAX) :: kindirect !< indirectly connected cells, i.e. cells sharing a node, but not a link, with cell k
integer, dimension(2,NMAX) :: kne !< left and right neighboring (in)direct cell that neighbors the directly connected cells
integer, dimension(:), allocatable :: kmask ! masking array
integer :: k, k_, kk, kkk, kkkk, k1, ja, N
! integer :: i, j, indx, isgn ! for sort_heap
integer, dimension(:), allocatable :: perm ! for sorting
! integer :: p1 ! for sort_heap
integer :: KEY ! for putget_un
integer :: iter
integer, parameter :: MAXITER = 1000
integer :: numchanged ! number of cells deleted
double precision, dimension(:), allocatable :: areas ! cell areas
double precision :: area, area_tot, Darea
double precision :: xc, yc, funct
double precision :: x, y ! for putget_un
double precision :: area_opt
logical :: Lstepbystep, Ldoit
Lstepbystep = .false.
! call findcells(100)
!
! call triangulate_cells()
call findcells(100)
call makenetnodescoding()
if ( nump.lt.1 ) return
iter = 0
numchanged = 1
do while ( iter.lt.MAXITER .and. numchanged.gt.0 )
numchanged = 0
allocate(kmask(nump))
kmask = 1
allocate(areas(nump), perm(nump))
areas = 0
! compute cell areas
do k=1,nump
call getcellsurface(k,areas(k),xc,yc)
end do
! determine order: smallest cells first
call indexx(nump, areas, perm)
! set optimal area as the average area
area_opt = sum(areas) / dble(nump)
k1 = 0
do k_=1,nump
k = perm(k_)
if ( kmask(k).eq.1 .and. netcell(k)%N.ge.3 ) then
Ldoit = .true.
else
Ldoit = .false.
end if
if ( Ldoit ) then
call find_surrounding_cells(k, NMAX, ndirect, nindirect, kdirect, kindirect, kne)
do kk=1,ndirect
if ( kmask(kdirect(kk)).ne.1 .or. netcell(kdirect(kk))%N.lt.3 ) then
Ldoit = .false.
exit
end if
end do
end if
if ( Ldoit) then
do kk=1,nindirect
if ( kmask(kindirect(kk)).ne.1 .or. netcell(kindirect(kk))%N.lt.3 ) then
Ldoit = .false.
exit
end if
end do
end if
if ( Ldoit ) then
area_tot = 0d0
funct = 0d0
call getcellsurface(k,area,xc,yc)
area_tot = area_tot + area
funct = funct - (area-area_opt)**2
do kk=1,ndirect
call getcellsurface(kdirect(kk),area,xc,yc)
area_tot = area_tot + area
funct = funct - (area-area_opt)**2
end do
! compute the area increase of the indirectly connected cells
if ( nindirect.gt.0 ) then
Darea = area_tot / dble(nindirect)
else
Darea = 0d0
end if
! compute the change in the functional
do kk=1,nindirect
call getcellsurface(kindirect(kk),area,xc,yc)
funct = funct - (area-area_opt)**2
area = area + Darea
funct = funct + (area-area_opt)**2
end do
! funct = -1d0
if ( funct.lt.0d0 ) then ! delete cell
! if (k.eq.395 ) then
if ( Lstepbystep ) then
! unhighlight mesh
if ( k1.ge.1 .and. k1.le.nump ) call teknode(k1,1)
! whipe out previous net image
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),211)
end do
end if
k1 = netcell(k)%nod(1) ! this node is kept
! delete the cell and update administration
call deletecell(k, ndirect, nindirect, kdirect, kindirect, kne, .false., ja)
if ( ja.eq.1 ) numchanged = numchanged+1
if ( Lstepbystep ) then
! new net image
if ( netcell(k)%N.eq.0 ) then ! cell removed: draw remaining node and links connected to it
call teknode(k1,ncolhl)
else ! cell not removed: draw whole cell and links connected to it
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),1)
end do
end if
end if
! deactive cells
kmask(k) = 0
kmask(kdirect(1:ndirect)) = 0
! kmask(kindirect(1:nindirect)) = 0
do kk=1,ndirect
kkk = kdirect(kk)
N = netcell(kkk)%N
if ( N.gt.0 ) then
xc = sum(xk(netcell(kkk)%nod(1:N))) / dble(N)
yc = sum(yk(netcell(kkk)%nod(1:N))) / dble(N)
call cirr(xc, yc, ncolhl)
end if
end do
! do kk=1,nindirect
! kkk = kindirect(kk)
! N = netcell(kkk)%N
! if ( N.gt.0 ) then
! xc = sum(xk(netcell(kkk)%nod(1:N))) / dble(N)
! yc = sum(yk(netcell(kkk)%nod(1:N))) / dble(N)
! call cirr(xc, yc, ncolhl)
! end if
! end do
end if
! user interface
if ( Lstepbystep ) then ! wait for key or mouse button press
call READLOCATOR(X,Y,KEY)
if ( key.eq.21 ) then
Lstepbystep = .not.Lstepbystep
else if ( key.eq.22 ) then
exit
end if
else !
call halt3(ja)
if ( ja.eq.1 ) then
Lstepbystep = .true.
else if ( ja.eq.3 ) then
exit
end if
end if
! else
! N = netcell(k)%N
! if ( N.gt.0 ) then
! xc = sum(xk(netcell(k)%nod(1:N))) / dble(N)
! yc = sum(yk(netcell(k)%nod(1:N))) / dble(N)
! call cirr(xc, yc, ncolhl)
!
! if ( Lstepbystep ) then
!! call READLOCATOR(X,Y,KEY)
! end if
!
! end if
end if
end do
call inflush()
deallocate(kmask)
deallocate(areas, perm)
write(6,*) 'coarsen mesh: ', area_opt, iter, numchanged
end do
if ( Lstepbystep ) call READLOCATOR(X,Y,KEY)
return
end subroutine coarsen_mesh
!> delete cell and update administration (no direct need for findcells afterwards)
subroutine deletecell(k, ndirect, nindirect, kdirect, kindirect, kne, Lprompt_nogo, jadeleted)
use m_netw
use m_missing
use m_netstore
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol
use gridoperations
implicit none
integer, intent(in) :: k !< cell number
!
integer, intent(in) :: ndirect !< number of directly connected cells
integer, intent(in) :: nindirect !< number of indirectly connected cells
integer, dimension(ndirect), intent(in) :: kdirect !< directly connected cells, i.e. cells sharing a link with cell k
integer, dimension(nindirect), intent(in) :: kindirect !< indirectly connected cells, i.e. cells sharing a node, but not a link, with cell k
integer, dimension(2,ndirect), intent(in) :: kne !< left and right neighboring (in)direct cell that neighbors the directly connected cells
logical , intent(in) :: Lprompt_nogo !< prompt for cells that cannot be delete (.true.) or not (.false.)
integer , intent(out) :: jadeleted !< cell has been deleted (1) or not (0)
double precision :: xc, yc, fac, factot
integer :: k1, k2, kk, N, ja
integer :: i, iR, im1, in, j, jj, kcell, kcell1, kcell2, L, L1, L2
integer :: kcL, kcR, Ndum
integer :: klin, knod, num
integer :: isconvexcell
logical :: Lnogo
jadeleted = 0
if ( ndirect.lt.1 .or. nindirect.lt.1 ) return
! Firstly, check and see if
! the cell to be deleted is not a corner cell, but has a link that
! is internal and whose both nodes are marked as non-internal nodes
! return if so
Lnogo = .false.
kk = 0
do while ( .not.Lnogo .and. kk.lt.netcell(k)%N )
kk=kk+1
klin = netcell(k)%lin(kk)
if ( kn(1,klin).lt.1 .or. kn(2,klin).lt.1 ) then
Lnogo = .true.
exit
end if
if ( lnn(klin).eq.2 ) then
if ( nb(kn(1,klin)).ne.1 .and. nb(kn(2,klin)).ne.1 ) Lnogo = .true.
end if
end do
! check if the cell is a cornercell
kk = 0
do while ( kk.lt.netcell(k)%N .and. Lnogo)
kk=kk+1
knod = netcell(k)%nod(kk)
if ( nb(knod).eq.3 .and. nmk(knod).le.2 ) Lnogo = .false.
end do
! check if all nodes are in the selecting polygon
in = -1
do kk=1,netcell(k)%N
k1 = netcell(k)%nod(kk)
call dbpinpol(xk(k1), yk(k1), in, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.ne.1 ) then
Lnogo = .true.
exit
end if
end do
if ( Lnogo ) then
if ( Lprompt_nogo ) then
call confrm('It is advised not to remove this cell. Do you still want to remove this cell? ', ja)
else
ja = 0
end if
if ( ja.eq.0 ) then
jadeleted = 0
return
end if
end if
! if ( Lnogo ) goto 1234
! store the affected part of the network
call local_netstore( (/k, kdirect(1:ndirect), kindirect(1:nindirect)/))
! compute new node coordinates
N = netcell(k)%N
xc = 0d0
yc = 0d0
factot = 0d0
do kk=1,N
fac = 1d0
k1 = netcell(k)%nod(kk)
if ( nb(k1).eq.2 .or. nb(k1).eq.4 ) then
fac = 1d45
else if ( nb(k1).eq.3 ) then
factot = 1d0
xc = xk(k1)
yc = yk(k1)
exit
end if
xc = xc + fac*xk(k1)
yc = yc + fac*yk(k1)
factot = factot + fac
end do
xc = xc/factot
yc = yc/factot
! move nodes
xk(netcell(k)%nod(1:N)) = xc
yk(netcell(k)%nod(1:N)) = yc
! alter directly connected cells
do kk=1,ndirect
kcell1 = kdirect(kk)
if ( netcell(kcell1)%N.lt.4 ) then
! remove boundary link of directly connected cell
do j=1,netcell(kcell1)%N
L = netcell(kcell1)%lin(j)
! if ( lnn(L).lt.2 ) kn(1:2,L) = 0
if ( lnn(L).lt.2 ) call cleanup_link(L)
end do
! find adjacent direct neighbors
L1 = 0
do i=1,2
kcL = kne(i,kk)
if ( kcL.eq.0 ) cycle
iR = i+1; if ( iR.gt.2 ) iR=iR-2
kcR = kne(iR,kk)
if ( kcL.lt.0 .or. kcR.lt.0 ) then
! call qnerror('deletecell: kcL<0 | kcR<0', ' ', ' ')
cycle
end if
! find the common link
do j=1,netcell(kcL)%N
L = netcell(kcL)%lin(j)
if ( lnn(L).lt.2 ) cycle
if ( lne(1,L).eq.kcell1 .and. lne(2,L).eq.kcL )then
if ( kcR.ne.0 ) then
lne(1,L) = kcR
else
lne(1,L) = lne(2,L)
lne(2,L) = 0
lnn(L) = 1
end if
exit
elseif ( lne(2,L).eq.kcell1 .and. lne(1,L).eq.kcL )then
if ( kcR.ne.0 ) then
lne(2,L) = kcR
else
lne(2,L) = 0
lnn(L) = 1
end if
exit
end if
end do
if ( L1.ne.0 ) then
netcell(kcL)%lin(j) = L1
call cleanup_link(L)
end if
L1=L
end do
! deactivate cell
netcell(kcell1)%N = 0
else
! polygons of degree higher than three: remove node and link
do j=1,netcell(kcell1)%N
L = netcell(kcell1)%lin(j)
if ( lnn(L).lt.2 ) cycle
if ( lne(1,L).eq.k .or. lne(2,L).eq.k ) then
Ndum = netcell(kcell1)%N - 1
netcell(kcell1)%lin(j:Ndum) = netcell(kcell1)%lin(j+1:Ndum+1)
! remove one node per removed link
! take the first node that has not been removed before, but not the node that is kept, which is the first of the center cell
i = 1
do while ( netcell(kcell1)%nod(i).ne.kn(1,L) .and. netcell(kcell1)%nod(i).ne.kn(2,L) .and. &
i.lt.netcell(kcell1)%N .and. netcell(kcell1)%nod(i).ne.netcell(k)%nod(1) ); i = i+1; end do
if ( kk.le.netcell(kcell1)%N ) then
netcell(kcell1)%nod(i:Ndum) = netcell(kcell1)%nod(i+1:Ndum+1)
else
call qnerror('coarsen_mesh: no node found', ' ', ' ')
end if
netcell(kcell1)%N = Ndum
end if
end do
end if
end do
! set the node code
k1 = netcell(k)%nod(1)
nb(k1) = maxval(nb(netcell(k)%nod))
! merge nodes
xk(k1) = xc
yk(k1) = yc
do kk=2,N
call mergenodes(netcell(k)%nod(kk),k1,ja)
end do
! redirect nodes of indirectly connected cells, deactivate polygons of degree smaller than three and
! remove unwanted boundary node
do kk=1,nindirect
kcell = kindirect(kk)
if ( netcell(kcell)%N.lt.3 ) netcell(kcell)%N=0 ! deactivate
do i=1,netcell(kcell)%N
k2 = netcell(kcell)%nod(i)
L = netcell(kcell)%lin(i)
do j=2,netcell(k)%N
if ( k2.eq.netcell(k)%nod(j) ) then
netcell(kcell)%nod(i) = k1
end if
end do
end do
end do
! remove unwanted boundary node: a non-corner node that is shared by two boundary links
in = -1
kklp:do kk=1,nindirect
kcell = kindirect(kk)
if ( netcell(kcell)%N.lt.3 ) netcell(kcell)%N=0 ! deactivate
do i=1,netcell(kcell)%N
k2 = netcell(kcell)%nod(i)
L = netcell(kcell)%lin(i)
if ( lnn(L).eq.1 ) then
im1 = i-1; if (im1.lt.1) im1=im1+netcell(kcell)%N
L1 = netcell(kcell)%lin(im1)
if ( lnn(L1).eq.1 ) then
call find_common_node(L,L1,k2)
if ( k2.lt.1 ) then ! weird
cycle
end if
! this node may be outside polygon: ignore
call dbpinpol(xk(k2),yk(k2),in, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( nb(k2).ne.3 .and. in.eq.1 ) then ! not a corner node
! remove node and link
N = netcell(kcell)%N
if ( N.gt.3 ) then ! polynomials of degree higher than three
netcell(kcell)%nod(i:N-1) = netcell(kcell)%nod(i+1:N)
netcell(kcell)%lin(i:N-1) = netcell(kcell)%lin(i+1:N)
netcell(kcell)%N = N-1
! redirect node of the link that is kept
if ( kn(1,L1).eq.k2 ) then
kn(1,L1) = kn(1,L)+kn(2,L)-k2
else
kn(2,L1) = kn(1,L)+kn(2,L)-k2
end if
! delete other link
call cleanup_link(L)
! delete node
xk(k2) = dmiss
yk(k2) = dmiss
cycle kklp
else ! triangles: completely remove
netcell(kcell)%N = 0
call cleanup_link(L)
call cleanup_link(L1)
L2 = sum(netcell(kcell)%lin(1:3))-L-L1
if ( lnn(L2).gt.1 ) then
if ( lne(1,L2).eq.kcell ) then
lnn(L2) = 1
lne(1,L2) = lne(2,L2)
elseif( lne(2,L2).eq.kcell ) then
lnn(L2) = 1
end if
end if
cycle kklp
end if
end if
end if
end if
end do
end do kklp
! redirect nodes of directly connected cells and deactivate polygons of degree smaller than three
do kk=1,ndirect
kcell = kdirect(kk)
if ( netcell(kcell)%N.lt.3 ) netcell(kcell)%N=0 ! deactivate
do i=1,netcell(kcell)%N
k2 = netcell(kcell)%nod(i)
L = netcell(kcell)%lin(i)
do j=2,netcell(k)%N
if ( k2.eq.netcell(k)%nod(j) ) then
netcell(kcell)%nod(i) = k1
end if
end do
end do
end do
! deactivate links
do kk=1,netcell(k)%N
L = netcell(k)%lin(kk)
call cleanup_link(L)
end do
! deactivate cell
netcell(k)%N = 0
jadeleted = 1
1234 continue
if ( .not.Lnogo ) then
! check and see if
! the altered indirectly connected cells are non convex
! restore and return if so
! check convexity
Lnogo = .false.
kk = 0
do while ( kk.lt.nindirect .and. .not.Lnogo )
kk = kk+1
if ( isconvexcell(kindirect(kk)).eq.0 ) Lnogo = .true.
end do
if ( Lnogo ) then
if ( Lprompt_nogo ) then
call confrm('It is advised not to remove this cell. Do you still want to remove this cell? ', ja)
else
ja = 0
end if
if ( ja.eq.0 ) then
! restore
call local_netrestore()
jadeleted = 0
return
end if
end if
end if
return
contains
!> clean up nod%lin and nmk for nodes comprising a deleted link
subroutine cleanup_link(L)
implicit none
integer :: L !< link number
integer :: i, j, k, N
! clean up nod%lin and nmk
do i=1,2
k = kn(i,L)
if ( k.lt.1 ) cycle ! already cleaned up
if (.not.allocated(nod(k)%lin) ) cycle
N = nmk(k)
! find link position in nod%lin array
j=1
do while ( nod(k)%lin(j).ne.L .and. j.lt.N ); j=j+1; end do
if ( nod(k)%lin(j).ne.L ) then
call qnerror('cleanup_nod: link not found', ' ', ' ')
netstat = NETSTAT_CELLS_DIRTY
return
end if
! clean up
if ( j.lt.N ) then
nod(k)%lin(j:N-1) = nod(k)%lin(j+1:N)
end if
nmk(k) = nmk(k)-1
end do
kn(:,L) = 0
return
end subroutine cleanup_link
end subroutine deletecell
!> delete cell by merging all its nodes and update administration
subroutine killcell(xp,yp)
use m_netw
use m_missing, only: dmiss, jins
use geometry_module, only: pinpok
use gridoperations
implicit none
double precision, intent(in) :: xp, yp !< coordinates of input point
integer, parameter :: NMAX=100 !< array size
integer :: ndirect !< number of directly connected cells
integer :: nindirect !< number of indirectly connected cells
integer, dimension(NMAX) :: kdirect !< directly connected cells, i.e. cells sharing a link with cell k
integer, dimension(NMAX) :: kindirect !< indirectly connected cells, i.e. cells sharing a node, but not a link, with cell k
integer, dimension(2,NMAX) :: kne !< left and right neighboring (in)direct cell that neighbors the directly connected cells
integer :: k, kk, k1
integer :: in, ja
integer, save :: NEEDFINDCELLS=1
if ( nump.lt.1 ) NEEDFINDCELLS=1
if ( NEEDFINDCELLS /= 0 .or. netstat /= NETSTAT_OK ) then
call findcells(100)
call makenetnodescoding()
NEEDFINDCELLS = 0
end if
! find the cell
in = 0
do k = 1,nump
if ( netcell(k)%N.lt.1 ) cycle
call pinpok(xp, yp, netcell(k)%N, xk(netcell(k)%nod), yk(netcell(k)%nod), in, jins, dmiss)
if ( in.gt.0 ) exit
end do
if ( in.eq.0 ) then ! no cell found
call qnerror('killcell: no cell found', ' ', ' ')
return
end if
! write(6,*) 'Cell ', k, 'N=', netcell(k)%N
! get the connected cells
call find_surrounding_cells(k, NMAX, ndirect, nindirect, kdirect, kindirect, kne)
! whipe out previous net image
! call teknet(0,ja)
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),0)
end do
! delete cell and update administration
k1 = netcell(k)%nod(1)
call deletecell(k, ndirect, nindirect, kdirect, kindirect, kne, .true., ja)
! call pfiller(xk(netcell(k)%nod), yk(netcell(k)%nod), netcell(k)%N, ncolhl, 30)
! call teknet(ncolhl,ja)
if ( netcell(k)%N.eq.0 ) then ! cell removed: draw remaining node and links connected to it
call teknode(k1,1)
else ! cell not removed: draw whole cell and links connected to it
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),1)
end do
end if
return
end subroutine killcell
!> check and see if the cell is convex (1) or not (0)
integer function isconvexcell(k)
use m_netw
use geometry_module, only: dcosphi
use m_sferic, only: jsferic, jasfer3D
use m_missing, only : dxymis
use gridoperations
implicit none
integer, intent(in) :: k !< cell number
integer :: i, j, ip1, ip2, N
integer :: k1, k2, k3
! integer :: L
double precision :: cosphi
double precision, parameter :: TOL=0d-2
isconvexcell = 1
N = netcell(k)%N
do i=1,N
ip1 = i+1; if ( ip1.gt.N ) ip1 = ip1-N
ip2 = i+2; if ( ip2.gt.N ) ip2 = ip2-N
k1 = netcell(k)%nod(i)
k2 = netcell(k)%nod(ip1)
k3 = netcell(k)%nod(ip2)
cosphi = dcosphi(xk(k1),yk(k1),xk(k2),yk(k2),xk(k2),yk(k2),xk(k3),yk(k3), jsferic, jasfer3D, dxymis)
! if ( abs(cosphi).lt.TOL .or. abs(1d0-abs(cosphi)).lt.TOL ) cycle
if ( abs(1d0-abs(cosphi)).lt.TOL ) cycle
! check counterclockwise
if ( rechtsaf(k1,k2,k3) ) then
isconvexcell = 0
exit
end if
end do
return
end function isconvexcell
!> find meshline nearest to land boundary
subroutine find_nearest_meshline(jasnap)
use m_netw
use m_landboundary
use m_missing
use m_alloc
use m_missing
implicit none
integer :: jasnap !< same as japroject
integer :: netboundonly ! consider only the net boundary (1) or not (0)
integer, dimension(:), allocatable :: nodemask, linkmask ! note that cellmask is in module
integer, dimension(:), allocatable :: klink ! link connected to the node in the shortest path
double precision, dimension(:), allocatable :: dismin ! minimum distance to whole land boundary
! integer, parameter :: maxnodes=100 ! in connect_boundary_paths: large enough, depends on DCLOSE
integer :: numnodes ! in connect_boundary_paths: number of nodes found so far
integer, dimension(:), allocatable :: nodelist ! in connect_boundary_paths: nodes found so far
integer :: MXLAN_sav
integer :: i, k, k_, L, N, in, ja
integer :: numseg ! land boundary segment number
integer :: jstart, jend, jstart1
integer :: kstart, kend ! start and end node resp.
integer :: kk, knode
integer :: j, j_prev, jstart_prev, jend_prev, numseg_prev
integer :: num, numrejected, numcellsmasked, maskdepth
integer :: ierr
double precision :: xp, yp
double precision :: xn, yn, ddis, rL, ddismin ! in toland
double precision :: xn_prev, yn_prev, ddis_prev, rL_prev
! integer, parameter :: IMISS = -999
double precision, parameter :: DISNEAREST = 2d0
logical, parameter :: LMASK = .true.
logical, parameter :: LDEBUG = .false.
! save MXLAN
MXLAN_sav = MXLAN
! set netboundonly
if ( jasnap.eq.2 .or. jasnap.eq.3 ) then
netboundonly = 1
else
netboundonly = 0
end if
! set the close-to-landboundary tolerance, measured in meshwidths
if ( netboundonly.ne.1 ) then
DCLOSE = DCLOSE_whole
else
DCLOSE = DCLOSE_bound
end if
call admin_landboundary_segments()
! allocate arrays
if ( allocated(cellmask) ) deallocate(cellmask)
allocate(nodemask(numk), linkmask(numL), cellmask(nump), klink(numk), stat=ierr)
if ( allocated(lanseg_map) ) deallocate(lanseg_map)
allocate(lanseg_map(numk))
lanseg_map = 0
allocate(dismin(numk))
allocate(nodelist(1))
! nodemask = IMISS ! not necessary
! linkmask = IMISS ! not necessary, appears in masknodes
! cellmask = IMISS ! not necessary, appears in masknodes
dismin = DMISS ! necessary
! loop over the segments of the land boundary
! the segments are from jstart to jend
do numseg=1,Nlanseg
call make_path(numseg, num, numrejected)
if ( netboundonly.eq.1 .and. jasnap.eq.3 .and. &
! numrejected.gt.num .and. numrejected.gt.2 ) then ! num.lt.2 gives problems
numrejected.gt.0 ) then
! land boundary is an internal land boundary -> snap to it
netboundonly = 0
DCLOSE = DCLOSE_whole
call make_path(numseg, num, numrejected)
! restore setting
netboundonly = 1
DCLOSE = DCLOSE_bound
end if
end do
! make the connection between boundary paths
if ( netboundonly.eq.1 ) then
do L=1,numL
if ( lnn(L).eq.1 ) then
if ( .not.allocated(nodelist) ) then ! safety
allocate(nodelist(1))
numnodes = 1
end if
call connect_boundary_paths(L, nodemask, 1, numnodes, nodelist)
end if
end do
end if
! error handling, memory deallocation and return
1234 continue
! deallocate
deallocate(nodemask, linkmask, cellmask, klink, dismin, nodelist)
! set actual MXLAN
MXLAN_loc = MXLAN
! restore MXLAN
MXLAN = MXLAN_sav
return
contains
!> make path for land boundary segment
subroutine make_path(numseg, num, numrejected)
use unstruc_colors, only: ncolhl
implicit none
integer, intent(in) :: numseg !< land boundary segment number
integer, intent(out) :: num !< number of nodes in path
integer, intent(out) :: numrejected !< number of rejected nodes
integer :: numpart ! number of connected nodes
integer :: klast, numseglast ! remember last added node
logical :: Lstopped ! the path has been temporarily stopped (.true.) or not (.false.)
! initialize
num = 0
numpart = 0
numrejected = 0
! find jstart and jend of landboundary segment
jstart = lanseg_startend(1,numseg)
jend = lanseg_startend(2,numseg)
! set the outer land boundary points
jleft = jend-1
jright = jstart
rLleft = 1d0
rLright = 0d0
if ( jstart.lt.1 .or. jstart.gt.MXLAN .or. jstart.gt.jend ) return
call masknodes(numseg) ! will set jleft, jright, rLleft and rLright
! write(6,*) numseg, jstart, jend, jleft, jright, rLleft, rLright
if ( LDEBUG ) then
do k=1,numk
if ( nodemask(k).eq.numseg ) then
call cirr(xk(k),yk(k),212)
end if
end do
end if
! find start- and endnode
! call get_kstartend(jstart,jend,kstart,kend) ! will use jleft, jright, rLleft and rLright
call get_kstartend2(jstart,jend,kstart,kend) ! will use jleft, jright, rLleft and rLright
if ( kstart.lt.1 .or. kend.lt.1 ) goto 1234 ! no start and/or end node found
if ( kstart.eq.kend ) goto 1234 ! no path can be found
call cirr(xk(kstart),yk(kstart),191)
call cirr(xk(kend), yk(kend), 191)
if ( Ldebug ) then
write(6,*) numseg, kstart, kend
end if
! shortest path
call shortest_path(numseg, jstart, jend, kstart, nodemask, netboundonly, klink)
! construct path from end to start node
k = kend
numseglast = lanseg_map(k)
klast = 0
do
! klast = k
! numseglast = lanseg_map(k)
Lstopped = .true.
! fill the node-to-boundary-segment-map array
if ( lanseg_map(k).gt.0 ) then ! netboundsonly check not necessary
! multiple boundary segments: take the nearest
numseg_prev = lanseg_map(k)
jstart_prev = lanseg_startend(1,numseg_prev)
jend_prev = lanseg_startend(2,numseg_prev)
call toland(xk(k),yk(k),jstart_prev,jend_prev,0,xn_prev,yn_prev,ddis_prev,j_prev,rL_prev)
call toland(xk(k),yk(k),jstart, jend, 0,xn, yn, ddis, j, rL)
ddismin = dismin(k)
if ( ddis.le.ddis_prev .and. ddis.le.DISNEAREST*ddismin ) then
Lstopped = .false.
! num = num+1
! numpart = numpart+1
! lanseg_map(k) = numseg
end if
else
! check if land boundary segment is not redicuously further than other parts of the land boundary
if ( dismin(k).eq.DMISS) then
call toland(xk(k),yk(k),1,MXLAN, 0, xn, yn, ddismin, j, rL)
dismin(k) = ddismin
else
ddismin = dismin(k)
end if
call toland(xk(k),yk(k),jstart,jend,0,xn,yn,ddis,j,rL)
if ( ddis.le.DISNEAREST*ddismin ) then
! check for netboundonly
if ( netboundonly.ne.1 .or. nb(k).eq.2 .or. nb(k).eq.3 ) then
Lstopped = .false.
! num = num+1
! numpart = numpart+1
! lanseg_map(k) = numseg
end if
end if
end if
if ( Lstopped ) then
! the path has been (temporarily) stopped
if ( numpart.eq.1 .and. numseglast.ne.0 ) then ! prevent one-node paths
lanseg_map(klast) = numseglast
end if
numpart = 0
numrejected = numrejected+1
else
klast = k
numseglast = lanseg_map(k)
num = num+1
numpart = numpart+1
lanseg_map(k) = numseg
end if
! prevent one-node-paths
! if ( Lstopped .and. numpart.eq.1 .and. klast.gt.0 ) then
! 25-05-12: lanseg_map may be reset to 0 for one-node-paths
if ( Lstopped .and. numpart.eq.1 ) then
lanseg_map(klast) = numseglast
end if
! exit if the start node is reached
if ( k.eq.kstart ) goto 1234
! proceed to the next node
L = klink(k)
if ( L.lt.1 .or. L.gt.numL ) exit
if ( netboundonly.eq.0 .or. lnn(L).eq.1 ) call teklink(L,ncolhl)
k = kn(1,L) + kn(2,L) - k
if ( k.lt.1 .or. k.gt.numk ) exit
end do
! plot landboundary segment
do j=jstart,jend-1
call movabs(xlan(j),ylan(j))
call clnabs(xlan(j+1),ylan(j+1),204)
end do
1234 continue
! prevent one-node-paths
if ( numpart.eq.1 ) then
lanseg_map(klast) = numseglast
end if
if ( LDEBUG ) then
! if ( num.gt.0 ) call qnerror(' ', ' ', ' ')
call qnerror(' ', ' ', ' ')
do k=1,numk
call cirr(xk(k),yk(k),0)
end do
! whipe out landboundary segment
do j=jstart,jend-1
call movabs(xlan(j),ylan(j))
call clnabs(xlan(j+1),ylan(j+1),0)
end do
ja = 0
!call teknet(1,ja)
end if
return
end subroutine make_path
!> mask the nodes that are considered in the shortest path algorithm
subroutine masknodes(numseg)
use m_missing
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol
use geometry_module, only: pinpok
implicit none
integer, intent(in) :: numseg !< land boundary segment number
integer, parameter :: M=10 ! maximum number of nodes per netcell
integer, dimension(M) :: nlist
double precision, dimension(M) :: xlist, ylist
integer, allocatable, dimension(:) :: listnext ! next-cell list in maskcells
integer :: numnext ! size of next-cell list in maskcells
integer :: k1, k2, N
integer :: in, j, ja, jacross, jland
double precision :: dis, xn, yn, rL
! integer, parameter :: IMISS = -999
! clear nodemask
nodemask = IMISS
! find the start cell for node masking
kstart = 0
in = -1
jstart1 = jstart ! first node of land boundary segment in mesh
do while( in.le.0 .and. jstart1.lt.jend )
xp = xlan(jstart1)
yp = ylan(jstart1)
! find the startcell
kstart = 0
do while ( in.le.0 .and. kstart.lt.nump )
kstart = kstart+1
N = netcell(kstart)%N
if ( N.lt.1 ) cycle
if ( N.gt.M ) then
call qnerror('masknodes: N>M', ' ', ' ')
end if
nlist(1:N) = netcell(kstart)%nod
xlist(1:N) = xk(nlist(1:N))
ylist(1:N) = yk(nlist(1:N))
call pinpok(xp, yp, N, xlist, ylist, in, jins, dmiss)
end do
if ( in.eq.0 ) jstart1=jstart1+1
end do
! no startcell found that contains a land boundary point:
! try to find a boundary cell that is crossed by the land boundary segment
! by checking the net boundaries (boundary links)
if ( in.le.0 ) then
kstart = 0
j = jstart
do L=1,numL
if ( lnn(L).ne.1 ) cycle
! get the boundary cell number
k = lne(1,L)
! check the cell
call cellcrossedbyland(k, jstart, jend, j, in)
if ( in.eq.1 ) then
! crossed: startcell found
kstart = k
exit
end if
end do
end if
if ( LMASK ) then ! startcell found -> masking possible
! mask cells
cellmask = IMISS
linkmask = IMISS
if (kstart > 0 .and. kstart <= nump) then
cellmask(kstart) = 1 ! sub maskcells assumes startcell has already been done.
end if
numcellsmasked = 0
maskdepth = 0
! cell masking
numnext = 1
allocate(listnext(numnext))
listnext(1) = kstart
call maskcells(listnext,numnext) ! will deallocate listnext
if ( allocated(listnext) ) then ! safety, should not happen
deallocate(listnext)
end if
! mask nodes
do k=1,nump
N = netcell(k)%N
if ( cellmask(k).eq.1 ) then
do kk=1,N
knode = netcell(k)%nod(kk)
nodemask(knode)=numseg
end do
end if
end do
else ! startcell not found
do k=1,numk
nodemask(k) = numseg
end do
end if
! take selecting polygon into account
in = -1
do k=1,numk
if ( nodemask(k).gt.0 ) then
call dbpinpol(xk(k),yk(k),in, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.ne.1 ) nodemask(k) = 0
end if
end do
end subroutine masknodes
!> mask the cells that are intersected by the land boundary
recursive subroutine maskcells(listcur, numcur)
use m_alloc
implicit none
integer, allocatable, dimension(:), intent(inout) :: listcur !< current-node list, will be deallocated here
integer, intent(inout) :: numcur !< number of cells in current-cell list
integer :: numnext ! number of cells in next-cell list
integer, allocatable, dimension(:) :: listnext ! next-node list
! integer, intent(in) :: jland !< node in land boundary that is visited first
integer :: jacross, jaland, jland, jacell
integer :: ic, k, k1, k2, kk
integer :: kcell, kothercell
double precision :: sl, sm, xcr, ycr, crp ! needed in subroutine cross
double precision :: x1, x2, x3, x4
double precision :: y1, y2, y3, y4
double precision :: rL
integer :: iter, j_, j
integer :: i, L, LL, N, in, NN
integer :: jalinkcrossed(6)
! if ( numcellsmasked.gt.2000) then
! continue
! end if
numnext = 0
! allocate next-cell list, set size initially to current-cell list size
allocate(listnext(numcur))
! process the current-cell list
do ic = 1,numcur
kcell = listcur(ic)
jalinkcrossed = 0
! write(6,'(I, $)') kcell
! write(6,*) kcell, numcellsmasked, maskdepth
! no startcell specified (kcell.eq.0): mask boundary cells only
! these are boundary cells that are crossed ( up to a certain tolerance ) by a land boundary
if ( kcell.eq.0 ) then
j = 1
do L=1,numL
if ( lnn(L).ne.1 ) cycle
kothercell = lne(1,L)
k1 = kn(1,L)
k2 = kn(2,L)
if ( k1.lt.1 .or. k2.lt.1 ) cycle
! cellmask(kothercell) = 1
! proximity check
! call cellcrossedbyland(kothercell, jstart, jend, j, jacross)
jacross = 0
do kk=1,netcell(kothercell)%N
LL = netcell(kothercell)%lin(kk)
call linkcrossedbyland(LL, jstart, jend, 0, j, jacross)
if ( jacross.eq.1 ) exit
end do
if ( jacross.eq.1 ) then
cellmask(kothercell) = 1
end if
end do
else
! j = max(min(jland,jend-1), jstart)
j = jstart
N = netcell(kcell)%N
if ( N.lt.3 ) cycle ! not a valid cell
do i=1,N ! Loop over all links (i.e. towards neighbouring cells)
L = netcell(kcell)%lin(i)
jacross = 0
jacell = 0
! If boundary cell: no further checking in that direction.
if (LNN(L) <= 1) then
cycle
end if
! There is a neighbour cell: compute its cellmask
kothercell = lne(1,L)+lne(2,L)-kcell
! If neighbour cell already visited, continue to next neighbour.
if (cellmask(kothercell) /= IMISS) then
cycle
! Important: jalinkcrossed(i) stays 0 now,
! so that no recursion for this kothercell is done.
end if
NN = netcell(kothercell)%N
do in=1,NN
LL = netcell(kothercell)%lin(in)
if ( linkmask(LL).eq.1 ) then
! previously visited crossed link
jacross = 1
jacell = 1
else if ( linkmask(LL).eq.0 ) then
! previously visited uncrossed link - check next (kothercell) link
cycle
else ! linkmask is IMISS, i.e. the link is unvisited
! unvisited links
linkmask(LL) = 0
call linkcrossedbyland(LL, jstart, jend, 0, j, jacross)
if ( jacross.eq.1 ) then
linkmask(LL) = 1
jacell = 1
! exit ! in
end if
end if
end do
! jacell is now either 0 or 1, directly defines cellmask for kothercell.
cellmask(kothercell) = jacell
if ( jacell.eq.1 ) then
numcellsmasked = numcellsmasked+1
! add the neighboring cell to the next-cell list, but only when it is unvisited
kothercell = lne(1,L)+lne(2,L)-kcell
numnext = numnext+1
! check array size and increase if necessary
if ( numnext.gt.ubound(listnext,1) ) then
call realloc(listnext,max(int(1.2*numnext),10))
end if
! fill next-cell list
listnext(numnext) = kothercell
end if
end do
end if
end do ! ic=1,numcur
! deallocate the current-cell list
deallocate(listcur)
numcur = 0
! process the next-cell list
if ( numnext.gt.0 ) then
maskdepth = maskdepth+1
call maskcells(listnext, numnext) ! will deallocate listnext
maskdepth = maskdepth-1
else
deallocate(listnext)
end if
! deallocate, safety, should not happen
if ( allocated(listnext) ) then
deallocate(listnext)
end if
return
end subroutine maskcells
!> Dijkstra's shortest path algorithm
subroutine shortest_path(numseg, jstart, jend, kstart, nodemask, netboundonly, klink)
use network_data
use geometry_module, only: dbdistance, dlinedis
use m_missing
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: numseg !< land boundary segment number
integer, intent(in) :: jstart, jend !< land boundary segment start and end point
integer, intent(in) :: kstart !< start node
integer, dimension(numk), intent(inout) :: nodemask !< 1 for active nodes, 0 otherwise
integer, intent(in) :: netboundonly !< consider only the net boundary (1) or not (0)
integer, dimension(numk), intent(out) :: klink !< link connected to the node in the shortest path
double precision, allocatable, dimension(:) :: dist
integer :: i, j, kcur, kneighbor, L
integer :: j1, j2, j3
integer :: ja
double precision :: x1, y1, x2, y2, x3, y3
double precision :: xn1, yn1, xn2, yn2, xn3, yn3 ! projection on land boundary
double precision :: ddis1, ddis2, ddis3
double precision :: rL1, rL2, rL3
double precision :: dl1, dl2, dL, ddmax
double precision :: dlinklength, dist_alt
double precision, parameter :: DMAX = 1d99
double precision, parameter :: fsixth = 1d0/6d0
integer, parameter :: alpha = 1
! integer, parameter :: IMISS = -999
allocate(dist(numk))
! nodemask < 1 deactivates nodes
dL = 0d0
dist = DMAX
klink = 0
kcur = kstart
dist(kcur) = 0d0
do
nodemask(kcur) = -nodemask(kcur)
x1 = xk(kcur)
y1 = yk(kcur)
call toland(x1,y1,jstart,jend,0,xn1,yn1,ddis1,j1,rL1)
if ( j1.lt.1 ) then
continue
end if
do i=1,nmk(kcur)
L = nod(kcur)%lin(i)
if ( kn(1,L).lt.1 .or. kn(2,L).lt.1 ) cycle
kneighbor = kn(1,L) + kn(2,L) - kcur
if ( nodemask(kneighbor).lt.1 ) cycle
x2 = xk(kneighbor)
y2 = yk(kneighbor)
x3 = 0.5d0*(x1+x2)
y3 = 0.5d0*(y1+y2)
dlinklength = dbdistance(x1,y1,x2,y2,jsferic, jasfer3D, dmiss)
call toland(x2,y2,jstart,jend,0,xn2,yn2,ddis2,j2,rL2)
call toland(x3,y3,jstart,jend,0,xn3,yn3,ddis3,j3,rL3)
dl1 = dbdistance(xn1,yn1,xn3,yn3, jsferic, jasfer3D, dmiss)
dl2 = dbdistance(xn2,yn2,xn3,yn3, jsferic, jasfer3D, dmiss)
! determine maximum distance to the landboundary for a link
ddmax = max(ddis1,ddis2) ! maximum distance to land boundary between n1 and n2
if ( j1.lt.j2 ) then
do j=j1+1,j2
call dlinedis(xlan(j),ylan(j),x1,y1,x2,y2,ja,ddis3,xn3,yn3, jsferic, jasfer3D, dmiss)
if ( ddis3.gt.ddmax) ddmax = ddis3
end do
dL = dL + dbdistance(xlan(j2),ylan(j2),xn2,yn2, jsferic, jasfer3D, dmiss)
else if ( j1.gt.j2 ) then
do j=j1,j2+1,-1
call dlinedis(xlan(j),ylan(j),x1,y1,x2,y2,ja,ddis3,xn3,yn3, jsferic, jasfer3D, dmiss)
if ( ddis3.gt.ddmax) ddmax = ddis3
end do
end if
if ( dL.lt.dlinklength ) then
continue
end if
! in case of netboundaries only: set penalty on weights when the link is not a boundary link
if ( netboundonly .eq. 1 .and. lnn(L).ne.1 ) ddmax = 1d6*ddmax
dist_alt = dist(kcur) + dlinklength * ddmax
if ( dist_alt.lt.dist(kneighbor) ) then
dist(kneighbor) = dist_alt
klink(kneighbor) = L
end if
end do
kcur = minloc(dist, MASK=nodemask.eq.numseg, DIM=1)
if ( kcur.lt.1 .or. kcur.gt.numk .or. dist(kcur).eq.DMAX .or. nodemask(kcur).lt.1 ) exit
end do
! reset nodemask
where( nodemask.lt.0 .and. nodemask.ne.IMISS ) nodemask = -nodemask
deallocate(dist)
end subroutine shortest_path
!> find start and end node for a land boundary segment
!> these are the nodes that are:
!> closest to the start and end node of the boundary segment respectively, and
!> within a certain distance from the land boundary segment
!> note: will use jleft, jright, rLleft and rLright
subroutine get_kstartend(jstart, jend, kstart, kend)
use m_missing, only: dmiss, imiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: jstart, jend !< land boundary segment start and end point
integer, intent(out) :: kstart, kend !< start and end node
integer :: k, instart, inend
integer :: ja ! for toland
integer :: kend_prev, disendmin_prev, dislandend_prev
double precision :: xstart, ystart, xend, yend ! coordinates of begin and end point of land boundary segment respectively
double precision :: x3, y3
double precision :: xn, yn, rl ! for toland
double precision :: dis, disstart, disend
double precision :: disstartmin, disendmin, dislandstart, dislandend
double precision :: dismax
! default values
kstart = 0
kend = 0
xstart = xlan(jleft) + rLleft*(xlan(min(jleft+1,jend))-xlan(jleft))
ystart = ylan(jleft) + rLleft*(ylan(min(jleft+1,jend))-ylan(jleft))
xend = xlan(jright) + rLright*(xlan(min(jright+1,jend))-xlan(jright))
yend = ylan(jright) + rLright*(ylan(min(jright+1,jend))-ylan(jright))
instart = -1
inend = 0
call dbpinpol(xstart,ystart,instart, dmiss, JINS, NPL, xpl, ypl, zpl)
call dbpinpol(xend,yend,inend, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( instart.ne.1 ) then
xstart = xlan(jleft+1)
ystart = ylan(jleft+1)
end if
if ( inend.ne.1 ) then
xend = xlan(jright)
yend = ylan(jright)
end if
disstartmin = 1d99
disendmin = 1d99
disendmin_prev = 0d0
dislandend_prev = 0d0
kend = 0 ! for kend_prev
kend_prev = 0
do k=1,numk
if ( k.eq.47065 ) then
continue
end if
if ( nodemask(k).lt.1 ) cycle
x3 = xk(k)
y3 = yk(k)
! compute minimum distance to the land boundary segment
call toland(x3, y3, jstart, jend, 0, xn, yn, dis, ja, rl)
! consider only nodes that are within a certain range from the land boundary segment
dismax = dmeshwidth(k)
if ( dismax.ne.DMISS .and. dis.lt.DCLOSE*dismax ) then
! write(6,*) dis, dmeshwidth(k), dbdistance(x3,y3,xstart,ystart), disstartmin
! check distance to start of land boundary segment
disstart = dbdistance(x3,y3,xstart,ystart,jsferic, jasfer3D, dmiss)
if ( disstart.lt.disstartmin ) then
kstart = k
disstartmin = disstart
dislandstart = dis
end if
! check distance to end of land boundary segment
disend = dbdistance(x3,y3,xend,yend, jsferic, jasfer3D, dmiss)
if ( disend.lt.disendmin ) then
kend_prev = kend
kend = k
disendmin = disend
dislandend = dis
end if
end if
end do
if ( kend.eq.kstart .and. kend_prev.gt.0 ) then
kend = kend_prev
disendmin = disendmin_prev
dislandend = dislandend_prev
end if
end subroutine get_kstartend
!> find start and end nodes for a land boundary segment
!> these are nodes that are
!> on a link that is closest to the start and end node of the boundary segment respectively
!> note: will use jleft, jright, rLleft and rLright
subroutine get_kstartend2(jstart, jend, kstart, kend)
use m_missing, only: dmiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: jstart, jend !< land boundary segment start and end point
integer, intent(out) :: kstart, kend !< start and end node
integer :: ja ! for toland
integer :: instart, inend, ierror
integer :: L, Lstart, Lend
integer :: ka, kb, kd, ke
double precision :: xstart, ystart, xend, yend ! coordinates of begin and end point of land boundary segment respectively
double precision :: xa, ya, xb, yb, xd, yd, xe, ye
double precision :: xn, yn, r ! for toland
double precision :: disstart, disend
double precision :: disstartmin, disendmin
ierror = 1
! default values
kstart = 0
kend = 0
Lstart = 0
Lend = 0
! compute the start and end point of the land boundary respectively
xstart = xlan(jleft) + rLleft*(xlan(min(jleft+1,jend))-xlan(jleft))
ystart = ylan(jleft) + rLleft*(ylan(min(jleft+1,jend))-ylan(jleft))
xend = xlan(jright) + rLright*(xlan(min(jright+1,jend))-xlan(jright))
yend = ylan(jright) + rLright*(ylan(min(jright+1,jend))-ylan(jright))
instart = -1
inend = 0
call dbpinpol(xstart,ystart,instart, dmiss, JINS, NPL, xpl, ypl, zpl)
call dbpinpol(xend,yend,inend, dmiss, JINS, NPL, xpl, ypl, zpl)
if ( instart.ne.1 ) then
xstart = xlan(jleft+1)
ystart = ylan(jleft+1)
end if
if ( inend.ne.1 ) then
xend = xlan(jright)
yend = ylan(jright)
end if
disstartmin = 1d99
disendmin = 1d99
! get the links that are closest the land boundary start and end respectively
do L=1,numL
ka = kn(1,L)
kb = kn(2,L)
if ( ka.lt.1 .or. kb.lt.1 ) cycle ! safety
if ( nodemask(ka).lt.1 .or. nodemask(kb).lt.1 ) cycle
! compute distance from link to land boundary start- and end-point
xa = xk(ka)
ya = yk(ka)
xb = xk(kb)
yb = yk(kb)
call dlinedis3(xstart, ystart, xa, ya, xb, yb, ja, disstart,xn,yn,r)
call dlinedis3(xend, yend, xa, ya, xb, yb, ja, disend, xn,yn,r)
if ( disstart.lt.disstartmin ) then
Lstart = L
disstartmin = disstart
end if
if ( disend.lt.disendmin ) then
Lend = L
disendmin = disend
end if
end do
! check if start and end link are found
if ( Lstart.eq.0 ) then
! call qnerror('get_kstartend2: Lstart=0', ' ', ' ')
goto 1234
end if
if ( Lend.eq.0 ) then
! call qnerror('get_kstartend2: Lend=0', ' ', ' ')
goto 1234
end if
! find start and end node on the start and end link respectively
ka = kn(1,Lstart)
kb = kn(2,Lstart)
if ( dbdistance(xk(ka),yk(ka),xstart,ystart, jsferic, jasfer3D, dmiss).le.dbdistance(xk(kb),yk(kb),xstart,ystart, jsferic, jasfer3D, dmiss) ) then
kstart = ka
else
kstart = kb
end if
kd = kn(1,Lend)
ke = kn(2,Lend)
if ( dbdistance(xk(kd),yk(kd),xend,yend,jsferic, jasfer3D, dmiss).le.dbdistance(xk(ke),yk(ke),xend,yend, jsferic, jasfer3D, dmiss) ) then
kend = kd
else
kend = ke
end if
ierror = 0
1234 continue
return
end subroutine get_kstartend2
!> compute typical mesh width for a node, which is the maximum length of the connected links
double precision function dmeshwidth(k)
use m_missing
use m_polygon, only: NPL, xpl, ypl, zpl
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: k !< node number
integer :: kother, kk, L, in
double precision :: x1, y1, x2, y2
! not-in-polygon value
dmeshwidth = DMISS
x1 = xk(k)
y1 = yk(k)
! check if node itself is in selecting polygon
in = -1
call dbpinpol(x1,y1,in,dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.ne.1 ) return
dmeshwidth = 0d0
do kk=1,nmk(k)
L = nod(k)%lin(kk)
kother = kn(1,L) + kn(2,L) - k
x2 = xk(kother)
y2 = yk(kother)
! check if the connected node is in selecting polygon
call dbpinpol(x2,y2,in,dmiss, JINS, NPL, xpl, ypl, zpl)
if ( in.ne.1 ) cycle
dmeshwidth = max(dmeshwidth, dbdistance(x1,y1,x2,y2, jsferic, jasfer3D, dmiss))
end do
end function dmeshwidth
end subroutine find_nearest_meshline
!> snap netnodes to land boundary segment
subroutine snap_to_landboundary()
use m_netw
use m_landboundary
implicit none
double precision :: xn, yn, ddis, rL
integer :: k, numlanseg, jstart, jend, j, MXLAN_sav
! save MXLAN
MXLAN_sav = MXLAN
! set MXLAN to actual value
MXLAN = MXLAN_loc
! if ( jasnap.ne.2 .and. jasnap.ne.3 ) return
do k=1,numk
if ( nb(k).eq.1 .or. nb(k).eq.2 .or. nb(k).eq.3 ) then
numlanseg = lanseg_map(k)
if ( numlanseg.lt.1 ) cycle
jstart = lanseg_startend(1,numlanseg)
jend = lanseg_startend(2,numlanseg)
call toland(xk(k),yk(k),jstart,jend,0,xn,yn,ddis,j,rL)
xk(k) = xn
yk(k) = yn
end if
end do
! restore MXLAN
MXLAN = MXLAN_sav
return
end subroutine snap_to_landboundary
!> administer the land boundary segments
!> the land boundary will be split into segments that are
!> within the selecting polygon, and
!> either close to the net boundary, or
!> not close to the net boundary
subroutine admin_landboundary_segments()
use m_landboundary
use m_polygon
use m_alloc
use m_netw
use m_missing, only: dmiss, JINS
use geometry_module, only: dbpinpol, dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, allocatable, dimension(:) :: lanmask ! mask the parts of the landboundary that are within the polygon
! 0: inactive
! -1: active, not member of an edge close to land boundary
! 1: active, member of an edge close to the net boundary
integer :: jstart, jend
integer :: jbreak ! used to break segment in two
integer :: i, j, jdum, ja, ja1, ja2, k, N, Nnew
double precision :: x1,y1,x2,y2,x3,y3,x4,y4,xn,yn,rl3,rl4
double precision :: dlanlength,dlinklength,dismin,dis3,dis4
double precision :: darea, dlength, dlenmx
logical :: Lisclose
! allocate
if ( allocated(lanseg_startend) ) deallocate(lanseg_startend)
allocate(lanseg_startend(2,1) )
allocate(lanmask(MXLAN-1))
! mask the landboundary that is inside the selecting polygon
! lanmask masks the landboundary edges
! mask set to -1
ja1 = -1
ja2 = -1
lanmask = 0
do i=1,MXLAN-1
if ( xlan(i).ne.DMISS .and. xlan(i+1).ne.DMISS ) then
call dbpinpol(xlan(i),ylan(i),ja1,dmiss, JINS, NPL, xpl, ypl, zpl)
call dbpinpol(xlan(i+1),ylan(i+1),ja2,dmiss, JINS, NPL, xpl, ypl, zpl)
! if ( ja1.eq.1.or.ja2.eq.1 ) then
! lanmask(i) = -1
! lanmask(i+1) = -1
if ( ja1.eq.1.or.ja2.eq.1 ) then
lanmask(i) = -1
end if
end if
end do
! mask the landboundary that is sufficiently close to the net
! mask set to 1
! save the selecting polygon
call savepol()
! copy network boundary to polygon
call copynetboundstopol(1, 0, 0, 1)
do i=1,MXLAN-1
if ( lanmask(i).ne.0 ) then ! segments in polygon only
! land boundary points
x1 = xlan(i)
y1 = ylan(i)
x2 = xlan(i+1)
y2 = ylan(i+1)
dlanlength = dbdistance(x1,y1,x2,y2, jsferic, jasfer3D, dmiss)
Lisclose = .false.
do j=1,NPL-1 ! loop over the network boundary
x3 = xpl(j)
y3 = ypl(j)
x4 = xpl(j+1)
y4 = ypl(j+1)
if ( x3.eq.DMISS .or. x4.eq. DMISS ) cycle
dlinklength = dbdistance(x3,y3,x4,y4, jsferic, jasfer3D, dmiss)
! dismin = DCLOSE*min(dlanlength,dlinklength)
dismin = DCLOSE*dlinklength
call dlinedis3(x3,y3,x1,y1,x2,y2,ja,dis3,xn,yn,rl3)
call dlinedis3(x4,y4,x1,y1,x2,y2,ja,dis4,xn,yn,rl4)
if ( dis3.le.dismin .or. dis4.le.dismin ) then
Lisclose = .true.
exit
end if
end do
if ( Lisclose ) then
lanmask(i) = 1
! lanmask(i+1) = 1
end if
end if
end do
! restore the selecting polygon
call restorepol()
! compose the boundary segments that have same lanmask
Nlanseg = 0
jend = 1
do while( jend.lt.MXLAN )
Nlanseg = Nlanseg+1
! find jstart and jend
jstart = jend
if ( xlan(jstart+1).eq.DMISS ) jstart = jstart+1
if ( jstart.ge.MXLAN ) exit
do while( xlan(jstart).eq.DMISS )
jstart = jstart+1
if ( jstart.eq.MXLAN ) exit
end do
if ( xlan(jstart).eq.DMISS ) exit
i = lanmask(jstart)
jend = jstart+1
if ( jend.lt.MXLAN ) then
do while( (xlan(jend+1).ne.DMISS .and. lanmask(jend).eq.i) )
jend = jend+1
if ( jend.eq.MXLAN ) exit
end do
end if
! only store landboundary segments that are inside the selecting polygon
if ( lanmask(jstart).ne.0 ) then
! allocate and administer
call realloc(lanseg_startend, (/ 2, Nlanseg /))
lanseg_startend(:,Nlanseg) = (/ jstart, jend /)
else
Nlanseg = Nlanseg-1
end if
end do
! count number of segments
if ( jend.gt.0 ) then
Nlanseg = ubound(lanseg_startend,2)
else
Nlanseg = 0
end if
! split the line segments into two to accommodate closed segments
! 28-10-11: deactivated, since the link distance (weight) embodies the maximum distance to the landboudary path between the projected begin and end node of the link
! unwanted paths could possibly be found under certain conditions
! 21-11-11: activated again
if ( Nlanseg.gt. 0 ) then
Nnew = Nlanseg
do i=1,Nlanseg
jstart = lanseg_startend(1, i)
jend = lanseg_startend(2, i)
if ( jend-jstart.gt.2 ) then
! only if the distance from begin to end of the landboundary is a fraction (one tenth) of the segment length
! call darean(xlan(jstart:jend), ylan(jstart:jend), jend-jstart+1, darea, dlength, dlenmx)
! if ( dbdistance(xlan(jstart),ylan(jstart),xlan(jend),ylan(jend)).lt.0.1d0*dlength ) then
Nnew = Nnew+1
call realloc(lanseg_startend, (/ 2, Nnew /) )
jbreak = jstart + ( jend - jstart ) / 2
lanseg_startend(2,i) = jbreak
lanseg_startend(1,Nnew) = jbreak
lanseg_startend(2,Nnew) = jend
! end if
end if
end do
Nlanseg = Nnew
end if
! deallocate
deallocate(lanmask)
return
end subroutine admin_landboundary_segments
!> check if a link is close to a land boundary segment
subroutine linkcrossedbyland(L, jstart, jend, netboundonly, jland, jacross)
use m_netw
use m_landboundary
use m_missing
use geometry_module, only: dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: L !< link number
integer, intent(in) :: jstart, jend !< start and end point of land boundary segment respectively
integer, intent(in) :: netboundonly !< consider only the net boundary (1) or not (0)
integer, intent(inout) :: jland !< point in land boundary that is (in:) visited first (out:) found
integer, intent(out) :: jacross !< crossed (1) or not (0)
integer :: k1, k2 ! nodes comprising the link
integer :: iter, j, j_
integer :: ja, jastop
double precision :: x1, y1, x2, y2 ! node coordinates
double precision :: x3, y3, x4, y4 ! land boundary point coordinates
double precision :: sl, sm, xcr, ycr, crp, DL, Dm, Dtol, dismin
double precision :: dis,xn,yn, rL, rL1, rL2 ! for dlinedis3
jacross = 0
j = max(min(jland,jend-1), jstart)
k1 = kn(1,L)
k2 = kn(2,L)
if ( k1.lt.0 .or. k2.lt.0 ) then ! safety
return
end if
x1 = xk(k1)
y1 = yk(k1)
x2 = xk(k2)
y2 = yk(k2)
DL = dbdistance(x1,y1,x2,y2,jsferic, jasfer3D, dmiss)
Dtol = DCLOSE * DL
dismin = 1d99
! loop over the segments of the land boundary
jacross = 0
jastop = 0
j_ = 0
do
x3 = xlan(j)
y3 = ylan(j)
x4 = xlan(j+1)
y4 = ylan(j+1)
Dm = dbdistance(x3,y3,x4,y4,jsferic, jasfer3D, dmiss)
if ( x3.ne.dmiss .and. x4.ne.dmiss .and. Dm.gt.0d0 ) then
rL1 = 0d0
rL2 = 1d0
call dlinedis3(x1,y1,x3,y3,x4,y4,ja,dis,xn,yn,rL1)
if ( dis.le.dtol ) then
jacross = 1
jland = j
if ( rL1.ge.0d0 .and. rL1.le.1d0 ) jastop = 1
else
call dlinedis3(x2,y2,x3,y3,x4,y4,ja,dis,xn,yn,rL2)
if ( dis.le.dtol ) then
jacross = 1
jland = j
if ( rL2.ge.0d0 .and. rL2.le.1d0 ) jastop = 1
end if
end if
dismin = min(dis, dismin)
if ( jastop.eq.1 ) exit
end if
! move pointer left-right-left-right-left-right etc.
iter = 0
do while( ( iter.eq.0 .or. j.lt.jstart .or. j.gt.jend-1 ) .and. iter.lt.3)
iter = iter+1
if ( j_.lt.0 ) then ! to right
j_ = -j_ + 1
else ! to left
j_ = -j_ - 1
end if
j = j + j_
end do
if ( iter.eq.3 ) exit
end do
! if ( jacross.eq.1 .and. max(rL1,rL2).gt.0d0 .and. min(rL1,rL2).le.1d0 ) then
if ( jacross.eq.1 ) then
j = jland
! set outer land boundary segment points
! minimum
sm = min(rL1,rL2)
if ( j.lt.jleft ) then
jleft = j
rLleft = min(max(sm,0d0),1d0)
else if ( j.eq.jleft ) then
rLleft = min(max(sm,0d0),rLleft)
end if
! maximum
sm = max(rL1,rL2)
if ( j.gt.jright ) then
jright = j
rLright = min(max(sm,0d0),1d0)
else if ( j.eq.jright ) then
rLright = max(min(sm,1d0),rLright)
end if
end if
return
end subroutine linkcrossedbyland
!> check if a cell is close to a land boundary segment
subroutine cellcrossedbyland(k, jstart, jend, jland, jacross)
use m_netw
use m_landboundary
use m_missing
use geometry_module, only: cross
use m_sferic, only: jsferic
implicit none
integer, intent(in) :: k !< cell number
integer, intent(in) :: jstart, jend !< start and end point of land boundary segment respectively
integer, intent(inout) :: jland !< point in land boundary that is (in:) visited first (out:) found
integer, intent(out) :: jacross !< crossed (1) or not (0)
double precision :: rL
double precision :: x1, y1, x2, y2, x3, y3, x4, y4, sL, sm, xcr, ycr, crp
integer :: j, kk, L, k1, k2
jacross = 0
kklp:do kk=1,netcell(k)%N
L = netcell(k)%lin(kk)
! call linkcrossedbyland(L, jstart, jend, 0, jland, jacross)
do j=jstart,jend-1
k1 = kn(1,L)
x1 = xk(k1)
y1 = yk(k1)
k2 = kn(2,L)
x2 = xk(k2)
y2 = yk(k2)
x3 = xlan(j)
y3 = ylan(j)
x4 = xlan(j+1)
y4 = ylan(j+1)
call cross(x1, y1, x2, y2, x3, y3, x4, y4, jacross,sL,sm,xcr,ycr,crp, jsferic, dmiss)
if ( jacross.eq.1 ) exit kklp
end do
end do kklp
return
end subroutine cellcrossedbyland
!> connect netboundary paths
recursive subroutine connect_boundary_paths(Lstart, nodemask, init, numnodes, nodelist)
use m_netw
use m_alloc
use m_missing
use m_landboundary
use unstruc_colors, only: ncolhl
implicit none
integer, intent(in) :: Lstart !< initial netlink
integer, dimension(numk), intent(in) :: nodemask !< nodemask
integer, intent(in) :: init !< initialize (1) or not (0)
integer, intent(in) :: numnodes !< number of nodes found so far
integer, dimension(numnodes), intent(in) :: nodelist !< nodes found so far
integer :: numnodes_loc
integer, allocatable, dimension(:) :: nodelist_loc ! local copy of nodes found so far
integer :: maxnodes ! large enough, depends on DCLOSE
integer :: i, j, k, kother, k1, k2, kk, L
integer :: jstart, jend, numseg
double precision :: xn, yn, ddis, rL ! for toland
! note: in allocation of nodelist_loc, add space for new node
! nodelist_loc will be allocated and deallocated here
if ( init.eq.1 ) then
L = Lstart
! find first node
if ( lnn(L).ne.1 .or. kn(1,L).lt.1 .or. kn(2,l).lt.1 ) return
k1 = kn(1,L)
k2 = kn(2,L)
if ( lanseg_map(k1).ge.1 .and. lanseg_map(k2).lt.1 .and. nodemask(k1).gt.0 .and. nodemask(k2).gt.0 ) then
! allocate
allocate(nodelist_loc(3))
nodelist_loc(1:2) = (/ k1, k2 /)
numnodes_loc = 2
else if ( lanseg_map(k1).lt.1 .and. lanseg_map(k2).ge.1 .and. nodemask(k1).gt.0 .and. nodemask(k2).gt.0 ) then
! allocate
allocate(nodelist_loc(3))
nodelist_loc(1:2) = (/ k2, k1 /)
numnodes_loc = 2
else ! not a valid link
return
end if
else
! allocate
allocate(nodelist_loc(numnodes+1))
numnodes_loc = numnodes
nodelist_loc(1:numnodes_loc) = nodelist
end if
! get the array size
maxnodes = ubound(nodelist_loc,1)
! get last node visited
k = nodelist_loc(numnodes_loc)
! loop over all connected links and check if a valid path exists
kklp:do kk=1,nmk(k)
L = nod(k)%lin(kk)
if ( lnn(L).ne.1 ) cycle kklp ! boundary links only
kother = kn(1,L) + kn(2,L) - k
! check if next node is already in nodelist
do i=numnodes_loc,1,-1
if ( kother.eq.nodelist_loc(i) ) cycle kklp
end do
if ( nodemask(kother).lt.1 ) cycle kklp ! path stopped
if ( numnodes_loc.ge.MAXNODES ) then
call qnerror('connect_boundary_paths: numnodes > MAXNODES', ' ', ' ')
goto 1234
end if
! add new node
nodelist_loc(numnodes_loc+1) = kother
! check and see if the next node completes a connection
if ( lanseg_map(kother).gt.0 ) then
! connection found!
! make the node-to-land boundary segment mapping
do i=2,numnodes_loc
! write(6,"(I5,$)") nodelist_loc(i)
k1 = nodelist_loc(i)
! find the land boundary segment
call toland(xk(k1),yk(k1),1,MXLAN,0,xn,yn,ddis,j,rL)
numseg = 1
do while ( ( j.lt.lanseg_startend(1,numseg) .or. j.ge.lanseg_startend(2,numseg)) .and. numseg.lt.Nlanseg )
numseg = numseg+1
end do
jstart = lanseg_startend(1,numseg)
jend = lanseg_startend(2,numseg)
if ( j.lt.jstart .or. j.gt.jend ) then
! land boundary segment not found, this should not happen
! call qnerror('connect_boundary_paths: land boundary segment not found', ' ', ' ')
goto 1234
end if
if ( (j.eq.jstart .and. rL.lt.0d0) .or. (j.eq.jend-1 .and. rL.gt.1d0) ) then
! prevent projection to end points of land boundary segments:
if ( Ladd_land ) then
! add new land boundary segment that connects the two others and project
call add_land()
lanseg_map(k1) = numseg
end if
else
lanseg_map(k1) = numseg
end if
end do
! write(6,*)
! plot the boundary path
k1 = nodelist_loc(1)
call setcol(ncolhl)
call movabs(xk(k1),yk(k1))
do i = 2,numnodes_loc+1
k1 = nodelist_loc(i)
call lnabs(xk(k1),yk(k1))
end do
! done, clean up
goto 1234
else
! no connection found -> continue path
call connect_boundary_paths(L,nodemask,0,numnodes_loc+1,nodelist_loc)
end if
end do kklp
! done, clean up
goto 1234
! error handling
1234 continue
deallocate(nodelist_loc)
return
contains
!> add new land boundary segment that connects two others
subroutine add_land()
use geometry_module, only: dbdistance
use m_missing, only: dmiss, imiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer :: numseg1, numseg2
double precision :: xL1, yL1, xL2, yL2
! find segments numbers
numseg1 = lanseg_map(nodelist_loc(1))
numseg2 = lanseg_map(nodelist_loc(numnodes_loc+1))
if ( numseg1.lt.1 .or. numseg1.gt.Nlanseg .or. numseg2.lt.1 .or. numseg2.gt.Nlanseg ) then
! this should never happen
return
end if
! find start/end
jstart = lanseg_startend(1,numseg1)
jend = lanseg_startend(2,numseg1)
if ( dbdistance(xk(k),yk(k),xlan(jstart),ylan(jstart),jsferic, jasfer3D, dmiss) .le. dbdistance(xk(k),yk(k),xlan(jend),ylan(jend),jsferic, jasfer3D, dmiss) ) then
xL1 = xlan(jstart)
yL1 = ylan(jstart)
else
xL1 = xlan(jend)
yL1 = ylan(jend)
end if
if ( numseg2.ne.numseg1 ) then
jstart = lanseg_startend(1,numseg2)
jend = lanseg_startend(2,numseg2)
if ( dbdistance(xk(k),yk(k),xlan(jstart),ylan(jstart),jsferic, jasfer3D, dmiss) .le. dbdistance(xk(k),yk(k),xlan(jend),ylan(jend),jsferic, jasfer3D, dmiss) ) then
xL2 = xlan(jstart)
yL2 = ylan(jstart)
else
xL2 = xlan(jend)
yL2 = ylan(jend)
end if
else
xL2 = xlan(jstart) + xlan(jend) - xL1
yL2 = ylan(jstart) + ylan(jend) - yL1
end if
! add to landboundary
if ( xlan(MXLAN).ne.DMISS ) then
MXLAN = MXLAN+1
if ( MXLAN.gt.ubound(xlan,1) ) call increaselan(MXLAN+2)
xlan(MXLAN) = dmiss
ylan(MXLAN) = dmiss
end if
MXLAN = MXLAN+2
if ( MXLAN.gt.ubound(xlan,1) ) call increaselan(MXLAN)
xlan(MXLAN-1) = xL1
ylan(MXLAN-1) = yL1
xlan(MXLAN) = xL2
ylan(MXLAN) = yL2
! update administration
Nlanseg = Nlanseg+1
if ( Nlanseg.gt.ubound(lanseg_startend,2) ) then
call realloc(lanseg_startend, (/2, Nlanseg/))
end if
lanseg_startend(:,Nlanseg) = (/ MXLAN-1, MXLAN /)
numseg = Nlanseg
return
end subroutine add_land
end subroutine connect_boundary_paths
!> generate curvilinear grid from spline
subroutine spline2curvi()
use m_grid
use m_splines
use m_gridsettings
use m_alloc
use m_missing
use m_spline2curvi
use m_sferic
use m_polygon
use geometry_module, only: pinpok, normalout
implicit none
integer :: ierror ! 0: no error, 1: error
integer, allocatable, dimension(:) :: ifront ! active node in front (1) or not (0), dim(mc)
double precision, allocatable, dimension(:) :: xg, yg ! coordinates of first gridline, dim(mc)
double precision, allocatable, dimension(:) :: sc ! spline-coordinates of grid points or edges
double precision, allocatable, dimension(:) :: xt2 ! crossspline-related data in crossspline coordinates
double precision, allocatable, dimension(:) :: edgevel ! grid layer segment normal-velocity, dim(mc-1)
integer :: numcrosssplines ! number of crosssplines
integer, allocatable, dimension(:) :: mfac1 ! number of cells along center spline, per center spline, dimension(mcs)
integer, allocatable, dimension(:,:) :: nfac1 ! number of cells perpendicular to center spline, per edge on spline for each subinterval of grid layers, dimension(Nsubmax,mc-1)
double precision, allocatable, dimension(:,:) :: dgrow1 ! grow factor, per edge on the spline for each subinterval of grid layers, dimension(Nsubmax,mc-1)
integer, allocatable, dimension(:) :: nlist ! dummy array, dimension(Nsubmax)
double precision :: dt ! time step
integer :: jacancelled
integer :: ig ! pointer to last entry in first gridline
integer :: igL, igR, jmaxL, jmaxR
integer :: i, is, js, isnew, isubL, isubR, isum, j, jc, ispline, jspline, k, num, numj
integer :: iL, iR, Ndum, mcs_old, mcs_new, j_loc
integer :: istop, idum, numcro, jatopol, mfacmax, ncs
integer :: inhul
double precision :: ti, tj, xp, yp, crp, hL, hR, fac
double precision, allocatable, dimension(:) :: h ! for curvature adapted meshing
double precision :: dspllength, dmaxwidth, growfac, hmax
double precision :: t, tL, tR
! grid edge-based cross splines
double precision, dimension(2) :: xs1, ys1
double precision :: xe, ye, nx, ny
integer, dimension(3,mcs) :: iLRmfac
integer, dimension(mcs) :: id
logical :: Lnewsplines
logical :: Lset, jaAllPoints
integer, external :: comp_nfac, get_isub
double precision, external :: splinelength, comp_dgrow
double precision, parameter :: dnu = -0.50d0
integer :: nul, nul1(1), nul2(1,1)
! Note: edge_vel is the grow velocity per front edge and in Cartesian coordinates
! vel is the grow velocity per front node and in spherical coordinates (when applicable)
ierror = 1
Lnewsplines = .false.
! if ( jsferic.eq.1 ) then
! call qnerror('spherical coordinates not supported', ' ', ' ')
! return
! end if
CALL READYY('Growing curvilinear grid',0d0)
! get the settings from a parameter menu, if user presses 'Esc', do nothing.
jacancelled = 0
call change_spline2curvi_param(jacancelled)
if (jacancelled == 1) then
return
end if
mfacmax = mfac
nc = nfac+1
if ( mcs.lt.1 ) goto 1234 ! no splines
! save splines
call savesplines()
! delete splines outside selecting polygon (mostly copied from deleteSelectedSplines)
if ( NPL.gt.2 ) then
i = 1
do while ( i.lt.mcs )
jaAllPoints = .true.
do j=1,lensp(i)
call pinpok(xsp(i,j), ysp(i,j), NPL, xpl, ypl, inhul, jins, dmiss)
jaAllpoints = jaAllpoints .and. (inhul==1)
enddo
if (.not.jaAllpoints) then
call delspline(i)
! splines are shifted to the left, so don't increment i.
else
i = i+1
end if
end do
end if
! get the properties of the center splines (no angle check)
nul = 0 ; nul1 = 0 ; nul2 = 0
call get_splineprops(nul,nul1,nul2)
! make the whole first gridline
call make_wholegridline(ierror)
CALL READYY('Growing curvilinear grid',0.4d0)
if ( ierror.eq.1 ) goto 1234
if ( mc.lt.2 ) goto 1234 ! no curvigrid
! make all gridedge based cross splines
! remember original spline information
Lnewsplines = .false.
do is=1,mcs
id(is) = splineprops(is)%id
end do
iLRmfac = 0
mcs_old = mcs
! construct new, or artificial, cross splines through the grid edge center points
do is=1,mcs_old
if ( splineprops(is)%id .ne. 0 ) cycle ! center splines only
! id(is) = 0
iLRmfac(1,is) = splineprops(is)%iL
iLRmfac(2,is) = splineprops(is)%iR
iLRmfac(3,is) = splineprops(is)%mfac
hmax = splineprops(is)%hmax
igL = splineprops(is)%iL
do i=igL,igL+splineprops(is)%mfac-1
! construct the cross spline through this edge
xe = 0.5d0*(xg1(i)+xg1(i+1))
ye = 0.5d0*(yg1(i)+yg1(i+1))
call normalout(xg1(i),yg1(i),xg1(i+1),yg1(i+1),nx,ny, jsferic, jasfer3D, dmiss, dxymis)
if ( jsferic.ne.1 ) then
xs1 = xe + 2d0*hmax * (/ -nx, nx /)
ys1 = ye + 2d0*hmax * (/ -ny, ny /)
else
xs1 = xe + 2d0*hmax * (/ -nx, nx /) / (Ra*dg2rd)
ys1 = ye + 2d0*hmax * (/ -ny, ny /) / (Ra*dg2rd)
end if
isnew = mcs+1
call addSplinePoint(isnew, xs1(1), ys1(1))
call addSplinePoint(isnew, xs1(2), ys1(2))
if ( .not.Lnewsplines ) Lnewsplines = .true.
end do
end do
call deallocate_splineprops
call get_splineprops(mcs_old, id, iLRmfac)
! artificial cross spline: remove the last part of the subintervals (since it makes no sence, as the artificial cross spline has an arbitrary, but sufficiently large, length)
do is=1,mcs_old
if ( splineprops(is)%id .ne. 0 ) cycle ! center splines only
do j=1,splineprops(is)%ncs
js = splineprops(is)%ics(j)
if ( splineprops(js)%id.eq.3 ) then ! artificial cross spline only
splineprops(is)%NsubL(j) = splineprops(is)%NsubL(j)-1
splineprops(is)%NsubR(j) = splineprops(is)%NsubR(j)-1
end if
end do
end do
CALL READYY('Growing curvilinear grid',.7d0)
! allocate
allocate(edgevel(mc-1), nfac1(Nsubmax,mc-1), dgrow1(Nsubmax,mc-1), nlist(Nsubmax))
! compute edge velocities
call comp_edgevel(mc, edgevel, dgrow1, nfac1, ierror)
if ( ierror.ne.0 ) goto 1234
call increasegrid(mc,nc)
xc = DMISS
yc = DMISS
! copy first gridline into grid
jc = 1
xc(1:mc,jc) = xg1(1:mc)
yc(1:mc,jc) = yg1(1:mc)
! allocate
allocate(ifront(mc))
ifront = 1
where ( xc(:,jc).eq.DMISS ) ifront = 0
do i=1,mc
if ( sum(nfac1(:,max(i-1,1))).eq.0 .and. sum(nfac1(:,min(i,mc-1))).eq.0 ) then
ifront(i) = 0
end if
end do
! grow the grid
dt = 1d0
do j=jc+1,nc
! idum = 1
! call plot(idum)
call growlayer(mc, nc, mmax, nmax, 1, maxaspect, j, edgevel, dt, xc, yc, ifront, istop)
! update edge velocity
nlist(:) = nfac1(:,1)
isubR = get_isub(j, nlist, j_loc)
do i=1,mc ! loop over grid points
! determine the subinterval of grid layers
isubL = isubR ! edge left of grid point
nlist(:) = nfac1(:,min(i,mc-1))
isubR = get_isub(j, nlist, j_loc) ! edge right of grid point
if ( isubR.gt.0 .and. i.lt.mc .and. j_loc.gt.0 ) then ! j_loc.eq.0: first layer in subinterval
edgevel(i) = dgrow1(isubR,i)*edgevel(i)
end if
if ( isubL.eq.0 .and. isubR.eq.0 ) then ! deactivate grid point
ifront(i) = 0
end if
end do
if ( dt.lt.1d-8 .or. istop.eq.1 ) exit
end do
call postgrid()
CALL READYY('Growing curvilinear grid',1d0)
CALL READYY('Growing curvilinear grid',-1d0)
jatopol = 1
call confrm('Copy center splines to polygon?', jatopol)
if ( jatopol.eq.1 ) then
call spline2poly() ! (re)sample the spline
end if
! merge grids on both sides of centerspline(s)
call merge_spline2curvigrids()
ierror = 0
1234 continue
! deallocate
if ( allocated(edgevel) ) deallocate(edgevel, nfac1, dgrow1, nlist)
if ( allocated(ifront) ) deallocate(ifront)
if ( allocated(xg1) ) deallocate(xg1, yg1, sg1)
call deallocate_splineprops()
! restore
mfac = mfacmax
if ( Lnewsplines ) call restoresplines()
! in case of error: restore previous the grid
if ( ierror.eq.1 ) call restoregrd()
return
end subroutine spline2curvi
integer function get_isub(j, nfac1, j_loc) !< gets the subinterval of grid layer j
use m_spline2curvi
implicit none
integer, intent(in) :: j !< grid layer index
integer, dimension(Nsubmax), intent(in) :: nfac1 !< subinterval lengths
integer, intent(out) :: j_loc !< grid layer in the subinterval
integer :: isum, isub
j_loc = j-1
if ( j.gt.sum(nfac1) ) then
isub = 0
goto 1234
end if
isub = 1
isum = 1+nfac1(isub)
do while ( isum.le.j .and. isub.lt.Nsubmax )
isub = isub + 1
isum = isum + nfac1(isub)
end do
j_loc= j-isum+nfac1(isub)
! error handling
1234 continue
get_isub = isub
return
end function
!> compute the grid heights at grid edges on the center spline
subroutine comp_gridheights(mc, eheight, ierror)
use m_splines
use m_gridsettings
use m_spline2curvi
use m_alloc
use m_missing
implicit none
integer, intent(in) :: mc !< number of grid points
double precision, dimension(Nsubmax,mc-1), intent(out) :: eheight !< edge-based grid height for each subinterval of gridlayers
integer, intent(out) :: ierror !< 0: no error, 1: error
double precision, allocatable, dimension(:,:) :: hL, hR
double precision, allocatable, dimension(:) :: hL2, hR2
! double precision, dimension(mcs) :: t
double precision, allocatable, dimension(:) :: sc ! grid points in center spline coordinates
double precision, allocatable, dimension(:,:) :: hgL, hgR ! grid heights at grid points
double precision, allocatable, dimension(:) :: hgL_loc, hgR_loc
double precision, allocatable, dimension(:) :: xlist, ylist, hlist
integer, allocatable, dimension(:) :: nlistL, nlistR, nlist_loc
double precision :: fac, tL, tR
! grid cross splines, per edge
integer :: ncs, ndx
integer, allocatable, dimension(:) :: ics, idx
double precision, allocatable, dimension(:) :: t
double precision, dimension(2) :: xs1, ys1
double precision :: hmax, xe, ye, nx, ny, htot
logical :: Lorient
integer :: is, igL, igR, mfacmax, isL, isR, iter, MAXITER
integer :: i, iL, iR, j, Ndum, num, NsubL, NsubR, numnew
logical :: Lset
double precision, external :: splinelength_int
ierror = 1
mfacmax = mfac
eheight(1,:) = DMISS
eheight(2:Nsubmax,:) = 0d0
allocate(hL(Nsubmax,mcs), hR(Nsubmax,mcs))
allocate(hL2(mcs), hR2(mcs))
allocate(hgL(Nsubmax,mfacmax), hgR(Nsubmax,mfacmax))
allocate(hgL_loc(Nsubmax), hgR_loc(Nsubmax))
allocate(xlist(1), ylist(1), hlist(1), nlistL(1), nlistR(1), nlist_loc(1))
allocate(ics(mcs), idx(mcs))
allocate(t(mcs))
do is=1,mcs
mfac = splineprops(is)%mfac
! if ( mfac.lt.1 ) cycle
if ( splineprops(is)%id.ne.0 ) cycle
igL = splineprops(is)%iL
igR = splineprops(is)%iR
ncs = splineprops(is)%ncs
! reallocate if necessary
if ( ncs.gt.ubound(nlistL,1) ) then
numnew = int(1.2d0*dble(ncs))+1
call realloc(nlistL,numnew)
call realloc(nlistR,numnew)
call realloc(nlist_loc,numnew)
end if
! get the minimum number of subintervals in the cross splines for this center spline
NsubL = minval(splineprops(is)%NsubL(1:ncs))
NsubR = minval(splineprops(is)%NsubR(1:ncs))
if ( NsubL.eq.0 ) hgL(1,1:mfac) = splineprops(is)%hmax
if ( NsubR.eq.0 ) hgR(1,1:mfac) = splineprops(is)%hmax
! interpolate the gridheight
! use default settings
hgL = 0d0
hgR = 0d0
hgL(1,1:mfac) = splineprops(is)%hmax
hgR(1,1:mfac) = splineprops(is)%hmax
if ( ncs.eq.1 ) then
do i=1,NsubL
hgL(i,1:mfac) = splineprops(is)%hR(i,1)
end do
do i=1,NsubR
hgR(i,1:mfac) = splineprops(is)%hL(i,1)
end do
else if ( ncs.gt.1 ) then
! use cross splines, spline interpolation
! allocate
if ( .not.allocated(sc) ) then
allocate(sc(mfac+1))
else
call realloc(sc, mfac+1)
end if
! compute center spline path length of grid points
call nump(is,num)
! reallocate if necessary
if ( num.gt.ubound(xlist,1) ) then
numnew = int(1.2d0*dble(num))+1
call realloc(xlist, numnew)
call realloc(ylist, numnew)
end if
xlist(1:num) = xsp(is,1:num)
ylist(1:num) = ysp(is,1:num)
sc(1) = splinelength_int(num, xlist, ylist, 0d0, sg1(igL))
do i=1,mfac
sc(i+1) = sc(i) + splinelength_int(num, xlist, ylist, sg1(igL+i-1), sg1(igL+i))
end do
! compute at edge center points
do i=1,mfac
sc(i) = 0.5d0*(sc(i) + sc(i+1)) ! sc(i+1) unaffected
end do
sc(mfac+1) = DMISS
! compute center spline path length of cross splines
t(1) = splinelength_int(num, xlist, ylist, 0d0, splineprops(is)%t(1))
do i=1,ncs-1
t(i+1) = t(i) + splinelength_int(num, xlist, ylist, splineprops(is)%t(i), splineprops(is)%t(i+1))
end do
nlistL(1:ncs) = splineprops(is)%NsubL(1:ncs)
nlistR(1:ncs) = splineprops(is)%NsubR(1:ncs)
do j=1,Nsubmax
nlist_loc = nlistL-j
call get_index(ncs, nlist_loc, ndx, idx)
if ( ndx.gt.0 ) then
hL(j,1:ncs) = splineprops(is)%hL(j,1:ncs)
! reallocate if necessary
if ( ndx.gt.ubound(hlist,1) ) then
numnew = int(1.2d0*dble(ndx))+1
call realloc(hlist, numnew)
end if
hlist(1:ndx) = hL(j,idx(1:ndx))
call spline(hlist,ndx,hL2)
do i=1,mfac
! find two nearest cross splines
! note that the cross splines need to be in increasing center spline coordinate order
iL = 1
tL = t(idx(iL))
iR = min(iL+1, ndx) ! allowed, since ncs>1
tR = t(idx(iR))
do while ( tR.lt.sc(i) .and. iR.lt.ndx )
iL = iR
tL = tR
iR = iR+1
tR = t(idx(iR))
if ( iR.eq.ndx ) exit
end do
if ( abs(tR-tL).gt.1d-8 ) then
fac = (sc(i)-tL) / (tR-tL)
else
fac = 0d0
iR = iL
end if
fac = max(min(dble((iL))+fac-1d0, dble(ndx-1)),0d0)
!
call splint(hlist,hL2,ndx,fac,hgL(j,i))
! linear interpolation
! fac = fac+1d0-dble(iL)
! hgL(j,i) = (1d0-fac)*hL(j,idx(iL)) + fac*hL(j,idx(iR))
end do ! do i=1,mfac
end if
nlist_loc = nlistR-j
call get_index(ncs, nlist_loc, ndx, idx)
if ( ndx.gt.0 ) then
hR(j,1:ncs) = splineprops(is)%hR(j,1:ncs)
! reallocate if necessary
if ( ndx.gt.ubound(hlist,1) ) then
numnew = int(1.2d0*dble(ndx))+1
call realloc(hlist, numnew)
end if
hlist(1:ndx) = hR(j,idx(1:ndx))
call spline(hlist,ndx,hR2)
do i=1,mfac
! find two nearest cross splines
! note that the cross splines need to be in increasing center spline coordinate order
iL = 1
tL = t(idx(iL))
iR = min(iL+1,1) ! allowed, since ncs>1
tR = t(idx(iR))
do while ( tR.lt.sc(i) .and. iR.lt.ndx )
iL = iR
tL = tR
iR = iR+1
tR = t(idx(iR))
if ( iR.eq.ndx ) exit
end do
if ( abs(tR-tL).gt.1d-8 ) then
fac = (sc(i)-tL) / (tR-tL)
else
fac = 0d0
iR = iL
end if
fac = max(min(dble((iL))+fac-1d0, dble(ndx-1)),0d0)
! spline interpolation between two original cross splines only
isL = splineprops(is)%ics(idx(iL))
if ( ndx.gt.1 ) then
isR = splineprops(is)%ics(idx(iR))
else
isR = isL
end if
call splint(hlist,hR2,ndx,fac,hgR(j,i))
end do ! do i=1,mfac
end if
end do ! do j=1,Nsubmax
end if
! store grid height
do i=1,mfac
eheight(:,igL+i-1) = hgL(:,i)
eheight(:,igR+mfac-i) = hgR(:,i)
end do
! smooth grid heights
! MAXITER = 0
! do iter=1,MAXITER
! do i=1,mfac
! hgL(:,i) = eheight(:,igL+i-1)
! hgR(:,i) = eheight(:,igR+mfac-i)
! end do
! do i=1,mfac
! iL = max(i-1,1)
! iR = min(i+1,mfac)
! eheight(:,igL+i-1) = 0.5d0*hgL(:,i) + 0.25d0*(hgL(:,iL) + hgL(:,iR))
! eheight(:,igR+mfac-i) = 0.5d0*hgR(:,i) + 0.25d0*(hgR(:,iL) + hgR(:,iR))
! end do
! end do
end do ! do is = 1,mcs
ierror = 0
! error handling
1234 continue
! restore
mfac = mfacmax
! deallocate
if ( allocated(hL) ) deallocate(hL, hR)
if ( allocated(hL2) ) deallocate(hL2, hR2)
if ( allocated(sc) ) deallocate(sc)
if ( allocated(hgL) ) deallocate(hgL, hgR)
if ( allocated(hgL_loc)) deallocate(hgL_loc, hgR_loc)
if ( allocated(xlist) ) deallocate(xlist, ylist, hlist, nlistL, nlistR, nlist_loc)
if ( allocated(ics) ) deallocate(ics, idx)
if ( allocated(t) ) deallocate(t)
return
end subroutine comp_gridheights
!> get the cross splines that have valid grid height
subroutine get_index(ncs, isvalid, ndx, idx)
implicit none
integer, intent(in) :: ncs !< number of cross splines
integer, dimension(ncs), intent(in) :: isvalid !< valid (>=0) or not (<0)
integer, intent(out) :: ndx !< number of valid cross splines
integer, dimension(ncs), intent(out) :: idx !< valid cross splines
integer :: i
ndx = 0
do i=1,ncs
if ( isvalid(i).ge.0 ) then
ndx = ndx+1
idx(ndx) = i
end if
end do
return
end subroutine
!> compute edge grow velocities, grow factors and number of grid layers in the subintervals
subroutine comp_edgevel(mc, edgevel, dgrow1, nfac1, ierror)
use m_splines
use m_gridsettings
use m_spline2curvi
use m_alloc
use m_missing
implicit none
integer, intent(in) :: mc !< number of grid points
double precision, dimension(mc-1), intent(out) :: edgevel !< edge-based grid grow velocity, first layer only
double precision, dimension(Nsubmax,mc-1), intent(out) :: dgrow1 !< edge-based grid growth factor, for each subinterval of grid layers
integer, dimension(Nsubmax,mc-1), intent(out) :: nfac1 !< edge-based number of grid layers, for each subinterval of grid layers
integer, intent(out) :: ierror !< 0: no error, 1: error
double precision, allocatable :: eheight(:,:) ! edge-based grid height, for each subinterval of grid layers
double precision :: growfac, hmax, h_h0_maxL, h_h0_maxR
integer :: i, is, igL, igR, j, js, mfacmax, nfacmax, ncs, numtruecross
integer :: Ndum, NuniL, NuniR, NexpL, NexpR, NsubL, NsubR, ja
integer :: iother, iter
integer, external :: comp_nfac
double precision, external :: comp_dgrow
ierror = 1
mfacmax = mfac
nfacmax = nfac
edgevel = DMISS
dgrow1 = 1d0
nfac1(1,:) = 1
nfac1(2:Nsubmax,:) = 0
allocate(eheight(Nsubmax,mc-1))
call comp_gridheights(mc, eheight, ierror)
! compute edge velocities and number of gridlayers
do is=1,mcs
mfac = splineprops(is)%mfac
! if ( mfac.lt.1 ) cycle
if ( splineprops(is)%id .ne. 0 ) cycle ! center splines only
!
igL = splineprops(is)%iL
igR = splineprops(is)%iR
ncs = splineprops(is)%ncs
! compute the number of cells perpendicalur to the center spline(s)
dheight0 = daspect*dwidth
dheight0 = min(maxval(eheight(1,:), MASK=eheight(1,:).ne.DMISS), dheight0)
NsubL = Nsubmax
NsubR = Nsubmax
numtruecross = 0
do j=1,ncs
js = splineprops(is)%ics(j)
if ( splineprops(js)%id.ne.1 ) cycle ! true cross splines only
numtruecross = numtruecross+1
NsubL = min(NsubL, splineprops(is)%NsubL(j))
NsubR = min(NsubR, splineprops(is)%NsubR(j))
end do
if ( numtruecross.eq.0 ) then ! no true cross splines: exponentially growing grid only
NsubL = 0
NsubR = 0
end if
do iter = 1,2 ! repeat, so the gridlayer thicknesses on both sides will match
! Left, uniform part
if ( (NsubL.gt.1 .and. NsubL.eq.NsubR) .or. NsubL.gt.NsubR ) then
hmax = maxval(eheight(1,igL:igL+mfac-1))
NuniL = floor(hmax/dheight0 + 0.99999d0)
! at maximum nfacUNImax grid layers in uniform part
NuniL = min(NuniL, nfacUNImax)
h_h0_maxL = 0d0 ! (h/h0)_max
do i=igL,igL+mfac-1
nfac1(1,i) = NuniL
edgevel(i) = eheight(1,i)/NuniL
h_h0_maxL = max( h_h0_maxL, eheight(2,i)/edgevel(i) )
end do
else
! only one subinterval: no uniform part
NuniL = 0
h_h0_maxL = 0d0 ! (h/h0)_max
do i=igL,igL+mfac-1
nfac1(1,i) = NuniL
edgevel(i) = dheight0
! compare with other side of spline
iother = igR+mfac-(i-igL+1)
if ( edgevel(iother).ne.DMISS ) then
if ( nfac1(1,iother).eq.0 ) then ! no uniform part on other side: take max
edgevel(i) = max(edgevel(i), edgevel(iother))
else ! uniform part on other side: take that value
edgevel(i) = edgevel(iother)
end if
end if
eheight(2:Nsubmax,i) = eheight(1:Nsubmax-1,i)
h_h0_maxL = max( h_h0_maxL, eheight(2,i)/edgevel(i) )
end do
end if
! Right, uniform part
if ( (NsubR.gt.1 .and. NsubL.eq.NsubR) .or. NsubR.gt.NsubL ) then
hmax = maxval(eheight(1,igR:igR+mfac-1))
NuniR = floor(hmax/dheight0 + 0.99999d0)
! at maximum nfacmax grid layers in uniform part
NuniR = min(NuniR, nfacUNImax)
h_h0_maxR = 0d0 ! (h/h0)_max
do i=igR,igR+mfac-1
nfac1(1,i) = NuniR
edgevel(i) = eheight(1,i)/NuniR
h_h0_maxR = max( h_h0_maxR, eheight(2,i)/edgevel(i) )
end do
else
! only one subinterval: no uniform part
NuniR = 0
h_h0_maxR = 0d0 ! (h/h0)_max
do i=igR,igR+mfac-1
nfac1(1,i) = NuniR
edgevel(i) = dheight0
! compare with other side of spline
iother = igL+mfac-(i-igR+1)
if ( edgevel(iother).ne.DMISS ) then
if ( nfac1(1,iother).eq.0 ) then ! no uniform part on other side: take max
edgevel(i) = max(edgevel(i), edgevel(iother))
else ! uniform part on other side: take that value
edgevel(i) = edgevel(iother)
end if
end if
eheight(2:Nsubmax,i) = eheight(1:Nsubmax-1,i)
h_h0_maxR = max( h_h0_maxR, eheight(2,i)/edgevel(i) )
end do
end if
end do ! do iter=1,2
ja = jaoutside
if ( (NsubL.eq.0 .and. NsubR.le.1) .or. (NsubR.eq.0 .and. NsubL.le.1) .or. (NsubL.eq.1 .and. NsubR.eq.1) ) then
ja = 1
end if
! Left, exponentially growing part
if ( ja.eq.1 ) then
NexpL = min(comp_nfac(h_h0_maxL, dgrow),nfac)
else
NexpL = 0
end if
nfac1(2,igL:igL+mfac-1) = NexpL
! Right, exponentially growing part
if ( ja.eq.1 ) then
NexpR = min(comp_nfac(h_h0_maxR, dgrow),nfac)
else
NexpR = 0
end if
nfac1(2,igR:igR+mfac-1) = NexpR
end do ! do is = 1,mcs
! compute local grow factors
do is=1,mcs
if ( splineprops(is)%mfac.lt.1 ) cycle
do i=splineprops(is)%iL,splineprops(is)%iR + splineprops(is)%mfac-1
if ( xg1(i).eq.DMISS .or. xg1(i+1).eq.DMISS .or. nfac1(2,i).lt.1 ) cycle
dgrow1(2,i) = comp_dgrow(eheight(2,i), edgevel(i), nfac1(2,i), ierror)
if ( ierror.eq.1 ) then
dgrow1(2,i) = 1d0
! goto 1234
end if
! no shrinking grid layers, decrease first exponentially growing grid layer height instead (to 1, i.e. equidistant grid layers)
! dgrow1(i) = max(dgrow1(i),1d0)
! compute the first grid layer height
! if ( abs(dgrow1(i)-1d0).gt.1d-8 ) then
! growfac = (dgrow1(i)-1d0)/(dgrow1(i)**(nfac1(1,i)-nfac1(2,i))-1d0)
! else
! growfac = 1d0/dble(nfac1(1,i)-nfac1(2,i))
! end if
! edgevel(i) = (eheight(1,i)-eheight(2,i)) * growfac
end do
end do
ierror = 0
! error handling
1234 continue
! restore
mfac = mfacmax
nfac = nfacmax ! not necessary, as nfac was not altered, but just to be sure
deallocate(eheight)
return
end subroutine comp_edgevel
!> get the intersections of a spline with all other splines
subroutine get_crosssplines(num, xs1, ys1, ncs, ics, Lorient, t, cosphi)
use m_splines
use m_spline2curvi
use m_alloc
use sorting_algorithms, only: indexx
use geometry_module, only: dbdistance
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xs1, ys1 !< coordinates of spline control points
integer, intent(out) :: ncs !< number of cross splines
integer, dimension(mcs), intent(out) :: ics !< indices of the cross splines
logical, dimension(mcs), intent(out) :: Lorient !< orientation
double precision, dimension(mcs), intent(out) :: t !< center-spline coordinate of cross splines
double precision, dimension(mcs), intent(out) :: cosphi !< cos of crossing angles
double precision, dimension(:), allocatable :: xlist, ylist
integer, dimension(mcs) :: perm ! for sorting the cross splines
integer, dimension(mcs) :: ics1
logical, dimension(mcs) :: Lorient1
double precision, dimension(mcs) :: t1
integer :: idum, idx, js, numj, numcro, numnew
double precision :: crp, tj, xp, yp, hsumL, hsumR, hmax, tt
! allocate
allocate(xlist(1), ylist(1))
! find the cross splines
ncs = 0
ics = 0
t = 1d99 ! default values will cause sorting to disregard non cross splines
do js = 1,mcs
call nump(js,numj)
! reallocate if necessary
if (numj.gt.ubound(xlist,1) ) then
numnew = int(1.2d0*dble(numj)) + 1
call realloc(xlist, numnew)
call realloc(ylist, numnew)
end if
! non-cross splines may only cross with cross splines visa versa
if ( (num.eq.2 .and. numj.eq.2) .or. (num.gt.2 .and. numj.gt.2) ) cycle
! get the intersection of the splines
xlist(1:numj) = xsp(js,1:numj)
ylist(1:numj) = ysp(js,1:numj)
call sect3r(xs1, ys1, xlist, ylist, &
1, 1, max(num,numj), crp, num, numj, numcro, tt, tj, xp, yp)
if ( abs(crp).lt.dtolcos ) then
numcro = 0d0
end if
if ( numcro.eq.1 ) then ! intersection found
ncs = ncs+1
ics(js) = js
if ( crp.gt.0d0 ) then
Lorient(js) = .false.
else
Lorient(js) = .true.
end if
t(js) = tt
cosphi(js) = crp
end if
end do ! do js=1,mcs
! sort cross splines, such that they are in increasing center spline coordinate order
call indexx(mcs,t,perm)
ics1 = ics
Lorient1 = Lorient
t1 = t
do js=1,mcs
idx = perm(js)
ics(js) = ics1(idx)
Lorient(js) = Lorient1(idx)
t(js) = t1(idx)
end do
! deallocate
deallocate(xlist, ylist)
return
end subroutine get_crosssplines
!> derive center spline propererties from cross splines
subroutine get_splineprops(mcs_old, id, iLRmfac)
use m_splines
use m_spline2curvi
use m_alloc
use m_missing
implicit none
integer, intent(in) :: mcs_old !< number of original splines
integer, dimension(mcs_old), intent(in) :: id !< original settings
integer, dimension(3,mcs_old), intent(in) :: iLRmfac !< original settings
integer, dimension(mcs) :: perm ! for sorting the cross splines
integer, dimension(mcs) :: ics
logical, dimension(mcs) :: Lorient
! double precision, dimension(mcs) :: t, hL, hR
double precision, dimension(mcs) :: t
double precision, dimension(:), allocatable :: xlist, ylist
integer :: idx, i, j, is, js, imiddle, ismiddle
integer :: num, numj, numcro, ncs, numnew
double precision :: crp, dslength, tj, xp, yp, hsumL, hsumR, hmax, cosphi
double precision, external :: splinelength
! allocate
allocate(xlist(1), ylist(1))
if ( allocated(splineprops) ) call deallocate_splineprops()
call allocate_splineprops()
do is = 1,mcs
! determine the number of control points in the spline
call nump(is,num)
! reallocate if necessary
if ( num.gt.ubound(xlist,1) ) then
numnew = int(1.2d0*dble(num))+1
call realloc(xlist, numnew)
call realloc(ylist, numnew)
end if
xlist(1:num) = xsp(is,1:num)
ylist(1:num) = ysp(is,1:num)
splineprops(is)%length = splinelength(num, xlist, ylist)
call get_crosssplines(num, xlist, ylist, splineprops(is)%ncs, splineprops(is)%ics, splineprops(is)%Lorient, splineprops(is)%t, splineprops(is)%cosphi)
end do ! do is=1,mcs
! determine whether a spline is a center spline or a bounding spline
! first, select all non-cross splines only
do is=1,mcs
call nump(is,num)
if ( num.gt.2 ) then
splineprops(is)%id = 0
else
splineprops(is)%id = 1
end if
end do
! then, check the cross splines; the center spline is the middle spline that crosses the cross spline
do js=1,mcs
call nump(js,num)
if ( num.ne.2 ) cycle ! cross splines only
ncs = splineprops(js)%ncs
if ( ncs.lt.1 ) cycle
! determine the middle
imiddle = min(ncs/2 + 1, ncs)
ismiddle = splineprops(js)%ics(imiddle)
! ncs is even: check if the middle spline has already been assigned as a bounding spline
if ( splineprops(ismiddle)%id.ne.0 .and. 2*(imiddle-1).eq.ncs ) then
imiddle = min(imiddle+1,ncs)
ismiddle = splineprops(js)%ics(imiddle)
end if
if ( splineprops(ismiddle)%id.eq.0 ) then
! associate bounding splines with the middle spline
ismiddle = splineprops(js)%ics(imiddle)
do i=1,imiddle-1
is = splineprops(js)%ics(i)
splineprops(is)%id = -ismiddle
end do
do i=imiddle+1,ncs
is = splineprops(js)%ics(i)
splineprops(is)%id = -ismiddle
end do
end if
end do
! restore original splines
if ( mcs_old.gt.0 ) then
do is=1,mcs_old
splineprops(is)%id = id(is)
splineprops(is)%iL = iLRmfac(1,is)
splineprops(is)%iR = iLRmfac(2,is)
splineprops(is)%mfac = iLRmfac(3,is)
end do
! mark new splines as artificial cross splines
do is=mcs_old+1,mcs
splineprops(is)%id = 3
! deactivate crosssplines that are not nearly orthogonal to the center spline(s)
! do j=1,splineprops(is)%ncs
! js = splineprops(is)%ics(j)
! cosphi = splineprops(is)%cosphi(js)
! if ( cosphi.ne.DMISS .and. abs(cosphi).lt.0.95d0 ) then
! exit
! end if
! end do
end do
end if
! get the grid heights
call get_heights()
! determine maximum grid height for this spline
do is = 1,mcs
ncs = splineprops(is)%ncs
dslength = splineprops(is)%length
if ( ncs.eq.0 ) then
splineprops(is)%hmax = daspect*dslength
else
hmax = 0d0
do i=1,ncs
hsumL = 0d0
hsumR = 0d0
do j=1,splineprops(is)%NsubL(i)
hsumL = hsumL + splineprops(is)%hL(j,i)
end do
do j=1,splineprops(is)%NsubR(i)
hsumR = hsumR + splineprops(is)%hR(j,i)
end do
hmax = max(hmax, max(hsumL, hsumR) )
end do
splineprops(is)%hmax = hmax
end if
end do
! deallocate
deallocate(xlist, ylist)
return
end subroutine get_splineprops
!> get the grid heights from the cross spline information
subroutine get_heights()
use m_splines
use m_spline2curvi
use m_missing
use m_alloc
implicit none
integer :: is, j, js, k, kk, ks, kks, ncs, num, numj, NsubL, NsubR
integer :: kL, kR ! left and right neighboring splines at the cross spline w.r.t. the center spline
integer :: numnew
double precision, dimension(Nsubmax) :: hL, hR
double precision, dimension(:), allocatable :: xlist, ylist
logical :: Lorient
double precision, external :: splinelength_int
! allocate
allocate(xlist(1), ylist(1))
do is=1,mcs
! determine the number of control points in the spline
call nump(is,num)
if ( num.le.2 ) cycle ! center splines only
do j=1,splineprops(is)%ncs
js = splineprops(is)%ics(j)
call nump(js,numj)
ncs = splineprops(js)%ncs
! for this cross spline, find the left and right neighboring splines w.r.t. the center spline
kL = 0
kR = 0
do k=1,ncs
ks = splineprops(js)%ics(k)
if ( ks.eq.is ) then
! if ( k.gt.1 ) kL = splineprops(js)%ics(k-1)
! if ( k.lt.ncs ) kR = splineprops(js)%ics(k+1)
do kk=k-1,1,-1
kks = splineprops(js)%ics(kk)
if ( splineprops(kks)%id.eq.-ks ) then
kL = kks
exit
end if
end do
do kk=k+1,ncs
kks = splineprops(js)%ics(kk)
if ( splineprops(kks)%id.eq.-ks ) then
kR = splineprops(js)%ics(kk)
exit
end if
end do
exit
end if
end do
Lorient = splineprops(is)%Lorient(j) ! orientation of the cross spline
! reallocate if necessary
if ( numj.gt.ubound(xlist,1) ) then
numnew = int(1.2d0*dble(numj))+1
call realloc(xlist, numnew)
call realloc(ylist, numnew)
end if
xlist(1:numj) = xsp(js,1:numj)
ylist(1:numj) = ysp(js,1:numj)
call comp_subheights(is, Lorient, numj, xlist, ylist, &
splineprops(js)%ncs, splineprops(js)%ics, splineprops(js)%t, splineprops(js)%cosphi, &
splineprops(is)%NsubL(j), splineprops(is)%NsubR(j), splineprops(is)%hL(:,j), splineprops(is)%hR(:,j))
end do
end do
! deallocate
deallocate(xlist, ylist)
return
end subroutine get_heights
!> compute the height of the subintervals of grid layers on a cross spline, w.r.t. a center spline
subroutine comp_subheights(is, Lorient, num, xs, ys, ncs, ics, t, cosphi, nsubL, nsubR, hL, hR)
use m_splines
use m_spline2curvi
implicit none
integer, intent(in) :: is !< center spline number
logical, intent(in) :: Lorient !< orientation of cross spline
integer, intent(in) :: num !< number of control points in cross spline (should be 2)
double precision, dimension(num), intent(in) :: xs, ys !< coordinates of cross spline control points
integer, intent(in) :: ncs !< number of splines crossing the cross spline
integer, dimension(ncs), intent(in) :: ics !< spline numbers of splines that cross the cross spline
double precision, dimension(ncs), intent(in) :: t !< cross spline coordinates of the crossings
double precision, dimension(ncs), intent(in) :: cosphi !< cosine of crossing angle
integer, intent(out) :: nsubL, nsubR !< number of subintervals left and right of the center spline
double precision, dimension(Nsubmax), intent(inout) :: hL, hR !< subinterval heights left and right of center spline
integer :: k, kk, kL, kR, ks, kkL, kkR, Ndum
double precision, dimension(Nsubmax) :: hdum
double precision, external :: splinelength_int
hL = 0d0
hR = 0d0
! for this cross spline, find the left and right neighboring splines w.r.t. the center spline
kL = 0
kR = 0
do k=1,ncs
ks = ics(k)
if ( ks.eq.is ) then
if ( k.gt.1 ) kL = ics(k-1)
if ( k.lt.ncs ) kR = ics(k+1)
exit
end if
end do
! compute the heights of the subintervals
NsubR = 0
kkR = k
do kk=k,ncs-1
if ( NsubR.ge.Nsubmax-1 ) exit
if ( splineprops(ics(kk+1))%id.ne.-is ) cycle
kkL = kkR
kkR = kk+1
NsubR = NsubR+1
hR(NsubR) = splinelength_int(num, xs, ys, t(kkL), t(kkR))
! begin test
! hR(NsubR) = cosphi(kk)*hR(NsubR)
! end test
end do
NsubR = NsubR+1
hR(NsubR) = splinelength_int(num, xs, ys, t(kkR), dble(num-1))
! begin test
! hR(NsubR) = cosphi(ncs)*hR(NsubR)
! end test
if ( NsubR.lt.Nsubmax ) hR(NsubR+1:Nsubmax) = 0d0
NsubL = 0
kkL = k
do kk=k,2,-1
if ( NsubL.ge.Nsubmax-1 ) exit
if ( splineprops(ics(kk-1))%id.ne.-is ) cycle
kkR = kkL
kkL = kk-1
NsubL = NsubL+1
hL(NsubL) = splinelength_int(num, xs, ys, t(kkL), t(kkR))
! begin test
! hL(NsubL) = cosphi(kk)*hL(NsubL)
! end test
end do
NsubL = NsubL+1
hL(NsubL) = splinelength_int(num, xs, ys, 0d0, t(kkL))
! begin test
! hL(NsubL) = cosphi(1)*hL(NsubL)
! end test
if ( NsubL.lt.Nsubmax ) hL(NsubL+1:Nsubmax) = 0d0
! check orientation
if ( .not.Lorient ) then
Ndum = NsubL
NsubL = NsubR
NsubR = Ndum
hdum = hL
hL = hR
hR = hdum
end if
return
end subroutine comp_subheights
!> allocate splineprops array
subroutine allocate_splineprops()
use m_splines
use m_spline2curvi
use m_missing
implicit none
integer :: ispline
allocate(splineprops(mcs))
do ispline=1,mcs
allocate(splineprops(ispline)%ics(mcs))
allocate(splineprops(ispline)%Lorient(mcs))
allocate(splineprops(ispline)%t(mcs))
allocate(splineprops(ispline)%cosphi(mcs))
allocate(splineprops(ispline)%hL(Nsubmax,mcs))
allocate(splineprops(ispline)%hR(Nsubmax,mcs))
allocate(splineprops(ispline)%NsubL(mcs))
allocate(splineprops(ispline)%NsubR(mcs))
! initialize
splineprops(ispline)%id = -999
splineprops(ispline)%ncs = 0
splineprops(ispline)%length = DMISS
splineprops(ispline)%hmax = DMISS
splineprops(ispline)%ics(:) = 0
splineprops(ispline)%Lorient(:) = .true.
splineprops(ispline)%t(:) = DMISS
splineprops(ispline)%cosphi(:) = DMISS
splineprops(ispline)%hL(:,:) = DMISS
splineprops(ispline)%hR(:,:) = DMISS
splineprops(ispline)%NsubL(:) = 0
splineprops(ispline)%NsubR(:) = 0
splineprops(ispline)%mfac = 0
splineprops(ispline)%nfacL(:) = 0
splineprops(ispline)%nfacR(:) = 0
splineprops(ispline)%iL = 0
splineprops(ispline)%iR = 0
end do
return
end subroutine allocate_splineprops
!> deallocate splineprops array
subroutine deallocate_splineprops()
use m_spline2curvi
implicit none
integer :: ispline
if ( .not.allocated(splineprops) ) return
do ispline=1,ubound(splineprops,1)
if ( allocated(splineprops(ispline)%ics) ) deallocate(splineprops(ispline)%ics)
if ( allocated(splineprops(ispline)%Lorient) ) deallocate(splineprops(ispline)%Lorient)
if ( allocated(splineprops(ispline)%t) ) deallocate(splineprops(ispline)%t)
if ( allocated(splineprops(ispline)%cosphi) ) deallocate(splineprops(ispline)%cosphi)
if ( allocated(splineprops(ispline)%hL) ) deallocate(splineprops(ispline)%hL)
if ( allocated(splineprops(ispline)%hR) ) deallocate(splineprops(ispline)%hR)
if ( allocated(splineprops(ispline)%NsubL) ) deallocate(splineprops(ispline)%NsubL)
if ( allocated(splineprops(ispline)%NsubR) ) deallocate(splineprops(ispline)%NsubR)
end do
deallocate(splineprops)
return
end subroutine deallocate_splineprops
!> generate the first gridline of the whole grid, i.e. on all center splines
subroutine make_wholegridline(ierror)
use m_splines
use m_grid
use m_gridsettings
use m_spline2curvi
use m_alloc
use m_missing
implicit none
integer, intent(out) :: ierror ! error (1) or not (0)
double precision, allocatable, dimension(:) :: xlist, ylist
integer :: ig ! index in gridline array
integer :: is, mfacmax, num, Nmaxsize, numnew
integer :: igL, igR, numcentersplines
ierror = 1
jacirc = 0 ! circularly connected gridlines not supported
mfacmax = mfac ! from grid settings
! allocate
if ( allocated(xg1) ) deallocate(xg1)
if ( allocated(yg1) ) deallocate(yg1)
if ( allocated(sg1) ) deallocate(sg1)
Nmaxsize = 2*mfacmax+1
allocate(xg1(Nmaxsize), yg1(Nmaxsize), sg1(Nmaxsize))
allocate(xlist(1), ylist(1))
! make the first gridline
ig = 0 ! index in gridline array
numcentersplines = 0
do is = 1,mcs
if ( splineprops(is)%id .ne. 0 ) cycle ! center splines only
numcentersplines = numcentersplines + 1
! determine the number of control points in the spline
call nump(is,num)
! reallocate if necessary
Nmaxsize = ig+2*(mfacmax+1)+2 ! upper bound of new grid size, i.e. with two sides of spline and two DMISSes added
if ( Nmaxsize.gt.ubound(xg1,1) ) then
call realloc(xg1, Nmaxsize)
call realloc(yg1, Nmaxsize)
call realloc(sg1, Nmaxsize)
end if
! add DMISS if necessary
if ( ig.gt.1 ) then
ig = ig+1
xg1(ig) = DMISS
yg1(ig) = DMISS
sg1(ig) = DMISS
end if
! make a gridline on the spline
ig = ig+1
igL = ig
! reallocate if necessary
if ( num.gt.ubound(xlist,1) ) then
numnew = int(1.2d0*dble(num))+1
call realloc(xlist,numnew)
call realloc(ylist,numnew)
end if
xlist(1:num) = xsp(is,1:num)
ylist(1:num) = ysp(is,1:num)
call make_gridline(num, xlist, ylist, dwidth, mfacmax, mfac, splineprops(is)%hmax, xg1(ig), yg1(ig), sg1(ig), jacurv)
! compute new (actual) grid size
! new size old size both sides of spline DMISS between both sides
mc = ig-1 + 2*(mfac+1) + 1
ig = ig+mfac
! add DMISS
ig = ig+1
xg1(ig) = DMISS
yg1(ig) = DMISS
sg1(ig) = DMISS
! add other side of gridline
ig = ig+1
igR = ig
xg1(ig:ig+mfac) = xg1(ig-2:ig-2-mfac:-1)
yg1(ig:ig+mfac) = yg1(ig-2:ig-2-mfac:-1)
sg1(ig:ig+mfac) = sg1(ig-2:ig-2-mfac:-1)
ig = ig+mfac
! store indices in gridline array
splineprops(is)%mfac = mfac
splineprops(is)%iL = igL
splineprops(is)%iR = igR
end do ! do is=1,mcs
if ( numcentersplines.eq.0 ) then
call qnerror('no center splines found', ' ', ' ')
goto 1234
end if
ierror = 0
! error handling
1234 continue
! deallocate
deallocate(xlist, ylist)
mfac = mfacmax ! restore
return
end subroutine make_wholegridline
!> generate a gridline on a spline with a prescribed maximum mesh width
subroutine make_gridline(num, xsp, ysp, dwidth, mfacmax, mfac, hmax, xg, yg, sc, jacurv)
use m_missing
use m_alloc
use geometry_module, only: dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xsp, ysp !< coordinates of spline control points
double precision, intent(in) :: dwidth !< maximum mesh width
integer, intent(in) :: mfacmax !< maximum allowed number of mesh intervals
double precision, intent(in) :: hmax !< maximum grid height for this spline (both sides)
integer, intent(out) :: mfac !< number of mesh intervals
double precision, dimension(mfacmax+1), intent(out) :: xg, yg !< coordinates of grid points
double precision, dimension(mfacmax+1), intent(inout) :: sc !< spline-coordinates of grid points
integer, intent(in) :: jacurv !< curvature adapted grid spacing (1) or not (0)
double precision, dimension(num) :: xsp2, ysp2 ! second order derivatives of spline coordinates
double precision :: dmaxwidth ! current maximum mesh width
double precision :: dspllength ! spline length
integer :: i, mfac_loc
double precision, external :: splinelength
! test
! copy spline nodes to grid points
! mfac = min(num-1, mfacmax)
! do i=1,mfac+1
! xg(i) = xsp(i)
! yg(i) = ysp(i)
! end do
! return
! end test
! compute second order derivates of spline coordinates
call spline(xsp,num,xsp2)
call spline(ysp,num,ysp2)
! make a gridline on the spline
dmaxwidth = huge(1d0)
dspllength = splinelength(num, xsp, ysp)
mfac_loc = int(0.9999d0+dspllength/dwidth)
mfac = min(mfac_loc,mfacmax)
do while ( dmaxwidth.gt.dwidth)
! make the gridline
if ( jacurv.eq.1 ) then
call spline2gridline(mfac+1, num, xsp, ysp, xsp2, ysp2, xg, yg, sc, hmax)
else
call spline2gridline(mfac+1, num, xsp, ysp, xsp2, ysp2, xg, yg, sc, -hmax)
end if
! determine maximum mesh width
dmaxwidth = 0d0
do i=1,mfac
if ( xg(i).eq.DMISS .or. xg(i+1).eq.DMISS ) cycle
dmaxwidth = max( dbdistance(xg(i),yg(i),xg(i+1),yg(i+1), jsferic, jasfer3D, dmiss), dmaxwidth)
end do
! compute and update the number of mesh intervals
if ( dmaxwidth.le.dwidth .or. mfac.eq.mfacmax ) then
exit
else
mfac = min(max(int(dmaxwidth/dwidth*mfac), mfac+1), mfacmax) ! add at least one grid point
end if
end do
return
end subroutine make_gridline
!> compute the number of grid layers for a given grow factor, first grid layer height and total grid height
integer function comp_nfac(h_h0, dgrow)
implicit none
double precision, intent(in) :: h_h0 !< ratio of first grid layer height w.r.t. total grid height, i.e. h/h0
double precision, intent(in) :: dgrow !< grow factor
if ( abs(dgrow-1d0).gt.1d-8 ) then
! comp_nfac = floor(0.999d0+ log( (dgrow-1d0)*h_h0 + 1d0 ) / log(dgrow) )
comp_nfac = floor(log( (dgrow-1d0)*h_h0 + 1d0 ) / log(dgrow) )
else
comp_nfac = floor(0.999d0+ h_h0 )
end if
return
end function comp_nfac
! determine the grid grow factor for a given total grid height, first grid layer height and number of grid layers
double precision function comp_dgrow(height, dheight0, nfac, ierror)
use m_missing
implicit none
double precision, intent(in) :: height !< total grid height
double precision, intent(in) :: dheight0 !< first grid layer height
integer, intent(in) :: nfac !< number of grid layers
integer, intent(out) :: ierror !< error (1) or not (0)
integer :: iter
double precision :: fkp1, fk, fkm1, gkp1, gk, gkm1, deltag
double precision, external :: comp_h
integer, parameter :: maxiter=1000
double precision, parameter :: dtol = 1d-8
double precision, parameter :: deps = 1d-2
double precision, parameter :: relax = 0.5d0
ierror = 1
gk = 1d0
fk = comp_h(gk, dheight0, nfac) - height
gkp1 = 1d0 + deps
fkp1 = comp_h(gkp1, dheight0, nfac) - height
if ( abs(fkp1).gt.dtol .and. abs(fkp1-fk).gt.dtol ) then
do iter=1,maxiter
gkm1 = gk
fkm1 = fk
gk = gkp1
fk = fkp1
gkp1 = gk - relax * fk / (fk-fkm1+1d-16) * ( gk - gkm1)
fkp1 = comp_h(gkp1, dheight0, nfac) - height
! if ( abs(fkp1).lt.dtol .or. abs(fkp1-fk).lt.dtol ) exit
if ( abs(fkp1).lt.dtol ) exit
end do
end if
if ( abs(fkp1).gt.dtol ) then
! no convergence
! call qnerror('comp_dgrow: no convergence', ' ', ' ')
comp_dgrow = DMISS
goto 1234
else
comp_dgrow = gkp1
end if
ierror = 0
! error handling
1234 continue
return
end function comp_dgrow
!> compute total grid height for a given grow factor, first grid layer height and number of grid layers
double precision function comp_h(dgrow, dheight0, nfac)
implicit none
double precision, intent(in) :: dgrow !< grow factor
double precision, intent(in) :: dheight0 !< first grid layer height
integer, intent(in) :: nfac !< number of grid layers
if ( abs(dgrow-1d0).gt.1d-8 ) then
comp_h = (dgrow**nfac-1d0) / (dgrow-1d0) * dheight0
else
comp_h = nfac * dheight0
end if
return
end function comp_h
!> approximate spline pathlength in interval
double precision function splinelength_int(num, xspl, yspl, s0, s1)
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xspl, yspl !< coordinates of slpine control points
double precision, intent(in) :: s0, s1 !< begin and end of interval in spline coordinates respectively
double precision, dimension(num) :: xspl2, yspl2 ! second order derivates of spline coordinates
double precision :: xL, yL, xR, yR, tL, tR, dt, fac
integer :: i,j,N
integer, parameter :: NSAM = 100 ! sample factor
integer, parameter :: Nmin = 10 ! minimum number of intervals
call splinxy(xspl, yspl, xspl2, yspl2, num)
dt = 1d0/dble(NSAM)
! number of intervals
N = max(floor(0.9999d0+(s1-s0)/dt), Nmin)
dt = (s1-s0)/dble(N)
! tR = s0
! call splintxy(xspl,yspl,xspl2,yspl2,num,tR,xR,yR)
splinelength_int = 0d0
tR = s0
call splintxy(xspl,yspl,xspl2,yspl2,num,tR,xR,yR)
do i=1,N
tL = tR
xL = xR
yL = yR
fac = dble(i)/dble(N)
tR = (1d0-fac) * s0 + fac*s1
call splintxy(xspl,yspl,xspl2,yspl2,num,tR,xR,yR)
splinelength_int = splinelength_int + dbdistance(xL,yL,xR,yR, jsferic, jasfer3D, dmiss)
end do
return
end function splinelength_int
!> approximate spline length
double precision function splinelength(num, xspl, yspl)
use geometry_module, only: dbdistance
use m_missing, only: dmiss
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xspl, yspl !< coordinates of slpine control points
double precision, dimension(num) :: xspl2, yspl2 ! second order derivates of spline coordinates
double precision :: xL, yL, xR, yR, tL, tR, dt
integer :: i,j
integer, parameter :: NSAM = 100 ! sample factor
call splinxy(xspl, yspl, xspl2, yspl2, num)
tR = 0d0
call splintxy(xspl,yspl,xspl2,yspl2,num,tR,xR,yR)
dt = 1d0/dble(NSAM)
splinelength = 0d0
do i=1,num-1
tR = dble(i-1)
do j=1,NSAM
tL = tR
xL = xR
yL = yR
tR = tR + dt
call splintxy(xspl,yspl,xspl2,yspl2,num,tR,xR,yR)
splinelength = splinelength + dbdistance(xL,yL,xR,yR, jsferic, jasfer3D, dmiss)
end do
end do
return
end function splinelength
!> copy the spline to a polyline
subroutine spline2poly()
use m_splines
use m_spline2curvi
use m_gridsettings
use m_polygon
use m_missing
implicit none
double precision, allocatable, dimension(:) :: sc ! spline-coordinates of grid points, not used
integer :: ispline, num, numpoints, kmax, mfacmax
double precision :: hmax
call savepol()
call delpol()
mfacmax = mfac
allocate(sc(mfacmax+1))
numpoints = 0
do ispline=1,mcs
! determine the number of control points in the spline
call nump(ispline,num)
if ( splineprops(ispline)%id .eq. 0 ) then ! center splines only
if ( numpoints.gt.0 ) then ! add to existing polygon
! add DMISS
! numpoints = numpoints+mfac_loc(ispline)+1+1
call increasepol(numpoints+mfacmax+2, 0 )
npl = npl+1
xpl(npl) = DMISS
ypl(npl) = DMISS
else ! no existing polygon
! numpoints = numpoints+mfac_loc(ispline)+1
call increasepol(numpoints+mfacmax+1, 0)
end if
mfac = splineprops(ispline)%mfac
hmax = splineprops(ispline)%hmax
call make_gridline(num, xsp(ispline,1:num), ysp(ispline,1:num), dwidth, mfacmax, mfac, hmax, xpl(npl+1:numpoints), ypl(npl+1:numpoints), sc, jacurv)
numpoints = numpoints+mfac+1
npl = numpoints
end if
end do
deallocate(sc)
! restore
mfac = mfacmax
return
end subroutine spline2poly
!> remove skewed cells and cells whose aspect ratio exceeds a prescibed value
!> note: latter not implemented yet
subroutine postgrid()
use m_grid
use m_spline2curvi, only: maxaspect
use m_missing
use geometry_module, only: dbdistance, dcosphi
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, dimension(mc) :: ifront
double precision :: dh, daspect, dcos, dcosR, xn, yn
integer :: i, iL, iR, iRR, idum, iL0, iR0, i1, j, ja, iter, numchanged
integer :: istriangle ! 0: no, -1: left, 1: right, 2: two
! double precision, parameter :: dcosmax = 0.86603
double precision, parameter :: dcosmax = 0.93969
double precision, parameter :: dtol = 1d-2
double precision, parameter :: dtolcos = 1d-2
call tekgrid(i)
ja = 1
call confrm('Remove skinny triangles?', ja)
if ( ja.eq.1 ) then
! remove skewed cells
do j=nc-1,2,-1
ifront = 1
do iter=1,10
write(6,"('iter = ', i0, ': ', $)") iter
numchanged = 0
! loop over the edges
! do i=1,mc-1
iR = 1
i = iR
do while (iR.ne.mc .or. i.ne.mc )
if ( iR.gt.i ) then
i = iR
else
i = i+1
if ( i.ge.mc ) exit
end if
if ( xc(i,j).eq.DMISS ) cycle
call get_LR(mc, xc(:,j), yc(:,j), i, iL, iR)
if ( dbdistance(xc(i,j),yc(i,j),xc(iR,j),yc(iR,j),jsferic, jasfer3D, dmiss).lt.dtol ) cycle
! detect triangular cell
if ( xc(i,j+1).eq.DMISS ) cycle
call get_LR(mc, xc(:,j+1), yc(:,j+1), i, iL0, iR0)
if ( dbdistance(xc(iL,j),yc(iL,j),xc(i,j),yc(i,j),jsferic, jasfer3D, dmiss).lt.dtol ) iL=i
if ( xc(iR,j+1).ne.DMISS ) then
if ( dbdistance(xc(i,j+1),yc(i,j+1),xc(iR,j+1),yc(iR,j+1),jsferic, jasfer3D, dmiss).lt.dtol .and. &
dcosphi(xc(i,j+1),yc(i,j+1),xc(i,j),yc(i,j),xc(i,j+1),yc(i,j+1),xc(iR,j),yc(iR,j),jsferic, jasfer3D, dxymis).gt.dcosmax ) then
! determine persistent node
dcos = dcosphi(xc(i,j-1),yc(i,j-1),xc(i,j),yc(i,j),xc(i,j),yc(i,j),xc(i,j+1),yc(i,j+1), jsferic, jasfer3D, dxymis)
dcosR = dcosphi(xc(iR,j-1),yc(iR,j-1),xc(iR,j),yc(iR,j),xc(iR,j),yc(iR,j),xc(iR,j+1),yc(iR,j+1), jsferic, jasfer3D, dxymis)
call get_LR(mc, xc(:,j), yc(:,j), iR, idum, iRR)
if ( (iRR.eq.iR .or. dcos-dcosR.lt.-dtolcos) .and. iL.ne.i ) then ! move left node
call cirr(xc(i,j),yc(i,j),211)
call cirr(xc(iR,j),yc(iR,j),31)
xc(i:iR-1,j) = xc(iR,j)
yc(i:iR-1,j) = yc(iR,j)
numchanged = numchanged+1
write(6,"(I0, '-', I0, 'L ', $)") i, iR-1
else if ( ( iL.eq.i .or. dcosR-dcos.lt.-dtolcos) .and. iRR.ne.iR ) then ! move right node
call cirr(xc(iR,j),yc(iR,j),211)
call cirr(xc(i,j),yc(i,j),204)
xc(iR:iRR-1,j) = xc(i,j)
yc(iR:iRR-1,j) = yc(i,j)
numchanged = numchanged+1
write(6,"(I0, '-', I0, 'R ', $)") iR, iRR-1
else ! move both nodes
xn = 0.5d0*(xc(i,j)+xc(iR,j))
yn = 0.5d0*(yc(i,j)+yc(iR,j))
call cirr(xn,yn,211)
xc(i:iR-1,j) = xn
yc(i:iR-1,j) = yn
xc(iR:iRR-1,j) = xn
yc(iR:iRR-1,j) = yn
numchanged = numchanged+1
write(6,"(I0, '-', I0, 'C ', $)") i, iRR-1
end if
end if
end if
end do
write(6,*)
if ( numchanged.eq.0 ) exit
end do
write(6,*) iter, numchanged
end do
end if
return
end subroutine postgrid
!> grow a gridlayer
subroutine growlayer(mc, nc, mmax, nmax, idir, maxaspect, j, edgevel, dt, xc, yc, ifront, istop)
use m_alloc
use m_missing
use unstruc_colors, only: ncolrg, ncolln
use unstruc_display
USE M_SAMPLES
use m_sferic
use m_spline2curvi, only: jaCheckFrontCollision, dtolLR
use geometry_module, only: dbdistance, dcosphi
implicit none
integer, intent(in) :: mc !< number of grid points
integer, intent(in) :: nc !< number of grid layers
integer, intent(in) :: mmax !< array size
integer, intent(in) :: nmax !< array size
integer, intent(in) :: idir !< grow direction, -1 or 1 (not used)
double precision, intent(in) :: maxaspect !< maximum cell aspect ratio height/width
integer, intent(in) :: j !< grid layer
double precision, dimension(mc-1), intent(in) :: edgevel !< grid layer edge-height
double precision, intent(inout) :: dt !< time step
double precision, dimension(mmax,nmax), intent(inout) :: xc, yc !< coordinates of grid points
integer, dimension(mc), intent(inout) :: ifront !< active nodes (1) or not (0)
integer, intent(out) :: istop !< stop (1) or not (0)
integer, dimension(mc) :: ifrontold, ifrontnew
double precision, dimension(mc) :: xc1, yc1 ! active grid layer coordinates
double precision, dimension(2,mc) :: vel ! growth velocity vector at grid layer, per node
! double precision, dimension(mc-1) :: edgevel ! edge normal-velocity
double precision, dimension(mc) :: dtmax ! maximum allowable grid layer growth time, per node
double precision, dimension(mc) :: dtmax_self ! maximum allowable grid layer growth time, per node
double precision, allocatable, dimension(:) :: dtmax2 ! maximum allowable grid layer growth time, per node
double precision :: dt_other ! maximum alloweble grid layer growth time; collision only
integer :: nf !< front dimension
integer :: numf !< array size
double precision, allocatable, dimension(:) :: xf, yf !< front point coordinates
double precision, allocatable, dimension(:,:) :: velf !< front growth velocity vectors
integer, allocatable, dimension(:,:) :: idxf !< (i,j)-indices of front points
double precision :: dt_loc, dt_tot
double precision :: dh, daspect, dtolLR_bak, dhmax
integer :: i, ii, j2, jj, iprev, jprev, inext, jnext, iL, iR, ja3
integer :: numchanged
logical :: LL, LR
double precision, parameter :: dtol = 1d-8
double precision, parameter :: dclearance = 5d2
integer :: icheck=3
logical :: Lalllines = .false. ! all gridlines (.true.) or not (.false.)
integer, save :: numgrow = 0
integer :: ndraw
COMMON /DRAWTHIS/ ndraw(50)
! store settings
dtolLR_bak = dtolLR
if ( abs(idir).ne.1 ) then
call qnerror('growlayer: abs(idir).ne.1', ' ', ' ')
end if
if ( j.eq.60 ) then
continue
end if
if ( j-1.eq.1 ) numgrow = 0
! dheight = 1d0
ifrontold = ifront
dt_tot = 0d0
xc1 = xc(:,j-idir)
yc1 = yc(:,j-idir)
! compute maximum mesh width and get dtolLR in the proper dimension
dhmax = 0d0
do i=1,mc-1
if ( xc(i,1).eq.DMISS .or. xc(i+1,1).eq.DMISS ) cycle
dhmax = max(dhmax, dbdistance(xc(i,1),yc(i,1),xc(i+1,1),yc(i+1,1),jsferic, jasfer3D, dmiss))
end do
dtolLR = dtolLR*dhmax
! allocate
numf = mc*(1+nc)
allocate( dtmax2(numf), xf(numf), yf(numf), velf(2,numf), idxf(2,numf))
! compute growth velocity vectors
! edgevel = 1d0
call comp_vel(mc, xc1, yc1, edgevel, vel)
! disable points that have no valid velocity vector
do i=1,mc
if ( vel(1,i).eq.DMISS ) then
xc(i,j-idir) = DMISS
xc1(i) = DMISS
end if
end do
! find front points
call findfront(mc, nc, mmax, nmax, xc, yc, numf, xf, yf, idxf, nf)
! copy growth velocity vectors to front
call copy_vel_to_front(mc, nc, j-1, vel, ifrontold, nf, numf, xf, yf, velf, idxf)
do while ( dt_tot.lt.dt )
numgrow = numgrow + 1
ifrontnew = ifrontold
! plot
! call teksam(xs,ys,zs,ns,ndraw(32))
! call tekgrid(i)
! call plotsplines()
! call teklan(ncolln)
call setcol(ncolrg)
call movabs(xf(1),yf(1))
do i=2,nf
if ( xf(i).ne.DMISS ) then
call lnabs(xf(i),yf(i))
else
if( i.lt.nf ) call movabs(xf(i+1),yf(i+1))
end if
end do
! call qnerror(' ', ' ', ' ')
! if ( idir.lt.0 ) dnormal = -dnormal
! remove stationary points
where ( ifrontold.eq.0 ) xc1 = DMISS
! compute maximum allowable growth time; node merger in grid layer
istop = 0
dt_other = 1d99
dtmax_self = 1d99
call comp_tmax_self(mc, xc1, yc1, vel, dtmax_self)
dt_loc = min(dt-dt_tot, minval(dtmax_self))
if ( jaCheckFrontCollision.eq.1 ) then
! collision with front
dtmax = dt_loc + 1d0 ! a bit larger, for safety
dtmax2 = 1d99 ! not used
call comp_tmax_other(mc, j, xc1, yc1, vel, nf, xf, yf, velf, idxf, dtmax, dtmax2)
dt_other = minval(dtmax)
else
dt_other = 1d99
end if
! update new frontmask
if ( dt_other.lt.dt_loc ) then
do i=1,mc
if ( dtmax(i)-dt_other.le.dtol .and. (dt_loc-dtmax(i)).gt.dtol ) ifrontnew(i) = 0
end do
end if
! remove isolated points from frontmask
if ( ifrontnew(1).eq.1 .and. ifrontnew(2) .eq.0 ) ifrontnew(1) = 0
if ( ifrontnew(mc).eq.1 .and. ifrontnew(mc-1).eq.0 ) ifrontnew(mc) = 0
where( ifrontnew(2:mc-1).eq.1 .and. ifrontnew(1:mc-2).eq.0 .and. ifrontnew(3:mc).eq.0 ) ifrontnew(2:mc-1) = 0
write(6,*) numgrow, j, dt_loc, dt_other
if ( dt_other.lt.dt_loc ) then
! istop = 1
write(6,'(A, $)') "--- stop ---"
do i=1,mc
if ( ifrontnew(i).eq.0 .and. ifrontold(i).eq.1 ) then
write(6,'(I5, ":", $)') i
end if
end do
write(6,*)
! call qnerror(' ', ' ', ' ')
end if
! determine grid layer growth time
if ( Lalllines ) then
dt_loc = min(dt_loc,dt_other)
else
! only consider node merger, colliding gridlines/nodes will be disabled
ifrontold = ifrontnew
dt_loc = min(dt_loc,dt_other)
end if
! update new grid layer coordinates
do i=1,mc
if ( ifrontold(i).eq.1 .and. vel(1,i).ne.DMISS ) then
if ( vel(1,i).eq.0d0 .and. vel(2,i).eq.0d0 ) then
continue
end if
xc1(i) = xc1(i) + dt_loc*vel(1,i)
yc1(i) = yc1(i) + dt_loc*vel(2,i)
else
xc1(i) = DMISS
yc1(i) = DMISS
end if
! if ( i.lt.mc ) then
! if ( dtmax_self(i).le.dt_loc .and. dtmax_self(i+1).lt.dt_loc ) then
! xc1(i+1) = xc1(i)
! yc1(i+1) = yc1(i)
! end if
! end if
end do
xc(:,j) = xc1
yc(:,j) = yc1
if ( Lalllines ) then
dt_tot = dt
else
dt_tot = dt_tot+dt_loc
end if
ifrontold = ifrontnew
! call qnerror(' ', ' ', ' ')
! erase front
! if ( dt_tot.lt.dheight ) then
call setcol(0)
call movabs(xf(1),yf(1))
do i=2,nf
if (xf(i) /= dmiss) then
call lnabs(xf(i),yf(i))
else
if( i.lt.nf ) call movabs(xf(i+1),yf(i+1))
end if
end do
! end if
! press any mouse button to terminate
call halt3(ja3)
if ( ja3.gt.0 ) then
istop = 1
if ( dt_tot.lt.dt ) then ! remove this incomplete front
xc1 = DMISS
yc1 = DMISS
end if
exit
end if
if ( dt_tot.lt.dt ) then
! update normal vectors and front
! compute the growth velocity vectors
! edgevel = 1d0
call comp_vel(mc, xc1, yc1, edgevel, vel)
! disable points that have no valid normal vector
do i=1,mc
if ( vel(1,i).eq.DMISS ) then
! xc(i,j) = DMISS
xc1(i) = DMISS
end if
end do
! remove stationary points
where ( ifrontold.eq.0 ) xc1 = DMISS
! find front points and fill front normal vectors
call findfront(mc, nc, mmax, nmax, xc, yc, numf, xf, yf, idxf, nf)
! copy growth velocity vectors to front
call copy_vel_to_front(mc, nc, j, vel, ifrontold, nf, numf, xf, yf, velf, idxf)
end if ! if ( dt_tot.lt.dt )
end do
! disable reverted gridlines
! the gridline connecting two layers will cross
if ( .not.Lalllines .and. j.gt.2 ) then
do i=2,mc-1
if ( xc1(i).eq.DMISS ) cycle
if ( dcosphi(xc(i,j-2), yc(i,j-2), xc(i,j-1), yc(i,j-1), xc(i,j-1), yc(i,j-1), xc1(i), yc1(i), jsferic, jasfer3D, dxymis) .lt. -0.5 ) then
call get_LR(mc, xc1, yc1, i, iL, iR)
do ii=iL+1,iR-1
ifrontnew(ii) = 0
xc(ii,j) = DMISS
end do
end if
end do
end if
! check aspectratio
! if ( .not.Lalllines ) then
! do i=1,mc
! call get_LR(mc, xc(:,j), yc(:,j), i, iL, iR)
! if ( iL.eq.iR ) cycle
! dh = dbdistance(xc(i,j-1), yc(i,j-1), xc(i,j), yc(i,j))
! daspect = 2d0*dh/dbdistance(xc(iL,j),yc(iL,j),xc(iR,j),yc(iR,j))
! if ( daspect.ge.maxaspect ) then
! ifrontnew(i) = 0
! end if
! end do
! end if
ifront = ifrontnew
if ( Lalllines ) then
dt = min(dt,5d2)
end if
! deallocate
deallocate(dtmax2, xf, yf, velf, idxf)
! restore settings
dtolLR = dtolLR_bak
return
end subroutine growlayer
!> copy growth velocities to the front, and add points in the front at corners
subroutine copy_vel_to_front(mc, nc, j, vel, ifront, nf, numf, xf, yf, velf, idxf)
use m_missing
implicit none
integer, intent(in) :: mc !< number of grid points
integer, intent(in) :: nc !< number of grid layers
integer, intent(in) :: j !< grid layer
double precision, dimension(2,mc), intent(in) :: vel ! growth velocity vector at grid layer, per node
integer, dimension(mc), intent(inout) :: ifront !< active nodes (1) or not (0)
integer, intent(inout) :: nf !< front dimension
integer, intent(in ) :: numf !< array size
double precision, dimension(numf), intent(inout) :: xf, yf !< front point coordinates
double precision, dimension(2,numf), intent(inout) :: velf !< front growth velocity vectors
integer, dimension(2,numf), intent(inout) :: idxf !< (i,j)-indices of front points
double precision, dimension(mc) :: xc1, yc1 ! active grid layer coordinates
integer :: i, ii, iprev, jprev, inext, jnext, num
logical :: LL, LR
velf = 0d0
num = 0 ! number of cornernodes (for ouput purposes only)
i = 0
do while ( i.lt.nf )
i = i+1
if ( idxf(2,i).eq.j .and. ifront(idxf(1,i)).eq.1 ) then
velf(:,i) = vel(:,idxf(1,i))
if ( velf(1,i).eq.DMISS ) velf(:,i) = 0d0
! check for cornernodes
iprev = idxf(1,max(i-1,1))
jprev = idxf(2,max(i-1,1))
inext = idxf(1,min(i+1,nf))
jnext = idxf(2,min(i+1,nf))
LL = (iprev.eq.idxf(1,i)-1 .and. jprev.eq.idxf(2,i) .and. ifront(iprev).eq.0 )
LR = (inext.eq.idxf(1,i)+1 .and. jnext.eq.idxf(2,i) .and. ifront(inext).eq.0 )
LL = LL .or. (iprev.eq.idxf(1,i) .and. jprev.lt.idxf(2,i))
LR = LR .or. (inext.eq.idxf(1,i) .and. jnext.lt.idxf(2,i))
if ( LL .or. LR ) then ! stationary edge
num = num+1
if ( nf+1.gt.numf ) then
call qnerror('growlayer: numf too small', ' ', ' ')
cycle
end if
! if ( num.eq.1 ) write(6,"('cornernode: ', $)")
! write (6,"(I0, ' ', $)") idxf(1,i)
do ii=nf,i,-1
xf(ii+1) = xf(ii)
yf(ii+1) = yf(ii)
velf(:,ii+1) = velf(:,ii)
idxf(:,ii+1) = idxf(:,ii)
end do
nf = nf+1
if ( LL ) then
velf(:,i) = 0d0
else
velf(:,i+1) = 0d0
end if
i = i+1
end if
end if
end do
! if ( num.gt.0 ) write(6,*)
return
end subroutine copy_vel_to_front
!> find the frontline of the old (static) grid
subroutine findfront(mc, nc, mmax, nmax, xc, yc, num, xf, yf, idxf, nf)
use m_missing
implicit none
integer, intent(in) :: mc, nc !< grid dimensions
integer, intent(in) :: mmax, nmax !< array size
double precision, dimension(mmax,nmax), intent(in) :: xc, yc !< grid point coordinates
integer, intent(in) :: num !< array size
double precision, dimension(num), intent(inout) :: xf, yf !< front point coordinates
integer, dimension(2,num), intent(inout) :: idxf !< (i,j)-indices of grid points
integer, intent(out) :: nf !< front dimension
integer, dimension(mc-1) :: jhfrontedge ! j-index of i-front edges
integer :: i, j, iL, iR, icirc
integer :: j1, j2
idxf = 0
! find the j-index of the i-front edges
do i=1,mc-1
jhfrontedge(i) = nc
do j=1,nc
if ( xc(i,j).eq.DMISS .or. xc(i+1,j).eq.DMISS ) then
jhfrontedge(i) = j-1
exit
end if
end do
end do
! make the front
nf = 0
j1 = 1
! check for circular connectivity
i = 1
call get_LR(mc, xc(:,1), yc(:,1), i, iL, iR)
if (iL.eq.i ) then
nf = nf+1
xf(nf) = xc(1,1)
yf(nf) = yc(1,1)
idxf(:,nf) = (/ 1, 1 /)
else
nf = nf+1
j1 = jhfrontedge(iL)
j2 = jhfrontedge(i)
xf(nf) = xc(i,j2)
yf(nf) = yc(i,j2)
idxf(:,nf) = (/ i, j2 /)
end if
do i=1,mc-1
call get_LR(mc, xc(:,1), yc(:,1), i, iL, iR)
j2 = jhfrontedge(i)
if ( j2.gt.0 ) then
if ( j1.eq.0 ) then
nf = nf+1
xf(nf) = xc(i,1)
yf(nf) = yc(i,1)
idxf(:,nf) = (/ i, 1 /)
end if
! add j-edges from j1 to j2
do j=j1+1,j2
nf = nf+1
xf(nf) = xc(i,j)
yf(nf) = yc(i,j)
idxf(:,nf) = (/ i, j /)
end do
do j=j1-1,j2,-1
nf = nf+1
xf(nf) = xc(i,j)
yf(nf) = yc(i,j)
idxf(:,nf) = (/ i, j /)
end do
! add i-edge from i to i+1
nf = nf+1
xf(nf) = xc(i+1,j2)
yf(nf) = yc(i+1,j2)
idxf(:,nf) = (/ i+1, j2 /)
else
if ( j1.gt.0 ) then
do j=j1-1,1,-1
nf = nf+1
xf(nf) = xc(i,j)
yf(nf) = yc(i,j)
idxf(:,nf) = (/ i, j /)
end do
nf = nf+1
xf(nf) = DMISS
yf(nf) = DMISS
idxf(:,nf) = (/i, 0 /)
end if
end if
j1 = j2
end do
! add last j-edges
! check for circular connectivity
i = mc
call get_LR(mc, xc(:,1), yc(:,1), i, iL, iR)
if (iR.eq.i ) then
do j=j2,1,-1
nf = nf+1
xf(nf) = xc(i,j)
yf(nf) = yc(i,j)
idxf(:,nf) = (/ i, j /)
end do
end if
return
end subroutine findfront
!> make a gridline on the spline
subroutine spline2gridline(mc, num, xsp, ysp, xsp2, ysp2, xc, yc, sc, h)
! use m_splines
implicit none
integer, intent(in) :: mc !< number of gridnodes
integer, intent(in) :: num !< number of splinenodes
double precision, dimension(num), intent(in) :: xsp, ysp !< splinenode coordinates
double precision, dimension(num), intent(inout) :: xsp2, ysp2 ! second order derivatives
double precision, dimension(mc), intent(out) :: xc, yc !< coordinates of grid points
double precision, dimension(mc), intent(out) :: sc !< spline-coordinates of grid points
double precision, intent(in) :: h !< for curvature adapted meshing (>0) or disable (<=0)
double precision, dimension(mc) :: curv ! curvature at grid points
double precision, dimension(mc) :: ds ! grid interval in spline coordinates, at grid points
double precision, dimension(mc) :: dL ! grid interval length, at grid points
double precision, dimension(2) :: startstop
integer :: i, iter, kmax
if ( mc .lt.2 ) return ! no curvigrid possible
startstop = (/0d0,dble(num-1)/)
call makespl(startstop, xsp, ysp, max(mc,num), num, 2, mc-1, xc, yc, kmax, sc, h)
if ( kmax.ne.mc ) then
continue
end if
return
end subroutine spline2gridline
!> compute growth velocity vectors at grid points
subroutine comp_vel(mc, xc, yc, edgevel, vel)
use m_missing
use m_sferic
use m_spline2curvi, only: dtolLR
use geometry_module, only: dbdistance, normalout
implicit none
integer, intent(in) :: mc !< number of grid points
double precision, dimension(mc), intent(in) :: xc, yc !< coordinates of grid points
double precision, dimension(mc-1), intent(in) :: edgevel !< edge normal-velocity (spherical: coordinates in meters)
double precision, dimension(2,mc), intent(out) :: vel !< velocity vectors at grid points (spherical: spherical coordinates)
double precision, dimension(mc) :: curv !< curvature at grid points
double precision, dimension(2) :: nL, nR, vL, vR
double precision :: cosphi, vR_vL, Rai
integer :: i, iL, iR
double precision, parameter :: dtolcos = 1d-8 ! not the module variable
vel = DMISS
Rai = 1d0/Ra
do i=1,mc
if ( xc(i).eq.DMISS .or. yc(i).eq.DMISS ) cycle
! first, compute the normal vector
! grid nodes may be on top of each other: find left neighboring node
call get_LR(mc, xc, yc, i, iL, iR)
! check if the right and left neighboring nodes are not on top of each other
if ( dbdistance(xc(iL),yc(iL),xc(iR),yc(iR),jsferic, jasfer3D, dmiss).le.dtolLR ) then
cycle
end if
! check for one-sided differentials
if ( dbdistance(xc(iL),yc(iL),xc(i),yc(i),jsferic, jasfer3D, dmiss).le.dtolLR .or. &
dbdistance(xc(iR),yc(iR),xc(i),yc(i),jsferic, jasfer3D, dmiss).le.dtolLR ) then
call normalout(xc(iR),yc(iR),xc(iL),yc(iL),nL(1),nL(2), jsferic, jasfer3D, dmiss, dxymis)
if ( jsferic.eq.1 ) then
nL(1) = nL(1) * cos(dg2rd*0.5d0*(yc(iL)+yc(iR)) )
end if
nR = nL
else
call normalout(xc(i),yc(i),xc(iL),yc(iL),nL(1),nL(2), jsferic, jasfer3D, dmiss, dxymis)
call normalout(xc(iR),yc(iR),xc(i),yc(i),nR(1),nR(2), jsferic, jasfer3D, dmiss, dxymis)
! dnormal = (hL+hR) / (1d0+dot_product(hL,hR)+1d-8)
if ( jsferic.eq.1 ) then
nL(1) = nL(1) * cos(dg2rd*0.5d0*(yc(iL)+yc(i)) )
nR(1) = nR(1) * cos(dg2rd*0.5d0*(yc(iR)+yc(i)) )
end if
end if
! compute the growth velocity vector
! circularly connected grid
if ( iL.eq.mc ) then
cycle
end if
cosphi = dot_product(nL,nR)
vL = edgevel(iL) * nL
vR = edgevel(iR-1) * nR
vR_vL = edgevel(iR-1) / edgevel(iL)
if ( cosphi.lt.-1d0+dtolcos ) then
continue
cycle
end if
if ( cosphi.lt.0d0 ) then
continue
end if
if ( ( vR_vL.gt.cosphi .and. 1d0/vR_vL.gt.cosphi ) .or. cosphi.le.dtolcos ) then
vel(:,i) = ( (1d0-vR_vL*cosphi) * vL + (1d0-(1d0/vR_vL)*cosphi) * vR ) / (1d0-cosphi**2)
else if ( vR_vL.lt.cosphi ) then
vel(:,i) = vR_vL / cosphi * vL
else
vel(:,i) = 1d0/ (vR_vL*cosphi) * vR
end if
! spherical coordinates
if ( jsferic.eq.1 ) then
vel(1,i) = vel(1,i) * Rai*rd2dg / cos(dg2rd*yc(i))
vel(2,i) = vel(2,i) * Rai*rd2dg
end if
end do
return
end subroutine comp_vel
!> compute curvature in a point on a spline
subroutine comp_curv(num, xsp, ysp, xsp2, ysp2, s, curv, dnx, dny, dsx, dsy)
use m_sferic
use geometry_module, only: dbdistance, getdxdy, normalout
use m_missing, only: dmiss, dxymis
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xsp, ysp !< spline control point coordinates
double precision, dimension(num), intent(in) :: xsp2, ysp2 !< spline control point second order derivatives of coordinates
double precision, intent(in) :: s !< point on spline in spline-coordinates
double precision, intent(out) :: curv !< curvature in point on spline
double precision, intent(out) :: dnx, dny !< normal vector
double precision, intent(out) :: dsx, dsy !< tangential vector
double precision :: A, B, x, y, xp, yp, xpp, ypp, x1, y1, csy, d1
integer :: iL, iR
double precision, parameter :: EPS=1d-4
double precision, external :: getdx, getdy
iL = max(min(int(s)+1,num-1),1)
iR = max(iL+1,1)
if ( iL-1.gt.s .or. iR-1.lt.s ) then
continue
end if
A = dble(iR-1) - s
B = s - dble(iL-1)
if ( A+B.ne.1d0 ) then
continue
end if
call splint(xsp,xsp2,num,s,x)
call splint(ysp,ysp2,num,s,y)
xp = -xsp(iL) + xsp(iR) + ( (-3d0*A**2 + 1d0)*xsp2(iL) + (3d0*B**2-1d0)*xsp2(iR) )/6d0
yp = -ysp(iL) + ysp(iR) + ( (-3d0*A**2 + 1d0)*ysp2(iL) + (3d0*B**2-1d0)*ysp2(iR) )/6d0
xpp = A*xsp2(iL) + B*xsp2(iR)
ypp = A*ysp2(iL) + B*ysp2(iR)
if ( jsferic.eq.1 ) then
csy = cos(dg2rd*y)
xp = xp * dg2rd*Ra*csy
xpp = xpp * dg2rd*Ra*csy
yp = yp * dg2rd*Ra
ypp = ypp * dg2rd*Ra
end if
curv = abs(xpp*yp-ypp*xp) / (xp**2+yp**2+1d-8)**1.5
x1 = x+EPS*xp
y1 = y+EPS*yp
call normalout(x,y,x1,y1,dnx,dny, jsferic, jasfer3D, dmiss, dxymis)
d1 = dbdistance(x,y,x1,y1,jsferic, jasfer3D, dmiss)
call getdxdy(x,y,x1,y1,dsx,dsy,jsferic)
dsx = dsx/d1
dsy = dsy/d1
return
end subroutine comp_curv
!> get left and right neighboring grid layer points
subroutine get_LR(mc, xc, yc, i, iL, iR)
use m_missing
use m_spline2curvi
use geometry_module, only: dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: mc !< grid layer size
double precision, dimension(mc), intent(in) :: xc, yc !< grid layer point coordinates
integer, intent(in) :: i !< grid layer point
integer, intent(out) :: iL, iR ! left and right neighboring grid layer points
! double precision, parameter :: dtolLR = 1d-1
integer :: jstart, jend, jacirc_loc
! check for circular connectivity
jacirc_loc = jacirc
jstart = 1
jend = mc
! grid points may be on top of each other: find left neighboring point
iL = i
do while ( dbdistance(xc(iL),yc(iL),xc(i),yc(i), jsferic, jasfer3D, dmiss).le.dtolLR )
if ( jacirc_loc.eq.0 ) then
if ( iL-1.lt.1 ) exit
else
if ( iL-1.lt.jstart ) then
iL = jend+1
jacirc_loc = 0 ! only once
end if
end if
if ( xc(iL-1).eq.DMISS .or. yc(iL-1).eq.DMISS ) exit
iL = iL-1
end do
! find right neighboring node
iR = i
do while ( dbdistance(xc(iR),yc(iR),xc(i),yc(i), jsferic, jasfer3D, dmiss).le.dtolLR )
if ( jacirc_loc.eq.0 ) then
if ( iR+1.gt.mc ) exit
else
if ( iR+1.gt.jend ) then
iR = jstart-1
jacirc_loc = 0 ! only once
end if
end if
if ( xc(iR+1).eq.DMISS .or. yc(iR+1).eq.DMISS ) exit
iR = iR+1
end do
return
end subroutine get_LR
!> compute maximum allowable grid layer growth time; with other grid points
subroutine comp_tmax_other(mc, jlay, xc, yc, vel, mc1, xc1, yc1, vel1, idx1, tmax, tmax1)
use m_missing
use m_sferic
use m_spline2curvi, only: dtolLR
use geometry_module, only: dbdistance
implicit none
integer, intent(in) :: mc !< number of grid points
integer, intent(in) :: jlay !< grid layer index
double precision, dimension(mc), intent(in) :: xc, yc !< coordinates of grid points
double precision, dimension(2,mc), intent(in) :: vel !< velocity vector at grid points
integer, intent(in) :: mc1 !< number of other grid points
double precision, dimension(mc1), intent(in) :: xc1, yc1 !< coordinates of other grid points
double precision, dimension(2,mc1), intent(in) :: vel1 !< velocity vector at other grid points
integer, dimension(2,mc1), intent(in) :: idx1 !< (i,j)-indices of other grid points
double precision, dimension(mc), intent(inout) :: tmax !< maximum allowable grid layer growth time
double precision, dimension(mc1), intent(inout) :: tmax1 !< maximum allowable other grid points growth time
! double precision, dimension(mc-1) :: edge_width, edge_incr
double precision, dimension(2) :: x1, x2, x3, x4, v1, v2, v3, v4 ! node coordinates and velocities
double precision, dimension(2) :: xL, xR
double precision :: tmax1234
double precision :: d, d1, d2, d3, d4, dL1, dL2
double precision :: vv1, vv2, vv3, vv4, maxvv, dt
double precision :: t1, t2, t3, t4 ! cross times
double precision :: hlow2
double precision :: dclearance
integer :: i, j, i1, j1, i2, j2, ja, iL, iR, nummax, idum, imin, imax
integer :: iLL, iRR, jsferic_old
double precision, external :: comp_cross_time_2
double precision, parameter :: dtol = 1d-8
! double precision, parameter :: dtolLR= 1d-2
! work in model-coordinates
jsferic_old = jsferic
jsferic = 0
! define the 'neighborhood' of an edge, which is checked for collision without clearance only, measured in weshwidths
nummax = 2*mc ! whole (partial) front gridline
! nummax = 4
! check for crossings with other grid
do i=1,mc-1
if ( xc(i).eq.DMISS .or. xc(i+1).eq.DMISS ) cycle
x1 = (/ xc(i), yc(i) /)
x2 = (/ xc(i+1), yc(i+1) /)
v1 = vel(:,i)
v2 = vel(:,i+1)
dL1 = dbdistance(x1(1),x1(2),x2(1),x2(2),jsferic, jasfer3D, dmiss)
! if ( dL1.lt.dtol ) cycle
! exclude edges that share a point
call get_LR(mc, xc, yc, i, iL, j)
call get_LR(mc, xc, yc, i+1, j, iR)
call get_LR(mc, xc, yc, iL, iLL, j)
call get_LR(mc, xc, yc, iR, j, iRR)
xL = (/ xc(iL), yc(iL) /)
xR = (/ xc(iR), yc(iR) /)
! find proximity [imin,imax] on gridline
idum = iL
do j=1,nummax
call get_LR(mc, xc, yc, idum, imin, i1)
if ( imin.eq.idum ) exit
idum = imin
end do
idum = iR
do j=1,nummax
call get_LR(mc, xc, yc, idum, i1, imax)
if ( imax.eq.idum ) exit
idum = imax
end do
do j = 1,mc1-1
if ( xc1(j).eq.DMISS .or. xc1(j+1).eq.DMISS ) cycle
! if ( i.eq.j ) cycle
x3 = (/ xc1(j), yc1(j) /)
x4 = (/ xc1(j+1), yc1(j+1) /)
v3 = vel1(:,j)
v4 = vel1(:,j+1)
dL2 = dbdistance(x3(1),x3(2),x4(1),x4(2),jsferic, jasfer3D, dmiss)
! if ( dL2.lt.dtolLR ) cycle
if ( dbdistance(x1(1),x1(2),x3(1),x3(2),jsferic, jasfer3D, dmiss).lt.dtolLR .or. dbdistance(x2(1),x2(2),x4(1),x4(2),jsferic, jasfer3D, dmiss).lt.dtolLR ) cycle
if ( dbdistance(x2(1),x2(2),x3(1),x3(2),jsferic, jasfer3D, dmiss).lt.dtolLR .or. dbdistance(x1(1),x1(2),x4(1),x4(2),jsferic, jasfer3D, dmiss).lt.dtolLR ) cycle
! d = dbdistance(xL(1),xL(2),x3(1),x3(2)); if ( d.lt.dtolLR ) cycle
! d = dbdistance(xL(1),xL(2),x4(1),x4(2)); if ( d.lt.dtolLR ) cycle
! d = dbdistance(xR(1),xR(2),x3(1),x3(2)); if ( d.lt.dtolLR ) cycle
! d = dbdistance(xR(1),xR(2),x4(1),x4(2)); if ( d.lt.dtolLR ) cycle
d1 = dbdistance(x1(1),x1(2),x3(1),x3(2),jsferic, jasfer3D, dmiss)
d2 = dbdistance(x2(1),x2(2),x3(1),x3(2),jsferic, jasfer3D, dmiss)
d3 = dbdistance(x1(1),x1(2),x4(1),x4(2),jsferic, jasfer3D, dmiss)
d4 = dbdistance(x2(1),x2(2),x4(1),x4(2),jsferic, jasfer3D, dmiss)
if ( d1.lt.dtol .or. d2.lt.dtol .or. d3.lt.dtol .or. d4.lt.dtol ) cycle
! compute clearance
! dclearance = 0.5d0*max(dL1,dL2)
! 26-06-12: set clearence to 0 in all cases
dclearance = 0d0
i1 = idx1(1,j)
i2 = idx1(1,j+1)
j1 = idx1(2,j)
j2 = idx1(2,j+1)
if ( (i1.ge.imin.and.i1.le.imax) .or. (i2.ge.imin.and.i2.le.imax) ) then
dclearance=0d0 ! in proximity on same gridline
end if
! do not include directly neighboring edges
if ( iRR.ge.iLL ) then
if ( ( (i1.gt.iLL .and. i1.lt.iRR) .or. (i2.gt.iLL .and. i2.lt.iRR) ) .and. j1.ge.jlay-1 .and. j2.ge.jlay-1 ) then
continue
cycle
end if
else ! circularly connected grid
if ( ( .not.(i1.ge.iRR .and. i1.le.iLL) .or. .not.(i2.ge.iRR .and. i2.le.iLL) ) .and. j1.ge.jlay-1 .and. j2.ge.jlay-1 ) then
continue
cycle
end if
end if
! get a lower bound for the cross time
hlow2 = 0.25d0*max((minval((/ d1, d2, d3, d4/)))**2 - (0.5d0*max(dL1,dL2))**2, 0d0)
! check if the lower bounds is larger than the minimum found so far
vv1 = sqrt(dot_product(v3-v1,v3-v1))
vv2 = sqrt(dot_product(v3-v2,v3-v2))
vv3 = sqrt(dot_product(v4-v1,v4-v1))
vv4 = sqrt(dot_product(v4-v2,v4-v2))
maxvv = maxval( (/ vv1, vv2, vv3, vv4 /) )
if ( sqrt(hlow2)-dclearance.gt.maxvv*min(tmax(i),tmax(i+1)) ) then
cycle ! no need to proceed
end if
! t1 = comp_cross_time_1(x1,x3,x4,v1,v3,v4)
! t2 = comp_cross_time_1(x2,x3,x4,v2,v3,v4)
! t3 = comp_cross_time_1(x3,x1,x2,v3,v1,v2)
! t4 = comp_cross_time_1(x4,x1,x2,v4,v1,v2)
t1 = comp_cross_time_2(x1,x3,x4,v1,v3,v4,dclearance)
t2 = comp_cross_time_2(x2,x3,x4,v2,v3,v4,dclearance)
t3 = comp_cross_time_2(x3,x1,x2,v3,v1,v2,dclearance)
t4 = comp_cross_time_2(x4,x1,x2,v4,v1,v2,dclearance)
tmax1234 = minval( (/t1, t2, t3, t4/) )
if ( t1.eq.tmax1234 ) then
tmax(i) = min( tmax(i), tmax1234 )
! tmax1(j) = min( tmax1(j), tmax1234 )
! tmax1(j+1) = min( tmax1(j+1), tmax1234 )
else if ( t2.eq.tmax1234 ) then
if ( tmax1234.lt.1d6 .and. i.eq.2 ) then
continue
end if
tmax(i+1) = min( tmax(i+1), tmax1234 )
! tmax1(j) = min( tmax1(j), tmax1234 )
! tmax1(j+1) = min( tmax1(j+1), tmax1234 )
else if ( t3.eq.tmax1234 .or. t4.eq.tmax1234 ) then
tmax(i) = min( tmax(i), tmax1234 )
tmax(i+1) = min( tmax(i+1), tmax1234 )
end if
if ( tmax1234.eq.0d0 ) exit
end do
end do
jsferic = jsferic_old
return
end subroutine comp_tmax_other
!> compute maximum allowable grid layer growth time; self crossings
subroutine comp_tmax_self(mc, xc, yc, vel, tmax)
use m_missing
use geometry_module, only: dbdistance
use m_sferic, only: jsferic, jasfer3D
implicit none
integer, intent(in) :: mc !< number of grid points
double precision, dimension(mc), intent(in) :: xc, yc !< coordinates of grid points
double precision, dimension(2,mc), intent(in) :: vel !< velocity vector at grid points
double precision, dimension(mc-1), intent(inout) :: tmax !< maximum allowable grid layer growth time
double precision, dimension(mc-1) :: edge_width, edge_incr
double precision :: dt
integer :: i, jsferic_old
double precision, parameter :: dtol=1d-8
double precision, external :: dprodin
! work in model-coordinates
jsferic_old = jsferic
jsferic = 0
! take unit time-step for edge length increase
dt = 1d0
! check for self-crossing
edge_incr = 1d99
do i=1,mc-1
if ( xc(i).eq.DMISS .or. xc(i+1).eq.DMISS ) cycle
edge_width(i) = dbdistance(xc(i),yc(i),xc(i+1),yc(i+1), jsferic, jasfer3D, dmiss)
if ( edge_width(i).lt.dtol) cycle
edge_incr(i) = dprodin(xc(i),yc(i),xc(i+1),yc(i+1),xc(i)+dt*vel(1,i),yc(i)+dt*vel(2,i),xc(i+1)+dt*vel(1,i+1),yc(i+1)+dt*vel(2,i+1))/edge_width(i) - edge_width(i)
edge_incr(i) = edge_incr(i)/dt
end do
do i=1,mc-1
if ( edge_incr(i).lt.0d0 ) then
tmax(i) = -edge_width(i)/edge_incr(i)
end if
end do
jsferic = jsferic_old
return
end subroutine comp_tmax_self
!> compute time (>0) when node x1 will cross line segment (3-4)
double precision function comp_cross_time_1(x1,x3,x4,v1,v3,v4,dclear)
use m_missing
implicit none
double precision, dimension(2) :: x1, x3, x4 !< coordinates
double precision, dimension(2) :: v1, v3, v4 !< velocities
double precision :: dclear !< clearance
double precision, dimension(2) :: xs, dn
double precision, dimension(4) :: t, beta
double precision, dimension(5) :: coeffs
double precision, dimension(2) :: x13, x34, v13, v34
double precision :: a, b, c, det, time, DdDt
double precision :: e, f, g
integer :: i
double precision, external :: cross_prod
double precision, parameter :: dtol = 1d-8
! a t^2 + b t + c = 0
x13 = x3-x1
x34 = x4-x3
v13 = v3-v1
v34 = v4-v3
a = cross_prod(v13,v34)
b = cross_prod(x13,v34) - cross_prod(x34,v13)
c = cross_prod(x13,x34)
coeffs = (/0d0,0d0,a,b,c/)
! coeffs = (/a,b,c,0d0,0d0/)
! clearance:
! ( a t^2 + b t + c )^2 = dclear^2 * (e t^2 + f t + g)
if ( dclear.gt.0d0 ) then
coeffs = (/a*a, 2d0*a*b, 2d0*a*c+b*b, 2d0*b*c, c*c /)
e = dot_product(v34,v34)
f = 2d0*dot_product(x34,v34)
g = dot_product(x34,x34)
coeffs = coeffs - dclear*dclear*(/ 0d0, 0d0, e, f, g /)
end if
t = DMISS
beta = DMISS
call comp_roots4(coeffs,t)
! if ( t(1).ne.DMISS .and. t(2).ne.DMISS ) then
do i=1,4
if ( t(i).eq.DMISS ) cycle
if ( t(i).lt.dtol ) cycle ! positive times only
xs = x4-x3+(v4-v3)*t(i)
det = dot_product(xs,xs)
if ( abs(det).gt.dtol ) then
beta(i) = - dot_product(x3-x1+(v3-v1)*t(i),xs)/det
end if
end do
! end if
time = 1d99
do i = 1,4
if ( beta(i).ge.0d0 .and. beta(i).le.1d0 .and. t(i).ge.0d0 .and. t(i).ne.DMISS ) then
if ( dclear.gt.0d0 ) then
DdDt = ( 2d0*(a*t(i)**2 + b*t(i) + c)*(2d0*a*t(i)+b) - dclear**2*(2d0*e*t(i)+f) ) / ( 2d0*dclear*(e*t(i)**2+f*t(i)+g))
else
DdDt = -1d99
end if
if ( DdDt.lt.0d0 ) time = min(time,t(i))
end if
end do
comp_cross_time_1 = time
return
end function comp_cross_time_1
double precision function comp_cross_time_2(x1,x3,x4,v1,v3,v4,dclear)
use m_missing
use geometry_module, only: dlinedis
use m_sferic, only: jsferic, jasfer3D
implicit none
double precision, dimension(2) :: x1, x3, x4 !< coordinates
double precision, dimension(2) :: v1, v3, v4 !< velocities
double precision :: dclear !< clearance
double precision, dimension(2) :: xdum1, xdum2
double precision, dimension(4) :: x
double precision, dimension(5) :: coeffs
double precision :: a, b, c, dnow, xc, yc, dteps, deps
double precision :: t1, t2, t3, DdDt
integer :: i, ja
double precision, external :: comp_cross_time_1
logical, external :: Lcrossgridline
comp_cross_time_2 = 1d99
call dlinedis(x1(1),x1(2), x3(1),x3(2), x4(1),x4(2), ja, dnow, xc, yc, jsferic, jasfer3D, dmiss)
t2 = 1d99
! only take nodes into account that are at the right-hand-side of the edge
if ( -(x1(1)-x3(1))*(x4(2)-x3(2)) + (x1(2)-x3(2))*(x4(1)-x3(1)).lt.0d0 ) return
if ( dnow.le.dclear .and. dclear.gt.0d0 ) then
t2 = comp_cross_time_1(x1,x3,x4,v1,v3,v4,0d0)
if ( t2.lt.1d99 ) then
! check if distance is increasing
dteps = 1d-2
call dlinedis(x1(1)+v1(1)*dteps, x1(2)+v1(2)*dteps, x3(1)+v3(1)*dteps, x3(2)+v3(2)*dteps, x4(1)+v4(1)*dteps, x4(2)+v4(2)*dteps, ja, deps, xc, yc, jsferic, jasfer3D, dmiss)
DdDt = (deps-dnow)/dteps
if ( DdDt.lt.-1d-4 ) then
! t2 = comp_cross_time_1(x1,x3,x4,v1,v3,v4,0d0)
t2 = 0d0
else
t2 = comp_cross_time_1(x1,x3,x4,v1,v3,v4,0d0)
end if
end if
comp_cross_time_2 = t2
return
end if
t1 = comp_cross_time_1(x1,x3,x4,v1,v3,v4,dclear)
if ( t1.eq.DMISS .or. t1.le.0d0 ) t1 = 1d99
! if ( dbdistance(x1(1),x1(2),x3(1),x3(2)).gt.dclear ) then
a = dot_product(v1-v3,v1-v3)
b = 2d0*dot_product(v1-v3,x1-x3)
c = dot_product(x1-x3,x1-x3)
coeffs = (/ 0d0, 0d0, a, b, c-dclear*dclear /)
call comp_roots4( coeffs, x)
do i=1,4
if ( x(i).eq.DMISS .or. x(i).le.0d0 .or. x(i).gt.t1 ) cycle
! check if intersection is in the right regime
if ( dot_product(x1-x3+(v1-v3)*x(i),x4-x3+(v4-v3)*x(i)).gt.0d0 ) then
cycle
end if
! check if distance is decreasing
DdDt = 1d99
if ( dclear.gt.0d0 .and. x(i).gt.0d0 ) then
! check if the new connecting line does not cross the center spline gridline
xdum1 = x1+v1*x(i)
xdum2 = x3+v3*x(i)
if ( .not.Lcrossgridline(xdum1, xdum2, 1) ) then
DdDt = (2d0*a*x(i)+b) / (2d0*dclear)
end if
end if
! take minimum time
if ( x(i).ne.DMISS .and. x(i).gt.0d0 .and. DdDt.lt.0d0 ) t1 = min(t1, x(i))
end do
! end if
!
! if ( dbdistance(x1(1),x1(2),x4(1),x4(2)).gt.dclear ) then
a = dot_product(v1-v4,v1-v4)
b = 2d0*dot_product(v1-v4,x1-x4)
c = dot_product(x1-x4,x1-x4)
coeffs = (/ 0d0, 0d0, a, b, c - dclear*dclear /)
call comp_roots4( coeffs, x)
do i=1,4
if ( x(i).eq.DMISS .or. x(i).le.0d0 .or. x(i).gt.t1 ) cycle
! check if intersection is in the right regime
if ( dot_product(x1-x4+(v1-v4)*x(i),x3-x4+(v3-v4)*x(i)).gt.0d0 ) then
cycle
end if
! check if distance is decreasing
DdDt = 1d99
if ( dclear.gt.0d0 .and. x(i).gt.0d0 ) then
! check if the new connecting line does not cross the center spline gridline
xdum1 = x1+v1*x(i)
xdum2 = x4+v4*x(i)
if ( .not.Lcrossgridline(xdum1, xdum2, 1) ) then
DdDt = (2d0*a*x(i)+b) / (2d0*dclear)
end if
end if
! take minimum time
if ( x(i).ne.DMISS .and. x(i).gt.0d0 .and. DdDt.lt.0d0 ) t1 = min(t1, x(i))
end do
! end if
comp_cross_time_2 = min(t1,t2)
return
end function comp_cross_time_2
!> check if a line segment crosses the gridline on the center spline
logical function Lcrossgridline(x1,x2,j)
use m_grid
use m_missing
use m_sferic, only: jsferic
use geometry_module, only: cross
implicit none
double precision, dimension(2), intent(in) :: x1, x2 !< coordinates of begin and end point of line segment
integer, intent(in) :: j !< gridline index
double precision, dimension(2) :: x3, x4
double precision :: sL, sm, xcr, ycr, crp
integer :: i, jacross
Lcrossgridline = .false.
! return
do i=1,mc-1 ! loop over the edges
x3 = (/ xc(i,j), yc(i,j) /)
x4 = (/ xc(i+1,j), yc(i+1,j) /)
if ( x3(1).eq.DMISS .or. x4(1).eq.DMISS ) cycle
call cross(x1(1), x1(2), x2(1), x2(2), x3(1), x3(2), x4(1), x4(2), jacross,sL,sm,xcr,ycr,crp, jsferic, dmiss)
if ( jacross.eq.1 ) then
Lcrossgridline = .true.
return
end if
end do
return
end function ! Lcrosscenterspline
!> cross product
double precision function cross_prod(a,b)
implicit none
double precision, dimension(2) :: a, b
cross_prod = a(1)*b(2) - a(2)*b(1)
return
end function cross_prod
subroutine comp_rootshu(Eup,aa,hu)
double precision :: Eup, aa, hu
double precision :: coeffs(5) !< coefficient vector (A,B,C,D,E)
double precision :: x(4) !< roots
integer :: i
coeffs(1) = 0d0
coeffs(2) = 1d0
coeffs(3) = -Eup
coeffs(4) = 0d0
coeffs(5) = aa
call comp_roots4(coeffs,x)
hu = 0d0
do i = 1,4
hu = max(hu, x(i))
enddo
end subroutine comp_rootshu
!> solves the quartic equation Ax^4+Bx^3+Cx^2+Dx+E=0
subroutine comp_roots4(coeffs,x)
use m_missing
use Solve_Real_Poly
implicit none
double precision, dimension(5), intent(in) :: coeffs !< coefficient vector (A,B,C,D,E)
double precision, dimension(4), intent(out) :: x !< roots
double precision, dimension(4) :: re, im !< real and imaginairy parts of zeros
double precision :: rhs
logical :: Lfail
double precision :: dtol = 1d-12
integer :: i, j, ndegree
x = DMISS
Lfail = .true.
!
! ndegree = 4
! do i=1,4
! if ( abs(coeffs(i)).gt.dtol ) exit
! ndegree = ndegree-1
! end do
!
! if ( ndegree.ge.1 ) then
! call rpoly(coeffs(5-ndegree:5), ndegree, re(1:ndegree), im(1:ndegree), Lfail)
! end if
do i=4,1,-1
ndegree = i
if ( abs(coeffs(5-ndegree)).lt.dtol ) cycle
call rpoly(coeffs(5-ndegree:5), ndegree, re(1:ndegree), im(1:ndegree), Lfail)
exit
! if ( .not.Lfail ) exit
end do
if ( Lfail .and. ndegree.gt.0 ) then
return
end if
! do i=1,ndegree
! if ( abs(im(i)).lt.dtol ) then
! x(i) = re(i)
! end if
! end do
! check validity of roots
! do i=1,ndegree
! rhs=0d0
! do j=ndegree,0,-1
! rhs = rhs + coeffs(5-j)*re(i)**j
! end do
! if ( abs(rhs).lt.dtol ) then
! x(i) = re(i)
! end if
! end do
do i=1,ndegree
if ( abs(im(i)).lt.1d-4 ) then
x(i) = re(i)
end if
end do
end subroutine comp_roots4
!> derefine mesh
subroutine derefine_mesh(xp,yp,Lconfirm)
use m_netw
use m_alloc
use geometry_module, only: pinpok
use m_missing, only: jins, dmiss
use gridoperations
implicit none
double precision, intent(in) :: xp, yp !< coordinates of input point ( not used with Lconfirm .eq. .true. )
logical, intent(in) :: Lconfirm !< prompt for cell deletion (.true.) or not (.false.)
integer, parameter :: NMAX=100 !< array size
integer :: ndirect !< number of directly connected cells
integer :: nindirect !< number of indirectly connected cells
integer, dimension(NMAX) :: kdirect !< directly connected cells, i.e. cells sharing a link with cell k
integer, dimension(NMAX) :: kindirect !< indirectly connected cells, i.e. cells sharing a node, but not a link, with cell k
integer, dimension(2,NMAX) :: kne !< left and right neighboring (in)direct cell that neighbors the directly connected cells
double precision :: xx, yy
integer :: numfront, numfrontnew
integer, dimension(:), allocatable :: ifront, ifrontnew, icellmask
integer :: i, ic, in, j, ja, k, k1, kk, kkk, L
integer :: kcell, kother, knew, newsize, iter, N
logical :: Liscell, Lplot
integer, parameter :: MAXNUMFRONT = 1000, MAXITER = 1000
call findcells(100)
call makenetnodescoding
if ( Lconfirm ) then
Lplot = .true.
! find the cell
in = -1
do k = 1,nump
if ( netcell(k)%N.lt.1 ) cycle
call pinpok(xp, yp, netcell(k)%N, xk(netcell(k)%nod), yk(netcell(k)%nod), in, jins, dmiss)
if ( in.gt.0 ) exit
end do
if ( in.eq.0 ) then ! no cell found
call qnerror('derefine_mesh: no cell found', ' ', ' ')
return
end if
else
Lplot = .false.
! give preference to a cell near a boundary
in = -1
k = 0 ! default
do L=1,numL
if ( lnn(L).ne.1 ) cycle
! check if this link is a true boundary link, or a link near the selecting polygon
if ( nb(kn(1,L)).ne.2 .or. nb(kn(2,L)).ne.2 ) cycle
! get the adjacent cell
k1 = lne(1,L)
! check if the adjacent cell is a quad
if ( netcell(k1)%N.ne.4 ) cycle
! check if all nodes are inside the selecting polygon
Liscell = .true.
do i=1,netcell(k1)%N
if ( nb(netcell(k1)%nod(i)).eq.0 ) then
Liscell = .false.
exit
end if
end do
if ( .not.Liscell ) cycle
! link found: get the adjacent cell and exit
k = k1
exit
end do
if ( k.lt.1 ) then ! no cell found: take the first quad inside the selecting polygon
do k1=1,nump
! check if the cell is a quad
if ( netcell(k1)%N.ne.4 ) cycle
! check if all nodes are inside the selecting polygon
Liscell = .true.
do i=1,netcell(k1)%N
if ( nb(netcell(k1)%nod(i)).eq.0 ) then
Liscell = .false.
exit
end if
end do
if ( .not.Liscell ) cycle
! cell found: get the cell and exit
k = k1
exit
end do
end if
! still no cell found: take the first
if ( k.lt.1 ) k = 1
end if
! allocate
allocate(ifront(MAXNUMFRONT), ifrontnew(MAXNUMFRONT), icellmask(nump))
icellmask = 0
! make the cellmask
! 1 : front, 'A' cell (used to be node, delete it)
! 2 : front, 'B' cell (used to be link, keep it)
! 3 : 'C' cell (used to be cell, keep it)
! -1 : not in front, 'A' cell
! -2 : not in front, 'B' cell
! 0 : unassigned
! fill the frontlist with the selected cell
numfront = 1
ifront(1) = k
icellmask(k) = 1
iter = 0
do while ( numfront.gt.0 .and. iter.lt.MAXITER)
iter = iter+1
numfrontnew = 0
do i=1,numfront
k = ifront(i)
! get the connected cells
call find_surrounding_cells(k, NMAX, ndirect, nindirect, kdirect, kindirect, kne)
if ( icellmask(k).eq.1 ) then ! 'A' cell
do j=1,ndirect
kother = kdirect(j)
if ( netcell(kother)%N.ne.4 ) cycle ! quads only
if ( abs(icellmask(kother)).ne.1 .and. abs(icellmask(kother)) .ne.2 ) then
icellmask(kother) = 2
call update_frontlist(kother)
end if
end do
do j=1,nindirect
kother = kindirect(j)
if ( netcell(kother)%N.ne.4 ) cycle ! quads only
if ( icellmask(kother).ne.3 ) then
icellmask(kother) = 3
end if
end do
icellmask(k) = -1
else if ( icellmask(k).eq.2 ) then ! 'B' cell
do j=1,ndirect
kother = kdirect(j)
if ( netcell(kother)%N.ne.4 ) cycle ! quads only
if ( icellmask(kother).ne.3 .and. abs(icellmask(kother)).ne.1 .and. abs(icellmask(kother)).ne.2 ) then
icellmask(kother) = 1
call update_frontlist(kother)
end if
end do
do j=1,nindirect
kother = kindirect(j)
if ( netcell(kother)%N.ne.4 ) cycle ! quads only
if ( abs(icellmask(kother)).ne.2 .and. abs(icellmask(kother)).ne.1 .and. icellmask(kother).ne.3 ) then
icellmask(kother) = 2
call update_frontlist(kother)
end if
end do
icellmask(k) = -2
end if
end do ! do i=1,numfront
numfront = numfrontnew
ifront = ifrontnew
end do ! do while ( numfront.gt.0 )
if ( Lconfirm .or. .not.Lconfirm) then
! plot
do k=1,nump
N = netcell(k)%N
if ( N.lt.1 ) cycle
xx = sum(xk(netcell(k)%nod(1:N)))/dble(N)
yy = sum(yk(netcell(k)%nod(1:N)))/dble(N)
if ( abs(icellmask(k)).eq.1 ) then
call cirr(xx, yy, 31)
else if ( abs(icellmask(k)).eq.2 ) then
! call cirr(xx, yy, 211)
else if ( icellmask(k).eq.3 ) then
! call cirr(xx, yy, 204)
else if ( icellmask(k).eq.0 ) then
! call cirr(xx, yy, 0)
else
continue
end if
end do
call confrm('Delete cells?', ja)
else
ja = 1
end if
if ( ja.eq.1 ) then
! delete the appropriate cells
do k=1,nump
if ( icellmask(k).eq.-1 .and. netcell(k)%N.gt.0 ) then
call find_surrounding_cells(k, NMAX, ndirect, nindirect, kdirect, kindirect, kne)
if ( Lplot ) then
! plot
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),0)
end do
end if
k1 = netcell(k)%nod(1)
! delete cell and update administration
call deletecell(k, ndirect, nindirect, kdirect, kindirect, kne, .false., ja)
if ( Lplot ) then
if ( netcell(k)%N.eq.0 ) then ! cell removed: draw remaining node and links connected to it
call teknode(k1,1)
else ! cell not removed: draw whole cell and links connected to it
do kk=1,netcell(k)%N
call teknode(netcell(k)%nod(kk),1)
end do
end if
end if
end if
end do
end if
! deallocate
deallocate(ifront, ifrontnew, icellmask)
! set network status
netstat = NETSTAT_CELLS_DIRTY
return
contains
subroutine update_frontlist(knew)
implicit none
integer, intent(in) :: knew !< number of cell to be added to frontlist
integer :: i
! add to new front list
if ( knew.gt.0 ) then
! check number of nodes
if ( netcell(knew)%N.ne.4 ) return ! quads only
! check if cell is already in frontlist
do i=1,numfront
if ( ifrontnew(i).eq.knew ) return
end do
numfrontnew = numfrontnew+1
! realloc if necessary
if ( numfrontnew.gt.ubound(ifrontnew,1) ) then
newsize = ceiling(1.2*ubound(ifrontnew,1))
call realloc(ifrontnew, newsize)
call realloc(ifront, newsize)
end if
! store
ifrontnew(numfrontnew) = knew
end if
end subroutine update_frontlist
end subroutine derefine_mesh
!> split a link, make new cells and update administration
subroutine splitlink(xp, yp, L_, dcosmin, jatek, ierror)
use m_netw
use network_data, only : xzw, yzw
use m_flowgeom, only: ndx, xz, yz, ba
use unstruc_colors, only: ncoldn
use geometry_module, only: dbdistance, dcosphi
use m_sferic, only: jsferic, jasfer3D, dtol_pole
use m_missing, only : dxymis
use gridoperations
use m_alloc
implicit none
double precision, intent(in) :: xp, yp !< clicked point coordinates (used if L.eq.0)
integer, intent(in) :: L_ !< link number (used if L_.ne.0)
double precision, intent(in) :: dcosmin !< parallelogram cosine tolerance
integer, intent(in) :: jatek !< plot new links (1) or not (0)
integer, intent(out) :: ierror ! error (1) or not (0)
double precision :: zp ! link z-value
double precision :: zzz, dcos1, dcos2, dcos3
integer :: L ! link number
integer :: ic1, icL, icR ! cell numbers
integer :: LL, LR ! left and right connected links
integer :: Ln1, Ln2, LnL, LnR ! new links
integer :: kk, kkk, kk1, kk2, kk3, kkL, kkR
integer :: k1, k2, k3, kp, kotherL, kotherR
integer :: i, N, kL, kR, Lk, kLL, kRR, LnLL, LnRR
integer :: idum, icLL, icRR, kLLL, kRRR, numnew
integer :: N2Dcells
ierror = 1
if ( netstat /= NETSTAT_OK ) then
call findcells(100)
end if
if ( L_.eq.0 ) then
L = 0
call islink(L, xp, yp, zp)
else
L = L_
end if
if ( L.eq.0 ) goto 1234
if ( jatek.eq.1 ) call teklink(L,0)
k1 = kn(1,L)
k2 = kn(2,L)
k3 = kn(3,L)
icL = 0
icR = 0
icLL = 0
icRR = 0
! count number of ajacent 2D cells
if ( kn(3,L) /= 2 ) then ! non-2D netlink
N2Dcells = 0
else
N2Dcells = lnn(L)
end if
! non-2D netlink, or isolated 2D netlink, or netlink outside selecting polygon
if ( N2Dcells.eq.0 ) then
! add node
call setnewpoint(0.5d0*(xk(k1)+xk(k2)), 0.5d0*(yk(k1)+yk(k2)), zp, kp)
call connectdbn(k1,kp,LnL)
if ( jatek.eq.1 ) call teklink (LnL,ncoldn)
kn(3,LnL) = k3
call connectdbn(kp,k2,LnR)
if ( jatek.eq.1 ) call teklink(LnR,ncoldn)
kn(3,LnR) = k3
! set lnn and lne for new links
! reallocate if necessary
if ( numL.gt.ubound(lnn,1) ) then
numnew = ceiling(1.2d0*dble(numL))
call realloc(lnn, numnew, keepExisting=.true.)
call realloc(lne, (/2, numnew/), keepExisting=.true.)
end if
lnn(LnL) = 0
lnn(LnR) = 0
lne(1,LnL) = 0
lne(2,LnL) = 0
lne(1,LnR) = 0
lne(2,LnR) = 0
if ( jatek.eq.1 ) call dcirr (xk(kp),yk(kp),zk(kp),ncoldn)
end if
! insert and connect new node
do i=1,N2Dcells
ic1 = lne(i,L)
N = netcell(ic1)%N
! find the link in the cell
kk1 = 1
do while( netcell(ic1)%lin(kk1).ne.L .and. kk1.lt.N ); kk1=kk1+1; end do
if ( netcell(ic1)%lin(kk1).ne.L ) then
call qnerror('splitlink: link not found', ' ', ' ')
goto 1234
end if
! find the left and right connected links and cells
kkL = kk1-1; if ( kkL.lt.1 ) kkL=kkL+N
kkR = kk1+1; if ( kkR.gt.N ) kkR=kkR-N
LL = netcell(ic1)%lin(kkL)
LR = netcell(ic1)%lin(kkR)
icL = 0
if ( lnn(LL).gt.1 ) icL = lne(1,LL)+lne(2,LL)-ic1
icR = 0
if ( lnn(LR).gt.1 ) icR = lne(1,LR)+lne(2,LR)-ic1
! find the left and right original nodes (either k1 or k2)
if ( kn(1,LL).eq.k1 .or. kn(2,LL).eq.k1 ) then
kL = k1
kR = k2
else
kL = k2
kR = k1
end if
! add node and make new links (once)
if ( i.eq.1 ) then
! add node
call setnewpoint(0.5d0*(xk(kL)+xk(kR)), 0.5d0*(yk(kL)+yk(kR)), zp, kp)
call connectdbn(kL,kp,LnL)
if ( jatek.eq.1 ) call teklink (LnL,ncoldn)
kn(3,LnL) = k3
call connectdbn(kp,kR,LnR)
if ( jatek.eq.1 ) call teklink(LnR,ncoldn)
kn(3,LnR) = k3
if ( jatek.eq.1 ) call dcirr (xk(kp),yk(kp),zk(kp),ncoldn)
else ! swap orientation: switch new links LnL and LnR
idum = LnL
LnL = LnR
LnR = idum
end if
! make new links
kLL = kn(1,LL)+kn(2,LL)-kL
kRR = kn(1,LR)+kn(2,LR)-kR
call connectdbn(kLL,kp,LnLL)
kn(3,LnLL) = kn(3,L)
if ( jatek.eq.1 ) call teklink(LnLL, ncoldn)
if ( kLL.ne.kRR ) then
call connectdbn(kRR,kp,LnRR)
kn(3,LnRR) = kn(3,L)
if ( jatek.eq.1 ) call teklink(LnRR, ncoldn)
else
LnRR = LnLL
end if
! remove link from original cell, delete two nodes, add one new node and replace two links
call del_intarrayelem(netcell(ic1)%N, netcell(ic1)%lin, L)
call del_intarrayelem(netcell(ic1)%N, netcell(ic1)%nod, kL)
call replace_intarrayelem(netcell(ic1)%N-1, netcell(ic1)%nod, kR, 1, (/ kp /))
call replace_intarrayelem(netcell(ic1)%N-1, netcell(ic1)%lin, LL, 1, (/ LnLL /))
call replace_intarrayelem(netcell(ic1)%N-1, netcell(ic1)%lin, LR, 1, (/ LnRR /))
netcell(ic1)%N = netcell(ic1)%N-1
! make new cells
call makecell(3, (/kLL, kL, kp/), (/LL, LnL, LnLL/), icLL, ierror)
call makecell(3, (/kR, kRR, kp/), (/LnR, LR, LnRR/), icRR, ierror)
if ( ierror.ne.0 ) goto 1234
! set lnn and lne for new links
! reallocate if necessary
if ( numL.gt.ubound(lnn,1) ) then
numnew = ceiling(1.2d0*dble(numL))
call realloc(lnn, numnew, keepExisting=.true.)
call realloc(lne, (/2, numnew/), keepExisting=.true.)
end if
if ( i.eq.1 ) then
lnn(LnL) = lnn(L)
lnn(LnR) = lnn(L)
lne(1,LnL) = icLL
lne(1,LnR) = icRR
else
lne(2,LnL) = icLL
lne(2,LnR) = icRR
end if
if ( netcell(ic1)%N.gt.2 ) then
lnn(LnLL) = 2
lne(1,LnLL) = icLL
lne(2,LnLL) = ic1
lnn(LnRR) = 2
lne(1,LnRR) = icRR
lne(2,LnRR) = ic1
else
lnn(LnLL) = 2
lne(1,LnLL) = icLL
lne(2,LnLL) = icRR
lnn(LnRR) = 2
lne(1,LnRR) = icRR
lne(2,LnRR) = icLL
end if
! update lne for old links
if ( lne(1,LL).eq.ic1 ) then
lne(1,LL) = icLL
else if ( lnn(LL).gt.1 ) then
lne(2,LL) = icLL
end if
if ( lne(1,LR).eq.ic1 ) then
lne(1,LR) = icRR
else if ( lnn(LR).gt.1 ) then
lne(2,LR) = icRR
end if
! compute cell centers, etcetera (may be needed for plotting)
if ( icL.gt.0 ) then
call getcellweightedcenter(icL, xz(icL) , yz(icL) , zzz)
call getcellsurface(icL, ba(icL), xzw(icL), yzw(icL))
end if
if ( icR.gt.0 ) then
call getcellweightedcenter(icR, xz(icR) , yz(icR) , zzz)
call getcellsurface(icR, ba(icR), xzw(icR), yzw(icR))
end if
if ( icLL.gt.0 ) then
call getcellweightedcenter(icLL, xz(icLL) , yz(icLL) , zzz)
call getcellsurface(icLL, ba(icLL), xzw(icLL), yzw(icLL))
end if
if ( icRR.gt.0 ) then
call getcellweightedcenter(icRR, xz(icRR) , yz(icRR) , zzz)
call getcellsurface(icRR, ba(icRR), xzw(icRR), yzw(icRR))
end if
! merge triangular cells
! if ( netcell(ic1)%N.lt.3 ) then
! if ( icL.gt.0 ) then
! if ( netcell(icL)%N.eq.3 .and. netcell(icLL)%N.eq.3 ) then
! call mergecells(icL, icLL,jatek)
! end if
! end if
! if ( icR.gt.0 ) then
! if ( netcell(icR)%N.eq.3 .and. netcell(icRR)%N.eq.3 ) then
! call mergecells(icR, icRR,jatek)
! end if
! end if
! end if
! if ( netcell(ic1)%N.lt.3 .and. icL.gt.0 .and. icR.gt.0 ) then
! if ( netcell(icL)%N.eq.3 .and. netcell(icLL)%N.eq.3 .and. &
! netcell(icR)%N.eq.3 .and. netcell(icRR)%N.eq.3 ) then
!! only merge cells if the two other links were formed by a split
! kLLL = sum(netcell(icL)%nod(1:3)) - kL - kLL
! kRRR = sum(netcell(icR)%nod(1:3)) - kR - kRR
!! note: kLL equals kRR in this case and should be halfway between kLLL and kRRR
! if ( dbdistance(0.5d0*(xk(kLLL)+xk(kRRR)), 0.5d0*(yk(kLLL)+yk(kRRR)), &
! xk(kLL), yk(kLL)) .lt. 1d-4 ) then
! call mergecells(icL, icLL,jatek)
! call mergecells(icR, icRR,jatek)
! end if
! end if
! end if
!! merge triangular cells
! if ( netcell(ic1)%N.lt.3 ) then
! if ( icL.gt.0 ) then
! if ( netcell(icL)%N.eq.3 .and. netcell(icLL)%N.eq.3 ) then
! kLLL = sum(netcell(icL)%nod(1:3)) - kL - kLL
! if ( abs(dcosphi(xk(kLLL), yk(kLLL), xk(kL), yk(kL), &
! xk(kL), yk(kL), xk(kp), yk(kp))).lt.0.5d0 ) then
! call mergecells(icL, icLL,jatek)
! end if
! end if
! end if
! if ( icR.gt.0 ) then
! if ( netcell(icR)%N.eq.3 .and. netcell(icRR)%N.eq.3 ) then
! kRRR = sum(netcell(icR)%nod(1:3)) - kR - kRR
! if ( abs(dcosphi(xk(kRRR), yk(kRRR), xk(kR), yk(kR), &
! xk(kR), yk(kR), xk(kp), yk(kp))).lt.1.5d0 ) then
! call mergecells(icR, icRR,jatek)
! end if
! end if
! end if
! end if
!! merge triangular cells
! if ( netcell(ic1)%N.lt.3 ) then
! if ( icL.gt.0 .and. icR.gt.0 ) then
! if ( netcell(icL)%N.eq.3 .and. netcell(icLL)%N.eq.3 .and. &
! netcell(icR)%N.eq.3 .and. netcell(icRR)%N.eq.3 ) then
! kLLL = sum(netcell(icL)%nod(1:3)) - kL - kLL
! kRRR = sum(netcell(icR)%nod(1:3)) - kR - kRR
!
! if ( abs(dcosphi(xk(kLLL), yk(kLLL), xk(kL), yk(kL), &
! xk(kRRR), yk(kRRR), xk(kR), yk(kR))).gt.0.95d0 ) then
! call mergecells(icL, icLL,jatek)
! call mergecells(icR, icRR,jatek)
! end if
! end if
! end if
! end if
! merge triangular cells in parallelograms
! dcos1 and dcos2: cosine of angel between parallel edges ('paralleliness')
! dcos3: a cosine of angle between two adjacent edges ('skewness')
if ( netcell(ic1)%N.lt.3 ) then
if ( icL.gt.0 ) then
if ( netcell(icL)%N.eq.3 .and. netcell(icLL)%N.eq.3 ) then
kLLL = sum(netcell(icL)%nod(1:3)) - kL - kLL
dcos1 = dcosphi(xk(kLLL), yk(kLLL), xk(kL), yk(kL), &
xk(kLL), yk(kLL), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
dcos2 = dcosphi(xk(kLLL), yk(kLLL), xk(kLL), yk(kLL), &
xk(kL), yk(kL), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
dcos3 = dcosphi(xk(kLLL), yk(kLLL), xk(kLL), yk(kLL), &
xk(kLL), yk(kLL), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
if ( abs(dcos1).gt.DCOSMIN .and. abs(dcos2).gt.DCOSMIN .and. dcos3.gt.-0.9d0 ) then
call mergecells(icL, icLL,jatek)
end if
end if
end if
if ( icR.gt.0 ) then
if ( netcell(icR)%N.eq.3 .and. netcell(icRR)%N.eq.3 ) then
kRRR = sum(netcell(icR)%nod(1:3)) - kR - kRR
dcos1 = dcosphi(xk(kRRR), yk(kRRR), xk(kR), yk(kR), &
xk(kRR), yk(kRR), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
dcos2 = dcosphi(xk(kRRR), yk(kRRR), xk(kRR), yk(kRR), &
xk(kR), yk(kR), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
dcos3 = dcosphi(xk(kRRR), yk(kRRR), xk(kRR), yk(kRR), &
xk(kRR), yk(kRR), xk(kp), yk(kp), jsferic, jasfer3D, dxymis)
if ( abs(dcos1).gt.DCOSMIN .and. abs(dcos2).gt.DCOSMIN .and. dcos3.gt.-0.9d0 ) then
call mergecells(icR, icRR,jatek)
end if
end if
end if
end if
end do
! delete link
call dellink(L)
ierror = 0
! error handling
1234 continue
return
contains
!> delete an element from an allocatable integer array
subroutine del_intarrayelem(N, ia, iy)
use m_alloc
implicit none
integer, intent(in) :: N !< array size
integer, allocatable, dimension(:), intent(inout) :: ia !< (allocatable) array
integer, intent(in) :: iy !< element to be deleted from array
integer, dimension(N) :: idum
integer :: k, knew
knew = 0
do k=1,N
if ( ia(k).ne.iy ) then
knew = knew+1
idum(knew) = ia(k)
end if
end do
call realloc(ia, knew)
ia(1:knew) = idum(1:knew)
return
end subroutine del_intarrayelem
!> replace an element from an allocatable integer array by another integer array
subroutine replace_intarrayelem(N, ia, iy, Nrep, iarep)
use m_alloc
implicit none
integer, intent(in) :: N !< array size
integer, allocatable, dimension(:), intent(inout) :: ia !< (allocatable) array
integer, intent(in) :: iy !< element to be replaced in array
integer, intent(in) :: Nrep !< array size
integer, dimension(Nrep), intent(in) :: iarep !< array to be inserted
integer, dimension(N+Nrep-1) :: idum
integer :: k, kk, knew
logical :: Ldone
Ldone = .false.
knew = 0
do k=1,N
if ( ia(k).ne.iy ) then
knew = knew+1
idum(knew) = ia(k)
else if ( .not.Ldone ) then
idum(knew+1:knew+Nrep) = iarep
knew = knew+Nrep
Ldone = .true. ! safety
end if
end do
call realloc(ia, knew)
ia(1:knew) = idum(1:knew)
return
end subroutine replace_intarrayelem
end subroutine splitlink
!> administer a cell
!> note: cell circumcenters are not updated (would require up-to-date lnn, lne)
subroutine makecell(N, nodlist, linlist, ic, ierror)
use m_netw
use m_alloc
use network_data, only : xzw, yzw
use m_flowgeom, only: ndx, xz, yz, ba
use gridoperations
implicit none
integer, intent(in) :: N !< number of nodes and links in cell
integer, dimension(N), intent(in) :: nodlist !< nodelist
integer, dimension(N), intent(in) :: linlist !< linklist
integer, intent(out) :: ic !< cell number
integer, intent(out) :: ierror !< error (1) or not (0)
integer :: numc
integer :: ierr
real , parameter :: growfac = 1.2
ierror = 1
call increasenetcells(NUMP+1, growfac, .true.)
ic = NUMP+1
call realloc(netcell(ic)%NOD, N, stat=ierr, keepExisting=.false.)
call realloc(netcell(ic)%LIN, N, stat=ierr, keepExisting=.false.)
if ( ierr.ne.0 ) then
return
end if
netcell(ic)%N = N
netcell(ic)%nod = nodlist
netcell(ic)%lin = linlist
! cell circumcenters etcetera
! the following is taken from update_cell_circumcenters(), however:
! keepExisting=.true. instead of keepExisting = .false.
! the array sizes are increased with an additional growfactor
if (nump+1 > size(xz)) then
numc = ceiling(growfac*dble(max(ndx+1,nump+1)))
call realloc(xz, numc, stat=ierr, keepExisting=.true.)
call aerr('xz(numc)',IERR, numc)
call realloc(yz, numc, stat=ierr, keepExisting=.true.)
call aerr('yz(numc)',IERR, numc)
call realloc(xzw, numc, stat=ierr, keepExisting=.true.)
call aerr('xzw(numc)',IERR, numc)
call realloc(yzw, numc, stat=ierr, keepExisting=.true.)
call aerr('yzw(numc)',IERR, numc)
call realloc(ba, numc, stat=ierr, keepExisting=.true.)
call aerr('ba(numc)',IERR, numc)
endif
! update nump
nump = nump + 1
ierror = 0
! error handling
1234 continue
return
end subroutine makecell
!> merge two cells with a common link and update administration
subroutine mergecells(ic1, ic2, jatek)
use m_netw
use m_alloc
use gridoperations
implicit none
integer, intent(in) :: ic1, ic2 !< cell numbers
integer, intent(in) :: jatek !< plot (1) or not (0)
integer, allocatable, dimension(:) :: nod3, lin3
integer :: kk, kk1, kk2, kk3
integer :: L, L1, L2, Lshare
integer :: N1, N2, N3
integer :: ierror
logical :: Lcommon
if ( ic1.eq.ic2 ) return
if ( netstat /= NETSTAT_OK ) call findcells(0)
ierror = 1
N1 = netcell(ic1)%N
N2 = netcell(ic2)%N
N3 = N1+N2-2
! allocate
allocate(nod3(N3), lin3(N3))
! add links
Lshare = 0
kk3 = 0
do kk1=1,N1
L1 = netcell(ic1)%lin(kk1)
Lcommon = .false.
! see if this link is shared with cell 2
do kk2=1,N2
L2 = netcell(ic2)%lin(kk2)
if ( L1.eq.L2 ) then
! add links of cell 2
if ( kk2.lt.N2 ) lin3(kk3+1:kk3+N2-kk2 ) = netcell(ic2)%lin(kk2+1:N2)
if ( kk2.gt.1 ) lin3(kk3+N2-kk2+1:kk3+N2-1) = netcell(ic2)%lin(1:kk2-1)
kk3 = kk3+N2-1
Lcommon = .true.
Lshare = L1
exit
end if
end do
if ( .not.Lcommon ) then
kk3 = kk3+1
lin3(kk3) = L1
end if
end do
if ( kk3.ne.N3 ) then
continue
end if
if ( Lshare.eq.0 ) goto 1234
! make the node list
! determine orientation of first link
L = lin3(1)
L2 = lin3(2)
if ( kn(1,L).eq.kn(1,L2) .or. kn(1,L).eq.kn(2,L2) ) then
nod3(1:2) = kn(2:1:-1,L)
else
nod3(1:2) = kn(1:2,L)
end if
do kk=2,N3-1
L = lin3(kk)
if ( kn(1,L).eq.nod3(kk-1) .or. kn(1,L).eq.nod3(kk) ) then
nod3(kk+1) = kn(2,L)
else
nod3(kk+1) = kn(1,L)
end if
end do
! change lne
do kk=1,N3
L = lin3(kk)
if ( lne(1,L).eq.ic2 ) then
lne(1,L) = ic1
else if ( lne(1,L).ne.ic1 .and. lnn(L).gt.1 ) then
lne(2,L) = ic1
end if
end do
! change cell 1
netcell(ic1)%N = N3
call realloc(netcell(ic1)%nod, N3, keepExisting=.false.)
netcell(ic1)%nod = nod3
call realloc(netcell(ic1)%lin, N3, keepExisting=.false.)
netcell(ic1)%lin = lin3
! disable cell 2
netcell(ic2)%N = 0
! delete link
if ( jatek.eq.1 ) call teklink(Lshare, 0)
call dellink(Lshare)
ierror = 0
! error handling
1234 continue
! deallocate
if ( allocated(nod3) ) deallocate(nod3, lin3)
return
end subroutine mergecells
!> Insert a netline by splitting a string of connected quadrilateral cells
!! in one direction.
!!
!! The direction and start cell is determined by specifying a single 'cross'
!! link that will be split.
recursive subroutine insert_netline(xp, yp, L_)
use m_netw
use gridoperations
implicit none
double precision, intent(in) :: xp, yp !< link coordinates (used only if L_.eq.0)
integer, intent(in) :: L_ !< link number (set to 0 first time)
double precision :: zp
double precision, parameter :: dcostol = 0.25d0
integer, dimension(2) :: Lnext ! next links in recursion
integer :: Nnext ! number of next links
integer :: i, ic, ja, kk, kknext, L, N, N2Dcells
integer :: ierror
ierror = 1
! initialization: find link
if ( L_.eq.0 ) then
if ( netstat /= NETSTAT_OK ) then
call findcells(100)
end if
L = 0
call islink(L, xp, yp, zp)
if ( L.eq.0 ) goto 1234
call teknet(0,ja) ! whipe out previous net
call readyy('Inserting meshline', 0d0)
else
L = L_
end if
Nnext = 0
Lnext = 0
if ( kn(3,L).eq.2 ) then
N2Dcells = lnn(L)
else ! 1D
N2Dcells = 0
end if
do i=1,N2Dcells
ic = lne(i,L)
N = netcell(ic)%N
if ( N.ne.4 ) cycle
kk=1; do while ( netcell(ic)%lin(kk).ne.L .and. kk.lt.N ); kk=kk+1; end do
if ( netcell(ic)%lin(kk).ne.L ) cycle
kknext = kk+2; if ( kknext.gt.N ) kknext = kknext-N
Nnext = Nnext+1
Lnext(Nnext) = netcell(ic)%lin(kknext)
end do
call splitlink(0d0, 0d0, L, dcostol, 1, ierror)
if ( ierror.ne.0 ) goto 1234
! ja = 1
! call confrm(' ', ja)
do i=1,Nnext
! proceed with links that are inside the selecting polygon
! if ( kc(kn(1,Lnext(i))).gt.0 .and. kc(kn(2,Lnext(i))).gt.0 ) then
if ( lc(Lnext(i)).gt.0 .and. kn(1,Lnext(i)).gt.0 .and. kn(2,Lnext(i)).gt.0 ) then ! Lnext(i) may have been disabled/deleted in the recursion
call insert_netline(0d0, 0d0, Lnext(i))
else
continue
end if
end do
ierror = 0
! error handling
1234 continue
if ( L_.eq.0 ) then
call readyy(' ',-1d0)
call teknet(1,ja) ! plot new net
end if
return
end subroutine insert_netline
!> refine cells by splitting links
subroutine refinecellsandfaces2()
use m_netw
use m_samples
use m_samples_refine
use m_ec_interpolationsettings
use m_missing
use m_alloc
use unstruc_messages
use unstruc_colors, only: ncolhl
use unstruc_display, only: jaGUI
use kdtree2Factory
use m_sferic
use gridoperations
implicit none
integer, dimension(:), allocatable :: jarefine ! refine cell (1) or not (0) or cell outside polygon (-1), dim(nump)
integer, dimension(:), allocatable :: jalink ! refine link (>0) or not (<=0),
integer, dimension(:), allocatable :: linkbrother ! brotherlink, that shares a (hanging) node, dim: numL
integer, dimension(:), allocatable :: kc_sav ! save of kc
double precision :: xboundmin, xboundmax, x1, x2, dxxmax, dxxmin, dl
integer :: ierror ! error (1) or not (0)
integer :: ja, jaCourantnetwork
integer :: i, ic, ip, j, k, kother, kk, kkm1, kkp1, kkk, L, Lm1, Lp1, N
integer :: numL_old
integer :: numrefine ! number of cells to be refined
integer :: nump_virtual
integer :: interpolationtype_old, IAV_old, jacancelled
integer :: JTEKINTERPOLATIONPROCESS_bak
integer :: jakdtree = 1 ! use kdtree (1) or not (0)
integer :: ilevel ! refinement level
integer :: k1, k2
integer :: num ! number of removed isolated hangning noded
double precision, external :: getdy, dlinklength
character(len = 64) :: tex
! determine if the refinement needs to adapt to sample values
! jaCourantnetwork = 1
! if ( Ns.lt.3 .or. MXSAM*MYSAM.ne.NS ) jacourantnetwork = 0
jaCourantnetwork = 0
if ( Ns.ge.1 .or. jaGUI.eq.0 ) then
jacourantnetwork = 1
if ( MXSAM*MYSAM.eq.NS ) then
irefinetype = ITYPE_WAVECOURANT
end if
end if
if ( jacourantnetwork.eq.1 ) then
if ( IPSTAT.ne.IPSTAT_OK ) then
write (6,"('tidysamples')")
call tidysamples(xs,ys,zs,IPSAM,NS,MXSAM,MYSAM) ! uses global kdtree
call get_samples_boundingbox()
IPSTAT = IPSTAT_OK
end if
end if
! if ( netstat.ne.netstat_OK .or. NPL.gt.0 ) then ! in case of selecting polygon: always call findcells
call findcells(0)
! end if
if ( Ns.ge. 1 .and. jakdtree.eq.1 ) then
! initialize kdtree
call build_kdtree(treeglob,Ns,xs,ys, ierror, jsferic, dmiss)
if ( ierror.ne.0 ) then
! disable kdtree
call delete_kdtree2(treeglob)
jakdtree = 0
end if
end if
! store original interpolation settings
interpolationtype_old = interpolationtype
IAV_old = IAV
!IPSTAT = IPSTAT_NOTOK
! allocate
allocate(jarefine(nump), stat = ierror)
call aerr('jarefine(nump)', ierror, nump)
if ( ierror.ne.0 ) goto 1234
allocate(jalink(numL), stat=ierror)
call aerr('jalink(numL)', ierror, numL)
if ( ierror.ne.0 ) goto 1234
allocate(linkbrother(numL), stat=ierror)
call aerr('linkbrother(numL)', ierror, numL)
if ( ierror.ne.0 ) goto 1234
linkbrother = 0
! get mesh bounds for spherical, periodic coordinates
if ( jsferic.eq.1 ) then
call get_meshbounds(xboundmin, xboundmax)
end if
if ( jacourantnetwork.eq.1 ) then
! store samples
call savesam()
! get the settings from a parameter screen
if ( jaGUI.eq.1 ) then
call change_samples_refine_param(jacancelled)
if ( jacancelled.eq.1 ) goto 1234
end if
if ( irefinetype.eq.ITYPE_RIDGE ) then
call prepare_sampleHessian(ierror)
if ( ierror.ne.0 ) goto 1234
end if
end if
! take dry cells into account (after findcells)
call delete_dry_points_and_areas()
! try to find brother links in the original net
linkbrother = 0
call find_linkbrothers(linkbrother)
! set initial node mask to ensure connection with the net outside the selecting polygon
call set_initial_mask(jarefine, linkbrother)
nump_virtual = nump
do ilevel=1,MAXLEVEL
numL_old = numL
jalink = 0
if ( jaCourantnetwork.eq.1 ) then
! compute cell refinement mask (cells outside polygon will be marked by -1)
call compute_jarefine(jarefine, jalink, jakdtree, ierror)
jalink = -jalink ! unset but remember link refinement mask
if ( ierror.eq.1 ) goto 1234
! smooth the cell refinement mask
call smooth_jarefine(jarefine, jalink, linkbrother)
else
jarefine = 1 ! refine all cells
jalink = -1 ! refine all links
end if
! disable direct refinement of cells with one or more inactive nodes
if ( ilevel.gt.1 ) then
do ic=1,nump
do kk=1,netcell(ic)%N
if ( kc(netcell(ic)%nod(kk)).ne.1 ) then
jarefine(ic) = 0
!call cirr(xzw(ic), yzw(ic), 204)
exit
end if
end do
end do
else ! first level: disable cells with all nodes inactive only
iclp:do ic=1,nump
do kk=1,netcell(ic)%N
k = netcell(ic)%nod(kk)
if ( kc(k).ne.0 .and. kc(k).ne.-2 ) cycle iclp ! active node found: discard this cell and continue with next
end do
jarefine(ic) = 0
!call cirr(xzw(ic), yzw(ic), 204)
end do iclp
end if
! call qnerror(' ', ' ', ' ')
call comp_jalink(jarefine, linkbrother, jalink)
! also refine cells and link to avoid links with more than one hanging node
call split_cells(jarefine, jalink, linkbrother)
numrefine = 0
do k=1,nump
if ( jarefine(k).ne.0 ) numrefine = numrefine+1
end do
if ( numrefine.eq.0 ) exit ! done
! perform the actual refinement
nump_virtual = nump_virtual*4
call refine_cells(jarefine, jalink, linkbrother, 1, ierror)
netstat = netstat_cells_dirty
! rearrange worldmesh
call rearrange_worldmesh(xboundmin, xboundmax)
if ( ierror.eq.1 ) goto 1234
! update cell administration
if ( NPL.gt.0 ) call store_and_set_kc()
call findcells(1000) ! do not update node mask (kc)
if ( NPL.gt.0 ) call restore_kc()
! call findcells(0) ! update node mask (kc)
call mess(LEVEL_INFO, 'refinement efficiency factor', real(dble(nump_virtual)/dble(max(nump,1))))
! take dry cells into account (after findcells)
call delete_dry_points_and_areas()
if ( jagui.eq.1 ) then
ja = 1
dxxmax = -huge(1d0) ; dxxmin = - dxxmax
do L = 1,numL
dl = dlinklength(L)
dxxmin = min(dxxmin, dl)
dxxmax = max(dxxmax, dl)
enddo
write (tex,'(2F14.3,I14)') dxxmin, dxxmax, nump
call confrm('Smallest and largest netlinks and number of cells: '//trim(tex)//' Continue? ', ja)
if ( ja.ne.1 ) exit ! done
end if
! reallocate
call realloc(jarefine, nump, stat=ierror, keepExisting=.false.)
if ( ierror.ne.0 ) goto 1234
call realloc(jalink, numL, stat=ierror, keepExisting=.false.)
if ( ierror.ne.0 ) goto 1234
! call realloc(linkbrother, numL, stat=ierror, keepExisting=.true., fill=0)
! if ( ierror.ne.0 ) gofto 1234
linkbrother = 0
call find_linkbrothers(linkbrother)
end do ! do ilevel=1,MAXLEVEL
! connect hanging nodes
if ( jagui.eq.1 ) then
jaconnect = 1
call confrm('connect hanging nodes?', jaconnect)
end if
if ( jaconnect.eq.1 ) then
where( kc.eq.-1 ) kc=1
if ( NPL.gt.0 ) call store_and_set_kc()
call findcells(1000) ! take dry cells into account (after findcells)
call delete_dry_points_and_areas()
if ( NPL.gt.0 ) call restore_kc()
! remove isolated hanging nodes and update netcell administration (no need for setnodadm)
call remove_isolated_hanging_nodes(linkbrother,num)
! check if illegal cells have been created by removing isolated hanging nodes, or by dry/cut-cells
call write_illegal_cells_to_pol(0)
call connect_hanging_nodes(linkbrother)
netstat = netstat_cells_dirty
keepcircumcenters = 0 ! do not keep circumcenters
else
keepcircumcenters = 0 ! keep circumcenters
call confrm('Keep circumcenters?', keepcircumcenters)
end if
ierror = 0
! error handling
1234 continue
! deallocate
if ( allocated(jarefine) ) deallocate(jarefine)
if ( allocated(jalink) ) deallocate(jalink)
if ( allocated(linkbrother) ) deallocate(linkbrother)
if ( allocated(zss) ) then
call deallocate_sampleHessian()
iHesstat = iHesstat_DIRTY
end if
! restore original interpolation settings
interpolationtype = interpolationtype_old
IAV = IAV_old
! deallocate kdtree if it was created
if ( Ns.ge. 1 .and. treeglob%itreestat.ne.ITREE_EMPTY ) call delete_kdtree2(treeglob)
return
contains
subroutine store_and_set_kc()
implicit none
integer :: k
if ( allocated(kc_sav) ) deallocate(kc_sav)
if ( numk.lt.1 ) goto 1234
allocate(kc_sav(numk))
do k=1,numk
kc_sav(k) = kc(k)
if ( kc(k).ne.0 ) kc(k) = 1
end do
1234 continue
return
end subroutine store_and_set_kc
subroutine restore_kc()
implicit none
integer k
if ( .not.allocated(kc_sav) ) goto 1234
if ( .not.allocated(kc) ) goto 1234
if ( ubound(kc_sav,1).lt.numk ) goto 1234
if ( ubound(kc,1) .lt.numk ) goto 1234
do k=1,numk
kc(k) = kc_sav(k)
end do
deallocate(kc_sav)
1234 continue
return
end subroutine restore_kc
!> do not refine, based on the criterion:
!> cells with hanging nodes
!> cells that are crossed by the selecting polygon
!>
!> ensure that no crossed cells have hanging nodes
subroutine set_initial_mask(jarefine, linkbrother)
use m_netw
implicit none
integer, dimension(:), intent(inout) :: jarefine
integer, dimension(:), intent(in) :: linkbrother
integer :: ic, k, kk, kkp1, L, Lp1, N
integer :: jahang, jacross, jarepeat
jarepeat = 1
do while ( jarepeat.eq.1 )
jarepeat = 0
do ic=1,nump
! if ( jarefine(ic).ne.0 ) cycle
N = netcell(ic)%N
jahang = 0
jacross = 0
do kk=1,N
k = netcell(ic)%nod(kk)
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
L = netcell(ic)%lin(kk)
Lp1 = netcell(ic)%lin(kkp1)
if ( ( linkbrother(L).eq.Lp1 .or. linkbrother(Lp1).eq.L ) ) then
jahang = 1
end if
if ( kc(k).eq.0 ) then
jacross = 1
end if
end do
if ( jacross.eq.1 ) then
jarefine(ic) = 0
do kk=1,N
k = netcell(ic)%nod(kk)
if ( kc(k).eq.1 ) then
kc(k) = -2
jarepeat = 1
!call cirr(xk(k), yk(k), 31)
end if
end do
end if
end do ! do ic=1,nump
end do ! do while ( jarepeat.eq.1 )
! call qnerror(' ', ' ', ' ')
return
end subroutine set_initial_mask
!> compute refinement criterion from sample data
subroutine compute_jarefine(jarefine, jalink, jakdtree, ierror)
use m_netw
use m_samples
use m_ec_interpolationsettings
use m_physcoef, only: ag
use m_flowtimes, only: dt_max
use m_flowgeom, only: ba
use m_missing
! use m_plotdots
implicit none
integer, dimension(:), intent(out) :: jarefine !< refine cell (1) or not (0), dim(nump)
integer, dimension(:), intent(out) :: jalink !< refine link (1) or not (0), dim(numL)
integer, intent(inout) :: jakdtree !< use kdtree (1) or not (0)
integer, intent(out) :: ierror !< error (1) or not (0)
integer, parameter :: M=10 ! maximum number of nodes in cell
integer, parameter :: MAXSUB = 4 ! maxinum number of subcells in cell
double precision, dimension(M) :: xloc, yloc ! node list
integer, dimension(M) :: jarefinelink ! refine links (1) or not (0)
integer, dimension(M) :: LnnL, Lorg ! not used
double precision :: aspect ! aspect ratio of netcell
! double precision, dimension(2) :: u, v ! orientation vectors of netcell
double precision :: xc, yc, area
double precision :: zz ! not used
integer :: i, ic, ip, j, k, kk, kkm1, kkp1, N
integer :: L, LL
integer, parameter :: NDIM=4 ! sample vector dimension
integer, parameter :: MMAX = 6
logical, dimension(MMAX) :: Lhang
integer, dimension(MMAX) :: ishangingnod
integer :: numhang, numhangnod, numrefine
ierror = 1
! default
jarefine = 0
jalink = 0
! numdots = 0
!if ( IPSTAT.ne.IPSTAT_OK ) then
! write (6,"('tidysamples')")
! call tidysamples(xs,ys,zs,IPSAM,NS,MXSAM,MYSAM) ! uses global kdtree
! call get_samples_boundingbox()
! IPSTAT = IPSTAT_OK
!end if
! cell masking
do ic=1,nump
! N = netcell(ic)%N
! if ( N.gt.M ) goto 1234
!
!! check if the whole cell is inside the selecting polygon and store node coordinates
! jain = 1
! do kk=1,N
! k = netcell(ic)%nod(kk)
! xloc(kk) = xk(k)
! yloc(kk) = yk(k)
! end do
! get the cell polygon that is safe for periodic, spherical coordinates, inluding poles
call get_cellpolygon(ic,M,N,1d0,xloc,yloc,LnnL,Lorg,zz)
! compute orientation vectors of netcell
! call orthonet_compute_orientation(aspect, u(1), v(1), u(2), v(2), ic)
! get hanging nodes (jalink, numrefine not used)
call find_hangingnodes(ic, jalink, linkbrother, numhang, Lhang, numhangnod, ishangingnod, numrefine)
! compute refinement criterion
call compute_jarefine_poly(N, xloc, yloc, jarefine(ic), jarefinelink, jakdtree, Lhang)
! fill jalink from jarefinelink
do kk=1,N
if ( jarefinelink(kk).eq.1 ) then
LL = Lorg(kk)
if ( LL.gt.0 ) then
L = netcell(ic)%lin(LL)
jalink(L) = 1
! call adddot(0.5d0*(xk(kn(1,L)) + xk(kn(2,L))), 0.5d0*(yk(kn(1,L)) + yk(kn(2,L))))
end if
end if
end do
! N = netcell(ic)%N
! do kk=1,N
! kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
!! find link
! k1 = netcell(ic)%nod(kk)
! k2 = netcell(ic)%nod(kkp1)
! do kkk=1,N
! L = netcell(ic)%lin(kkk)
! if ( ( kn(1,L).eq.k1 .and. kn(2,L).eq.k2 ) .or. &
! ( kn(1,L).eq.k2 .and. kn(2,L).eq.k1 ) ) then
! if ( jarefinelink(kkk).eq.1 ) then
! jalink(L) = 1
! end if
! exit
! end if
! end do
! end do
end do
ierror = 0
! error handling
1234 continue
! restore samples
! call restoresam()
return
end subroutine compute_jarefine
!> compute refinement criterion in a polygon
!> always based on averaging2
subroutine compute_jarefine_poly(N, x, y, jarefine, jarefinelink, jakdtree, Lhang)
use m_ec_interpolationsettings
use m_samples, only: NS, xs, ys, zs
use m_samples_refine
use m_physcoef
use kdtree2Factory
use m_missing, only: dmiss, JINS
use m_polygon, only: NPL, xpl, ypl, zpl
use m_ec_basic_interpolation, only: averaging2
use m_sferic, only: jsferic, jasfer3D
use geometry_module, only: dbdistance, comp_masscenter
implicit none
integer, intent(in) :: N !< polygon size
integer :: nnn(1) !< polygon size
double precision, intent(in) :: x(:), y(:) !< polygon coordinates
! double precision, dimension(N), intent(in) :: x, y !< polygon coordinates
! double precision, dimension(2), intent(in) :: u, v !< orientation vectors of polygon
integer, intent(out) :: jarefine !< refine (1) or not (0)
integer, dimension(:), intent(out) :: jarefinelink !< refine link (1) or not (0)
integer, intent(inout) :: jakdtree !< use kdtree (1) or not (0)
logical, dimension(:), intent(in) :: Lhang !< link with hanging node (.true.) or not (.false.)
double precision, dimension(1) :: xc, yc ! polygon center coordinates
double precision, dimension(NDIM) :: zc ! interpolated sample vector [zs, DzsDx, DzsDy]
double precision :: area, zsloc, DzsDx, DzsDy, diff
double precision :: dsize, dcellsize_wanted, dcellsize, dmincellsize, dmaxcellsize
double precision, dimension(N) :: dlinklength ! link lengths
integer, dimension(1) :: isam
double precision :: dval, C, Courant, dlinklengthnew
integer :: ivar, k, kp1, num, ierror
integer :: jacounterclockwise ! counterclockwise (1) or not (0) (not used here)
double precision, parameter :: FAC = 1d0
! double precision, parameter :: dtol = 1d-8
jarefine = 0
jarefinelink = 0
nnn(1) = N
! compute cell center
call comp_masscenter(N, x, y, xc(1), yc(1), area, jacounterclockwise, jsferic, jasfer3D, dmiss)
! initialization
zc = DMISS
dmincellsize = 1d99
dmaxcellsize = 0d0
do k=1,N
kp1 = k+1; if ( kp1.gt.N ) kp1=kp1-N
dsize = dbdistance(x(k),y(k),x(kp1),y(kp1),jsferic, jasfer3D, dmiss)
dlinklength(k) = dsize
dmincellsize = min(dmincellsize, dsize)
dmaxcellsize = max(dmaxcellsize, dsize)
end do
dcellsize = dmaxcellsize
if ( irefinetype.eq.ITYPE_RIDGE ) then
!------------------------------------------------------------------------
! ridge detection
!------------------------------------------------------------------------
if ( interpolationtype.ne.INTP_AVG .or. IAV.ne.3) then
! call qnerror('Interpolation type is set to averaging and averaging type to maximum', ' ', ' ')
interpolationtype = 2
IAV = 3
end if
zc = DMISS
call averaging2(NDIM,NS,xs,ys,zss,ipsam,xc,yc,zc,1,x,y,N,nnn,jakdtree,&
dmiss, jsferic, jasfer3D, JINS, NPL, xpl, ypl, zpl)
do ivar=1,3
if ( zc(ivar).eq.DMISS ) goto 1234
end do
zsloc = zc(1)
DzsDx = zc(2)
DzsDy = zc(3)
! diff = max(abs(DzsDx*u(1)+DzsDy*u(2)), abs(DzsDx*v(1)+DzsDy*v(2)))
! dcellsize = sqrt(max(u(1)*u(1), u(2)*u(2)))
dcellsize_wanted = threshold / ( abs(zc(4)) + 1d-8 )
if ( dcellsize.gt.dcellsize_wanted .and. dcellsize.gt.2d0*hmin .and. abs(zc(4)).gt.thresholdmin ) then
! if ( abs(zc(4)).gt.thresholdmin ) then
jarefine = 1
jarefinelink = 1
else
jarefine = 0
jarefinelink = 0
end if
else if ( irefinetype.eq.ITYPE_WAVECOURANT .or. &
irefinetype.eq.ITYPE_MESHWIDTH ) then
!------------------------------------------------------------------------
! wave Courant number
!------------------------------------------------------------------------
if ( interpolationtype.ne.INTP_AVG .or. IAV.ne.6) then
! call qnerror('Interpolation type is set to averaging and averaging type to minabs', ' ', ' ')
interpolationtype = 2
IAV = 6 ! minabs
end if
! only interpolate samples if necessary
if ( Dt_maxcour.gt.0d0 .or. irefinetype.eq.ITYPE_MESHWIDTH ) then
zc = DMISS
call averaging2(1,NS,xs,ys,zs,ipsam,xc,yc,zc,1,x,y,N,nnn,jakdtree, &
dmiss, jsferic, jasfer3D, JINS, NPL, xpl, ypl, zpl)
! check if a value is found, use nearest sample from cell center if not so
if ( zc(1).eq.DMISS .and. jakdtree.eq.1 .and. jaoutsidecell.eq.1 ) then
call find_nearest_sample_kdtree(treeglob,Ns,1,xs,ys,zs,xc(1),yc(1),1,isam,ierror, jsferic, dmiss)
if ( ierror.ne.0 ) then
jakdtree=0
else
if ( isam(1).gt.0 .and. isam(1).lt.Ns+1 ) zc(1) = zs(isam(1))
end if
end if
dval = zc(1)
else
dval = 0d0
end if
if ( dval.eq.DMISS ) goto 1234
jarefine = 0
num = 0 ! number of links in cell to be refined
do k=1,N
if ( dlinklength(k).lt.tooclose ) then
jarefinelink(k) = 0
num = num + 1
cycle
end if
dlinklengthnew = 0.5d0*dlinklength(k)
if ( irefinetype.eq.ITYPE_WAVECOURANT ) then
! compute wave speed
C = sqrt(AG*abs(dval))
! C = sqrt(AG*max(-dval,0d0))
! compute wave Courant number
Courant = C * Dt_maxcour / dlinklength(k)
!if ( Courant.lt.1 .and. 0.5d0*dlinklength(k).gt.FAC*hmin ) then
if ( Courant.lt.1 .and. abs(dlinklengthnew-hmin).lt.abs(dlinklength(k)-hmin) ) then
num = num+1
jarefinelink(k) = 1
else
jarefinelink(k) = 0
end if
else if ( irefinetype.eq.ITYPE_MESHWIDTH ) then
if ( dlinklength(k).gt.dval .and. dlinklengthnew.ge.hmin ) then
num = num+1
jarefinelink(k) = 1
else
jarefinelink(k) = 0
end if
end if
end do
! check if at least one link needs to be refined
if ( num.gt.0 ) then
! count number of links to be refined, or that are already refined (i.e. have a hanging node)
num = 0
do k=1,N
if ( jarefinelink(k).eq.1 .or. Lhang(k) ) then
num=num+1
end if
end do
end if
! check for non-directional refinement and refine all links without hanging nodes if so
if ( jadirectional.eq.0 ) then
if ( num.eq.N ) then
! jarefinelink = 1
! also refine links without hanging nodes
do k=1,N
if ( .not.Lhang(k) ) then
jarefinelink(k) = 1
end if
end do
else
num = 0
jarefinelink = 0
end if
end if
if ( num.eq.0 ) then
jarefine = 0
else if ( num.eq.1 ) then
! do not refine cell with only one link that needs to be, or is already, refined
jarefine = 0
jarefinelink = 0
else
jarefine = 1
end if
else
!------------------------------------------------------------------------
! undefined type
!------------------------------------------------------------------------
jarefine = 0
end if
1234 continue
return
end subroutine compute_jarefine_poly
!> smooth the cell refinement mask
subroutine smooth_jarefine(jarefine, jalink, linkbrother)
use m_netw
implicit none
integer, dimension(:), intent(inout) :: jarefine !< refine cell (1) or not (0), dim: nump
integer, dimension(:), intent(inout) :: jalink !< refine link (1) or not (0), dim(numL)
integer, dimension(:), intent(in) :: linkbrother !< brotherlink, that shares a (hanging) node
! integer, dimension(:), allocatable :: janode ! refine around node (1) or not (0), dim: numk
integer, dimension(:), allocatable :: jalin ! refine at link (1) or not (0), dim: numL
integer :: iter, ic, k, kk, kkm1, kkp1, L, N
if ( NUMITCOURANT.lt.1 ) return ! nothing to do
if ( jadirectional.ne.0 ) then
call qnerror('directional refinement not allowed in combination with smoothing', ' ', ' ')
jadirectional = 0
end if
! allocate
! allocate(janode(numk)
allocate(jalin(numL))
do iter=1,NUMITCOURANT
! determine node refinement mask
! janode = 0
! determine link refinement mask
jalin = 0
do ic=1,nump
if ( jarefine(ic).ne.1 ) cycle
N = netcell(ic)%N
! do kk=1,N
! k = netcell(ic)%nod(kk)
! janode(k) = 1
! end do
do kk=1,N
L = netcell(ic)%lin(kk)
! do not pass on mask to already refined cells
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
if ( linkbrother(L).ne.netcell(ic)%lin(kkp1) .and. linkbrother(L).ne.netcell(ic)%lin(kkm1) ) then
jalin(L) = 1
end if
end do
end do
! update cell refinement mask
do ic=1,nump
do kk=1,netcell(ic)%N
! k = netcell(ic)%nod(kk)
! if ( janode(k).eq.1 ) then
! jarefine(ic) = 1
! exit
! end if
L = netcell(ic)%lin(kk)
if ( jalin(L).eq.1 ) then
jarefine(ic) = 1
exit
end if
end do
end do
end do
! update link refinement mask
do ic=1,nump
if ( jarefine(ic).eq.1 ) then
N = netcell(ic)%N
do kk=1,N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
L = netcell(ic)%lin(kk)
if ( linkbrother(L).eq.netcell(ic)%lin(kkm1) .or. linkbrother(L).eq.netcell(ic)%lin(kkp1) ) then
! link already refined with hanging node
else
jalink(L) = 1
end if
end do
end if
end do
! deallocate
! if ( allocated(janode) ) deallocate(janode)
if ( allocated(jalin) ) deallocate(jalin)
return
end subroutine smooth_jarefine
!> refine the cells, based on a cell and link refinement mask
subroutine refine_cells(jarefine, jalink, linkbrother, jahang, ierror)
use m_netw
use m_alloc
use network_data, only: dcenterinside
use m_sferic, only: jsferic
use geometry_module, only: dbdistance, getcircumcenter
use m_missing, only : dmiss, dxymis
implicit none
integer, dimension(:), intent(inout) :: jarefine !< refine cell (>0) or not (0), dim(nump)
integer, dimension(:), intent(inout) :: jalink !< refine link (>0) or not (0), dim(numL)
integer, allocatable, dimension(:), intent(inout) :: linkbrother !< brotherlink, that shares a (hanging) node
integer, intent(in) :: jahang !< allow hanging nodes (1) or not (0)
integer, intent(out) :: ierror !< error (1) or not (0)
double precision :: xnew, ynew
double precision :: ymin, ymax
double precision :: dlength1, dlength2
integer, parameter :: MMAX = 10 ! maximum number of links per netcell
integer, dimension(MMAX) :: LLnew ! list with refined links (in netcell numbering)
integer, dimension(MMAX) :: nods ! list with new nodes
integer :: i, ip1, k, k2, k3, kk, kkm1, kkp1, kkk
integer :: knew, knew2, k0, k1, k0m1, k1p1, k0m2, k1p2
integer :: L, L1, L2, Lm1, Lp1, Lm2, Lp2, Lnew, N
integer :: num, numbrothers, numrefined
integer :: Lsize
integer :: jahang_
integer :: ierr
logical :: Lparentcross ! original parent cell crossed by selecting polygon (.true.) or not (.false.)
logical :: Lrefine ! refine cell (.true.) or not (.false.)
double precision :: xmn, xmx ! for spherical, periodic coordinates
integer :: Np, kp
integer, dimension(MMAX) :: ishanging
double precision :: xz, yz
double precision, dimension(MMAX) :: xp, yp
! for spherical, periodic coordinates
double precision, dimension(MMAX) :: xv, yv
integer, dimension(MMAX) :: LnnL
integer, dimension(MMAX) :: Lorg
double precision :: zz
integer :: nn
logical :: Lhanging
logical :: Lpole1, Lpole2
ierror = 1
! first add new nodes at the links that need to be refined (jalink will contain new node number),
! then make the internal links in the cells, and
! then split the original links
KN3TYP = 2 ! 2d links only
! add new nodes
do L=1,numL
if ( jalink(L).ne.0 ) then
k1 = kn(1,L)
k2 = kn(2,L)
xnew = 0.5d0*(xk(k1)+xk(k2))
ynew = 0.5d0*(yk(k1)+yk(k2))
if ( jsferic.eq.1 ) then
call comp_middle_latitude(yk(k1),yk(k2),ynew,ierr)
end if
! fix for spherical, periodic coordinates
if ( jsferic.eq.1 ) then
if ( abs(xk(k1)-xk(k2)).gt.180d0 ) then
xnew = xnew+180d0
end if
! fix at the poles (xk can have any value at the pole)
Lpole1 = abs(abs(yk(k1))-90d0).lt.dtol_pole
Lpole2 = abs(abs(yk(k2))-90d0).lt.dtol_pole
if ( Lpole1 .and. .not. Lpole2 ) then
xnew = xk(k2)
else if ( .not.Lpole1 .and. Lpole2 ) then
xnew = xk(k1)
end if
end if
call dsetnewpoint(xnew, ynew, knew)
jalink(L) = knew
if ( kc(k1).eq.0 .and. kc(k2).eq.0 ) then
kc(knew) = 0
else if ( kc(k1).ne.1 .or. kc(k2).ne.1 ) then
kc(knew) = -1
else
kc(knew) = 1
end if
end if
end do
! connect new nodes in cells
do k=1,nump
! write(6,*) k, jacell(k)
if ( jarefine(k).eq.0 ) cycle
N = netcell(k)%N
! determine if the oldest parent of this cell is crossed by the selecting polygon
Lparentcross = .false.
do kk=1,N
if ( kc(netcell(k)%nod(kk)).ne.1 ) then
Lparentcross = .true.
exit
end if
end do
! fix for global. spherical coordinates
call get_cellpolygon(k,MMAX,nn,1d0,xv,yv,LnnL,Lorg,zz)
! BEGIN DEBUG
! call tekpoly(nn,xv,yv,31)
! call toemaar()
! call tekpoly(nn,xv,yv,1)
! END DEBUG
! find the number of hanging nodes
num = 0 ! number of non-hanging nodes
numbrothers = 0 ! number of hanging nodes
nods = 0 ! all-nodes list
Lrefine = .true. ! refine cell (.true.) or not (.false.)
ishanging = 0
! kklp:do kk=1,N
do kk=1,nn
! kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+nn
! kkp1 = kk+1; if ( kkp1.gt.N ) kkp1 = kkp1-N
kkp1 = kk+1; if ( kkp1.gt.nn ) kkp1 = kkp1-nn
! L = netcell(k)%lin(kk)
! Lm1 = netcell(k)%lin(kkm1)
! Lp1 = netcell(k)%lin(kkp1)
L = Lorg(kk)
if ( L.gt.0 ) L = netcell(k)%lin(L)
Lm1 = Lorg(kkm1)
if ( Lm1.gt.0 ) Lm1 = netcell(k)%lin(Lm1)
Lp1 = Lorg(kkp1)
if ( Lp1.gt.0 ) Lp1 = netcell(k)%lin(Lp1)
if ( L.eq.0 ) then
! fictitious link at pole
cycle
end if
if ( linkbrother(L).eq.Lp1 .and. Lp1.gt.0 ) then
numbrothers = numbrothers+1
call find_common_node(L,linkbrother(L),knew)
num = num+1
nods(num) = knew
else if ( Linkbrother(L).ne.Lm1 .or. Linkbrother(L).eq.0 ) then
if ( jalink(L).eq.0 ) then
!Lrefine = .false.
else
num = num+1
nods(num) = jalink(L)
end if
end if
if ( num.gt.MMAX ) goto 1234
! check if start of this link is hanging
if ( Linkbrother(L).eq.Lm1 .and. Lm1.gt.0 ) then
ishanging(kk) = 1
end if
end do
! check if this cell needs to be refined
if ( .not.Lrefine ) cycle
! compute new center node: circumcenter without hanging nodes for quads, c/g otherwise
Np = 0
! do kk=1,N
! kk = 0
do kkk=1,nn
L = Lorg(kkk)
! if ( L.eq.0 ) then
!! next attached link is fictitious link at pole
! Lhanging = .false.
! else
! L = netcell(k)%lin(L)
! kk = kk+1
!
! if ( kk.gt.N ) then ! something wrong
! call qnerror('refine_cells: numbering error', ' ', ' ')
! end if
!
! kp = netcell(k)%nod(kk)
! Lhanging = .false.
! do i=1,num
! if ( kp.eq.nods(i) ) then
! Lhanging = .true.
! exit
! end if
! end do
! end if
! if ( .not.Lhanging ) then
if ( ishanging(kkk).eq.0 ) then
Np = Np+1
! xp(Np) = xk(kp)
! yp(Np) = yk(kp)
! LnnL(Np) = 2
xp(Np) = xv(kkk)
yp(Np) = yv(kkk)
if ( L.gt.0 ) then
LnnL(Np) = lnn(L)
else
LnnL(Np) = 1
end if
end if
end do
if ( Np.eq.4 ) then
if ( jsferic.eq.1 ) then
ymin = 1d99
ymax = -ymin
do i=1,Np
if ( yp(i).lt.ymin ) then
ymin = yp(i)
end if
if ( yp(i).gt.ymax ) then
ymax = yp(i)
end if
end do
end if
! compute circumcenter without hanging nodes
call getcircumcenter(Np, xp, yp, LnnL, xz, yz, jsferic, jasfer3D, jglobe, jins, dmiss, dxymis, dcenterinside)
if ( jsferic.eq.1 ) then
call comp_middle_latitude(ymin,ymax,ynew,ierr)
if ( ierr.eq.0 .and. ymax-ymin.gt.1d-8 ) then
yz = ymin + 2d0*(ynew-ymin)/(ymax-ymin) * (yz-ymin)
end if
end if
else
! use masscenter
xz = xzw(k)
yz = yzw(k)
end if
!call cirr(xz, yz, 211)
! split the cell
if ( Np.ge.4 ) then
if ( num.gt.2 ) then
call dsetnewpoint(xz,yz,knew)
do kk=1,num
call newlink(nods(kk), knew, Lnew)
end do
if ( .not.Lparentcross ) then
kc(knew) = 1
else
kc(knew) = -1 ! deactive nodes in cells crossed by polygon
end if
else if ( num.eq.2 ) then
call newlink(nods(1), nods(2), Lnew)
end if
else
do kk=1,num
kkp1 = kk+1; if ( kkp1.gt.num ) kkp1=kkp1-num
call newlink(nods(kk),nods(kkp1),Lnew)
end do
end if
end do
! split original links
do L=1,numL_old
if ( jalink(L).gt.0 ) then
k1 = kn(1,L)
k2 = kn(2,L)
k3 = kn(3,L)
knew = jalink(L)
kn(2,L) = knew
call newlink(knew,k2,Lnew)
kn(3,Lnew) = k3
! set the brother links
Lsize = ubound(linkbrother,1)
if ( numL.gt.ubound(linkbrother,1) ) then
Lsize = ceiling(1.2d0*dble(numL+1))
call realloc(linkbrother, Lsize, keepExisting=.true., fill=0)
end if
linkbrother(Lnew) = L
linkbrother(L) = Lnew
end if
end do
ierror = 0
! error handling
1234 continue
return
end subroutine refine_cells
!> split cells before refinement that:
!> have more nodes than allowed
!> have links with hanging nodes that need to be refined
!>
!> note: linkmask is set and the actual splitting is performed by refine_cells
!> it is assumed that findcells leaves the link numbering intact
subroutine split_cells(cellmask, linkmask, linkbrother)
! we can't use m_netw because it overwrites cellmask, redefine variable before using m_netw
!use m_netw
use m_plotdots
implicit none
integer, dimension(:), intent(inout) :: linkmask !< new nodes on links
integer, dimension(:), intent(inout) :: cellmask !< refine cell without hanging nodes (1), refine cell with hanging nodes (2), do not refine cell at all (0) or refine cell outside polygon (-2)
integer, dimension(:), intent(in) :: linkbrother !< brotherlink, that shares a (hanging) node
character(len=128) :: FNAM
integer :: jawritten
integer :: ic, L, k, kk, N
integer :: jasplit, num, numrefine, numhang, numhangnod, N_eff
integer :: ierror
integer :: iter
integer, parameter :: MAXITER = 1000
integer, parameter :: MMAX = 6
logical, dimension(MMAX) :: Lhang
integer, dimension(MMAX) :: ishangingnod
ierror = 1
iter = 0
num = 1
do while ( num.ne.0 )
iter = iter+1
if ( iter.gt.MAXITER) goto 1234
num = 0
do ic=1,nump
if ( cellmask(ic).ne.0 .and. cellmask(ic).ne.-1 ) cycle
call find_hangingnodes(ic, linkmask, linkbrother, numhang, Lhang, numhangnod, ishangingnod, numrefine)
jasplit = 0
N = netcell(ic)%N
if ( N.gt.MMAX ) goto 1234
do kk=1,N
L = netcell(ic)%lin(kk)
! check if the link has a brother link and needs to be refined
if ( Lhang(kk) .and. linkmask(L).gt.0 ) then
jasplit = 1
end if
end do
! compute the effective cell type
N = netcell(ic)%N
N_eff = N - numhang/2
if ( 2*(N-N_eff).ne.numhang ) then
call qnerror('splitcell: uneven number of brotherlinks', ' ', ' ')
call adddot(xzw(ic),yzw(ic))
end if
! prevent certain cell types
if ( N+numrefine.gt.MMAX ) jasplit=1 ! would result in unsupported cells after refinement
if ( N-numhang-numrefine.le.1 ) jasplit=1 ! cells with only one unrefined edge
if ( N_eff.eq.numrefine ) jasplit=1 ! all links refined
if ( jasplit.eq.1 ) then
if ( cellmask(ic).ne.-1 ) then
cellmask(ic) = 2
else
cellmask(ic) = -2
end if
do kk=1,N
L = netcell(ic)%lin(kk)
if ( linkmask(L).eq.0 .and. .not.Lhang(kk) ) then
linkmask(L) = 1
num = num+1
if ( iter.eq.MAXITER ) then
! call adddot(xzw(ic),yzw(ic))
call adddot(0.5d0*(xk(kn(1,L)) + xk(kn(2,L))), 0.5d0*(yk(kn(1,L)) + yk(kn(2,L))))
end if
end if
end do
end if
end do ! do ic=1,nump
write(6,*) iter, num
end do ! do while ( num.ne.0 )
ierror = 0
! error handling
1234 continue
if ( ierror.ne.0 ) then
FNAM = 'split_cells_errors.xyz'
call write_dots(trim(FNAM),jawritten)
if ( jawritten.eq.1 ) then
call qnerror('split_cells: no convergence, output written to' // trim(FNAM), ' ', ' ')
else
call qnerror('split_cells: no convergence', ' ', ' ')
end if
end if
return
end subroutine split_cells
!> find the brother links
!> hanging nodes are assumed to have two consecutive brother links
subroutine find_linkbrothers(linkbrother)
use m_netw
use m_sferic
use geometry_module, only: dbdistance
use m_missing, only: dmiss
implicit none
integer, dimension(:), intent(inout) :: linkbrother !< brother links, that share a common hanging node, dim(numL)
double precision :: xkc, ykc, dtol
double precision :: xmn, xmx ! for periodic coordinates
integer :: k, k1, k2, kk, kkp1, L, Lp1
integer :: ic1L, ic1R, ic2L, ic2R
integer :: ierr
logical :: Lpole1, Lpole2
do k=1,numk
! check if the node is a hanging node
! if ( nmk(k).ne.3 ) cycle
! check all combinations of connected links
do kk=1,nmk(k)
kkp1 = kk+1; if ( kkp1.gt.nmk(k) ) kkp1 = kkp1-nmk(k)
L = nod(k)%lin(kk)
if ( lnn(L).lt.1 ) cycle
! if ( lnn(L).ne.2 ) cycle ! inner links only
! if ( linkbrother(L).ne.0 ) cycle ! allready has a brother link
Lp1 = nod(k)%lin(kkp1)
if ( lnn(Lp1).lt.1 ) cycle
! if ( lnn(L).ne.2 ) cycle ! inner links only
! if ( linkbrother(Lp1).ne.0 ) cycle ! allready has a brother link
! both links have to share a common cell
ic1L = lne(1,L)
ic1R = lne(min(lnn(L),2),L)
ic2L = lne(1,Lp1)
ic2R = lne(min(lnn(Lp1),2),Lp1)
if ( ic1L.ne.ic2L .and. ic1L.ne.ic2R .and. ic1R.ne.ic2L .and. ic1R.ne.ic2R ) then
cycle
end if
! check if node k is in the middle
k1 = kn(1,L) + kn(2,L) - k
k2 = kn(1,Lp1) + kn(2,Lp1) - k
xkc = 0.5d0*(xk(k1)+xk(k2))
ykc = 0.5d0*(yk(k1)+yk(k2))
if ( jsferic.eq.1 ) then
call comp_middle_latitude(yk(k1),yk(k2),ykc,ierr)
end if
! check for periodic, spherical coordinates
if ( jsferic.eq.1 ) then
! check for poles
Lpole1 = .false.
Lpole2 = .false.
if ( abs(abs(yk(k1))-90d0).lt.dtol_pole) then
Lpole1 = .true.
end if
if ( abs(abs(yk(k2))-90d0).lt.dtol_pole) then
Lpole2 = .true.
end if
if ( Lpole1 .and. .not.Lpole2 ) then
xkc = xk(k2)
else if ( Lpole2 .and. .not.Lpole1 ) then
xkc = xk(k1)
else
xmn = min(xk(k1),xk(k2))
xmx = max(xk(k1),xk(k2))
if ( xmx-xmn.gt.180d0 ) then
xkc = xkc + 180d0
end if
end if
end if
! compute tolerance
dtol = 1d-4*max(dbdistance(xk(k1),yk(k1),xk(k),yk(k),jsferic, jasfer3D, dmiss), &
dbdistance(xk(k2),yk(k2),xk(k),yk(k),jsferic, jasfer3D, dmiss))
if ( dbdistance(xk(k),yk(k),xkc,ykc,jsferic, jasfer3D, dmiss).lt.dtol ) then ! brother links found
linkbrother(L) = Lp1
linkbrother(Lp1) = L
call teklink(L,210)
call teklink(Lp1,210)
! call toemaar()
! call teklink(L,1)
! call teklink(Lp1,1)
exit ! brother links found for this node, continue with next node
end if
end do
end do
return
end subroutine find_linkbrothers
! compute link refinement mask
subroutine comp_jalink(jarefine, linkbrother, jalink)
use m_netw
use m_plotdots
implicit none
integer, dimension(:), intent(inout) :: jarefine !< refine cell (>0), or not
integer, dimension(:), intent(in) :: linkbrother !< brotherlink, that shares a (hanging) node
integer, dimension(:), intent(inout) :: jalink !< in: refine link (<0) or not (0), out: refine link (1) or not (0)
integer, parameter :: MMAX=10 ! maximum number of nodes and links per netcell
integer :: numhang ! number of links with hanging node
logical, dimension(MMAX) :: Lhang ! link with hanging node (true) or not (false)
integer :: numhangnod ! number of hanging nodes
integer, dimension(MMAX) :: ishangingnod ! hanging node (1) or not (0)
integer :: numrefine ! number of links to be refined
integer, dimension(MMAX) :: numlink ! link identifier for quads
integer, dimension(4) :: jaquadlink ! refine quad edge (<>0) or not (0)
integer :: num, nump2, N_eff
integer :: k, kk, kkm1, kkp1, L, N, k1, k2
integer :: numfirst, numnext
integer :: jarepeat, ja_doall
integer :: iter
integer, parameter :: MAXITER=6
! compute the link refinement mask
jarepeat = 1
iter = 0
! numdots=0
do while ( jarepeat.eq.1 .and. iter.lt.MAXITER)
iter = iter+1
jarepeat = 0
do k=1,nump
if ( jarefine(k).ne.0 ) then
N = netcell(k)%N
call find_hangingnodes(k, jalink, linkbrother, numhang, Lhang, numhangnod, ishangingnod, numrefine)
N_eff = N-numhangnod
if ( N_eff.ne.4 ) then ! non-quads
do kk=1,N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
L = netcell(k)%lin(kk)
num = numlink(kk)
if ( linkbrother(L).eq.netcell(k)%lin(kkm1) .or. linkbrother(L).eq.netcell(k)%lin(kkp1) ) then
! link already refined with hanging node
else
jalink(L) = 1
end if
end do
else ! quads
! number the links in the cell, links that share a hanging node will have the same number
num = 1
jaquadlink = 0
do kk=1,N
L = netcell(k)%lin(kk)
numlink(kk) = num
if ( jalink(L).ne.0 ) jaquadlink(num) = jalink(L)
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
if ( kk.ne.N .and. linkbrother(L).ne.netcell(k)%lin(kkp1) ) then
num = num+1
else if ( linkbrother(L).eq.netcell(k)%lin(kkp1) ) then
jaquadlink(num) = 1 ! already refined (with hanging node)
end if
end do
! check if we found all quad edges
if ( num.ne.4 ) then
call qnerror('comp_jalink: numbering error', ' ', ' ')
goto 1234
end if
! quads may only be refined horizontally, vertically or both
numrefine = 0
numfirst = 0
numnext = 0
do num=1,4
if ( jaquadlink(num).ne.0 ) then
numrefine = numrefine+1
if ( numfirst.eq.0 ) then
numfirst=num
else if ( numnext.eq.0 ) then
numnext=num
end if
end if
end do
num = numnext - numfirst
ja_doall = 0
if ( numrefine.eq.2 .and. ( num.eq.1 .or. num.eq.3 ) ) then
jarepeat = 1
ja_doall = 1
if ( iter.eq.MAXITER ) then
! call adddot(xzw(k),yzw(k))
end if
end if
do kk=1,N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
L = netcell(k)%lin(kk)
if ( jalink(L).gt.0 ) cycle ! link already marked for refinement
if ( ja_doall.ne.1 .and. jalink(L).ne.-1 ) cycle
num = numlink(kk)
if ( num.eq.numlink(kkm1) .or. num.eq.numlink(kkp1) ) then
! link already refined with hanging node
else
jalink(L) = 1
end if
end do
end if
end if
end do
end do
if ( jarepeat.eq.1 ) then
call plotdots()
! write(6,*) "numdots=", numdots
! write(6,*) "iter=", iter
call qnerror('comp_jalink: no convergence', ' ', ' ')
end if
! only keep jalink=1, set other values to 0
do L=1,numL
if ( jalink(L).ne.1 ) jalink(L) = 0
end do
1234 continue
return
end subroutine comp_jalink
subroutine find_hangingnodes(ic, linkmask, linkbrother, numhang, Lhang, numhangnod, ishangingnod, numrefine)
use m_netw
implicit none
integer, parameter :: MMAX=6 ! maximum number of nodes and links per netcell
integer, intent(in) :: ic !< cell number
integer, dimension(:), intent(inout) :: linkmask !< new nodes on links
integer, dimension(:), intent(in) :: linkbrother !< brotherlink, that shares a (hanging) node
integer, intent(out) :: numhang !< number of links with hanging node
logical, dimension(:), intent(out) :: Lhang !< link with hanging node (true) or not (false)
integer, intent(out) :: numhangnod !< number of hanging nodes
integer, dimension(:), intent(out) :: ishangingnod !< hanging node (1) or not (0)
integer, intent(out) :: numrefine !< number of links to be refined
integer :: i, k, kk, kkm1, kkp1, kknod
integer :: L, Lm1, Lp1, N
N = netcell(ic)%N
if ( N.gt.MMAX ) goto 1234
Lhang = .false.
ishangingnod = 0
numhang = 0
numhangnod = 0
kknod = 0 ! pointer to node in cell
numrefine = 0
do kk=1,N
L = netcell(ic)%lin(kk)
if ( linkmask(L).ne.0 ) numrefine = numrefine+1
! check if the link has a brother link and needs to be refined
if ( linkbrother(L).ne.0 ) then
! check if the brother link is in the cell
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1=kkp1-N
Lm1 = netcell(ic)%lin(kkm1)
Lp1 = netcell(ic)%lin(kkp1)
! find hanging node
if ( linkbrother(L).eq.Lm1 ) then
call find_common_node(L,Lm1,k)
else if ( linkbrother(L).eq.Lp1 ) then
call find_common_node(L,Lp1,k)
else
k = 0
end if
if ( k.ne.0 ) then
! hanging node found
Lhang(kk) = .true.
numhang = numhang + 1
! find node pointer in cell
do i=1,N
kknod = kknod+1; if ( kknod.gt.N ) kknod=kknod-N
if ( netcell(ic)%nod(kknod).eq.k .and. ishangingnod(kknod).eq.0 ) then
numhangnod = numhangnod+1
ishangingnod(kknod) = 1
exit
end if
end do
end if
end if
end do
1234 continue
return
end subroutine find_hangingnodes
end subroutine refinecellsandfaces2
!> delete missing values part of network
subroutine net_delete_DMISS()
use m_netw
use m_missing
use gridoperations
implicit none
integer :: k
if ( netstat.ne.netstat_OK ) call findcells(0)
do k=1,numk
if ( zk(k).eq.DMISS ) then
call delnode(k)
end if
end do
call setnodadm(0)
netstat = NETSTAT_CELLS_DIRTY
return
end subroutine net_delete_DMISS
!> make inner links in a cell with hanging nodes
subroutine connect_hanging_nodes(linkbrother)
use m_netw
implicit none
integer, dimension(numL), intent(in) :: linkbrother !< brotherlink, that shares a (hanging) node, dim: numL
integer :: ic, kk, kkm1, kkm2, kkp1, kkp2
integer :: L, Lm1, Lp1, Lnew, N
integer :: num, num_eff
integer, parameter :: MMAX = 6 ! maximum number of link per netcell
integer, dimension(MMAX) :: knode ! counterclockwise end-node of link, excluding the hanging nodes
integer, dimension(MMAX) :: khang ! hanging nodes per unrefined link
integer :: ierror
ierror = 0
do ic=1,nump
! find the counterclockwise end-nodes, excluding the hanging nodes, and the hanging nodes
knode = 0
khang = 0
N = netcell(ic)%N
if ( N.gt.MMAX ) then
! call qnerror('connect_hanging_nodes: unsupported cell', ' ', ' ')
! goto 1234
ierror = 1
cycle
end if
num = 0
do kk=1,N
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1 = kkp1-N
L = netcell(ic)%lin(kk)
Lm1 = netcell(ic)%lin(kkm1)
Lp1 = netcell(ic)%lin(kkp1)
if ( linkbrother(L).ne.Lp1 ) then
num = num+1
if ( num.gt.MMAX ) goto 1234
! store ccw end node of this link
call find_common_node(L, Lp1, knode(num))
! check of the counterclockwise start-node of this link is a hanging node
if ( linkbrother(L).eq.Lm1 ) then
call find_common_node(L,linkbrother(L),khang(num))
end if
end if
end do ! do kk=1,N
if ( num.eq.N ) cycle ! no hanging nodes
if ( num.eq.4 ) then ! quads
if ( N-num.eq.1 ) then ! quad with one hanging node
do kk=1,num
if ( khang(kk).ne.0 ) then
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+num
kkm2 = kk-2; if ( kkm2.lt.1 ) kkm2 = kkm2+num
kkp1 = kk+1; if ( kkp1.gt.num ) kkp1 = kkp1-num
call newlink(knode(kkm2),khang(kk),Lnew)
call newlink(knode(kkp1),khang(kk),Lnew)
exit ! done with this cell
end if ! if ( khang(kk).ne.0 ) then
end do
else if ( N-num.eq.2 ) then ! quad with two hanging nodes
do kk=1,num
if ( khang(kk).ne.0 ) then
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+num
kkp1 = kk+1; if ( kkp1.gt.num ) kkp1 = kkp1-num
kkp2 = kk+2; if ( kkp2.gt.num ) kkp2 = kkp2-num
! check if the two hanging nodes are neighbors
if ( khang(kkm1).ne.0 ) then ! left neighbor
call newlink(khang(kkm1), khang(kk), Lnew)
call newlink(khang(kk), knode(kkp1), Lnew)
call newlink(knode(kkp1), khang(kkm1), Lnew)
else if ( khang(kkp1).ne.0 ) then ! right neighbor
call newlink(khang(kk), khang(kkp1), Lnew)
call newlink(khang(kkp1), knode(kkp2), Lnew)
call newlink(knode(kkp2), khang(kk), Lnew)
else if ( khang(kkp2).ne.0 ) then ! hanging nodes must be oposing
call newlink(khang(kk), khang(kkp2), Lnew)
end if
exit ! done with this cell
end if ! if ( khang(kk).ne.0 ) then
end do
else if ( N-num.eq.3 ) then ! quad with three hanging nodes
! N.eq.7 can never happen if MMAX = 6
end if
else if ( num.eq.3 ) then ! triangles
if ( N-num.eq.1 ) then ! triangle with one hanging node
do kk=1,num
if ( khang(kk).ne.0 ) then
kkp1 = kk+1; if ( kkp1.gt.num ) kkp1=kkp1-num
call newlink(khang(kk), knode(kkp1), Lnew)
exit ! done with this cell
end if ! if ( khang(kk).ne.0 ) then
end do
else if ( N-num.eq.2 ) then ! triangle with two hanging nodes
! split_cell should prevent this
do kk=1,num
if ( khang(kk).ne.0 ) then
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1=kkm1+num
kkp1 = kk+1; if ( kkp1.gt.num ) kkp1=kkp1-num
if ( khang(kkm1).ne.0 ) then
call newlink(khang(kk), khang(kkm1), Lnew)
else
call newlink(khang(kk), khang(kkp1), Lnew)
end if
! call teklink(Lnew, 22)
call qnerror('connect_hanging_nodes: triangle with two hanging nodes', ' ', ' ')
exit ! done with this cell
end if ! if ( khang(kk).ne.0 ) then
end do
end if
else
! call qnerror('connect_hanging_nodes: unsupported cell', ' ', ' ')
! goto 1234
ierror = 1
end if
end do ! do ic=1,nump
if ( ierror.eq.1 ) then
call qnerror('connect_hanging_nodes: unsupported cell(s)', ' ', ' ')
end if
! error handling
1234 continue
return
end subroutine connect_hanging_nodes
!> delete hanging nodes on net boundary
!> and update netcell admin (no need for setnodadm)
subroutine remove_isolated_hanging_nodes(linkbrother, num)
use m_netw
use unstruc_messages
implicit none
integer, dimension(numL), intent(inout) :: linkbrother !< brotherlink, that shares a (hanging) node, dim: numL
integer, intent(out) :: num !< number of removed isolated hanging nodes
integer :: ierror ! error (1) or not (0)
integer :: L, Lother, k, kother
integer :: ic, i, ii, ik, iL, kk, LL
character(len=128) :: msg
ierror = 1
num = 0 ! number of removed hanging nodes
do L=1,numL
! check if link is 2D
if ( kn(3,L).eq.2 ) then
Lother = Linkbrother(L)
if ( Lother.gt.0 ) then
! check if other link is 2D
if ( kn(3,L).eq.2 ) then
! find common node
call find_common_node(L,Lother,k)
! check if node exists and if it is connected by two links only (an isolated hanging node)
if ( k.gt.0 .and. nmk(k).eq.2 ) then
! update netcell admin
do ii=1,lnn(L)
ic = lne(ii,L)
! safety check
if ( ic.ne.lne(1,Lother) .and. ic.ne.lne(min(2,lnn(Lother)),Lother) ) then
call mess(LEVEL_ERROR,'remove_isolated_hanging_nodes: error')
goto 1234
end if
iL = 0
ik = 0
do i=1,netcell(ic)%N
LL = netcell(ic)%lin(i)
if ( LL.ne.Lother ) then
iL = iL+1
netcell(ic)%lin(iL) = LL
end if
kk = netcell(ic)%nod(i)
if ( kk.ne.k ) then
ik = ik+1
netcell(ic)%nod(ik) = kk
end if
end do
netcell(ic)%N = netcell(ic)%N-1
! safety check
if ( netcell(ic)%N.ne.iL .or. netcell(ic)%N.ne.ik ) then
call mess(LEVEL_ERROR,'remove_isolated_hanging_nodes: error')
goto 1234
end if
end do
! update lin admin
kother = kn(1,Lother) + kn(2,Lother) - k
if ( kn(1,L).eq.k ) then
kn(1,L) = kother
else
kn(2,L) = kother
end if
! change nod adm of other node
do ii=1,nmk(kother)
if ( nod(kother)%lin(ii).eq.Lother ) then
nod(kother)%lin(ii) = L
exit
end if
end do
! delete node
! call delnode(k)
nmk(k) = 0
! delete other link
kn(:,Lother) = 0
linkbrother(Lother) = 0
lnn(Lother) = 0
num = num+1
end if
end if
end if
end if
end do
if ( num.gt.0 ) then
write(msg,"('removed ', I0, ' isolated hanging nodes')") num
call mess(LEVEL_INFO,trim(msg))
end if
ierror = 0
1234 continue
return
end subroutine remove_isolated_hanging_nodes
!> output illegal cells to polygon file
subroutine write_illegal_cells_to_pol(jausekc)
use m_netw
use m_polygon
use m_missing
use gridoperations
implicit none
integer, intent(in) :: jausekc !