!----- AGPL --------------------------------------------------------------------
!
! Copyright (C) Stichting Deltares, 2015.
!
! This file is part of Delft3D (D-Flow Flexible Mesh component).
!
! Delft3D is free software: you can redistribute it and/or modify
! it under the terms of the GNU Affero General Public License as
! published by the Free Software Foundation version 3.
!
! Delft3D is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU Affero General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License
! along with Delft3D. If not, see .
!
! contact: delft3d.support@deltares.nl
! Stichting Deltares
! P.O. Box 177
! 2600 MH Delft, The Netherlands
!
! All indications and logos of, and references to, "Delft3D",
! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting
! Deltares, and remain the property of Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
! $Id: net.F90 43424 2015-12-04 17:30:45Z kernkam $
! $HeadURL: https://repos.deltares.nl/repos/ds/trunk/additional/unstruc/src/net.F90 $
#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_SAMPLES2
use m_commandline_option
use dfm_signals
use m_crosssections, only: increaseCrossSections, maxcrs
implicit none
double precision :: ag
double precision :: cdflow
double precision :: cfl
double precision :: cfric
double precision :: deltx
double precision :: delty
double precision :: deltz
double precision :: dscr
double precision :: dx
double precision :: e0
double precision :: eps
double precision :: epsgs
double precision :: fbouy
double precision :: fdyn
double precision :: gx
double precision :: gy
double precision :: 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(40)
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
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()
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
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) , RNOD(1) )
allocate(nod(1)%lin(1))
endif
if (.not. allocated(xk0)) then
allocate( xk0(1), yk0(1), zk0(1) , NOD0(1) , KC0(1) , NMK0(1), KN0(1,1), LC0(1) )
allocate(nod0(1)%lin(1))
nmk0 = 0
endif
KMAX = 2
LMAX = 2
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)
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 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_crosssections
use m_flow
use m_flowgeom
use m_ship
use unstruc_model
implicit none
integer :: n, i
double precision :: tim
return ! His file broken
if (mxls == 0) then
call newfil(mxls, trim(md_ident)//'_his.tek')
write(mxls,'(2a,i0)') 'tim, ( s1(kobs(n)), n= 1,numobs ) , ( ucx(kobs(n)), n= 1,numobs ), ( ucy(kobs(n)), n= 1,numobs ) )' , 'numobs= ', numobs
endif
! write(mxls,'(130G14.6)') tim, ( hs(kobs(n)), n= 1,numobs ) , ( ucx(kobs(n)), n= 1,numobs ), ( ucy(kobs(n)), n= 1,numobs )
! write(mxls,'(130G14.6)') tim, ( hs(kobs(n)), n= 1,numobs )
! if (ncrs.gt.0) then
! write(mxls,'(13f14.4)') tim/ 60, ( crs(i)%sumvalcur(4), i=1,min(6,ncrs)) , ( crs(i)%sumvalcur(1) , i = 1,ncrs)
! endif
return
if (nshiptxy ==0 ) then
write(mxls, '(100e18.5)' ) tim, ( s1(kobs(n)), n= 1,numobs ) , ( ucx(kobs(n)), n= 1,numobs )
else
write(mxls, '(100e18.5)' ) tim, ( -1d-3*(fx2(n)+fricx(n)), -1d-3*fricx(n) , n= 1, nshiptxy )
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 unstruc_files, only: getoutputdir
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()
use m_netw
USE M_MAKENET ! NTYP ANGLE SIZE THICK NRX NRY
USE M_POLYGON
USE M_GRID
USE M_MISSING
use m_sferic
implicit none
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 :: xpmax
double precision :: xpmin
double precision :: xx
double precision :: ypmax
double precision :: ypmin
double precision :: yy
double precision :: X(8), Y(8), Z(8), XD, YD
! COMMON /CONSTANTS/ E0, RHO, RHOW, CFL, EPS, AG, PI
CALL MAKENETPARAMETERS()
IF (NPL > 0) THEN
CALL DMINMAX( XPL , NPL , XPMIN, XPMAX, NPL)
CALL DMINMAX( YPL , NPL , YPMIN, YPMAX, NPL)
X0 = XPMIN ; Y0 = YPMIN
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 = (XPMAX-XPMIN)/DX
NRY = (YPMAX-YPMIN)/DY
ELSE IF (DX == 0) THEN
DX = (XPMAX-XPMIN)/NRX
DY = (YPMAX-YPMIN)/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 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)
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
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
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.
double precision :: dbdistance
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)) ) )
! 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) ) < 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
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, external :: dcosphi, dbdistance
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)
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)*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
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.)
double precision, external :: getdx, getdy
! find the start and end index in the polygon array
call get_polstartend(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)
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)
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_samples2
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
implicit none
integer :: k1,k2,k
double precision :: dbdistance
k2 = 0
do k = 1,ns
if (k .ne. k1) then
if (dbdistance(xs(k), ys(k), xs(k1), ys(k1) ) < 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
implicit none
integer :: k1,k2,k,kk,n1,n2
double precision :: dbdistance
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) )< 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_startend(MMAX-MP+1, X(MP:MMAX), Y(MP:MMAX), jstart, jend )
! get_startend will always take the first subarray of length>1
if ( MP+1.le.MMAX ) then ! one-point subarray
if ( X(MP+1).eq.DMISS ) then
jstart = 1
jend = 1
end if
end if
jstart = jstart+MP-1
jend = jend+MP-1
x(jend+1:MMAX) = DMISS
! call get_startend(MP, X(MP:1:-1), Y(MP:1:-1), jstart, jend )
call get_startend(1, X(1:MP:1), Y(1:MP:1), jend, jstart )
jstart = MP-jstart+1
jend = MP-jend+1
! get_startend will always take the first subarray of length>1
if ( MP-1.ge.1 ) then ! one-point subarray
if ( X(MP-1).eq.DMISS ) then
jstart = 1
jend = 1
end if
end if
jstart = MP-jend+1
jend = MP-jstart+1
x(1:jstart-1) = DMISS
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
!> get the start and end index of the first enclosed non-DMISS subarray
subroutine get_startend(num, x, y, jstart, jend)
use m_missing
implicit none
integer, intent(in) :: num !< array size
double precision, dimension(num), intent(in) :: x, y !< array coordinates
integer, intent(out) :: jstart, jend !< subarray indices
! find jstart and jend
jend = 1
jstart = jend
if ( jend.ge.num ) return
if ( x(jstart+1).eq.DMISS ) jstart = jstart+1
if ( jstart.ge.num ) return
do while( x(jstart).eq.DMISS )
jstart = jstart+1
if ( jstart.eq.num ) exit
end do
if ( x(jstart).eq.DMISS ) return
jend = jstart
if ( jend.lt.num ) then
do while( x(jend+1).ne.DMISS )
jend = jend+1
if ( jend.eq.num ) exit
end do
end if
return
end subroutine
!> indentify the points in an array
subroutine makelineindex(num, x, idx)
use m_missing
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)
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
implicit none
integer :: K1, K2
double precision :: XD,YD,ZD, DBDISTANCE
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) )
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
implicit none
integer, intent(in) :: L !< link number
double precision :: dx, dy
integer :: La, k1, k2
double precision, external :: dbdistance
La = iabs(L)
k1 = kn(1,La)
k2 = kn(2,La)
dLinklength = dbdistance(xk(k1), yk(k1), xk(k2), yk(k2))
end function dLinklength
subroutine triangulate_quadsandmore(ja) ! ja==1, findcells moet opnieuw
use m_netw
use m_flowgeom
use m_polygon
implicit none
integer ja
integer in, k, k1, k2, k3, k4, k5, lnu
double precision, external :: dbdistance
call findcells(0)
in = -1
do k = 1,nump
if (netcell(k)%n >= 4) then
call dbpinpol(xz(k), yz(k), in)
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) ) < dbdistance( xk(k2), yk(k2), xk(k4), yk(k4) ) ) 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
implicit none
integer :: MNET
character(len=*) :: filnam
double precision :: xz2, yz2, dl, xn, yn, sl, sm, crp, xcr, ycr
double precision , external :: dbdistance
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))
call normaloutchk(xk(k3), yk(k3), xk(k4), yk(k4), xzw(n), yzw(n), xn, yn, ja)
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)
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
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
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 save()
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
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
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 RESTORE()
use m_netw
implicit none
integer :: k, ls, ls0, NODSIZ, IERR
IF ( NUMK0.EQ.0 ) RETURN
XK (1:NUMK0) = XK0 (1:NUMK0)
YK (1:NUMK0) = YK0 (1:NUMK0)
ZK (1:NUMK0) = ZK0 (1:NUMK0)
NMK(1:NUMK0) = NMK0(1:NUMK0)
KC (1:NUMK0) = KC0 (1:NUMK0)
KN(:,1:NUML0) = KN0(:,1:NUML0)
LC( 1:NUML0) = LC0( 1:NUML0)
NODSIZ = SIZE(NOD)
DO K = 1,NUMK0
LS0 = NMK0(K)
IF (LS0 .GE. 1) THEN
! IF (.NOT. ASSOCIATED(NOD(K)%LIN) ) THEN
IF (ALLOCATED(NOD(K)%LIN) ) THEN
LS = SIZE(NOD(K)%LIN )
ELSE
LS = 0
ENDIF
IF (LS .LT. LS0) THEN
IF (LS .GE. 1) DEALLOCATE (NOD(K)%LIN )
ALLOCATE (NOD(K)%LIN(LS0), STAT = IERR )
NOD(K)%LIN = 0
ENDIF
NOD(K)%LIN(1:LS0) = NOD0(K)%LIN(1:LS0)
ENDIF
ENDDO
NUMK = NUMK0
NUML = NUML0
! need findcells
netstat = NETSTAT_CELLS_DIRTY
RETURN
END SUBROUTINE RESTORE
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 SAVE()
use m_netw
implicit none
integer :: ierr
integer :: k, KX, LS, LS0, LX, NN
if (numk == 0) return
KX = NUMK
IF (ALLOCATED(nod0)) THEN
DO K= 1, SIZE(NOD0)
if ( allocated(nod0(k)%lin) ) DEALLOCATE(NOD0(K)%LIN)
ENDDO
DEALLOCATE(NOD0)
ALLOCATE ( NOD0(KX) , stat = ierr )
!CALL AERR('NOD0(KX)', IERR, KX)
ENDIF
if (allocated(xk0)) deallocate(xk0,yk0,zk0)
allocate ( XK0(KX), YK0(KX), ZK0(KX) , STAT=IERR)
!call aerr('XK0(KX), YK0(KX), ZK0(KX)', IERR, 3*kx)
if (allocated (KC0) ) deallocate ( KC0, NMK0 )
ALLOCATE( KC0(KX), NMK0(KX), STAT=IERR)
XK0 (1:NUMK) = XK (1:NUMK)
YK0 (1:NUMK) = YK (1:NUMK)
ZK0 (1:NUMK) = ZK (1:NUMK)
KC0( 1:NUMK) = KC (1:NUMK)
NMK0(1:NUMK) = NMK(1:NUMK)
IF (ALLOCATED(LC0)) DEALLOCATE(KN0 ,LC0)
LX = NUML
ALLOCATE (KN0(3,LX), LC0(LX), STAT=IERR)
KN0(:,1:NUML) = KN(:,1:NUML)
LC0( 1:NUML) = LC( 1:NUML)
DO K = 1,NUMK
LS = NMK(K) ! SIZE(NOD (K)%LIN )
IF (LS .GE. 1) THEN
! IF (.NOT. ASSOCIATED(NOD0(K)%LIN) ) THEN
IF (.NOT. ALLOCATED(NOD0(K)%LIN) ) THEN
LS0 = 0
ELSE
LS0 = SIZE(NOD0(K)%LIN )
ENDIF
IF (LS0 .LT. LS) THEN
IF (LS0 .GE. 1 .and. allocated(NOD0(K)%LIN)) DEALLOCATE (NOD0(K)%LIN )
ALLOCATE (NOD0(K)%LIN(LS) ) ; NOD0(K)%LIN = 0
ENDIF
NOD0(K)%LIN(1:LS) = NOD(K)%LIN(1:LS)
ENDIF
ENDDO
NUMK0 = NUMK
NUML0 = NUML
RETURN
END SUBROUTINE SAVE
SUBROUTINE INCREASENETW(K0,L0) ! TODO AFMAKEN
USE M_MISSING
use m_netw
use m_alloc
implicit none
integer :: ierr
integer :: k
integer :: knxx
INTEGER :: K0, L0
if (K0 < KMAX .and. L0 < LMAX) RETURN
CALL SAVE()
IF (KMAX <= K0) THEN
KMAX = K0 + 100000 ! 2 KAN WEG
IF (allocated(nod)) then
do k = 1,size(nod)
deallocate (nod(k)%lin)
enddo
deallocate(nod, xk, yk, zk, kc, nmk, rnod)
end if
ALLOCATE ( NOD(KMAX) , STAT = IERR)
CALL AERR('NOD(KMAX)', IERR, KMAX )
ALLOCATE ( XK (KMAX), YK (KMAX), ZK (KMAX), KC (KMAX), NMK (KMAX), RNOD(KMAX) , STAT=IERR )
CALL AERR('XK (KMAX), YK (KMAX), ZK (KMAX), KC (KMAX), NMK (KMAX), RNOD(KMAX)', IERR, 7*KMAX)
DO K = 1,KMAX
IF (K .LE. SIZE(NMK0) ) THEN
KNXX = MAX(NMK0(K),KNX)
ELSE
KNXX = KNX
ENDIF
ALLOCATE(NOD(K)%LIN(KNXX) , STAT=IERR) ;
NOD(K)%LIN = 0
ENDDO
NMK = 0 ; KC = 1 ; XK = XYMIS ; YK = XYMIS ; ZK = zkUNI
ENDIF
IF (LMAX <= L0) THEN
LMAX = L0 + 3*100000
IF (SIZE(LC) > 0 .and. allocated(kn)) THEN
DEALLOCATE(KN ,LC , RLIN)
ENDIF
ALLOCATE (KN (3,LMAX), LC (LMAX), STAT=IERR) ; KN = 0 ; LC = 0 ! TODO: AvD: catch memory error
ALLOCATE (RLIN (LMAX), STAT=IERR)
ENDIF
CALL RESTORE()
END SUBROUTINE INCREASENETW
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
!> Increases the global netcell array to a new size.
!! Will not shrink the array. Specify a growfac > 1.0 to grow in bigger chunks.
!!
!! Example:
!! do
!! call increasenetcells(NUMP+1, 1.2, .true.)
subroutine increasenetcells(numpx, growfac, keepExisting)
use network_data
use m_alloc
implicit none
integer, intent(in) :: numpx !< New maximum size for netcell array.
real, intent(in) :: growfac !< When growing, resize by additional factor growfac*numpx (e.g. 1.2)
logical, intent(in) :: keepExisting !< Restore existing data after reallocate, otherwise leave undefined.
integer :: p, ierr, n0
integer :: numpx0 !< Current size of netcell
integer :: numpx1 !< Actual size of to-be-increased netcell
type(tface), allocatable :: netcell0(:)
if (allocated(netcell)) then
numpx0 = size(netcell)
else
numpx0 = 0
end if
if (numpx0 >= numpx) return ! Array is still large enough
numpx1 = max(numpx, ceiling(numpx*growfac)) ! Grow a bigger chunk at once
! 1: SAVE
if (nump > 0 .and. keepExisting) then ! NOTE: Only create backup if nump > 0 (not numpx0 > 0)
allocate(netcell0(nump), stat = ierr)
CALL AERR('netcell0(nump)', ierr, nump)
do p=1,nump
n0 = netcell(p)%n
if (n0 <= 0) then
cycle
end if
allocate(netcell0(p)%nod(n0), netcell0(p)%lin(n0), stat = ierr)
!CALL AERR('netcell0(p)%nod(n0), netcell0(p)%lin(n0)', ierr, 2*n0)
netcell0(p)%n = netcell(p)%n
netcell0(p)%nod = netcell(p)%nod
netcell0(p)%lin = netcell(p)%lin
deallocate(netcell(p)%nod, netcell(p)%lin)
end do
end if
if (allocated(netcell)) then
deallocate(netcell)
CALL AERR('netcell', 0, -numpx0)
end if
allocate(netcell(numpx1), stat = ierr)
CALL AERR('netcell(numpx1)', ierr, numpx1)
! 2: RESTORE
if (nump > 0 .and. keepExisting) then ! NOTE: Only restore backup if nump > 0 (not numpx0 > 0)
do p=1,nump
n0 = netcell0(p)%n
if (n0 <= 0) then
cycle
end if
allocate(netcell(p)%nod(n0), netcell(p)%lin(n0), stat = ierr)
!CALL AERR('netcell(p)%nod(n0), netcell(p)%lin(n0)', ierr, 2*n0)
netcell(p)%n = netcell0(p)%n
netcell(p)%nod = netcell0(p)%nod
netcell(p)%lin = netcell0(p)%lin
deallocate(netcell0(p)%nod, netcell0(p)%lin)
end do
deallocate(netcell0)
CALL AERR('netcell0', 0, -nump)
end if
end subroutine increasenetcells
DOUBLE PRECISION FUNCTION GETRCIR()
use m_wearelt
implicit none
GETRCIR = RCIR
END FUNCTION GETRCIR
SUBROUTINE MAKEPANELXY(JPANEL)
use m_netw
USE M_AFMETING
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 SAVE()
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)
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
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
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 SETNEWPOINT(XP,YP,ZP,K1)
use m_netw
use m_missing
implicit none
integer :: jav
integer :: jview
double precision :: xyz
double precision :: XP, YP, ZP
integer :: K1
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
CALL GIVENEWNODENUM(K1)
CALL TWEEDRIE(XP,YP,XK(K1),YK(K1),ZK(K1))
IF (JVIEW .EQ. 1) THEN
ZK(K1) = dmiss ! AvD: Was changed from XYZ to dmiss. TODO: What about other views. Used at all?
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 SETNEWPOINT
SUBROUTINE SETPOINT(XP,YP,ZP,K1)
use m_netw
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
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
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)
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)
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 ISND(XP, YP, NN) ! IS THIS A flow NODE ?
use m_netw
use m_flowgeom
use m_wearelt
implicit none
double precision :: XP, YP
integer :: NN
integer n, l, k1, k2
double precision :: xa, ya
NN = 0
DO n = 1,ndx
IF (ABS(Xz(n)-XP) .LT. RCIR .AND. ABS(Yz(n)-YP) .LT. RCIR) THEN
NN = n
CALL DISND(NN)
RETURN
ENDIF
ENDDO
END SUBROUTINE ISND
SUBROUTINE ISLN(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. RCIR .AND. ABS(YA-YP) .LT. RCIR) THEN
LL = L
CALL DISLN(LL)
RETURN
ENDIF
ENDDO
RETURN
END SUBROUTINE ISLN
SUBROUTINE MERGENODESINPOLYGON()
use m_netw
use m_kdtree2
use unstruc_messages
use m_sferic
implicit none
INTEGER :: K, KK, KM, K1, K2, KK1, KK2, KA, KB, L, LL, JA, JACROS
INTEGER :: IBR, KP, N, JADUM
DOUBLE PRECISION :: DIST, DISMIN, DBDISTANCE
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 :: 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
CALL SAVE()
call setnodadm(0)
KC = 0
in = -1
DO K = 1,NUMK
CALL DBPINPOL( XK(K), YK(K), in )
if ( in.gt.0 ) kc(k) = 1
ENDDO
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
numk_inpoly = 0
do k=1,numk
if ( kc(k).eq.1 ) then
numk_inpoly=numk_inpoly+1
xx(numk_inpoly) = xk(k)
yy(numk_inpoly) = yk(k)
iperm(numk_inpoly) = k
end if
end do
! compute squared search radius
R2search = tooclose**2
! initialize kdtree
call build_kdtree(treeglob,numk_inpoly,xx,yy, ierror)
! 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
nummerged = 0
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))
! 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
call mergenodes(kother,k,ja)
if ( ja.eq.1 ) then
iperm(kkother) = 0
nummerged = nummerged+1
endif
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) ) < TOOCLOSE ) THEN
CALL MERGENODES(K,KK,JA)
IF (JA .EQ. 1) THEN
KC(K) = -1
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) ) < 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) THEN
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
JADUM = 0
CYCLE ! SKIP OWN BRANCH
ENDIF
IF (dbdistance( XK(K), yk(k), XK(Ka), yk(ka) ) < CONNECT1DEND ) THEN
DIST = DBDISTANCE( XK(KA),YK(KA),XK(K),YK(K) )
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) = 1
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)
USE M_NETW
IMPLICIT NONE
INTEGER :: K1,K2,K,IBR,NRL,JASTOP,LX
INTEGER :: KK,L
JASTOP = 0
DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LC(L) == 0) THEN
LC(L) = IBR ; NRL = NRL + 1
CALL OTHERNODE(K1,L,K2)
CALL NOGTEDOEN(K1,KC(K1))
CALL NOGTEDOEN(K2,KC(K2))
LIB(NRL) = L ; K1BR(NRL) = K1 ; IBN(NRL) = IBR; NRLB(L) = NRL
IF (NMK0(K2) .NE. 2) THEN
JASTOP = 1
RETURN
ENDIF
K1 = K2
CALL WALK1D(K1,IBR,NRL,JASTOP)
IF (JASTOP == 1) THEN
RETURN
ENDIF
ENDIF
ENDDO
END SUBROUTINE WALK1D
SUBROUTINE NOGTEDOEN(K,JA) !SET JA = -1 ALS NOG TE DOEN
USE M_NETW
IMPLICIT NONE
INTEGER :: K,JA,KK,L
JA = 0
DO KK = 1,NMK0(K)
L = NOD(K)%LIN(KK)
IF (LC(L) == 0) THEN
JA = -1 ; RETURN
ENDIF
ENDDO
END SUBROUTINE NOGTEDOEN
SUBROUTINE SETBRANCH_LC(nrl1d)
USE M_NETW
IMPLICIT NONE
INTEGER :: NRL1D, NRL, NRLO, L, JONCE, K, K1, k2, IBR, N, JASTOP, IERR, IBX, KS, KK, KE, ja
call setnodadm(0)
IF (ALLOCATED(NMK0) ) DEALLOCATE(NMK0) ; ALLOCATE(NMK0(NUMK)) ; NMK0 = 0
DO L = 1,NUML
IF (KN(3,L) == 1) THEN
K1 = KN(1,L) ; K2 = KN(2,L)
NMK0(K1) = NMK0(K1) + 1
NMK0(K2) = NMK0(K2) + 1
ENDIF
ENDDO
LC = 0 ! BRANCH NRS VAN ALLE LINKS
KC = -1
NRL1D = 0
DO L = 1,NUML
k1 = kn(1,L) ; k2 = kn(2,L)
IF (KN(3,L) == 2) THEN ! set KC(1D NODES) = 1 , KC(2D NODES) = 2
KC(k1) = 2
KC(K2) = 2
ELSE IF (KN(3,L) == 3) THEN ! set KC(1D NODES) = 1 , KC(2D NODES) = 2
if (nmk(k1) == 1) then
KC(K1) = 2
endif
if (nmk(k2) == 1) then
KC(K2) = 2
endif
LC(L) = -1
ELSE IF (KN(3,L) == 0) THEN
cycle
ELSE
NRL1D = NRL1D + 1 ! count 1D links
ENDIF
ENDDO
if (NRL1D == 0) then
netstat = NETSTAT_OK ; return
endif
IBR = 0; NRL = 0 ; JONCE = 0
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
DO WHILE (NRL < NRL1D )
NRLO = NRL
DO K = 1,NUMK
K1 = K
IF ( JONCE == 0 .AND. KC(K1) == -1 .AND. NMK0(K1) .NE. 2 .OR. &
JONCE == 1 .AND. KC(K1) == -1 .AND. NMK0(K1) == 2 ) THEN ! FIRST SWEEP
IBR = IBR + 1
CALL WALK1D(K1,IBR,NRL,JASTOP)
ENDIF
ENDDO
IF (NRL == NRLO) THEN
JONCE = JONCE + 1
ENDIF
ENDDO
IBX = MAXVAL(IBN) ! MUST BE IBR
MXNETBR = IBX
if (ibr .ne. IBX) THEN
MXNETBR = MAX(IBR,IBX)
ENDIF
IF ( ALLOCATED(NETBR) ) DEALLOCATE(NETBR)
ALLOCATE ( NETBR(IBX) ,STAT=IERR)
CALL AERR('NETBR(IBX)',IERR,NUML)
IBR = 1; KS = 1
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)
use m_netw
USE M_FLOWGEOM
use m_kdtree2
use m_missing, only : DMISS
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, KL
INTEGER , ALLOCATABLE :: KNP(:)
INTEGER :: KK(4)
DOUBLE PRECISION :: XM, YM, XXC(8), YYC(8), DAREA, DLENGTH, DLENMX
DOUBLE PRECISION :: DBDISTANCE
double precision :: cx, cy, R2search, Area, cof0
integer :: i, num, k_start, k_end, numsam, ierror
integer :: jakdtree = 1
CALL READYY('CUTCELWU',0d0)
IN = -1
if( jakdtree == 1 ) then
!
! gravity point of polygon
!
Area = 0d0
cx = 0d0
cy = 0d0
num = 0
do i = 1,npl-1
if( xpl(i+1) == DMISS ) cycle
cof0 = xpl(i) * ypl(i+1) - xpl(i+1) * ypl(i)
Area = Area + cof0
cx = cx + ( xpl(i) + xpl(i+1) ) * cof0
cy = cy + ( ypl(i) + ypl(i+1) ) * cof0
num = num + 1
enddo
area = area * 0.5d0
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)**2 )
enddo
call make_queryvector_kdtree( treeglob,cx, cy )
numsam = kdtree2_r_count( treeglob%tree, treeglob%qv, R2search )
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)
end if
KC = 0
do k = k_start,k_end ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
k1 = treeglob%results(k)%idx
CALL DBPINPOL( xk(k1), yk(k1), IN)
KC(K1) = IN
enddo
!!!
else
DO K = 1,NUMK ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
CALL DBPINPOL( XK(K), YK(K), IN)
KC(K) = IN
ENDDO
endif
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,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 .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) )
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) )
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
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
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
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
DEALLOCATE(KNP)
CALL READYY('CUTCELWU', -1d0)
END SUBROUTINE CUTCELwu
SUBROUTINE CUTCELWUx(n12)
use m_netw
USE M_FLOWGEOM
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
DOUBLE PRECISION :: DBDISTANCE
CALL READYY('CUTCELWU',0d0)
IN = -1
DO K = 1,NUMK ! LOKAAL BINNEN BUITEN POLYGON, IN REKENGEBIED = 0
CALL DBPINPOL( XK(K), YK(K), IN)
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,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) )
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) )
!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
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,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
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) ) ! 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,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,XM,YM,JA)
use m_netw
implicit none
integer :: L, JA
DOUBLE PRECISION :: XM, YM
integer :: jacros
integer :: k
integer :: k1
integer :: k2
integer :: ku
DOUBLE PRECISION :: XP1, YP1, XP2, YP2, SL, SM, XCR, YCR, CRP
double precision, external :: dbdistance
double precision, parameter :: dtol = 1d-8
K1 = KN(1,L); K2 = KN(2,L)
! initialization
xm = 0d0
ym = 0d0
JA = 0
DO K= 1,NPL
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)
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
if ( ja.eq.0 .or. dbdistance(xcr,ycr,xm,ym).gt.dtol ) then
JA = JA+1
XM = XCR
YM = YCR
end if
end if
ENDDO
END SUBROUTINE CROSSLINKPOLY
SUBROUTINE CROSSED2d_BNDCELL(NML, XP1, YP1, XP2, YP2 , NC1)
use m_netw
implicit none
INTEGER :: NML, NC1
DOUBLE PRECISION :: XP1, YP1, XP2, YP2
INTEGER :: L, JACROS, K1, K2
DOUBLE PRECISION :: SL, SM, XCR, YCR, CRP, slm
NC1 = 0
slm = 1d9
DO L = 1,NML
K1 = KN(1,L) ; K2 = KN(2,L)
if ( k1.lt.1 .or. k2.lt.1 ) cycle ! SPvdP: safety
IF (LNN(L) == 1) THEN ! LINK MET 1 BUURCEL
IF (KN(3,L) == 2) THEN
CALL CROSSinbox (XP1, YP1, XP2, YP2, XK(K1), YK(K1), XK(K2), YK(K2), jacros, SL, SM, XCR, YCR, CRP)
if (jacros == 1) then
if (sl < slm) then
NC1 = LNE(1,L)
slm = sl
endif
end if
ENDIF
ENDIF
ENDDO
END SUBROUTINE CROSSED2d_BNDCELL
SUBROUTINE CROSSPOLY(xa,ya,xb,yb,xpl,ypl,npl,XM,YM,CRPM,JA,isec)
use m_missing
implicit none
integer :: npl, ja
integer, intent(out) :: isec !< crossed polyline section (>0) or not crossed (0)
DOUBLE PRECISION :: xa, xb, ya, yb, xm, ym, crpm
DOUBLE PRECISION :: xpl(npl), ypl(npl)
integer :: jacros
integer :: k
integer :: k1
integer :: k2
integer :: ku
DOUBLE PRECISION :: XP1, YP1, XP2, YP2, SL, SM, XCR, YCR, CRP
isec = 0
JA = 0
DO K = 1,NPL - 1
KU = K + 1
XP1 = XPL(K ) ; YP1 = YPL(K )
XP2 = XPL(KU) ; YP2 = YPL(KU)
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)
if (jacros == 1) then
JA = JA+1
XM = XCR
YM = YCR
crpm = crp
isec = k
return ! SPvdP: added
end if
ENDDO
END SUBROUTINE CROSSPOLY
SUBROUTINE REFINELINES()
use m_netw
USE M_GRIDSETTINGS
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)
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
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_INTERPOLATIONSETTINGS
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 SAVE()
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); AR = DMISS
CALL AERR('AR(NUMP)', IERR, NUMP )
DO N = 1,NUMP
CALL getcellsurface ( N, AR(N), XC(N), YC(N) )
ENDDO
ALLOCATE( ZC(NUMP) , STAT = IERR); ZC = DMISS
CALL AERR('ZC(NUMP)', IERR, NUMP )
! First interpolate bottom level in netcell-based zc, then use zc as cellmask
IF (JACOURANTNETWORK == 1) THEN
ALLOCATE ( NA(NUMP) , STAT = IERR); NA = 0
CALL AERR('NA(NUMP)', IERR, NUMP )
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)
else
CALL triinterp2(XC,YC,ZC,NUMP,JDLA)
end if
else if (interpolationtype == INTP_AVG) then
n6 = 6
ALLOCATE( XX(N6,NUMP), YY(N6,NUMP), NNN(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)
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
!> interpolate/average sample vector data in a polygon (e.g. a netcell)
!> note: M_samples is not used
!> XS and YS are the sample coordinates, dim(NS)
!> ZSS contains a NDIM-dimensional vector for each of the NS samples, dim(NDIM,NS)
SUBROUTINE AVERAGING2(NDIM,NS,XS,YS,ZSS,IPSAM,XC,YC,ZC,NX,XX,YY,N6,NNN,jakdtree_) ! WERKT ALLEEN VOOR CELL REGIONS, DIE ZITTEN IN XX EN YY
use M_NETW
USE M_INTERPOLATIONSETTINGS
USE M_MISSING
use m_polygon
use m_kdtree2
use m_sferic, only : jsferic
use unstruc_messages
IMPLICIT NONE
INTEGER, INTENT(IN) :: NDIM ! sample vector dimension
INTEGER, INTENT(IN) :: NS ! number of samples
DOUBLE PRECISION, DIMENSION(NS), INTENT(IN) :: XS, YS ! sample coordinates
DOUBLE PRECISION, DIMENSION(NDIM,NS), INTENT(IN) :: ZSS ! sample values
INTEGER, DIMENSION(NS), INTENT(IN) :: IPSAM ! sample permutation array (increasing x-coordinate)
INTEGER, INTENT(IN) :: NX, N6 ! number of polygons and maximum polygon size
DOUBLE PRECISION, INTENT(IN) :: XC(NX), YC(NX) ! polygon center coordinates
DOUBLE PRECISION, INTENT(INOUT) :: ZC(NDIM,NX) ! ZC not initialized here
DOUBLE PRECISION, INTENT(IN) :: XX(N6,NX), YY(N6,NX) ! polygon coordinates
INTEGER, INTENT(IN) :: NNN(NX) ! polygon sizes
integer, intent(in) :: jakdtree_ ! use kdtree (1) or not (0)
DOUBLE PRECISION, ALLOCATABLE :: XH(:), YH(:)
DOUBLE PRECISION, DIMENSION(NDIM) :: HP, RHP
DOUBLE PRECISION :: XLOW, XHIH, YLOW, YHIH, AF, RMIN2, WALL, DIS2, WEIGHT, XP, YP, XDUM
INTEGER :: N,K,NN,MODIN, NLOWX, NHIHX, NUMXY, IFIRS, ILAST, INHUL
INTEGER :: IVAR
INTEGER :: K_, k_start, k_end
integer :: japrogressbar, jadoen, in, numsam
character(len=128) :: txt
double precision :: R2search, t0, t1, t2
integer :: ierror
integer :: jakdtree = 0 ! use kdtree (1) or not (0)
integer, parameter :: jatimer = 0 ! output timings (1) or not (0)
double precision, external :: dbdistance
INTEGER :: NCOLNOW
COMMON /COLNOW/ NCOLNOW
! default/no samples in cell
! ZC = DMISS
! hk : do not switch off please
jakdtree = jakdtree_
japrogressbar = 1
if ( jtekinterpolationprocess.eq.1 .or. Nx.lt.100 ) then
japrogressbar = 0
end if
ALLOCATE (XH(N6), YH(N6) )
IF ( japrogressbar.eq.1 ) THEN
CALL READYY('GRIDCELL AVERAGING', AF)
ENDIF
if ( jatimer.eq.1 ) then
call klok(t0)
t1 = t0
end if
MODIN = MAX(1.0,REAL(NX)/100.0)
in = -1
DO N = 1,NX
JADOEN = 0
do ivar=1,NDIM
if ( ZC(ivar,N) == DMISS ) THEN
JADOEN = 1
endIF
enddo
if (jadoen == 0 .or. NNN(N) == 0) cycle ! Skip undefined cells (0 corners)
if (npl > 0) then
CALL DBPINPOL( XC(N), YC(N), in )
if (in == 0) then
cycle
endif
endif
IF ( japrogressbar.eq.1 )THEN
IF (MOD(MODIN,N) .EQ. 0) THEN
AF = DBLE(N) / DBLE(NX)
CALL READYY('GRIDCELL AVERAGING', AF)
ENDIF
ENDIF
NN = NNN(N)
DO K = 1,NN
XH(K) = XX(K,N)
YH(K) = YY(K,N)
ENDDO
DO K = 1,NN
XH(K) = RCEL*XH(K) + (1D0-RCEL)*XC(N)
YH(K) = RCEL*YH(K) + (1D0-RCEL)*YC(N)
ENDDO
XLOW = MINVAL(XH(1:NN)) ; XHIH = MAXVAL(XH(1:NN))
YLOW = MINVAL(YH(1:NN)) ; YHIH = MAXVAL(YH(1:NN))
! check for periodic coordinates
! it is assumed that the user has provided sufficient sample overlap
if ( jsferic.eq.1 ) then
if ( xhih-xlow.gt.180d0) then
xdum = 0.5d0*(xlow+xhih)
do k=1,NN
if ( xh(k).lt.xdum ) then
xh(k) = xh(k) + 360d0
end if
end do
XLOW = MINVAL(XH(1:NN)) ; XHIH = MAXVAL(XH(1:NN))
end if
end if
if ( jakdtree.eq.0 ) then
CALL LOCATE(XS,NS,IPSAM,XLOW,NLOWX); IF (NLOWX == 0) NLOWX = 1
CALL LOCATE(XS,NS,IPSAM,XHIH,NHIHX)
k_start = NLOWX
k_end = min(NHIHX+1,NS)
else ! kdtree
! compute cell-bounding circle radius
R2search = 0d0
do k=1,NN
R2search = max(R2search,dbdistance(xc(N),yc(N),xh(k),yh(k))**2)
end do
! find all samples in the cell-bounding circle
call make_queryvector_kdtree(treeglob,xc(N),yc(N))
! count number of points in search area
numsam = kdtree2_r_count(treeglob%tree,treeglob%qv,R2search)
! set number of points to be queried
k_start = 1
k_end = numsam
if ( numsam.gt.0 ) then
! resize results array if necessary
call realloc_results_kdtree(treeglob,numsam)
! find samples
call kdtree2_n_nearest(treeglob%tree,treeglob%qv,numsam,treeglob%results)
end if
end if
HP = 0
NUMXY = 0
RMIN2 = dbdistance(XHIH, yhih,xlow,ylow)
IFIRS = 0
WALL = 0
DO K_ = k_start,k_end
if ( jakdtree.ne.1 ) then
k = ipsam(k_)
else
k = treeglob%results(k_)%idx
end if
do ivar=1,NDIM
if ( zss(ivar,k).eq.DMISS ) cycle
end do
IF (YS(K) .GE. YLOW .AND. YS(K) .LE. YHIH) THEN
CALL PINPOK(XS(K),YS(K),NN,XH,YH,INHUL)
IF (INHUL .EQ. 1) THEN
do ivar=1,NDIM
IF (IAV .EQ. 1) THEN
NUMXY = NUMXY + 1
HP(IVAR) = HP(IVAR) + ZSS(IVAR,K)
ELSE IF (IAV .EQ. 2) THEN
DIS2 = dbdistance(XS(K),YS(K),XC(N),YC(N))
IF (DIS2 .LT. RMIN2) THEN
RMIN2 = DIS2
HP(IVAR) = ZSS(IVAR,K)
NUMXY = 1
ENDIF
ELSE IF (IAV .LE. 4 .OR. IAV .EQ. 6) THEN
IF (IFIRS .EQ. 0) THEN
IFIRS = 1
HP(IVAR) = ZSS(IVAR,K)
NUMXY = 1
ENDIF
IF (IAV .EQ. 3) THEN
HP(IVAR) = MAX(HP(IVAR),ZSS(IVAR,K))
ELSE IF (IAV .EQ. 4) THEN
HP(IVAR) = MIN(HP(IVAR),ZSS(IVAR,K))
ELSE IF (IAV .EQ. 6) THEN
HP(IVAR) = MIN(ABS(HP(IVAR)),ABS(ZSS(IVAR,K)))
ENDIF
ELSE IF (IAV .EQ. 5) THEN
NUMXY = NUMXY + 1
DIS2 = dbdistance(XS(K),YS(K),XC(N),YC(N))
DIS2 = MAX(0.01,DIS2)
WEIGHT = 1/DIS2
WALL = WALL + WEIGHT
HP(IVAR) = HP(IVAR) + WEIGHT*ZSS(IVAR,K)
ENDIF
end do ! do ivar=1,NDIM
ENDIF
ENDIF
ENDDO
RHP = DMISS
IF (IAV .EQ. 1 .OR. IAV .EQ. 5) THEN
IF (NUMXY .GE. NUMMIN) THEN
IF (IAV .EQ. 1) THEN
RHP = HP / REAL(NUMXY)
ELSE IF (IAV .EQ. 5) THEN
RHP = HP/WALL
ENDIF
IF (JTEKINTERPOLATIONPROCESS > 0) THEN ! plot first variable only
CALL KCIR(XP,YP,RHP(1))
CALL DISPF2(XH,YH,NN,NN,NCOLNOW)
CALL LNABS(XH(1),YH(1))
ENDIF
ENDIF
ELSE IF (NUMXY .GE. 1) THEN
RHP = HP
IF (JTEKINTERPOLATIONPROCESS > 0) THEN
CALL KCIR(XP,YP,RHP(1))
CALL DISPF2(XH,YH,NN,NN,NCOLNOW)
CALL LNABS(XH(1),YH(1))
ENDIF
ENDIF
do ivar=1,NDIM
IF (RHP(ivar) .NE. DMISS) THEN
ZC(ivar,N) = RHP(ivar)
ENDIF
end do
if ( jatimer.eq.1 ) then
call klok(t2)
if ( t2-t1.gt.10d0 ) then
write(txt, "('averaging2: ', F0.2, ' seconds passed, N= ', I0, ' of ', I0)") t2-t0, N, NS
call mess(LEVEL_INFO, trim(txt))
t1 = t2
end if
end if
ENDDO
DEALLOCATE (XH, YH)
IF ( japrogressbar.eq.1 ) CALL READYY('GRIDCELL AVERAGING', -1d0)
! output message
if ( jatimer.eq.1 ) then
call klok(t1)
txt = ''
write(txt, "('averaged ', I0, ' values in ', I0, ' samples in ', F0.2, ' seconds.')") NX, NS, t1-t0
call mess(LEVEL_INFO, trim(txt))
end if
END SUBROUTINE AVERAGING2
!> 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 LOCATE(XX,N,IPERM,X,J)
INTEGER :: N, J
integer, dimension(N), intent(in) :: IPERM !< permutation array (increasing xx)
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(IPERM(N)).GT.XX(IPERM(1))).EQV.(X.GT.XX(IPERM(JM))))THEN
JL=JM
ELSE
JU=JM
ENDIF
GO TO 10
ENDIF
J=JL
RETURN
END
SUBROUTINE MAKECOARSE2FINETRIANGLECONNECTIONCELLS()
use m_netw
implicit none
INTEGER :: N3(6), N4(4)
DOUBLE PRECISION :: DCOSPHI
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)) ) < 0.3 .AND. &
ABS(dcosphi(XK(K0), YK(K0), XK(K1), YK(K1) , XK(K1), YK(K1), XK(K2), YK(K2)) ) < 0.3 ) THEN
IF ( ABS(dcosphi(XK(L1), YK(L1), XK(K0), YK(K0) , XK(K0), YK(K0), XK(K1), YK(K1)) ) > 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
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)
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
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 :: dbdistance, 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)))
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)
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)
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)
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)
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) ) ; 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)
implicit none
double precision :: x1,y1,x2,y2, dbdistance, r2, r
integer :: ja
ja = 0
r2 = DBDISTANCE(x1,y1,x2,y2)
if (r2 < r) then
ja = 1
endif
end subroutine
subroutine islinkadjacenttolink(L1,L2,ja,k1k,k2k)
use m_netw
implicit none
integer :: L1,L2,ja,k1k,k2k
double precision :: x1,y1,x2,y2,x3,y3,x4,y4
double precision :: dp
double precision, external :: dcosphi
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)
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)
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, dbdistance
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)
r2 = dbdistance(x3,y3,x4,y4)
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)
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)
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
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
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
SUBROUTINE OTHERNODE(K1,L1,K2)
use m_netw
implicit none
integer :: K1, L1, K2
integer :: ka
KA = KN(1,L1)
K2 = KN(2,L1)
IF (KA .EQ. K1) RETURN
K2 = KA
RETURN
END SUBROUTINE OTHERNODE
SUBROUTINE OTHERNODECHK(K1,L1,K2)
use m_netw
implicit none
integer :: K1, L1, K2
K2 = 0
IF (KN(3,L1) .NE. 2 .and. KN(3,L1) .NE. 0) RETURN
IF (K1 == KN(1,L1)) THEN
IF (LC(L1) == 1) RETURN
K2 = KN(2,L1)
RETURN
ENDIF
IF (LC(L1) == -1) RETURN
K2 = KN(1,L1)
RETURN
END SUBROUTINE OTHERNODECHK
SUBROUTINE FINDEL(K1,K2,L1)
use m_netw
implicit none
integer :: K1, K2, L1
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 SETNODADM(JACROSSCHECK)
use m_netw
use m_alloc
use m_missing
use m_sferic, only: pi, dg2rd
use unstruc_messages
use m_triangle, only: triangleminangle
implicit none
INTEGER :: JACROSSCHECK
double precision :: crp, e, e1
integer :: jacros, mout
integer :: k, k1, k12, k2, k22, k3, KI, ka, kb, kk, L, L1, L2, LL, LLL, LI, LTOT, ls, JA
INTEGER :: jDupLinks, jOverlapLinks, jSmallAng, maxlin
double precision :: sl, sm, xcr, ycr
INTEGER, ALLOCATABLE :: KC2(:), KN2(:,:), KCK(:)
double precision, allocatable :: arglin(:)
integer, allocatable :: linnrs(:), inn(:)
LOGICAL :: DINVIEW
double precision :: getdx, getdy, dcosphi
double precision :: phi, dx, dy, dmaxcosp, dcosp, costriangleminangle, phi0
double precision :: X(4), Y(4)
IF (NUML == 0) RETURN
E = 1E-6 ; E1 = 1-E
IF (JACROSSCHECK == 1) THEN
LL = 0
DO L=NUML,1,-1
K1 = KN(1,L) ; K2 = KN(2,L); K3 = KN(3, L)
if (k3 .NE. 2) then
cycle ! 1D links mogen blijven
endif
IF (DINVIEW(XK(K1),YK(K1),ZK(K1)) .OR. DINVIEW(XK(K2),YK(K2),ZK(K2)) ) THEN
DO LLL = MAX(1,L-1), 1 ,-1
KA = KN(1,LLL) ; KB = KN(2,LLL)
! If interfaces share same node, no further action:
if (k1 == ka .or. k1 == kb .or. k2 == ka .or. k2 == kb ) cycle
X(1) = XK(K1)
Y(1) = YK(K1)
X(2) = XK(K2)
Y(2) = YK(K2)
X(3) = XK(KA)
Y(3) = YK(KA)
X(4) = XK(KB)
Y(4) = YK(KB)
CALL CROSS(XK(K1), YK(K1), XK(K2), YK(K2), XK(KA), YK(KA), XK(KB), YK(KB), JACROS,SL,SM,XCR,YCR,CRP)
IF (SL > E .AND. SL < E1 .AND. SM > E .AND. SM < E1 ) THEN
KN(1,L) = 0; KN(2,L) = 0 ; KN(3, L) = -1; EXIT
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
100 continue
ALLOCATE(KCK(NUMK) )
if ( .not.allocated(kc) ) then
allocate(kc(numk))
kc = 0
kck = 0
else
KCK(1:NUMK) = KC(1:NUMK) ! STORE ORG KC
kc = 0
end if
ALLOCATE(KN2(3,NUML)) ; KN2 = 0 ! RESERVE KN
L2 = 0 ; L1 = 0
jathindams = 0
DO L=1,NUML ! LINKS AANSCHUIVEN, 1d EERST
K1 = KN(1,L) ; K2 = KN(2,L) ; K3 = KN(3,L)
if (k3 == 0) then
jathindams = 1
end if
IF (K1 .NE. 0 .AND. K2 .NE. 0 .AND. K1 .NE. K2 ) THEN
JA = 1
IF (XK(K1) == DMISS .OR. XK(K2) == DMISS) THEN ! EXTRA CHECK: ONE MISSING
JA = 0
ELSE IF (XK(K1) == XK(K2) .AND. YK(K1) == YK(K2) ) THEN ! : OR BOTH EQUAL
JA = 0
ENDIF
IF (JA == 1) THEN
IF (K3 == 0 .or. K3 == 2) THEN
L2 = L2 + 1
KN2(1,L2) = K1 ; KN2(2,L2) = K2 ; KN2(3,L2) = K3
ELSE IF (K3 == 1 .OR. K3 > 2) THEN
L1 = L1 + 1
KN(1,L1) = K1 ; KN(2,L1) = K2 ; KN(3,L1) = K3
ENDIF
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDIF
ENDDO
NUML1D = L1
NUML = L1 + L2
DO L = 1,L2
LL = NUML1D + L
KN(:, LL) = KN2(:,L) ! 2D na 1D
ENDDO
ALLOCATE (KC2(NUMK) )
KK = 0
DO K = 1,NUMK ! NODES AANSCHUIVEN
IF (KC(K) .NE. 0 ) THEN
KK = KK + 1
KC (KK) = K ! HIER KWAM IE VANDAAN
XK (KK) = XK(K)
YK (KK) = YK(K)
ZK (KK) = ZK(K)
KCK(KK) = KCK(K) ! COPY ORG KC
KC2(K) = KK ! EN HIER GAAT IE NAARTOE
ENDIF
ENDDO
NUMK = KK
DO L = 1,NUML
K1 = KN(1,L) ; K2 = KN(2,L) ; K3 = KN(3,L)
K12 = KC2(K1) ; K22 = KC2(K2)
KN2(1,L) = K12 ; KN2(2,L) = K22; KN2(3,L) = K3
ENDDO
KN(:,1:NUML) = KN2(:,1:NUML) ! TERUGZETTEN
KC(1:NUMK) = KCK(1:NUMK)
DEALLOCATE (KC2, KN2, KCK) ! WEGWEZEN
NMK = 0
DO L = 1,NUML ! TEL LINKS PER NODE
K1 = KN(1,L) ; K2 = KN(2,L)
NMK(K1) = NMK(K1) + 1
NMK(K2) = NMK(K2) + 1
ENDDO
DO K = 1,NUMK ! ALLOCEER RUIMTE
IF (NMK(K) > 0) THEN
!call REALLOC(NOD(K)%LIN, NMK(K), keepexisting = .false. )
if (allocated(NOD(K)%LIN)) then
deallocate(NOD(K)%LIN)
endif
allocate( NOD(K)%LIN(nmk(k)) )
ENDIF
ENDDO
NMK = 0
jDupLinks = 0
lnk:DO L=1,NUML ! EN ZET NODEADMIN (+check/reset dubbele links)
K1 = KN(1,L) ;
K2 = KN(2,L) ;
DO LL = 1,NMK(K1) ! Check all previously added links
if (KN(1,NOD(K1)%LIN(LL)) == K2 .or. KN(2,NOD(K1)%LIN(LL)) == K2) then
KN(1,L) = 0
KN(2,L) = 0
jDupLinks = 1
cycle lnk ! Jump to next outer L-loop
end if
ENDDO
NMK(K1) = NMK(K1) + 1
NMK(K2) = NMK(K2) + 1
NOD(K1)%LIN(NMK(K1)) = L
NOD(K2)%LIN(NMK(K2)) = L
END DO lnk
if (jDupLinks /= 0) then
goto 100 ! Er waren duplicate links: opnieuw aanschuiven
endif
! New cross check (two-smallangle check) is always performed
jOverlapLinks = 0
costriangleminangle = cos(triangleminangle*dg2rd)
if ( triangleminangle > 0 ) then
lnl:do L=1,NUML
k1 = kn(1,L) ; k2 = kn(2,L) ; k3 = kn(3,L)
if (k3 == 1) cycle
jSmallAng = 1
do ki=1,2 ! Consider links of both nodes in link L
if (jSmallAng /= 1) exit ! First or second end node did not have small angle between links
if (ki == 2) then ! Check second node
k1 = k2 ; k2 = kn(1,L)
end if
dmaxcosp = -huge(dmaxcosp)
do LI=1,NMK(k1)
LL = NOD(k1)%lin(LI)
if (LL == L) cycle ! No self-check
call othernode(k1, LL, kb)
if (kb == 0) then ! hk: dit kan hier toch nooit voorkomen?
cycle ! Incomplete link?
endif
dcosp = dcosphi(xk(k1), yk(k1), xk(k2), yk(k2), xk(k1), yk(k1), xk(kb), yk(kb))
dmaxcosp = max(dmaxcosp, dcosp)
end do
if (dmaxcosp > costriangleminangle) then
jSmallAng = 1
else
jSmallAng = 0
end if
end do
if (jSmallAng == 1) then ! Disable original link L
kn(1,L) = 0
kn(2,L) = 0
jOverlapLinks = 1
write(msgbuf, '(a,i8, a)') 'Removed link', L, ', because of tiny angles at endpoints.'
call msg_flush()
! cycle lnl ! Jump to next outer L-loop ben je al?
end if
end do lnl
end if
if (jOverlapLinks /= 0) then
goto 100 ! Er waren overlapping links: opnieuw aanschuiven
end if
! Sort nod%lin in counterclockwise order
maxlin = maxval(nmk(1:numk))
allocate(linnrs(maxlin), arglin(maxlin), inn(maxlin))
do k=1,numk
call sort_links_ccw(k, maxlin, linnrs, arglin, inn)
end do
deallocate(linnrs, arglin, inn)
! Reset small link count for linkbadqual (net link based).
! Will only be recomputed in flow_geominit.
nlinkbadortho = 0
nlinktoosmall = 0
nlinkcross = 0
! call trace_netlink_polys()
! netcell administration out of date
netstat = NETSTAT_CELLS_DIRTY
END SUBROUTINE SETNODADM
subroutine trace_netlink_polys()
use network_data
use m_alloc
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
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
logical :: dinview
! 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)
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
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
implicit none
integer , allocatable :: adj_row(:)
integer , allocatable :: adj(:)
integer , allocatable :: perm(:), perm_inv(:), perm_lnk(:), perm_inv_lnk(:)
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
!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()
! 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 readyy('Renumber flow nodes', 1d0 )
deallocate(adj_row, adj, &
perm, perm_inv, perm_lnk, perm_inv_lnk, &
i1, xz1, yz1, tface1)
deallocate(adj_tmp,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
SUBROUTINE INIALLOCnetcell()
use m_netw
implicit none
integer :: ierr, nx
NUMP = 0
nx = max(1,int(1.5*NUMK))
call increasenetcells(nx, 1.0, .false.)
netcell(:)%N = 0
if (allocated(lnn) ) deallocate(lnn)
allocate ( lnn(numl) , stat=ierr )
call aerr('lnn(numl)', ierr, numl )
LNN = 0
if (allocated(lne) ) deallocate(lne)
allocate( lne(2,numl) , stat=ierr )
call aerr('lne(2,numl)', ierr, 2*numl )
lne = 0 ! array = 0
RETURN
END SUBROUTINE INIALLOCnetcell
subroutine update_cell_circumcenters()
use network_data
use m_flowgeom
use m_alloc
implicit none
integer :: n, numc, ierr
double precision :: zzz
! Compute (circum)center coordinates now already.
! nump is in same rythm as (future) ndx2d
if (nump > 0) then
! if ( keepcircumcenters.eq.1 ) call qnerror('updating circumcenter', ' ', ' ')
! If ndx>nump, probably already some 1D stuff present.
! We can safely ignore it here, but won't, because this saves some
! realloc costs for xz, yz in flow_geominit.
numc = max(ndx,nump)
if (numc > size(xz)) then
call realloc(xz, numc, stat=ierr, keepExisting=.false.)
call aerr('xz(numc)',IERR, numc)
call realloc(yz, numc, stat=ierr, keepExisting=.false.)
call aerr('yz(numc)',IERR, numc)
end if
if (numc > size(xzw)) then
call realloc(xzw, numc, stat=ierr, keepExisting=.false.)
call aerr('xzw(numc)',IERR, numc)
call realloc(yzw, numc, stat=ierr, keepExisting=.false.)
call aerr('yzw(numc)',IERR, numc)
end if
if (numc > size(ba)) then
call realloc(ba, numc, stat=ierr, keepExisting=.false.)
call aerr('ba(numc)',IERR, numc)
endif
do n = 1,nump ! get cell center coordinates 2D
CALL GETCELLWEIGHTEDCENTER(n, xz(n) , yz(n) , zzz)
call getcellsurface(n, ba(n), xzw(n), yzw(n))
! call cirr( xzw(n), yzw(n), 211 )
end do
end if
end subroutine update_cell_circumcenters
subroutine EMBED1DCHANNELS()
use m_flowgeom, only: xz, yz, WU1dUNI
USE M_FLOW, ONLY: JAEMBED1D
use network_data
use m_alloc
implicit none
integer :: K1, K2, K3, L, NC1, NC2, JA, KK2(2), KK, NML
integer :: i, ierr, k, kcell
DOUBLE PRECISION :: XN, YN, XK2, YK2, WWU
DOUBLE PRECISION, EXTERNAL :: DBDISTANCE
call save()
call findcells(0)
if (jaembed1D > 0) then
DO L = 1, NUML1D
IF ( KN(3,L) == 1 ) THEN ! ZEKER WETEN
K1 = KN(1,L) ; K2 = KN(2,L)
NC1 = 0 ; NC2 = 0
CALL INCELLS(XK(K1), YK(K1), NC1) ! IS INSIDE 2D CELLS()
IF (NC1 > 0) THEN
XK(K1) = XZ(NC1) ; YK(K1) = YZ(NC1)
ENDIF
CALL INCELLS(XK(K2), YK(K2), NC2)
IF (NC2 > 0) THEN
XK(K2) = XZ(NC2) ; YK(K2) = YZ(NC2)
ENDIF
IF (NC1 == NC2 .and. nc1 .ne. 0) THEN
CALL MERGENODES(K2,K1,JA)
ENDIF
ENDIF
ENDDO
ELSE
KC = 2
DO L = 1,NUML ! FLAG TO 1 ANY NODE TOUCHED BY SOMETHING 1D
K1 = KN(1,L) ; K2 = KN(2,L); K3 = KN(3,L)
IF (K3 .NE. 2 .AND. K3 .NE. 0) THEN
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDDO
NML = NUML
DO K = 1,NUMK
IF (NMK(K) == 2) THEN
IF (KC(K) == 1) THEN
NC1 = 0
CALL INCELLS(XK(K), YK(K), NC1)
IF (NC1 > 1) THEN
CALL SETNEWPOINT(XZ(NC1),YZ(NC1),ZK(K) ,NC2)
call connectdbn(NC2, K, L)
KN(3,L) = 3
ELSE
DO KK = 1,2
L = NOD(K)%LIN(KK)
KK2(KK) = KN(1,L) + KN(2,L) - K
ENDDO
K1 = KK2(1) ; K2 = KK2(2)
CALL normalout(XK(K1), YK(K1), XK(K2), YK(K2) , XN, YN )
WWU = 5D0*DBDISTANCE(XK(K1), YK(K1), XK(K2), YK(K2) )
XK2 = XK(K) + XN*WWU
YK2 = YK(K) + YN*WWU
CALL CROSSED2d_BNDCELL(NML, XK(K), YK(K), XK2, YK2, NC1)
IF (NC1 > 1) THEN
CALL SETNEWPOINT(XZ(NC1),YZ(NC1),ZK(K) ,NC2)
call connectdbn(NC2, K, L)
KN(3,L) = 3
ENDIF
XK2 = XK(K) - XN*WWU
YK2 = YK(K) - YN*WWU
CALL CROSSED2d_BNDCELL(NML, XK(K), YK(K), XK2, YK2, NC1)
IF (NC1 > 1) THEN
CALL SETNEWPOINT(XZ(NC1),YZ(NC1),ZK(K) ,NC2)
call connectdbn(NC2, K, L)
KN(3,L) = 3
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
CALL SETNODADM(0)
END SUBROUTINE EMBED1DCHANNELS
!> 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_flow, only: jaembed1D
use m_flowgeom, only: xz, yz, ba
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 .or. K3 == 3) THEN
KC(K1) = 1 ; KC(K2) = 1
ENDIF
ENDDO
DO L = 1, NUML1D
K1 = KN(1,L) ; K2 = KN(2,L)
NC1 = 0 ; NC2 = 0
IF (NMK(K1) == 1) THEN
CALL INCELLS(XK(K1), YK(K1), NC1) ! IS INSIDE 2D CELLS()
ENDIF
IF (NMK(K2) == 1) 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
netstat = NETSTAT_CELLS_DIRTY
ierror = 0
1234 continue
return
end subroutine find1dcells
!> Finds 2D cells in the unstructured net.
!! Optionally within a polygon mask.
! Resets netcell data and also computes circumcenters in xz (flowgeom)
SUBROUTINE FINDCELLS(JP)
use m_netw
use m_flowgeom
use m_alloc
implicit none
integer, intent(in) :: JP !< Type of cells to find (unfolded: 3: triangle, etc. up to 6=hexa, 0 = all; folded: code+100; no new nodemask (nonzero values will be used as mask here): code+1000)
integer, allocatable, dimension(:) :: kc_sav ! save of kc
integer :: ik
integer :: k
integer :: k1
integer :: k2
integer :: l
integer :: jafold, jakeepmask
integer :: jp_
jp_ = jp
! determine if the nodemask has to be made
if ( jp_.ge.1000 ) then
jp_ = jp_-1000
jakeepmask = 1
else
jakeepmask = 0
end if
! determine if folded cells have to be accounted for
if ( jp_.ge.100 ) then
jp_ = jp_-100
jafold = 1
else
jafold = 0
end if
CALL SETNODADM(0)
CALL INIALLOCnetcell()
LC = 0
IK = -1
if ( jakeepmask.ne.1 ) then
KC = 0
DO K = 1,NUMK
CALL DBPINPOL(xk(k), yk(k), ik)
IF (IK > 0) THEN
KC(K) = IK
ENDIF
ENDDO
end if
IF (JP_ .EQ. 0) THEN
CALL FINDTRIS(0)
CALL FINDQUADS(0)
CALL FINDPENTAS(0)
CALL FINDHEXAS(0)
if ( jafold.eq.1 ) then
CALL FINDQUADS(1)
CALL FINDTRIS(1)
CALL FINDPENTAS(1)
CALL FINDHEXAS(1)
end if
ELSE IF (JP_ .EQ. 3) THEN
CALL FINDTRIS(0)
if ( jafold.eq.1 ) CALL FINDTRIS(1)
ELSE IF (JP_ .EQ. 4) THEN
CALL FINDQUADS(0)
if ( jafold.eq.1 ) CALL FINDQUADS(1)
ELSE IF (JP_ .EQ. 5) THEN
CALL FINDPENTAS(0)
if ( jafold.eq.1 ) CALL FINDPENTAS(1)
ELSE IF (JP_ .EQ. 6) THEN
CALL FINDHEXAS(0)
if ( jafold.eq.1 ) CALL FINDHEXAS(1)
ELSE IF (JP_ .EQ. 11)THEN
CALL FINDPENTAS(0)
CALL FINDHEXAS(0)
if ( jafold.eq.1 ) then
CALL FINDPENTAS(1)
CALL FINDHEXAS(1)
end if
ENDIF
IF (NPL < 3) THEN
! LC = 1; KC = 1 ! SPvdP: this gives problems in orthogonalisenet
LC = 1
if ( jakeepmask.ne.1 ) then
KC = 1
end if
ELSE
DO L = 1, NUML
K1 = KN(1,L) ; K2 = KN(2,L)
IF (KC(K1) == 1 .or. KC(K2) == 1) LC(L) = 1
ENDDO
ENDIF
call update_cell_circumcenters()
nump1d2d = nump ! there are no 1D cells yet, safety
! If one chooses to add find1dcells to findcells in future, this is how it may look like.
! Note however, that:
! -lne now has negative entries, which causes problems in various 2d-only subroutines, like orthonogalisenet, at the moment
! -kc is detroyed
! For these reasons, find1dcells is not included here
!
!! find 1D cells, will destroy kc
! allocate(kc_sav(numk))
! kc_sav = kc(1:numk)
!
! call find1dcells() ! will destroy kc
!
!! restore kc
! kc(1:numk) = kc_sav(1:numk)
! deallocate(kc_sav)
NDX2D = NUMP ! NR OF 2d CELLS=NUMP
lasttopology = numk + numl
! set network status
netstat = NETSTAT_OK
RETURN
END SUBROUTINE FINDCELLS
SUBROUTINE FINDTRIS(jafold)
use m_netw
USE M_AFMETING
use m_alloc
implicit none
integer, intent(in) :: jafold !< find folded cells (1), or not (0)
integer :: ierr
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: kk
integer :: kkk
integer :: kkkk
integer :: kmod
integer :: l
integer :: ll
integer :: lll
integer :: i
integer :: kr(3), Lr(3)
integer :: kkk_, kkkk_, nmkmax
LOGICAL RECHTSAF
logical :: alreadycell
logical :: iscounterclockwise
CALL READYY ('FIND TRIS', 0d0)
nmkmax = 1
if ( jafold.eq.1 ) nmkmax = 1000
KMOD = max(1,NUMK/100)
DO K1 = 1,NUMK
IF (MOD(K1,KMOD) == 1) CALL READYY ('FIND TRIS',dble(K1)/dble(NUMK))
IF (KC(K1) .EQ. 1) THEN
kklp:DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LNN(L) .GE. 2) CYCLE
CALL OTHERNODECHK(K1,L,K2); IF (K2 == 0) CYCLE
kkk = 1
do while ( nod(k2)%lin(kkk).ne.L )
kkk=kkk+1
end do
DO KKK_ = 1,min(NMK(K2),nmkmax)
kkk = kkk-1
if ( kkk.lt.1 ) kkk=kkk+nmk(k2)
if ( kkk.gt.nmk(k2) ) kkk=kkk-nmk(k2)
LL = NOD(K2)%LIN(KKK) ; IF (LL .EQ. L) CYCLE
IF (LNN(LL) .GE. 2) CYCLE
CALL OTHERNODECHK(K2,LL,K3) ; IF (K3 == 0) CYCLE
IF ( RECHTSAF(K1,K2,K3) ) CYCLE
IF (K3 .NE. K1) THEN
kkkk = 1
do while ( nod(k3)%lin(kkkk).ne.LL )
kkkk=kkkk+1
end do
DO KKKK_ = 1,min(NMK(K3),nmkmax)
kkkk = kkkk-1
if ( kkkk.lt.1 ) kkkk=kkkk+nmk(k3)
if ( kkkk.gt.nmk(k3) ) kkkk=kkkk-nmk(k3)
LLL = NOD(K3)%LIN(KKKK) ; IF (LLL .EQ. LL .OR. LLL .EQ. L) CYCLE
IF (LNN(LLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K3,LLL,K4) ; IF (K4 == 0) CYCLE
IF ( RECHTSAF(K2,K3,K4) ) CYCLE
IF (K4 .EQ. K1) THEN ! TRI GEVONDEN
IF (LNN(L)>1 .OR. LNN(LL)>1 .OR. LNN(LLL)>1) EXIT
! call setcol(31) ! red
! call rcirc(xk(k1),yk(k1))
! call setcol(204) ! green
! call rcirc(xk(k2),yk(k2))
! call setcol(211) ! blue
! call rcirc(xk(k3),yk(k3))
! SPvdP: check and see if cell already exist
if ( lnn(L).gt.0 .and. lnn(LL).gt.0 .and. lnn(LLL).gt.0 ) then
if ( lne(1,L).eq.lne(1,LL) .and. lne(1,L).eq.lne(1,LLL) ) then
cycle
else ! more expensive check
kr(1)=k1; kr(2)=k2; kr(3)=k3
Lr(1)=L; Lr(2)=LL; Lr(3)=LLL
if ( alreadycell(3, kr, Lr) ) cycle
! do not allow folded cells when all links already have neighboring cells
if ( kkk_.ne.1 .or. kkkk_.ne.1 ) then
cycle
end if
end if
end if
kr(1)=k1; kr(2)=k2; kr(3)=k3
if ( .not.iscounterclockwise(3, kr) ) cycle
!CALL ALREADYTRI(K1,K2,K3,JA); IF (JA > 0) EXIT
call increasenetcells(NUMP+1, 1.2, .true.)
NUMP = NUMP + 1
call realloc(netcell(NUMP)%NOD, 3, stat=ierr, keepExisting=.false.)
call realloc(netcell(NUMP)%LIN, 3, stat=ierr, keepExisting=.false.)
netcell(NUMP)%N = 3
netcell(NUMP)%NOD(1) = K1
netcell(NUMP)%NOD(2) = K2
netcell(NUMP)%NOD(3) = K3
netcell(NUMP)%LIN(1) = L
netcell(NUMP)%LIN(2) = LL
netcell(NUMP)%LIN(3) = LLL
LNN(L) = LNN(L) + 1
LNN(LL) = LNN(LL) + 1
LNN(LLL) = LNN(LLL) + 1
LNE(LNN(L),L) = NUMP
LNE(LNN(LL),LL) = NUMP
LNE(LNN(LLL),LLL) = NUMP
! SPvdP: linkmask deactivated with the purpose to find folded cells; check if cells already exist instead
! LC(L) = 1 ; IF (KN(1,L) == K2) LC(L) = -1
! LC(LL) = 1 ; IF (KN(1,LL) == K3) LC(LL) = -1 ! AvD: re-enabled, in line with new rgfgrid
! LC(LLL) = 1 ; IF (KN(1,LLL) == K1) LC(LLL) = -1 !
! cell found and administered: proceed
cycle kklp
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO kklp
ENDIF
ENDDO
CALL READYY ( 'FIND TRIS', -1d0 )
RETURN
END SUBROUTINE FINDTRIS
SUBROUTINE FINDQUADS(jafold)
use m_netw
USE M_AFMETING
use m_alloc
implicit none
integer, intent(in) :: jafold !< find folded cells (1), or not (0)
double precision :: af
integer :: ierr
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: k5
integer :: kk
integer :: kkk
integer :: kkkk
integer :: kkkkk
integer :: kmod
integer :: l
integer :: ll
integer :: lll
integer :: llll
integer :: kr(4), Lr(4)
integer :: kkk_, kkkk_, kkkkk_, nmkmax
LOGICAL RECHTSAF
logical :: alreadycell
logical :: iscounterclockwise
CALL READYY('FIND QUADS',0d0)
nmkmax = 1
if ( jafold.eq.1 ) nmkmax = 1000
KMOD = max(1,NUMK/100)
DO K1 = 1,NUMK
if (mod(k1,KMOD) == 1) then
af = dble(k1) /dble(numk)
CALL READYY('FIND QUADS',AF)
endif
IF (KC(K1) .EQ. 1) THEN
kklp:DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LNN(L) .GE. 2) CYCLE
CALL OTHERNODECHK(K1,L,K2); IF (K2 == 0) CYCLE
kkk = 1
do while ( nod(k2)%lin(kkk).ne.L )
kkk=kkk+1
end do
DO KKK_ = 1,min(NMK(K2),nmkmax)
kkk = kkk-1
if ( kkk.lt.1 ) kkk=kkk+nmk(k2)
if ( kkk.gt.nmk(k2) ) kkk=kkk-nmk(k2)
LL = NOD(K2)%LIN(KKK) ; IF (LL .EQ. L) CYCLE
IF (LNN(LL) .GE. 2) CYCLE
CALL OTHERNODECHK(K2,LL,K3); IF (K3 == 0) CYCLE
IF ( RECHTSAF(K1,K2,K3) ) CYCLE
IF (K3 .NE. K1) THEN
kkkk = 1
do while ( nod(k3)%lin(kkkk).ne.LL )
kkkk=kkkk+1
end do
DO KKKK_ = 1,min(NMK(K3),nmkmax)
kkkk = kkkk-1
if ( kkkk.lt.1 ) kkkk=kkkk+nmk(k3)
if ( kkkk.gt.nmk(k3) ) kkkk=kkkk-nmk(k3)
LLL = NOD(K3)%LIN(KKKK) ; IF (LLL .EQ. LL .OR. LLL .EQ. L) CYCLE
IF (LNN(LLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K3,LLL,K4); IF (K4 == 0) CYCLE
IF ( RECHTSAF(K2,K3,K4) ) CYCLE
IF (K4 .NE. K2) THEN
kkkkk = 1
do while ( nod(k4)%lin(kkkkk).ne.LLL )
kkkkk=kkkkk+1
end do
DO KKKKK_ = 1,min(NMK(K4),nmkmax)
kkkkk = kkkkk-1
if ( kkkkk.lt.1 ) kkkkk=kkkkk+nmk(k4)
if ( kkkkk.gt.nmk(k4) ) kkkkk=kkkkk-nmk(k4)
LLLL = NOD(K4)%LIN(KKKKK)
IF (LLLL .EQ. LLL .OR. LLLL .EQ. LL .OR. LLLL .EQ. L) CYCLE
IF (LNN(LLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K4,LLLL,K5) ; IF (K5 == 0) CYCLE
IF ( RECHTSAF(K3,K4,K5) ) CYCLE
IF (K5 .EQ. K1) THEN ! PANEEL GEVONDEN
IF (LNN(L)>1 .OR. LNN(LL)>1 .OR. LNN(LLL)>1 .OR. LNN(LLLL)>1) EXIT
! SPvdP: check and see if cell already exist
if ( lnn(L).gt.0 .and. lnn(LL).gt.0 .and. lnn(LLL).gt.0 .and. lnn(LLLL).gt.0 ) then
if ( lne(1,L).eq.lne(1,LL) .and. lne(1,L).eq.lne(1,LLL) .and. lne(1,L).eq.lne(1,LLLL) ) then
cycle
else ! more expensive check
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4
Lr(1)=L; Lr(2)=LL; Lr(3)=LLL; Lr(4)=LLLL
if ( alreadycell(4, kr, Lr) ) cycle
! do not allow folded cells when all links already have neighboring cells
if ( kkk_.ne.1 .or. kkkk_.ne.1 .or. kkkkk_.ne.1 ) then
cycle
end if
end if
end if
!CALL ALREADYQUAD(K1,K2,K3,K4,JA) ; IF (JA > 0 ) EXIT
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4
if ( .not.iscounterclockwise(4, kr) ) cycle
call increasenetcells(NUMP+1, 1.2, .true.)
NUMP = NUMP + 1
call realloc(netcell(NUMP)%NOD, 4, stat=ierr, keepExisting=.false.)
call realloc(netcell(NUMP)%LIN, 4, stat=ierr, keepExisting=.false.)
netcell(NUMP)%N = 4
netcell(NUMP)%NOD (1) = K1
netcell(NUMP)%NOD (2) = K2
netcell(NUMP)%NOD (3) = K3
netcell(NUMP)%NOD (4) = K4
netcell(NUMP)%LIN(1) = L
netcell(NUMP)%LIN(2) = LL
netcell(NUMP)%LIN(3) = LLL
netcell(NUMP)%LIN(4) = LLLL
LNN(L) = LNN(L) + 1
LNN(LL) = LNN(LL) + 1
LNN(LLL) = LNN(LLL) + 1
LNN(LLLL) = LNN(LLLL) + 1
LNE(LNN(L),L) = NUMP
LNE(LNN(LL),LL) = NUMP
LNE(LNN(LLL),LLL) = NUMP
LNE(LNN(LLLL),LLLL) = NUMP
! SPvdP: linkmask deactivated with the purpose to find folded cells; check if cells already exist instead
! LC(L) = 1 ; IF (KN(1,L) == K2) LC(L) = -1
! LC(LL) = 1 ; IF (KN(1,LL) == K3) LC(LL) = -1
! LC(LLL) = 1 ; IF (KN(1,LLL) == K4) LC(LLL) = -1
! LC(LLLL) = 1 ; IF (KN(1,LLLL) == K1) LC(LLLL) = -1
! cell found and administered: proceed
cycle kklp
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO kklp
ENDIF
ENDDO
CALL READYY('FIND QUADS',-1d0)
RETURN
END SUBROUTINE FINDQUADS
SUBROUTINE FINDPENTAS(jafold)
use m_netw
USE M_AFMETING
use m_alloc
implicit none
integer, intent(in) :: jafold !< find folded cells (1), or not (0)
integer :: ierr
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: k5
integer :: k6
integer :: kk
integer :: kkk
integer :: kkkk
integer :: kkkkk
integer :: kkkkkk
integer :: kmod
integer :: l
integer :: ll
integer :: lll
integer :: llll
integer :: lllll
integer :: kr(5), Lr(5)
integer :: kkk_, kkkk_, kkkkk_, kkkkkk_, nmkmax
LOGICAL RECHTSAF
logical :: alreadycell
logical :: iscounterclockwise
CALL READYY ('FINDPENTAS',0d0)
nmkmax = 1
if ( jafold.eq.1 ) nmkmax = 1000
KMOD = max(1,NUMK/100)
DO K1 = 1,NUMK
IF (MOD(K1,KMOD) == 1) CALL READYY ('FINDPENTAS',dble(K1)/dble(NUMK))
IF (KC(K1) == 1) THEN
kklp:DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LNN(L) .GE. 2) CYCLE
CALL OTHERNODECHK(K1,L,K2); IF (K2 == 0) CYCLE
kkk = 1
do while ( nod(k2)%lin(kkk).ne.L )
kkk=kkk+1
end do
DO KKK_ = 1,min(NMK(K2),nmkmax)
kkk = kkk-1
if ( kkk.lt.1 ) kkk=kkk+nmk(k2)
if ( kkk.gt.nmk(k2) ) kkk=kkk-nmk(k2)
LL = NOD(K2)%LIN(KKK)
IF (LL .EQ. L) CYCLE
IF (LNN(LL) .GE. 2) CYCLE
CALL OTHERNODECHK(K2,LL,K3); IF (K3 == 0) CYCLE
IF ( RECHTSAF(K1,K2,K3) ) CYCLE
IF (K3 .NE. K1) THEN
kkkk = 1
do while ( nod(k3)%lin(kkkk).ne.LL )
kkkk=kkkk+1
end do
DO KKKK_ = 1,min(NMK(K3),nmkmax)
kkkk = kkkk-1
if ( kkkk.lt.1 ) kkkk=kkkk+nmk(k3)
if ( kkkk.gt.nmk(k3) ) kkkk=kkkk-nmk(k3)
LLL = NOD(K3)%LIN(KKKK)
IF (LLL .EQ. LL .OR. LLL .EQ. L) CYCLE
IF (LNN(LLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K3,LLL,K4); IF (K4 == 0) CYCLE
IF ( RECHTSAF(K2,K3,K4) ) CYCLE
IF (K4 .NE. K2 .AND. K4 .NE. K1) THEN
kkkkk = 1
do while ( nod(k4)%lin(kkkkk).ne.LLL )
kkkkk=kkkkk+1
end do
DO KKKKK_ = 1,min(NMK(K4),nmkmax)
kkkkk = kkkkk-1
if ( kkkkk.lt.1 ) kkkkk=kkkkk+nmk(k4)
if ( kkkkk.gt.nmk(k4) ) kkkkk=kkkkk-nmk(k4)
LLLL = NOD(K4)%LIN(KKKKK)
IF (LLLL .EQ. LLL .OR. LLLL .EQ. LL .OR. LLLL .EQ. L) CYCLE
IF (LNN(LLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K4,LLLL,K5) ; IF (K5 == 0) CYCLE
IF ( RECHTSAF(K3,K4,K5) ) CYCLE
IF (K5 .NE. K3 .AND. K5 .NE. K2 .AND. K5 .NE. K1) THEN
kkkkkk = 1
do while ( nod(k5)%lin(kkkkkk).ne.LLLL )
kkkkkk=kkkkkk+1
end do
DO KKKKKK_ = 1,min(NMK(K5),nmkmax)
kkkkkk = kkkkkk-1
if ( kkkkkk.lt.1 ) kkkkkk=kkkkkk+nmk(k5)
if ( kkkkkk.gt.nmk(k5) ) kkkkkk=kkkkkk-nmk(k5)
LLLLL = NOD(K5)%LIN(KKKKKK)
IF (LLLLL .EQ. LLLL .OR. LLLLL .EQ. LLL .OR. LLLLL .EQ. LL .OR. LLLLL .EQ. L) CYCLE
IF (LNN(LLLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K5,LLLLL,K6); IF (K6 == 0) CYCLE
IF ( RECHTSAF(K4,K5,K6) ) CYCLE
IF (K6 .EQ. K1) THEN ! PENTA GEVONDEN
IF (LNN(L)>1 .OR. LNN(LL)>1 .OR. LNN(LLL)>1 .OR. &
LNN(LLLL)>1 .OR. LNN(LLLLL) > 1 ) EXIT
! SPvdP: check and see if cell already exist
if ( lnn(L).gt.0 .and. lnn(LL).gt.0 .and. lnn(LLL).gt.0 .and. &
lnn(LLLL).gt.0 .and. lnn(LLLLL).gt.0 ) then
if ( lne(1,L).eq.lne(1,LL) .and. lne(1,L).eq.lne(1,LLL) .and. &
lne(1,L).eq.lne(1,LLLL) .and. lne(1,L).eq.lne(1,LLLLL) ) then
cycle
else ! more expensive check
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4; kr(5)=k5
Lr(1)=L; Lr(2)=LL; lr(3)=LLL; Lr(4)=LLLL; Lr(5)=LLLLL
if ( alreadycell(5, kr, Lr) ) cycle
! do not allow folded cells when all links already have neighboring cells
if ( kkk_.ne.1 .or. kkkk_.ne.1 .or. kkkkk_.ne.1 .or. kkkkkk_.ne.1 ) then
cycle
end if
end if
end if
!CALL ALREADYPENTA(K1,K2,K3,K4,K5,JA) ; IF (JA > 0) EXIT
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4; kr(5)=k5
if ( .not.iscounterclockwise(5, kr) ) cycle
call increasenetcells(NUMP+1, 1.2, .true.)
NUMP = NUMP + 1
call realloc(netcell(NUMP)%NOD, 5, stat=ierr, keepExisting=.false.)
call realloc(netcell(NUMP)%LIN, 5, stat=ierr, keepExisting=.false.)
netcell(NUMP)%N = 5
netcell(NUMP)%NOD(1) = K1
netcell(NUMP)%NOD(2) = K2
netcell(NUMP)%NOD(3) = K3
netcell(NUMP)%NOD(4) = K4
netcell(NUMP)%NOD(5) = K5
netcell(NUMP)%LIN(1) = L
netcell(NUMP)%LIN(2) = LL
netcell(NUMP)%LIN(3) = LLL
netcell(NUMP)%LIN(4) = LLLL
netcell(NUMP)%LIN(5) = LLLLL
LNN(L) = LNN(L) + 1
LNN(LL) = LNN(LL) + 1
LNN(LLL) = LNN(LLL) + 1
LNN(LLLL) = LNN(LLLL) + 1
LNN(LLLLL) = LNN(LLLLL) + 1
LNE(LNN(L),L) = NUMP
LNE(LNN(LL),LL) = NUMP
LNE(LNN(LLL),LLL) = NUMP
LNE(LNN(LLLL),LLLL) = NUMP
LNE(LNN(LLLLL),LLLLL) = NUMP
! SPvdP: linkmask deactivated with the purpose to find folded cells; check if cells already exist instead
! LC(L) = 1 ; IF (KN(1,L) == K2) LC(L) = -1
! LC(LL) = 1 ; IF (KN(1,LL) == K3) LC(LL) = -1
! LC(LLL) = 1 ; IF (KN(1,LLL) == K4) LC(LLL) = -1
! LC(LLLL) = 1 ; IF (KN(1,LLLL) == K5) LC(LLLL) = -1
! LC(LLLLL) = 1 ; IF (KN(1,LLLLL) == K1) LC(LLLLL) = -1
! cell found and administered: proceed
cycle kklp
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO kklp
ENDIF
ENDDO
CALL READYY ('FINDPENTAS', -1d0)
RETURN
END SUBROUTINE FINDPENTAS
SUBROUTINE FINDHEXAS(jafold)
use m_netw
USE M_AFMETING
use m_alloc
implicit none
integer, intent(in) :: jafold !< find folded cells (1), or not (0)
integer :: ierr
integer :: k1
integer :: k2
integer :: k3
integer :: k4
integer :: k5
integer :: k6
integer :: k7
integer :: kk
integer :: kkk
integer :: kkkk
integer :: kkkkk
integer :: kkkkkk
integer :: kkkkkkk
integer :: kmod
integer :: l
integer :: ll
integer :: lll
integer :: llll
integer :: lllll
integer :: llllll
integer :: kr(6), Lr(6)
integer :: kkk_, kkkk_, kkkkk_, kkkkkk_, kkkkkkk_, nmkmax
LOGICAL RECHTSAF
logical :: alreadycell
logical :: iscounterclockwise
CALL READYY ('FINDHEXAS', 0d0)
nmkmax = 1
if ( jafold.eq.1 ) nmkmax = 1000
KMOD = max(1,NUMK/100)
DO K1 = 1,NUMK
IF (MOD(K1,KMOD) == 1) CALL READYY ('FINDHEXAS',dble(K1)/dble(NUMK))
IF (KC(K1) == 1) THEN
kklp:DO KK = 1,NMK(K1)
L = NOD(K1)%LIN(KK)
IF (LNN(L) .GE. 2) CYCLE
CALL OTHERNODECHK(K1,L,K2); IF (K2 ==0) CYCLE
kkk = 1
do while ( nod(k2)%lin(kkk).ne.L )
kkk=kkk+1
end do
DO KKK_ = 1,min(NMK(K2),nmkmax)
kkk = kkk-1
if ( kkk.lt.1 ) kkk=kkk+nmk(k2)
if ( kkk.gt.nmk(k2) ) kkk=kkk-nmk(k2)
LL = NOD(K2)%LIN(KKK)
IF (LL .EQ. L) CYCLE
IF (LNN(LL) .GE. 2) CYCLE
CALL OTHERNODECHK(K2,LL,K3); IF (K3 ==0) CYCLE
IF ( RECHTSAF(K1,K2,K3) ) CYCLE
IF (K3 .NE. K1) THEN
kkkk = 1
do while ( nod(k3)%lin(kkkk).ne.LL )
kkkk=kkkk+1
end do
DO KKKK_ = 1,min(NMK(K3),nmkmax)
kkkk = kkkk-1
if ( kkkk.lt.1 ) kkkk=kkkk+nmk(k3)
if ( kkkk.gt.nmk(k3) ) kkkk=kkkk-nmk(k3)
LLL = NOD(K3)%LIN(KKKK)
IF (LLL .EQ. LL .OR. LLL .EQ. L) CYCLE
IF (LNN(LLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K3,LLL,K4); IF (K4 ==0) CYCLE
IF ( RECHTSAF(K2,K3,K4) ) CYCLE
IF (K4 .NE. K2 .AND. K4 .NE. K1) THEN
kkkkk = 1
do while ( nod(k4)%lin(kkkkk).ne.LLL )
kkkkk=kkkkk+1
end do
DO KKKKK_ = 1,min(NMK(K4),nmkmax)
kkkkk = kkkkk-1
if ( kkkkk.lt.1 ) kkkkk=kkkkk+nmk(k4)
if ( kkkkk.gt.nmk(k4) ) kkkkk=kkkkk-nmk(k4)
LLLL = NOD(K4)%LIN(KKKKK)
IF (LLLL .EQ. LLL .OR. LLLL .EQ. LL .OR. LLLL .EQ. L) CYCLE
IF (LNN(LLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K4,LLLL,K5); IF (K5 ==0) CYCLE
IF ( RECHTSAF(K3,K4,K5) ) CYCLE
IF (K5 .NE. K3 .AND. K5 .NE. K2 .AND. K5 .NE. K1) THEN
kkkkkk = 1
do while ( nod(k5)%lin(kkkkkk).ne.LLLL )
kkkkkk=kkkkkk+1
end do
DO KKKKKK_ = 1,min(NMK(K5),nmkmax)
kkkkkk = kkkkkk-1
if ( kkkkkk.lt.1 ) kkkkkk=kkkkkk+nmk(k5)
if ( kkkkkk.gt.nmk(k5) ) kkkkkk=kkkkkk-nmk(k5)
LLLLL = NOD(K5)%LIN(KKKKKK)
IF (LLLLL .EQ. LLLL .OR. LLLLL .EQ. LLL .OR. LLLLL .EQ. LL .OR. LLLLL .EQ. L) CYCLE
IF (LNN(LLLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K5,LLLLL,K6); IF (K6 ==0) CYCLE
IF ( RECHTSAF(K4,K5,K6) ) CYCLE
IF (K6 .NE. K4 .AND. K6 .NE. K3 .AND. K6 .NE. K2 .AND. K6 .NE. K1) THEN
kkkkkkk = 1
do while ( nod(k6)%lin(kkkkkkk).ne.LLLLL )
kkkkkkk=kkkkkkk+1
end do
DO KKKKKKK_ = 1,min(NMK(K6),nmkmax)
kkkkkkk = kkkkkkk-1
if ( kkkkkkk.lt.1 ) kkkkkkk=kkkkkkk+nmk(k6)
if ( kkkkkkk.gt.nmk(k6) ) kkkkkkk=kkkkkkk-nmk(k6)
LLLLLL = NOD(K6)%LIN(KKKKKKK)
IF (LLLLLL .EQ. LLLLL .OR. LLLLLL .EQ. LLLL .OR. &
LLLLLL .EQ. LLL .OR. LLLLLL .EQ. LL .OR. LLLLLL .EQ. L) CYCLE
IF (LNN(LLLLLL) .GE. 2) CYCLE
CALL OTHERNODECHK(K6,LLLLLL,K7); IF (K7 ==0) CYCLE
IF ( RECHTSAF(K5,K6,K7) ) CYCLE
IF (K7 .EQ. K1) THEN ! HEXA GEVONDEN
IF (LNN(L)>1 .OR. LNN(LL)>1 .OR. LNN(LLL)>1 .OR. &
LNN(LLLL)>1 .OR. LNN(LLLLL)>1 .OR. LNN(LLLLLL)>1) EXIT
! SPvdP: check and see if cell already exist
if ( lnn(L).gt.0 .and. lnn(LL).gt.0 .and. lnn(LLL).gt.0 .and. &
lnn(LLLL).gt.0 .and. lnn(LLLLL).gt.0 .and. lnn(LLLLLL).gt.0 ) then
if ( lne(1,L).eq.lne(1,LL) .and. lne(1,L).eq.lne(1,LLL) .and. &
lne(1,L).eq.lne(1,LLLL) .and. lne(1,L).eq.lne(1,LLLLL) .and. lne(1,L).eq.lne(1,LLLLLL) ) then
cycle
else ! more expensive check
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4; kr(5)=k5; kr(6)=k6
Lr(1)=L; Lr(2)=LL; lr(3)=LLL; Lr(4)=LLLL; Lr(5)=LLLLL; Lr(6)=LLLLLL
if ( alreadycell(6, kr, Lr) ) cycle
! do not allow folded cells when all links already have neighboring cells
if ( kkk_.ne.1 .or. kkkk_.ne.1 .or. kkkkk_.ne.1 .or. kkkkkk_.ne.1 .or. kkkkkkk_.ne.1 ) then
cycle
end if
end if
end if
!CALL ALREADYHEXA(K1,K2,K3,K4,K5,K6,JA) ; IF (JA > 0) EXIT
kr(1)=k1; kr(2)=k2; kr(3)=k3; kr(4)=k4; kr(5)=k5; kr(6)=k6
if ( .not.iscounterclockwise(6, kr) ) cycle
call increasenetcells(NUMP+1, 1.2, .true.)
NUMP = NUMP + 1
call realloc(netcell(NUMP)%NOD, 6, stat=ierr, keepExisting=.false.)
call realloc(netcell(NUMP)%LIN, 6, stat=ierr, keepExisting=.false.)
netcell(NUMP)%N = 6
netcell(NUMP)%NOD(1) = K1
netcell(NUMP)%NOD(2) = K2
netcell(NUMP)%NOD(3) = K3
netcell(NUMP)%NOD(4) = K4
netcell(NUMP)%NOD(5) = K5
netcell(NUMP)%NOD(6) = K6
netcell(NUMP)%LIN(1) = L
netcell(NUMP)%LIN(2) = LL
netcell(NUMP)%LIN(3) = LLL
netcell(NUMP)%LIN(4) = LLLL
netcell(NUMP)%LIN(5) = LLLLL
netcell(NUMP)%LIN(6) = LLLLLL
LNN(L) = LNN(L) + 1
LNN(LL) = LNN(LL) + 1
LNN(LLL) = LNN(LLL) + 1
LNN(LLLL) = LNN(LLLL) + 1
LNN(LLLLL) = LNN(LLLLL) + 1
LNN(LLLLLL) = LNN(LLLLLL) + 1
LNE(LNN(L),L) = NUMP
LNE(LNN(LL),LL) = NUMP
LNE(LNN(LLL),LLL) = NUMP
LNE(LNN(LLLL),LLLL) = NUMP
LNE(LNN(LLLLL),LLLLL) = NUMP
LNE(LNN(LLLLLL),LLLLLL) = NUMP
! SPvdP: linkmask deactivated with the purpose to find folded cells; check if cells already exist instead
! LC(L) = 1 ; IF (KN(1,L) == K2) LC(L) = -1
! LC(LL) = 1 ; IF (KN(1,LL) == K3) LC(LL) = -1
! LC(LLL) = 1 ; IF (KN(1,LLL) == K4) LC(LLL) = -1
! LC(LLLL) = 1 ; IF (KN(1,LLLL) == K5) LC(LLLL) = -1
! LC(LLLLL) = 1 ; IF (KN(1,LLLLL) == K6) LC(LLLLL) = -1
! LC(LLLLLL) = 1 ; IF (KN(1,LLLLLL) == K1) LC(LLLLLL) = -1
! cell found and administered: proceed
cycle kklp
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO kklp
ENDIF
ENDDO
CALL READYY ('FINDHEXAS', -1d0)
RETURN
END SUBROUTINE FINDHEXAS
!> check and see if the links already form a cell
logical function alreadycell(N, K, L)
use m_netw
implicit none
integer, intent(in) :: N !< number of links and nodes
integer, dimension(N), intent(in) :: K !< node set
integer, dimension(N), intent(in) :: L !< link set
integer :: i, j
integer :: kL, kR, LL
integer :: num
integer :: knod, kcom
integer, dimension(N) :: icell
integer, dimension(N) :: dum
! search for a link that:
! -is a member of the link set,
! -bounds two cells which are adjacent to the links in the link set, and
! -connects two nodes that are members of the node set
!
! this link will be an internal link in the polygon formed by the links in the link set, hence these links do not form a new cell
alreadycell = .false.
do i=1,N
if ( lnn(L(i)).eq.2 ) return
end do
icell = lne(1, L)
do i=1,N
if ( lnn(L(i)).lt.1 ) cycle
do j = 1,netcell(icell(i))%N
LL = netcell(icell(i))%lin(j)
if ( lnn(LL).ne.2 ) cycle ! this also excludes all members of the link set
kL = lne(1,LL)
kR = lne(2,LL)
! check if both kL and kR are members of the cell set
dum = 0
where( icell.eq.kL ) dum = 1
if ( sum(dum).eq.0 ) cycle ! kL not a member
dum = 0
where( icell.eq.kR ) dum = 1
if ( sum(dum).eq.0 ) cycle ! kR not a member
! check if the link connects nodes in the node set
dum = 0
where( K.eq.kn(1,LL) ) dum =1
if ( sum(dum).eq.0 ) cycle ! first node of link not a member
dum = 0
where( K.eq.kn(2,LL) ) dum =1
if ( sum(dum).eq.0 ) cycle ! second node of link not a member
alreadycell = .true.
return
end do
end do
! check for nodes inside the polygon - to be done
! see if a cell contains only triangles that share a node
kcom = 0
! if ( N.eq.4 ) then ! quads only
do i=1,N
LL = L(i)
if ( lnn(LL).lt.1 ) then
kcom = 0
exit
end if
if ( netcell(icell(i))%N.ne.3 ) then
kcom = 0
exit ! triangles only
end if
! find the node of the triangle not on the link
knod = sum(netcell(icell(i))%nod(1:3)) - kn(1,LL) - kn(2,LL)
if ( kcom.eq.0 ) then ! set common node
kcom = knod
else if ( knod.ne.kcom ) then ! check with common node
kcom = 0
exit
end if
end do
! end if
! common node found
if ( kcom.ne.0 ) then
alreadycell = .true.
return
end if
end function alreadycell
! check if cell is counterclockwise
logical function iscounterclockwise(N, K)
use m_netw
implicit none
integer, intent(in) :: N !< number of links and nodes
integer, dimension(N), intent(in) :: K !< node set
integer, parameter :: MMAX = 10
double precision, dimension(MMAX) :: xv, yv
double precision :: xdum, ydum
double precision :: darea
integer :: jacounterclockwise ! counterclockwise (1) or not (0)
integer :: i, ip1, kk, kkp1
iscounterclockwise = .true.
!
! darea = 0d0
! do i=1,N
! ip1 = i+1; if ( ip1.gt.N ) ip1=ip1-N
! kk = K(i)
! kkp1 = K(ip1)
! darea = darea + xk(kk) * (yk(kkp1)-yk(kk)) - yk(kk) * (xk(kkp1)-xk(kk))
! end do
! darea = 0.5d0*darea ! not really necessary
!
! if ( darea.le.0d0 ) then
! iscounterclockwise = .false.
! end if
do i=1,N
kk = K(i)
xv(i) = xk(kk)
yv(i) = yk(kk)
end do
call comp_masscenter(N, xv, yv, xdum, ydum, darea, jacounterclockwise)
if ( jacounterclockwise.eq.1 ) then
iscounterclockwise = .true.
else
iscounterclockwise = .false.
end if
return
end function iscounterclockwise
LOGICAL FUNCTION RECHTSAF(K1,K2,K3)
use m_netw
implicit none
integer :: K1, K2, K3
double precision :: sig
rechtsaf = .false.
return
call duitpl(xk(k1), yk(k1), xk(k2), yk(k2), xk(k2), yk(k2), xk(k3), yk(k3), sig)
if (sig < 0) then
rechtsaf = .true.
else
rechtsaf = .false.
endif
return
end FUNCTION RECHTSAF
SUBROUTINE CONNECT(K1,K2,LFAC,A0,R00)
use m_netw
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
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 CONNECTDBN(K1,K2,LNU)
implicit none
integer :: K1, K2, LNU
if (k1 == k2) return
CALL CONNECTDB(K1,K2,lnu)
CALL ADDLINKTONODES(K1,K2,LNU)
RETURN
END SUBROUTINE CONNECTDBN
SUBROUTINE CONNECTDB(K1,K2,lnu) ! fast version without refinement
use m_netw
implicit none
integer :: K1, K2, LNU
integer :: l
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
! CALL CONFRM('POINTS ALREADY CONNECTED, CONTINUE', JA)
! IF (JA .NE. 1) RETURN
LNU = L
RETURN
ENDIF
ENDDO
LNU = 0
DO L = NUML,1,-1
IF (KN(1,L) .EQ. 0) THEN
LNU = L
EXIT
ENDIF
ENDDO
IF (LNU == 0) THEN ! NO FREE NR
NUML = NUML + 1
LNU = NUML
IF (NUML >= LMAX) THEN
CALL INCREASENETW(NUMK,NUML)
ENDIF
ENDIF
kn(1,lnu) = k1 ; kn(2,lnu) = k2 ; kn(3,lnu) = KN3TYP ! cheap version only to be used icm setnodadm
! mark link as active
lc(lnu) = 1
RETURN
END SUBROUTINE CONNECTDB
SUBROUTINE ADDLINKTONODES(KL,KR,LNU)
use m_netw
implicit none
integer :: KL, KR, LNU
KN(1,LNU) = KL
KN(2,LNU) = KR
NMK(KL) = NMK(KL) + 1
NMK(KR) = NMK(KR) + 1
CALL SETNODLIN(KL,NMK(KL),LNU)
CALL SETNODLIN(KR,NMK(KR),LNU)
IF (KC(KL) .EQ. 0) KC(KL) = 1
IF (KC(KR) .EQ. 0) KC(KR) = 1
RETURN
END SUBROUTINE ADDLINKTONODES
SUBROUTINE SETNODLIN(K,LK,L)
use m_netw
implicit none
integer :: K, LK, L
CALL CHKLINSIZTONODE(K)
NOD(K)%LIN(LK) = L
RETURN
END SUBROUTINE SETNODLIN
SUBROUTINE CHKLINSIZTONODE(KK)
use m_netw
implicit none
integer :: KK
integer :: ierr
integer :: knxk
INTEGER, ALLOCATABLE :: IH(:)
if ( allocated(nod(kk)%lin) ) then ! SPvdP: nod(kk)%lin may not have been allocated
KNXK = SIZE(NOD(KK)%LIN)
IF (NMK(KK) .GT. KNXK) THEN
ALLOCATE (IH(KNXK),STAT=IERR)
IH(1:KNXK) = NOD(KK)%LIN(1:KNXK)
DEALLOCATE (NOD(KK)%LIN)
ALLOCATE (NOD(KK)%LIN(KNXK+1),STAT=IERR) ; NOD(KK)%LIN = 0
NOD(KK)%LIN(1:KNXK) = IH(1:KNXK)
DEALLOCATE(IH)
ENDIF
else
ALLOCATE (NOD(KK)%LIN(1),STAT=IERR) ; NOD(KK)%LIN = 0
end if
RETURN
END SUBROUTINE CHKLINSIZTONODE
SUBROUTINE OGIVENEWLINKNUM(LNU)
use m_netw
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
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 GIVENEWNODENUM(KNU)
use m_netw
implicit none
integer :: KNU
integer :: kx
integer :: lx
IF ( NUMK == SIZE(KC) ) THEN
KX = 1.2*NUMK ; LX = 1.2*NUML
CALL INCREASENETW(KX, LX)
ENDIF
NUMK = NUMK + 1
KNU = NUMK
RETURN
END SUBROUTINE GIVENEWNODENUM
SUBROUTINE OGIVENEWNODENUM(KNU)
use m_netw
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
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
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) ! filnam = mask
USE M_NETW
USE M_FLOWGEOM
use m_missing
use unstruc_messages
use m_kdtree2
IMPLICIT NONE
integer, intent(in) :: n12, lenf !< type of operation (1, 2, 3, 4, 5), see docs below.
CHARACTER(LEN=lenf), intent(in) :: FILNAM
LOGICAL JAWEL
INTEGER N, MPOL, MLIST, KEY, JADEL, NN, L, K, IN, NUMFIL, ierror
CHARACTER(LEN=132), ALLOCATABLE :: FILIST(:)
INQUIRE (FILE = 'cutcellpolygons.lst', EXIST = JAWEL)
NUMFIL = 0
IF (JAWEL) THEN
CALL OLDFIL(MLIST, 'cutcellpolygons.lst')
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
!IF (N12 == 3) THEN
CALL SAVEPOL()
CALL DELPOL()
!ENDIF
KC = 1 ! VOOR NU EVEN, ALLE NET NODES DOEN MEE
if (N12 >= 4) then !prepare for cutcellwu
call build_kdtree( treeglob, numk, xk, yk, ierror )
end if
DO N = 1,NUMFIL
CALL OLDFIL(MPOL,TRIM(FILIST(N)))
CALL REAPOL(MPOL, 0)
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 >= 4) then ! 4 and 5
CALL CUTCELWU(n12)
endif
ENDDO
if (N12 >= 4) then ! cleanup after cutcellwu
call delete_kdtree2(treeglob)
end if
IF (N12 == 3) THEN
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
CALL SETNODADM(0)
ENDIF
call restorepol()
DEALLOCATE ( filist )
END SUBROUTINE cutcell_list
subroutine delnetzkabovezkuni()
use m_netw
USE M_MISSING
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
implicit none
integer :: KEY, jacheckcells, JASAVE
integer :: inhul, inall, ip, ic, n, k
integer :: ja
integer :: k1
integer :: k2
integer :: l
! delete grid
DOUBLE PRECISION :: XL, YL
inhul = -1 ; inall = 1
IF (JASAVE .EQ. 1) CALL SAVE()
KEY = 3
IF (NPL .LE. 2) THEN
CALL CONFRM('NO POLYON, SO DELETE all NET POINTS ? ',JA)
IF (JA .EQ. 0) THEN
KEY = 0
ELSE
CALL ZERONET()
ENDIF
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)
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)
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)
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)
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)
IF (INHUL .EQ. 1) THEN
KN(1,L) = 0 ; KC(K1) = 0
KN(2,L) = 0 ; KC(K2) = 0
ENDIF
ENDIF
ENDDO
else
do k = 1,numk
CALL DBPINPOL( Xk(k), Yk(k), INHUL)
if (inhul == 1) then
xk(k) = dmiss ; yk(k) = dmiss
endif
enddo
end if
CALL SETNODADM(0)
if ( jacheckcells == 0) 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
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
!
! implicit none
! double precision :: crp
! integer :: in1
! integer :: in2
! integer :: ja
! integer :: jacros
! integer :: k
! integer :: k1
! integer :: k2
! integer :: k3
! integer :: ku
! integer :: l
! integer :: lnu
! double precision :: sl
! double precision :: sm
! double precision :: xcr
! double precision :: ycr
! double precision :: z
! double precision :: zcr
! double precision :: 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)
! CALL DPINPOK( XK(K2), YK(K2), ZK(K2), NPL, XPL, YPL, IN2)
! 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)
! IF (JACROS .EQ. 1) THEN
! LNU = L
! CALL DELELEM(K1,K2,LNU)
! 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
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)
CALL DPINPOK( XK(K2), YK(K2), ZK(K2), NPL, XPL, YPL, IN2)
! 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
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)
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
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)
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
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)
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
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 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 DRIETWEE(XD,YD,ZD,X,Y,Z)
implicit none
integer :: jav
integer :: jview
double precision :: xyz
DOUBLE PRECISION XD,YD,ZD,X,Y,Z
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
IF (JVIEW .EQ. 1) THEN ! NORMAL
X = XD
Y = YD
Z = ZD
ELSE IF (JVIEW .EQ. 2) THEN ! FROM LEFT
X = ZD
Y = YD
Z = XD
ELSE IF (JVIEW .EQ. 3) THEN ! FROM TOP
X = XD
Y = -ZD
Z = YD
ELSE IF (JVIEW .EQ. 4) THEN
! CALL DVIEW(XD,YD,-ZD,X,Y,Z)
CALL DVIEW(XD,YD,-ZD,X,Y,Z)
ENDIF
RETURN
END SUBROUTINE DRIETWEE
SUBROUTINE TWEEDRIE(X,Y,XD,YD,ZD)
implicit none
integer :: jav
integer :: jview
double precision :: xyz
double precision :: X,Y,XD,YD,ZD
COMMON /HOWTOVIEW/ JVIEW, JAV, XYZ ! 1,2,3 OF 4
IF (JVIEW .EQ. 1) THEN
XD = X
YD = Y
ZD = XYZ
ELSE IF (JVIEW .EQ. 2) THEN
ZD = X
YD = Y
XD = XYZ
ELSE IF (JVIEW .EQ. 3) THEN
XD = X
ZD = -Y
YD = XYZ
ELSE IF (JVIEW .EQ. 4) THEN
! CALL DVIEW(XD,YD,ZD,X,Y,Z) ! MOET NOG INVERS MAKEN
XD = X
YD = Y
ZD = XYZ
ENDIF
RETURN
END SUBROUTINE TWEEDRIE
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 DVIEW(XD,YD,ZD,X,Y,Z)
use m_missing
implicit none
double precision :: ce
integer :: i
double precision :: vs
double precision :: x0s
double precision :: y0s
! GEEF perspectievische COORDINATEN
! xD,yD,zD :coordinaten te tekenen punt
! x0s,y0s :waar op scherm ligt kijklijn
! X,Y,Z :scherm coordinaten
! Vs :viewing matrix na viema
DOUBLE PRECISION XD,YD,ZD,X,Y,Z
COMMON /VIEWMAT/ VS(4,4), X0S, Y0S
DIMENSION CE(4)
! use z as zd temporarily (zet to zero when zd==dmiss)
if (zd == dmiss) then
z = 0
else
z = zd
end if
DO I = 1,3
CE(I) = VS(I,1)*XD + VS(I,2)*YD + VS(I,3)*Z + VS(I,4)
ENDDO
Z = CE(3)
IF (Z .LT. 0) THEN
Z = dmiss
ELSE
X = CE(1)/Z + X0S
Y = CE(2)/Z + Y0S
ENDIF
END SUBROUTINE DVIEW
SUBROUTINE NODTOALL()
use m_netw
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 INDEXX(N,ARRIN,INDX)
implicit none
integer :: i
integer :: indxt
integer :: ir
integer :: j
integer :: l
double precision :: q
integer :: N
double precision :: ARRIN(N)
integer :: INDX(N)
DO J=1,N
INDX(J)=J
ENDDO
IF (N == 1) RETURN
L=N/2+1
IR=N
10 CONTINUE
IF(L.GT.1)THEN
L=L-1
INDXT=INDX(L)
Q=ARRIN(INDXT)
ELSE
INDXT=INDX(IR)
Q=ARRIN(INDXT)
INDX(IR)=INDX(1)
IR=IR-1
IF(IR.EQ.1)THEN
INDX(1)=INDXT
RETURN
ENDIF
ENDIF
I=L
J=L+L
20 IF(J.LE.IR)THEN
IF(J.LT.IR)THEN
IF(ARRIN(INDX(J)).LT.ARRIN(INDX(J+1)))J=J+1
ENDIF
IF(Q.LT.ARRIN(INDX(J)))THEN
INDX(I)=INDX(J)
I=J
J=J+J
ELSE
J=IR+1
ENDIF
GO TO 20
ENDIF
INDX(I)=INDXT
GO TO 10
END SUBROUTINE INDEXX
SUBROUTINE INDEXXI(N,ARRIN,INDX)
implicit none
integer :: i
integer :: indxt
integer :: ir
integer :: j
integer :: l
integer :: q
integer :: N
integer :: ARRIN(N)
integer :: INDX(N)
DO J=1,N
INDX(J)=J
ENDDO
IF (N == 1) RETURN
L=N/2+1
IR=N
10 CONTINUE
IF(L.GT.1)THEN
L=L-1
INDXT=INDX(L)
Q=ARRIN(INDXT)
ELSE
INDXT=INDX(IR)
Q=ARRIN(INDXT)
INDX(IR)=INDX(1)
IR=IR-1
IF(IR.EQ.1)THEN
INDX(1)=INDXT
RETURN
ENDIF
ENDIF
I=L
J=L+L
20 IF(J.LE.IR)THEN
IF(J.LT.IR)THEN
IF(ARRIN(INDX(J)).LT.ARRIN(INDX(J+1)))J=J+1
ENDIF
IF(Q.LT.ARRIN(INDX(J)))THEN
INDX(I)=INDX(J)
I=J
J=J+J
ELSE
J=IR+1
ENDIF
GO TO 20
ENDIF
INDX(I)=INDXT
GO TO 10
END SUBROUTINE INDEXXi
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
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)
ENDIF
KIN(K) = IN
ENDDO
ENDIF
END SUBROUTINE DSELECTINP
SUBROUTINE SELLLINKSINPOL(LIN,N)
use m_netw
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 :: xpmax
double precision :: xpmin
double precision :: yp1
double precision :: yp2
double precision :: ypmax
double precision :: ypmin
IF (NPL < 3) THEN
LIN = 1
ELSE
CALL MINMAXPOL(XpMIN, YpMIN, XpMAX, YpMAX)
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 >= XpMIN .AND. Xp1 <= XpMAX .AND. Yp1 >= YpMIN .AND. Yp1 <= YpMAX .AND. &
Xp2 >= XpMIN .AND. Xp2 <= XpMAX .AND. Yp2 >= YpMIN .AND. Yp2 <= YpMAX ) THEN
CALL PINPOK(Xp1, Yp1, NPL, XPL, YPL, IN)
CALL PINPOK(Xp2, Yp2, NPL, XPL, YPL, IN2)
LIN(L) = in*in2
ELSE
LIN(L) = 0
ENDIF
ENDDO
ENDIF
END SUBROUTINE SELLLINKSINPOL
SUBROUTINE DELLINKSINPOL()
use m_netw
implicit none
integer :: in
integer :: in2
integer :: k1
integer :: k2
integer :: l
double precision :: xp1
double precision :: xp2
double precision :: xpmax
double precision :: xpmin
double precision :: yp1
double precision :: yp2
double precision :: ypmax
double precision :: ypmin
IF (NPL == 0) THEN
RETURN
ELSE
CALL MINMAXPOL(XpMIN, YpMIN, XpMAX, YpMAX)
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 >= XpMIN .AND. Xp1 <= XpMAX .AND. Yp1 >= YpMIN .AND. Yp1 <= YpMAX .AND. &
Xp2 >= XpMIN .AND. Xp2 <= XpMAX .AND. Yp2 >= YpMIN .AND. Yp2 <= YpMAX ) THEN
CALL PINPOK(Xp1, Yp1, NPL, XPL, YPL, IN)
CALL PINPOK(Xp2, Yp2, NPL, XPL, YPL, IN2)
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_TRIANGLE
USE M_POLYGON
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
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, dbdistance
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)
! 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)
rout = areatot / R01
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x0,y0,x2,y2,x4,y4,xn,yn, JA)
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)
rout = areatot / R01
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x0,y0,x3,y3,x4,y4,xn,yn, JA)
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)
rout = areatot / R23
if (jsferic==1) then
rout = rout*RD2DG / ra
end if
call normaloutchk(x2,y2,x3,y3,x4,y4,xn,yn, JA) ! 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)
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)
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)
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)
!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)
R01 = DBDISTANCE(X0,Y0,X1,Y1)
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)
X1 = xbd(1,K0) ; Y1 = ybd(1,K0)
R01 = DBDISTANCE(X0,Y0,X1,Y1)
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)
CALL DLINEDIS(X0,Y0,XK0(K),YK0(K),X3,Y3,JA3,DIS3,X3,Y3)
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
implicit none
double precision, external :: dcosphi
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 if (kn(3,l) == 1 .or. (kn(3,L) == 2 .and. lnn(L) == 0)) then ! 1D-links sowieso niet meenemen.
nb(k1) = -1 ! or empty 2D
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)) > -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
implicit none
DOUBLE PRECISION :: DBDISTANCE, R01, R02, AN1, AN2, XL, YL, XR, YR, XZWr, YZWr, ZZZ
INTEGER :: KL1, KL2, KN1a, KN2a, L, jaremove
DOUBLE PRECISION :: AREA, TAREA, COSMIN, COSPHI, DCOSPHI, 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 SAVE()
CALL SETNODADM(0) !
CALL REMOVECOINCIDINGTRIANGLES() !
CALL FINDCELLS(0)
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) ! 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)) )
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)
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
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)
!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)
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)
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)
!DX0 = GETDX(X0,Y0,XN,YN)
!DY0 = GETDY(X0,Y0,XN,YN)
call getdxdy(X0,Y0,XN,YN,dx0,dy0)
CALL DLINEDIS(X3,Y3,X1,Y1,X2,Y2,JA,DIS,XN,YN)
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)
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)
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
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)
XN = 3*XN - 2*X0
YN = 3*YN - 2*Y0
RETURN
END SUBROUTINE MIRRORLINE2
SUBROUTINE GETQUAD(LN,K1,K2,K3N,K4N)
use m_netw
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
SUBROUTINE DELSAM(JACONFIRM) ! SPvdP: need promptless delsam in orthogonalisenet
USE M_SAMPLES
use M_POLYGON
USE M_MISSING
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
deallocate (xs, ys, zs)
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
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)
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)
ENDIF
20 CONTINUE
NS = K
DO 30 I = NS+1,NSOL
XS(I) = DMISS
YS(I) = DMISS
ZS(I) = DMISS
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
WRITE (MSAM,'(3(F16.7))') XS(I), YS(I), ZS(I)
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
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
DOUBLE PRECISION, EXTERNAL :: DBDISTANCE
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)
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)
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) )
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
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
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)
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
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)
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_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)
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
SUBROUTINE SWAPSAMPLES()
USE M_SAMPLES
USE M_SAMPLES3
implicit none
integer :: i
integer :: nh
integer :: nn
DOUBLE PRECISION :: XH, YH, ZH
IF (NSMAX < NS3) THEN
CALL increasesam(NS3)
ELSE IF (NS3 < NS) THEN
CALL increasesam3(NS)
ENDIF
NN = MAX(NS,NS3)
NH = NS ; NS = NS3 ; NS3 = NH
DO I = 1, NN
XH = XS(I) ; XS(I) = XS3(I) ; XS3(I) = XH
YH = YS(I) ; YS(I) = YS3(I) ; YS3(I) = YH
ZH = ZS(I) ; ZS(I) = ZS3(I) ; ZS3(I) = ZH
ENDDO
END SUBROUTINE SWAPSAMPLES
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
USE M_SAMPLES
USE M_SAMPLES2
USE M_TRIANGLE
USE M_POLYGON
USE M_ALLOC
implicit none
integer :: jadoorladen
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)
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)
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)
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()
call delsam(1)
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
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)
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_SAMPLES2
USE M_TRIANGLE
USE M_POLYGON
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 :: DBDISTANCE, 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)
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) )
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)
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)
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)
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 INCELLS(XA,YA,KIN)
use m_netw
implicit none
double precision :: xa
double precision :: ya
integer :: kin
integer :: in
integer :: k
integer :: k1
integer :: n
integer :: nn
double precision :: XH(6), YH(6)
KIN = 0
DO K = 1,NUMP
NN = netcell(K)%N
DO N = 1,NN
K1 = netcell(K)%NOD(N)
XH(N) = XK(K1) ; YH(N) = YK(K1)
ENDDO
CALL PINPOK(XA, YA , NN, XH, YH, IN)
IF (IN == 1) THEN
KIN = K
RETURN
ENDIF
ENDDO
END SUBROUTINE INCELLS
SUBROUTINE in_flowcell(xp,yp,kk)
use m_flowgeom
implicit none
double precision :: xp
double precision :: yp
integer :: in
integer :: k
integer :: kk
integer :: nn
kk = 0
DO K = 1,ndx
if (.not. allocated(nd(K)%x)) cycle
!NN = size(nd(K)%nod)
NN = size(nd(K)%x)
CALL PINPOK(xp, yp , NN, nd(K)%x, nd(K)%y, IN)
IF (IN == 1) THEN
KK = K
RETURN
ENDIF
ENDDO
END SUBROUTINE in_flowcell
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_TRIANGLE
USE M_POLYGON
use m_netw
USE M_SAMPLES
use M_MISSING
use m_sferic
use m_alloc
implicit none
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, xpmin, xpmax, ypmin, ypmax
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.
xpmin = 0d0; xpmax = dlenpol/4d0; ypmin = 0d0; ypmax = dlenpol/4d0
call get_startend(NPL,XPL,YPL,n, nn)
if (nn > n) then
xpmin = minval(xpl(n:nn))
xpmax = maxval(xpl(n:nn))
ypmin = minval(ypl(n:nn))
ypmax = maxval(ypl(n:nn))
end if
triarea = triarea * (xpmax-xpmin)*(ypmax-ypmin)/arepol
NTX = SAFESIZE * (xpmax-xpmin)*(ypmax-ypmin)/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)) = 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)
IF (IN == 1) THEN
NS = NS + 1
XS(NS) = XP ; YS(NS) = YP
ENDIF
ENDDO
! CALL REMOVESAMPLESONTOPOFNETPOINTS(XS(NS1), YS(NS1), NN )
! CALL DELPOL()
RETURN
END SUBROUTINE CREATESAMPLESINPOLYGON
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_TRIANGLE
USE M_SFERIC
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, DCOSPHI, 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)
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_TRIANGLE
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, DCOSPHI, 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)
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
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
double precision, external :: dbdistance
if (jaregrid == 1) then
call savepol()
endif
call save()
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
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)
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
double precision :: dbdistance
T(1) = 0d0
DO K = 2,MMAX
T(K) = T(K-1) + dbdistance( x(k), y(k), x(k-1), y(k-1) )
ENDDO
RETURN
END SUBROUTINE accumulateDistance
!> Refine entire current polygon from start to end.
subroutine refinepolygon()
use m_polygon, only: npl
implicit none
integer :: i1, i2
i1 = 1
i2 = npl
call refinepolygonpart(i1,i2)
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) !DPLA = ACTUELE LENGTECOOR, DXA = ACTUELE GRIDSIZE, DXS = STREEF GRIDSIZE, ALLEN OP POLYGONPOINTS
USE M_POLYGON
USE M_MISSING
USE M_TRIANGLE
USE M_SAMPLES
use m_alloc
implicit none
integer :: i1, i2
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(:), DPL (:)
DOUBLE PRECISION, ALLOCATABLE :: XH (:) , YH(:), 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 (NO < 4 ) return
NPLO = NPL ! Back up current poly length
NPL = NO
NX = 10*NO
ALLOCATE ( XPLO(NPLO), YPLO(NPLO), DPL(NPLO) , STAT = IERR)
CALL AERR('XPLO(NPLO), YPLO(NPLO), DPL(NPLO)', IERR, 3*NPLO)
do kk=i1,NPLO
XPLO(kk-i1+1) = XPL(kk)
YPLO(kk-i1+1) = YPL(kk)
end do
ALLOCATE ( XH(NX), YH(NX) , STAT= IERR ) ; XH = DXYMIS ; YH = DXYMIS
CALL AERR('XH(NX), YH(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
DXS1 = 1d0*DXA(1) ! Start segment
DXS2 = 1d0*DXA(NO) ! Eind segment
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(NMN) > 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(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)
end do
do kk=1,NPL
XPL(i1+kk-1) = XH(kk)
YPL(i1+kk-1) = YH(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)
end do
NPL=NPLO-NO+NPL
DEALLOCATE (XPLO, YPLO, DPL, XH, YH, DPLA, DXA, DXS)
END SUBROUTINE REFINEPOLYGONpart
SUBROUTINE INTDXSTRI(XH,YH,DXS,NPH,JDLA)
USE M_MISSING
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)
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
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
implicit none
integer :: n1
double precision :: XP1, YP1
double precision :: dbdistance
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)
IF (JA .EQ. 1) THEN
IF (DIS .LT. DISMIN) THEN
N1 = L
DISMIN = DIS
ENDIF
ENDIF
ENDIF
ENDDO
IF (N1 .NE. 0) THEN
K1 = LN(1,n1) ; K2 = LN(2,n1)
IF (dbdistance(XP1,YP1,XZ(K1),YZ(K1)) < dbdistance(XP1,YP1,XZ(K2),YZ(K2)) ) THEN
N1 = K1
ELSE
N1 = K2
ENDIF
ENDIF
END SUBROUTINE CLOSETO1DORBND
SUBROUTINE CLOSEdefinedflownode(XP1,YP1,N1) !
use m_FLOWGEOM
use m_flow
implicit none
integer :: n1
double precision :: XP1, YP1
double precision :: dbdistance
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))
IF (dis < dismin) then
n1 = n ; dismin = dis
endif
endif
enddo
end subroutine CLOSEdefinedflownode
SUBROUTINE CLOSENETBNDLINK(XP1,YP1,N1)
use m_netw
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)
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
implicit none
integer :: n1
double precision :: XP1, YP1, XN1,YN1
double precision, intent(out) :: DIST !< distance to 1D link
double precision :: dbdistance
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) 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)
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 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
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
LOGICAL dINVIEW
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)
call pinpok(xb,yb,NPL,XPL,YPL,inb)
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(numl+numk, 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
subroutine copynetboundstopol(inpol,needfindcells)
use m_alloc
use m_polygon
use m_missing
use network_data
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 :: 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
integer, allocatable :: jalinkvisited(:)
integer, allocatable :: isegstart(:)
double precision :: xkb, ykb, zkb, SL,SL0,sl1, sl2,SM,XCR,YCR,CRP
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) == 1) cycle
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)
call dbpinpol(XK(kn(2,L)), YK(kn(2,L)), inhul2)
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)
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)
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)
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)
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
do i2=ia,ic
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)
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)
! polygon changed: set netstat to dirty
netstat = NETSTAT_CELLS_DIRTY
end subroutine copynetboundstopol
!> Copy the original polygons that define the current cross sections
!! to the active polygons in xpl,...
subroutine copyCrossSectionsToPol()
use m_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_crosssections
use m_flowgeom, only: Lnx
use m_missing
use m_kdtree2
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
if ( ncrs.lt.1 ) return
! allocate
allocate(istartcrs(ncrs+1))
istartcrs = 1
allocate(idum(1))
idum = 0
if ( jakdtree.eq.1 ) then
num = 0
! determine polyline size
do ic=1,ncrs
num = num+crs(ic)%path%np+1 ! add space for missing value
istartcrs(ic+1) = num+1
end do
! allocate
allocate(xx(num), yy(num))
! determine paths to single polyline map
num = 0
do ic=1,ncrs
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 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)
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
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 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)
end if
icMOD = MAX(1,ncrs/100)
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 ( jakdtree.eq.0 ) then
call crspath_on_flowgeom(crs(ic)%path,0,0,1,idum)
else
call crspath_on_flowgeom(crs(ic)%path,0,1,numlist(ic),linklist(1,ic))
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 m_kdtree2
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)
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)
use m_crspath
use m_flowgeom
use network_data
use m_sferic
use m_partitioninfo
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 :: 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(:)
double precision, external :: dbdistance
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)) == 1) then
! For 1D links: produce fictious 'cross/netlink'
call normalout(xz(n1), yz(n1), xz(n2), yz(n2), xn, yn)
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
else
! 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))
end if
call crspath_on_singlelink(path, Lf, x1, y1, x2, y2, xz(n1), yz(n1), xz(n2), yz(n2))
enddo
if ( path%lnx.gt.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))
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) 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.
!! Stored in crs()%sumvalcur/sumvalcum
subroutine updateValuesOnCrossSections(tim1)
use m_crosssections
use m_missing
use m_transport , only: NUMCONST
implicit none
double precision, intent(in) :: tim1 !< Current (new) time
double precision, save :: timprev = -1d0
double precision, save :: timstart
double precision :: timstep, timtot
double precision, dimension(:,:), allocatable :: valu
integer :: iv, icrs, numvals
numvals = 5 + NUMCONST
! allocate
allocate(valu(numvals,ncrs))
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(valu, numvals)
do icrs=1,ncrs
do iv = 1, numvals ! Nu nog "5+ Numconst" standaard grootheden, in buitenlus
crs(icrs)%sumvalcur(iv) = valu(iv,icrs)
crs(icrs)%sumvalcum(iv) = crs(icrs)%sumvalcum(iv) + timstep*valu(iv,icrs)
if (timtot > 0d0) then
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcum(iv)/timtot
else
crs(icrs)%sumvalavg(iv) = crs(icrs)%sumvalcur(iv)
end if
end do
end do
timprev = tim1
! deallocate
if ( allocated(valu) ) deallocate(valu)
end subroutine updateValuesOnCrossSections
!> compute cross-section data for all cross-sections
subroutine sumvalueOnCrossSections(resu, numvals)
use m_flow
use m_flowgeom
use m_crosssections
use m_partitioninfo
use m_timer
use m_transport, only: NUMCONST, ISALT, ITEMP, ISED1, ITRA1, constituents
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_crosssections
integer :: i, Lf, L, k1, k2, IP, num, LL
integer :: icrs
double precision :: val
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) ! weigted waterdepth
if( jatransportmodule == 1 ) then
IP = IPNT_HUA
do num = 1,NUMCONST
IP = IP + 1
do LL = Lbot(L), Ltop(L)
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
end do
end do ! do icrs=1,ncrs
if ( jampi.eq.1 ) then
if ( jatimer.eq.1 ) call starttimer(IOUTPUTMPI)
call reduce_crs(resu,ncrs,numvals)
if ( jatimer.eq.1 ) call stoptimer(IOUTPUTMPI)
end if
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 ! do icrs=1,ncrs
!! 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
subroutine obs_on_flowgeom(iobstype)
use m_observations
use unstruc_messages
use m_partitioninfo
use m_flowgeom, only : xz,yz,ndx2D,ndxi
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, external :: dbdistance
double precision :: d1, d2
integer :: 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
call find_flownode(n2-n1+1, xobs(n1:n2), yobs(n1:n2), namobs(n1:n2), kobs(n1:n2), jakdtree, 1)
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)
use unstruc_messages
use m_partitioninfo
use m_flowgeom
use m_kdtree2
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 :: ierror ! error (1) or not (0)
integer :: i, k, k1b
integer, dimension(1) :: idum
double precision, external :: dbdistance
double precision :: d1, d2
ierror = 1
if ( jakdtree.eq.1 ) then
call find_flowcells_kdtree(treeglob,N,xobs,yobs,kobs,jaoutside,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)
if ( jaoutside.eq.1 ) 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) )
D2 = DBDISTANCE(XZ(K ), YZ(K ), XOBS(I), YOBS(I) )
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 observation point #', i, ' (', trim(namobs(i)), '). Discarding.'
call msg_flush()
endif
end do
ierror = 0
1234 continue
return
end subroutine find_flownode
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
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(40)
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
DOUBLE PRECISION :: dcosphi
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) )
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
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
double precision, external :: dbdistance
ierror = 1
if ( NPL.lt.3 ) goto 1234
! get the first polygon
call get_startend(NPL,XPL,YPL,jstart,jend)
! 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)
! 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
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
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)
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)
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
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
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
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 = DTOT / unidx1D + 1
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
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
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
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
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
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
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, dbdistance, 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
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, dbdistance, 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
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 :: zzz, 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
integer :: NDRAW
common /DRAWTHIS/ NDRAW(40)
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)
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
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) == 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
!-------------------------------------------------
call readyy('Orthogonalising net',0d0)
tp:do no = 1,itatp
! call removesmalllinks()
xk1(1:numk) = xk(1:numk)
yk1(1:numk) = yk(1:numk)
call readyy('Orthogonalising net',dble(no-1+.35d0)/itatp)
!------------------------------------------------------------------------
! grid refinement
!------------------------------------------------------------------------
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
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)) )
! 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) ! ,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
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
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
y1 = yk1(k1)
DUM(1) = wwx * Ra * dg2rd * dcos(0.5d0*(y00+y1)*dg2rd)
DUM(2) = wwy * Ra * dg2rd
else
DUM(1) = wwx
DUM(2) = wwy
end if
w0 = w0 + DUM
x0 = x0 + DUM(1) * xk(k1)
y0 = y0 + DUM(2) * yk(k1)
! 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
x0 = (x0 + righthandside(1)) / w0(1)
y0 = (y0 + righthandside(2)) / w0(2)
xk1(k) = relaxin*x0 + relax1*xk(k) !hk: trying to remove wiggles in high aspect ratio cells
yk1(k) = relaxin*y0 + relax1*yk(k)
else
call cirr(xk1(k), yk1(k), ncolhl)
! call qnerror('orthogonalisenet: w0=0', ' ', ' ')
cycle ndki
! goto 1234
! iexit = 1
end if
enddo ndki
enddo
! project boundary nodes back to the boundary
if ( JAPROJECT.ge.1 ) then
call orthonet_project_on_boundary(nmkx, kk1, k_bc, xkb, ykb)
end if
! 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)
!-------------------------------------------------
! 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
!> 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
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 :: dbdistance, dprodin, getdx, getdy, dcosphi
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 = xk1(k0)
y0 = yk1(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)
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
call normaloutchk(x0, y0, x1, y1, x3, y3, xn, yn, ja)
if (JSFERIC.eq.1) 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).gt.1 ) 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, 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
! 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)) )
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)) )
! 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 coefficentmatrix 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 angel 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 = xk1(k0)
y0 = yk1(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
xk1(k0) = x0 ; yk1(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
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, dbdistance
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)
! 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)
! 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
implicit none
integer :: kk !< link number
double precision :: dbdistance
dblinklength = dbdistance(xk(kn(1,kk)), yk(kn(1,kk)), xk(kn(2,kk)), yk(kn(2,kk)))
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
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, external :: dcosphi
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 = xk1(k1)
y1 = yk1(k1)
x2 = xk1(k2)
y2 = yk1(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 = xk1(k3)
y3 = yk1(k3)
cosphi = dcosphi(x2,y2, x1,y1, x1,y1, x3,y3)
! 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 = xk1(k3)
y3 = yk1(k3)
cosphi = dcosphi(x1,y1, x2,y2, x2,y2, x3,y3)
! 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
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, external :: dcosphi, dbdistance
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
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, external :: dcosphi, dbdistance
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
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
!--------------------------------------------------------------
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
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
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
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)
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
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
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))
allocate(linnrs(maxlin),arglin(maxlin),inn(maxlin))
! open(666, file='test.m')
! write(666, "('data=[')")
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)
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)
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 save()
! Emin = Etot
! end if
end do
! 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 links in nod%lin counterclockwise (copy-paste from setnodadm)
subroutine sort_links_ccw(k,maxlin,linnrs,arglin,inn)
use m_netw
use m_sferic
implicit none
integer, intent(in) :: k !< node number
integer, intent(in) :: maxlin !< array size
double precision, intent(inout) :: arglin(maxlin) ! dummy array
integer, intent(inout) :: linnrs(maxlin), inn(maxlin) ! dummy arrays
integer :: k1, k2, L, LL
integer :: jDupLinks, jOverlapLinks, jSmallAng
double precision :: sl, sm, xcr, ycr, phi0
double precision :: getdx, getdy, dcosphi
double precision :: phi, dx, dy, dmaxcosp, dcosp, costriangleminangle
do L=1,NMK(K)
K1 = KN(1,nod(K)%lin(L)); K2 = KN(2,nod(K)%lin(L))
if (K2 == K) then
K2 = K1
K1 = K
end if
!dx = getdx(xk(k1), yk(k1), xk(k2), yk(k2))
!dy = getdy(xk(k1), yk(k1), xk(k2), yk(k2))
call getdxdy(xk(k1), yk(k1), xk(k2), yk(k2),dx,dy)
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(nmk(k), arglin(1:nmk(k)), inn(1:nmk(k)))
linnrs(1:nmk(k)) = nod(k)%lin(1:nmk(k))
do L=1,nmk(k)
nod(k)%lin(L) = linnrs(inn(L))
end do
return
end subroutine sort_links_ccw
!> sort flowlinks in nd%lin 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
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 :: getdx, getdy, dcosphi
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)
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
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
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(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
if ( lnn(L1).lt.1 .or. kn(3,L1).eq.1 ) 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 ) 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 ) 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
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
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
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)
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)
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
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)
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
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
double precision :: dcosphi
logical :: rechtsaf
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))
! 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
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)
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)
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)
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
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
double precision, external :: dbdistance
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)
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)
dl2 = dbdistance(xn2,yn2,xn3,yn3)
! 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)
if ( ddis3.gt.ddmax) ddmax = ddis3
end do
dL = dL + dbdistance(xlan(j2),ylan(j2),xn2,yn2)
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)
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)
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
double precision, external :: dbdistance
! 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)
call dbpinpol(xend,yend,inend)
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)
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)
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)
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
double precision, external :: dbdistance
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)
call dbpinpol(xend,yend,inend)
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).le.dbdistance(xk(kb),yk(kb),xstart,ystart) ) then
kstart = ka
else
kstart = kb
end if
kd = kn(1,Lend)
ke = kn(2,Lend)
if ( dbdistance(xk(kd),yk(kd),xend,yend).le.dbdistance(xk(ke),yk(ke),xend,yend) ) 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
implicit none
integer, intent(in) :: k !< node number
integer :: kother, kk, L, in
double precision :: x1, y1, x2, y2
double precision, external :: dbdistance
! 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)
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)
if ( in.ne.1 ) cycle
dmeshwidth = max(dmeshwidth, dbdistance(x1,y1,x2,y2))
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_missing
use m_netw
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
double precision, external :: dbdistance
! 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)
call dbpinpol(xlan(i+1),ylan(i+1),ja2)
! 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)
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)
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)
! 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
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
double precision, external :: dbdistance
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)
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)
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
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)
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()
implicit none
integer :: numseg1, numseg2
double precision :: xL1, yL1, xL2, yL2
double precision, external :: dbdistance
! 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)) .le. dbdistance(xk(k),yk(k),xlan(jend),ylan(jend)) ) 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)) .le. dbdistance(xk(k),yk(k),xlan(jend),ylan(jend)) ) 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
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 :: dbdistance, 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)
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)
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
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 :: dbdistance, 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
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 :: dbdistance, 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)), 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)
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
double precision, external :: dbdistance
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)
end do
return
end function splinelength_int
!> approximate spline length
double precision function splinelength(num, xspl, yspl)
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
double precision, external :: dbdistance
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)
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
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
double precision, external :: dbdistance, dcosphi
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)).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)).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)).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)).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))
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))
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
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, external :: dbdistance, dcosphi
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(40)
! 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)))
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)) .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
double precision, external :: dbdistance
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
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, external :: dbdistance
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)).le.dtolLR ) then
cycle
end if
! check for one-sided differentials
if ( dbdistance(xc(iL),yc(iL),xc(i),yc(i)).le.dtolLR .or. &
dbdistance(xc(iR),yc(iR),xc(i),yc(i)).le.dtolLR ) then
call normalout(xc(iR),yc(iR),xc(iL),yc(iL),nL(1),nL(2))
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))
call normalout(xc(iR),yc(iR),xc(i),yc(i),nR(1),nR(2))
! 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
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 :: dbdistance, 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)
d1 = dbdistance(x,y,x1,y1)
call getdxdy(x,y,x1,y1,dsx,dsy)
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
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, external :: dbdistance
! 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)).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)).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
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, dbdistance
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))
! 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))
! if ( dL2.lt.dtolLR ) cycle
if ( dbdistance(x1(1),x1(2),x3(1),x3(2)).lt.dtolLR .or. dbdistance(x2(1),x2(2),x4(1),x4(2)).lt.dtolLR ) cycle
if ( dbdistance(x2(1),x2(2),x3(1),x3(2)).lt.dtolLR .or. dbdistance(x1(1),x1(2),x4(1),x4(2)).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))
d2 = dbdistance(x2(1),x2(2),x3(1),x3(2))
d3 = dbdistance(x1(1),x1(2),x4(1),x4(2))
d4 = dbdistance(x2(1),x2(2),x4(1),x4(2))
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 m_sferic
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 :: dbdistance, 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))
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
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, dbdistance
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)
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)
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
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)
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
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)
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 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
double precision, external :: dbdistance, dcosphi
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).lt.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))
dcos2 = dcosphi(xk(kLLL), yk(kLLL), xk(kLL), yk(kLL), &
xk(kL), yk(kL), xk(kp), yk(kp))
dcos3 = dcosphi(xk(kLLL), yk(kLLL), xk(kLL), yk(kLL), &
xk(kLL), yk(kLL), xk(kp), yk(kp))
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))
dcos2 = dcosphi(xk(kRRR), yk(kRRR), xk(kRR), yk(kRR), &
xk(kR), yk(kR), xk(kp), yk(kp))
dcos3 = dcosphi(xk(kRRR), yk(kRRR), xk(kRR), yk(kRR), &
xk(kRR), yk(kRR), xk(kp), yk(kp))
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
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)
double precision :: zzz
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
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
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
!> bilinear interpolation of structed sample data at points
subroutine bilin_interp(Nc, xc, yc, zc)
use m_samples
use m_missing
implicit none
integer, intent(in) :: Nc !< number of points to be interpolated
double precision, dimension(Nc), intent(in) :: xc, yc !< point coordinates
double precision, dimension(Nc), intent(out) :: zc !< interpolated point values
double precision :: xi, eta
integer :: ierror
integer :: k
ierror = 1
if ( MXSAM.eq.0 .or. MYSAM.eq.0 ) then
call qnerror('bilin_interp: sample data is unstructured', ' ', ' ')
goto 1234
end if
xi = 0d0
eta = 0d0
do k=1,Nc
if ( zc(k).eq.DMISS ) then
call bilin_interp_loc(MXSAM, MYSAM, MXSAM, MYSAM, 1, XS, YS, ZS, xc(k), yc(k), xi, eta, zc(k), ierror)
end if
end do
ierror = 0
! error handling
1234 continue
return
end subroutine bilin_interp
!> bilinear interpolation between nodes
subroutine bilin_interp_loc(Nxmax, Nymax, Nx, Ny, NDIM, x, y, z, xp, yp, xi, eta, zp, ierror)
use m_missing
implicit none
integer, intent(in) :: Nxmax, Nymax !< node array size
integer, intent(in) :: Nx, Ny !< actual sizes
integer, intent(in) :: NDIM !< sample vector dimension
double precision, dimension(Nxmax,Nymax), intent(in) :: x, y !< node coordinates
double precision, dimension(NDIM,Nxmax,Nymax), intent(in) :: z !< node values
double precision, intent(in) :: xp, yp !< interpolant coordinates
double precision, intent(inout) :: xi, eta !< interpolant index coordinates (in: first iterate)
double precision, dimension(NDIM), intent(out) :: zp !< interpolant value
integer, intent(out) :: ierror !< error (1) or not (0)
double precision :: x1, y1
double precision, dimension(NDIM) :: z1
double precision, dimension(2,2) :: DxDxi, DxiDx
double precision :: Dx, Dy ! residual (in Cartesian coordinates always)
double precision :: Dxi, Deta
double precision :: eps, epsprev
double precision :: det
integer :: iter, ierror_loc
double precision, parameter :: dtol = 1d-6
double precision, parameter :: dmaxincrease = 100
integer, parameter :: MAXITER = 1000
double precision, parameter :: dmindif = 1d-2
double precision, external :: getdx, getdy
ierror = 1
zp = DMISS
! set realistic start values
xi = min(max(xi, 0d0),dble(Nx)-1d0)
eta = min(max(eta,0d0),dble(Ny)-1d0)
! Newton iterations
eps = 1d99
epsprev = 2d0*eps
do iter=1,MAXITER
call comp_x_DxDxi(Nxmax, Nymax, Nx, Ny, NDIM, x, y, z, xi, eta, x1, y1, z1, DxDxi, ierror_loc)
if ( ierror_loc.ne.0 ) goto 1234
! compute residual
!Dx = getdx(x1,y1,xp,yp)
!Dy = getdy(x1,y1,xp,yp)
call getdxdy(x1,y1,xp,yp,dx,dy)
epsprev= eps
eps = sqrt(Dx**2 + Dy**2)
if ( eps.lt.dtol .or. (epsprev-eps).lt.dmindif*epsprev ) exit
! invert Jacobian matrix
det = DxDxi(1,1)*DxDxi(2,2) - DxDxi(2,1)*DxDxi(1,2)
if ( abs(det).lt.1d-9 ) goto 1234
DxiDx(1,1) = DxDxi(2,2)/det
DxiDx(1,2) = -DxDxi(1,2)/det
DxiDx(2,1) = -DxDxi(2,1)/det
DxiDx(2,2) = DxDxi(1,1)/det
! compute (xi,eta)-increment
Dxi = DxiDx(1,1) * Dx + DxiDx(1,2) * Dy
Deta = DxiDx(2,1) * Dx + DxiDx(2,2) * Dy
! limit (xi,eta)-increment
if ( Dxi .gt. dmaxincrease ) Dxi = dmaxincrease
if ( Dxi .lt. -dmaxincrease ) Dxi = -dmaxincrease
if ( Deta .gt. dmaxincrease ) Deta = dmaxincrease
if ( Deta .lt. -dmaxincrease ) Deta = -dmaxincrease
xi = xi + Dxi
eta = eta + Deta
! set realistic values
xi = min(max(xi, 0d0),dble(Nx)-1d0)
eta = min(max(eta,0d0),dble(Ny)-1d0)
end do
if ( eps.gt.dtol ) then
! call qnerror('bilin_interp_loc: no convergence', ' ', ' ')
goto 1234
end if
! set interpolated node value
zp = z1
ierror = 0
! error handling
1234 continue
return
end subroutine bilin_interp_loc
!> bilinear interpolation of node coordinates and Jacobian matrix
subroutine comp_x_DxDxi(Ncx, Ncy, Nx, Ny, NDIM, x, y, z, xi, eta, x1, y1, z1, DxDxi, ierror)
use m_missing
implicit none
integer, intent(in) :: Ncx, Ncy !< node array sizes
integer, intent(in) :: Nx, Ny !< actual sizes
integer, intent(in) :: NDIM !< sample vector dimension
double precision, dimension(Ncx,Ncy), intent(in) :: x, y !< node coordinates
double precision, dimension(NDIM,Ncx,Ncy), intent(in) :: z !< node values
double precision, intent(in) :: xi, eta !< interpolant index coordinates
double precision, intent(out) :: x1, y1 !< interpolant coordinates
double precision, dimension(NDIM), intent(out) :: z1 !< interpolant value
double precision, dimension(2,2), intent(out) :: DxDxi !< Jacobian matrix
integer, intent(out) :: ierror !< error (1) or not (0)
double precision :: xiL, etaL, xiL1, etaL1
integer :: i0, i1, j0, j1, k
double precision, external :: getdx, getdy
ierror = 1
if ( Nx.lt.2 .or. Ny.lt.2 ) goto 1234
! get the cell indices
i0 = max(min(int(xi)+1, Nx-1), 1)
i1 = i0+1
j0 = max(min(int(eta)+1, Ny-1), 1)
j1 = j0+1
! compute local index coordinates
xiL = xi - dble(i0-1)
etaL = eta - dble(j0-1)
xiL1 = 1d0 - xiL
etaL1 = 1d0 - etaL
! check if all values are valid
if ( x(i0,j0).eq.DMISS .or. x(i1,j0).eq.DMISS .or. x(i0,j1).eq.DMISS .or. x(i1,j1).eq.DMISS .or. &
y(i0,j0).eq.DMISS .or. y(i1,j0).eq.DMISS .or. y(i0,j1).eq.DMISS .or. y(i1,j1).eq.DMISS ) then
goto 1234
end if
! bilinear interpolation of node coordinates
x1 = ( xiL1*x(i0,j0) + xiL*x(i1,j0) )*etaL1 + ( xiL1*x(i0,j1) + xiL*x(i1,j1) )*etaL
y1 = ( xiL1*y(i0,j0) + xiL*y(i1,j0) )*etaL1 + ( xiL1*y(i0,j1) + xiL*y(i1,j1) )*etaL
do k=1,NDIM
if ( z(k,i0,j0).eq.DMISS .or. z(k,i1,j0).eq.DMISS .or. z(k,i0,j1).eq.DMISS .or. z(k,i1,j1).eq.DMISS ) then
z1(k) = DMISS
else
z1(k) = ( xiL1*z(k,i0,j0) + xiL*z(k,i1,j0) )*etaL1 + ( xiL1*z(k,i0,j1) + xiL*z(k,i1,j1) )*etaL
end if
end do
! Jacobian matrix
DxDxi(1,1) = etaL1*getdx(x(i0,j0),y(i0,j0),x(i1,j0),y(i1,j0)) + &
etaL *getdx(x(i0,j1),y(i0,j1),x(i1,j1),y(i1,j1))
DxDxi(1,2) = xiL1 *getdx(x(i0,j0),y(i0,j0),x(i0,j1),y(i0,j1)) + &
xiL *getdx(x(i1,j0),y(i1,j0),x(i1,j1),y(i1,j1))
DxDxi(2,1) = etaL1*getdy(x(i0,j0),y(i0,j0),x(i1,j0),y(i1,j0)) + &
etaL *getdy(x(i0,j1),y(i0,j1),x(i1,j1),y(i1,j1))
DxDxi(2,2) = xiL1 *getdy(x(i0,j0),y(i0,j0),x(i0,j1),y(i0,j1)) + &
xiL *getdy(x(i1,j0),y(i1,j0),x(i1,j1),y(i1,j1))
ierror = 0
! error handling
1234 continue
return
end subroutine comp_x_DxDxi
!> refine cells by splitting links
subroutine refinecellsandfaces2()
use m_netw
use m_samples
use m_samples_refine
use m_interpolationsettings
use m_missing
use m_alloc
use unstruc_messages
use unstruc_colors, only: ncolhl
use unstruc_display, only: jaGUI
use m_kdtree2
use m_sferic
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
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 ( 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)
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
! 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)
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))))
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)
if ( NPL.gt.0 ) call restore_kc()
call connect_hanging_nodes(linkbrother)
netstat = netstat_cells_dirty
keepcircumcenters = 0 ! do not keep circumcenters
else
call confrm('Keep circumcenters?', ja)
keepcircumcenters = 1 ! keep circumcenters
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_interpolationsettings
use m_physcoef, only: ag
use m_flowtimes, only: dt_max
use m_flowgeom, only: ba
use m_missing
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=6 ! 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)
double precision :: aspect ! aspect ratio of netcell
! double precision, dimension(2) :: u, v ! orientation vectors of netcell
double precision :: xc, yc, area
integer :: i, ic, ip, j, jain, k, kk, kkm1, kkp1, N
integer, parameter :: NDIM=4 ! sample vector dimension
ierror = 1
! default
jarefine = 0
jalink = 0
if ( IPSTAT.ne.IPSTAT_OK ) then
write (6,"('tidysamples')")
call tidysamples(xs,ys,zs,IPSAM,NS,MXSAM,MYSAM)
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
! compute orientation vectors of netcell
! call orthonet_compute_orientation(aspect, u(1), v(1), u(2), v(2), ic)
! compute refinement criterion
call compute_jarefine_poly(N, xloc, yloc, jarefine(ic), jarefinelink, jakdtree)
! fill jalink from jarefinelink
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)
use m_interpolationsettings
use m_samples, only: NS, xs, ys, zs
use m_samples_refine
use m_physcoef
use m_kdtree2
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)
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 :: depth, 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, external :: dbdistance
jarefine = 0
jarefinelink = 0
nnn(1) = N
! compute cell center
call comp_masscenter(N, x, y, xc(1), yc(1), area, jacounterclockwise)
! 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))
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)
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 ) then
!------------------------------------------------------------------------
! wave Courant number
!------------------------------------------------------------------------
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 = 6 ! minabs
end if
! only interpolate samples if necessary
if ( Dt_maxcour.gt.0d0 ) then
zc = DMISS
call averaging2(1,NS,xs,ys,zs,ipsam,xc,yc,zc,1,x,y,N,nnn,jakdtree)
! check if a depth 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)
if ( ierror.ne.0 ) then
jakdtree=0
else
if ( isam(1).gt.0 .and. isam(1).lt.Ns ) zc(1) = zs(isam(1))
end if
end if
depth = zc(1)
else
depth = 0d0
end if
if ( depth.eq.DMISS ) goto 1234
! compute wave speed
C = sqrt(AG*abs(depth))
jarefine = 0
num = 0 ! number of links in cell to be refined
do k=1,N
! compute wave Courant number
Courant = C * Dt_maxcour / dlinklength(k)
!if ( Courant.lt.1 .and. 0.5d0*dlinklength(k).gt.FAC*hmin ) then
dlinklengthnew = 0.5d0*dlinklength(k)
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
end do
! check for non-directional refinement and refine all links if so
if ( jadirectional.eq.0 ) then
if ( num.eq.N ) then
jarefinelink = 1
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 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)
use m_netw
implicit none
integer, dimension(:), intent(inout) :: jarefine !< refine cell (1) or not (0), dim: nump
integer, dimension(:), allocatable :: janode ! refine around node (1) or not (0), dim: numk
integer :: iter, ic, k, kk
! allocate
allocate(janode(numk))
do iter=1,NUMITCOURANT
! determine node refinement mask
janode = 0
do ic=1,nump
if ( jarefine(ic).ne.1 ) cycle
do kk=1,netcell(ic)%N
k = netcell(ic)%nod(kk)
janode(k) = 1
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
end do
end do
end do
! deallocate
if ( allocated(janode) ) deallocate(janode)
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 m_sferic, only: jsferic
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 :: dlength1, dlength2
integer, parameter :: MMAX = 6 ! 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_
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, LnnL
double precision :: xz, yz
double precision, dimension(MMAX) :: xp, yp
logical :: Lhanging
double precision, external :: dbdistance
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))
! fix for spherical, periodic coordinates
if ( jsferic.eq.1 ) then
if ( abs(xk(k1)-xk(k2)).gt.180d0 ) then
xnew = xnew+180d0
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
! 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
kkm1 = kk-1; if ( kkm1.lt.1 ) kkm1 = kkm1+N
kkp1 = kk+1; if ( kkp1.gt.N ) kkp1 = kkp1-N
L = netcell(k)%lin(kk)
Lm1 = netcell(k)%lin(kkm1)
Lp1 = netcell(k)%lin(kkp1)
if ( linkbrother(L).eq.Lp1 ) then
numbrothers = numbrothers+1
call find_common_node(L,linkbrother(L),knew)
num = num+1
nods(num) = knew
else if ( Linkbrother(L).ne.Lm1 ) 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
end do kklp
! 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
kp = netcell(k)%nod(kk)
Lhanging = .false.
do i=1,num
if ( kp.eq.nods(i) ) then
Lhanging = .true.
exit
end if
end do
if ( .not.Lhanging ) then
Np = Np+1
xp(Np) = xk(kp)
yp(Np) = yk(kp)
LnnL(Np) = 2
end if
end do
if ( Np.eq.4 ) then
! compute circumcenter without hanging nodes
call getcircumcenter(Np, xp, yp, LnnL, xz, yz)
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
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
integer :: ic, L, k, kk, N
integer :: jasplit, num, numrefine, numhang, numhangnod, N_eff
integer :: ierror
integer :: iter
integer, parameter :: MAXITER = 100
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', ' ', ' ')
goto 1234
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
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
call qnerror('split_cells: no convergence', ' ', ' ')
end if
return
end subroutine
!> find the brother links
!> hanging nodes are assumed to have two consecutive brother links
subroutine find_linkbrothers(linkbrother)
use m_netw
use m_sferic
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
double precision, external :: dbdistance
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))
! check for periodic, spherical coordinates
if ( jsferic.eq.1 ) then
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
! compute tolerance
dtol = 1d-4*max(dbdistance(xk(k1),yk(k1),xk(k),yk(k)), &
dbdistance(xk(k2),yk(k2),xk(k),yk(k)))
if ( dbdistance(xk(k),yk(k),xkc,ykc).lt.dtol ) then ! brother links found
linkbrother(L) = Lp1
linkbrother(Lp1) = L
call teklink(L,210)
call teklink(Lp1,210)
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
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=6 ! 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, kkp1, L, N
integer :: numfirst, numnext
integer :: jarepeat, ja_doall
integer :: iter
integer, parameter :: MAXITER=6
! compute the link refinement mask
jarepeat = 1
iter = 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
L = netcell(k)%lin(kk)
jalink(L) = 1
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
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
end if
do kk=1,N
L = netcell(k)%lin(kk)
if ( jalink(L).gt.0 ) cycle ! link already marked for refinement
num = numlink(kk)
if ( ja_doall.ne.1 .and. jalink(L).ne.-1 ) cycle
jalink(L) = 1
end do
end if
end if
end do
end do
if ( jarepeat.eq.1 ) then
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
!> compute area and mass center of polygon
subroutine comp_masscenter(N, xin , y, xcg, ycg, area, jacounterclockwise)
use m_sferic
implicit none
integer, intent(in) :: N !< polygon size
double precision, dimension(N), intent(in) :: xin, y !< polygon coordinates
double precision, intent(out) :: xcg, ycg !< polygon mass center coordinates
double precision, intent(out) :: area !< polygon area
integer, intent(out) :: jacounterclockwise !< counterclockwise (1) or not (0)
double precision, dimension(N) :: x ! Copy of xin, with possibly periodic fixes.
double precision :: dsx, dsy, xc, yc, dcos, xds, fac, x0, y0, x1, dx0, dx1, dy0, dy1
double precision :: xdum
integer :: i, ip1
double precision, external :: getdx, getdy
double precision, parameter :: dtol=1d-8
area = 0d0
xcg = 0d0
ycg = 0d0
jacounterclockwise = 1
if ( N.lt.1 ) goto 1234
x = xin
! set reference point (furthest away from poles)
x0 = minval(x(1:N))
y0 = y(1)
do i=2,N
if ( abs(y(i)).lt.abs(y0) ) then
y0 = y(i)
end if
end do
! fix for periodic, spherical coordinates
if ( jsferic.eq.1 ) then
x1 = maxval(x(1:N))
if ( x1-x0.gt.180d0 ) then
! determine cutline
xdum = x1-180d0
do i=1,N
if ( x(i).lt.xdum ) then
x(i) = x(i) + 360d0
end if
end do
x0 = minval(x(1:N))
end if
end if
do i=1,N
ip1 = i+1; if ( ip1.gt.N ) ip1=ip1-N
call getdxdy(x0,y0,x(i),y(i), dx0,dy0)
call getdxdy(x0,y0,x(ip1),y(ip1), dx1, dy1)
xc = 0.5d0*(dx0 + dx1)
yc = 0.5d0*(dy0 + dy1)
! xc = 0.5d0*(getdx(x0,y0,x(i),y(i)) + getdx(x0,y0,x(ip1),y(ip1)))
! yc = 0.5d0*(getdy(x0,y0,x(i),y(i)) + getdy(x0,y0,x(ip1),y(ip1)))
call getdxdy(x(i), y(i), x(ip1), y(ip1), dx0, dy0)
dsx = dy0 ; dsy = -dx0
!dsx = getdy(x(i), y(i), x(ip1), y(ip1))
!dsy = -getdx(x(i), y(i), x(ip1), y(ip1))
xds = xc*dsx+yc*dsy
area = area + 0.5d0*xds
xcg = xcg + xds * xc
ycg = ycg + xds * yc
end do
! for clockwise oriented cells, the normal will be inward, and consequently the area negative
! it must stay negative in the computation of the cell center (xcg,ycg)
area = sign(max(abs(area),dtol),area)
fac = 1d0/(3d0*area)
xcg = fac * xcg
ycg = fac * ycg
if ( JSFERIC.ne.0 ) then
ycg = ycg / (Ra*dg2rd)
xcg = xcg / (Ra*dg2rd*cos((ycg+y0)*dg2rd))
end if
xcg = xcg + x0
ycg = ycg + y0
! output cell orientation
if ( area.gt.0d0 ) then
jacounterclockwise = 1
else
jacounterclockwise = 0
end if
! fix for inward normals (clockwise oriented cells)
area = abs(area)
1234 continue
return
end subroutine comp_masscenter
!> get netcell polygon that is safe for periodic, spherical coordinates and poles
subroutine get_cellpolygon(n, Msize, nn, xv, yv, LnnL, zz)
use m_sferic
use m_missing
use network_data
implicit none
integer, intent(in) :: n !< cell number
integer, intent(in) :: Msize !< array size
integer, intent(out) :: nn !< polygon size
double precision, dimension(Msize), intent(out) :: xv, yv !< polygon coordinates
integer, dimension(Msize), intent(out) :: LnnL !< polygon link Lnn
double precision, intent(out) :: zz !< polygon-averaged value
integer :: num, numz, m, mp1, k1, k2
! initialization
xv = 0d0
yv = 0d0
LnnL = 0
zz = 0d0
nn = netcell(n)%n
if ( nn.lt.3 ) then
return ! safety
end if
zz = 0d0
num = 0 ! number of nodes in polygon
numz = 0
do m = 1,nn
!num = num+1
!k1 = netcell(n)%NOD(m)
!xv(num) = xk(k1)
!yv(num) = yk(k1)
!zz = zz + zk(k1)
!lnnl(num) = LNN(netcell(n)%lin(m))
mp1 = m+1; if ( mp1.gt.nn ) mp1=mp1-nn
k1 = netcell(n)%nod(m)
k2 = netcell(n)%nod(mp1)
if ( jsferic.eq.1 .and. abs(abs(yk(k1))-90d0).lt.dtol_pole ) then
num = num+1
xv(num) = xk(k2)
yv(num) = yk(k1)
if ( zk(k1).ne.DMISS ) then
numz = numz+1
zz = zz + zk(k1)
end if
lnnl(num) = LNN(netcell(n)%lin(m))
else if ( jsferic.eq.1 .and. abs(abs(yk(k2))-90d0).lt.dtol_pole ) then
num = num+1
xv(num) = xk(k1)
yv(num) = yk(k1)
if ( zk(k1).ne.DMISS ) then
numz = numz+1
zz = zz + zk(k1)
end if
lnnl(num) = LNN(netcell(n)%lin(m))
! add dummy link on pole ("unmerge")
num = num+1
xv(num) = xk(k1)
yv(num) = yk(k2)
if ( zk(k2).ne.DMISS ) then
numz = numz+1
zz = zz + zk(k2)
end if
lnnl(num) = LNN(netcell(n)%lin(m))
else
num = num+1
k1 = netcell(n)%NOD(m)
xv(num) = xk(k1)
yv(num) = yk(k1)
if ( zk(k1).ne.DMISS ) then
numz = numz+1
zz = zz + zk(k1)
end if
lnnl(num) = LNN(netcell(n)%lin(m))
end if
enddo
nn = num
if (numz.eq.0) then
zz = DMISS
else
zz = zz / numz
endif
return
end subroutine get_cellpolygon
!> delete missing values part of network
subroutine net_delete_DMISS()
use m_netw
use m_missing
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
!> compute sample Hessians
subroutine comp_sampleHessian(ierror)
use m_samples
use m_samples_refine
use m_missing
implicit none
integer, intent(out) :: ierror !< error (1) or not (0)
double precision, dimension(2,2) :: UU, VV ! for SVD: H = USV'
double precision, dimension(2) :: S ! for SVD: H = USV'
double precision, dimension(2) :: gradiL, gradiR ! sample gradients at i-edges
double precision, dimension(2) :: gradjL, gradjR ! sample gradients at j-edges
double precision, dimension(2) :: SniL, sniR ! i-edge surface vector (for divergence)
double precision, dimension(2) :: SnjL, snjR ! j-edge surface vector (for divergence)
double precision :: dareaiL, dareaiR ! contribution to control volume area (for divergence)
double precision :: dareajL, dareajR ! contribution to control volume area (for divergence)
double precision :: area ! control volume area of divergence operator (for Laplacian)
double precision :: zxx, zxy, zyx, zyy ! second order partial derivatives
double precision :: zx, zy ! first order partial derivatives
double precision :: af, dum, EPS, Dx, Dy, Dh
integer :: i, j, k, nrot, ip, ihasridge
double precision, external :: dbdistance
! compute sample mesh width
Dh = min(dbdistance(xs(1),ys(1),xs(2),ys(2)), dbdistance(xs(1),ys(1),xs(1+MXSAM),ys(1+MXSAM)))
ierror = 1
if ( MXSAM.lt.3 .or. MYSAM.lt.3 ) goto 1234
zss(4,1:MXSAM,1:MYSAM) = 0d0
zss(5,1:MXSAM,1:MYSAM) = DMISS
call readyy('Computing sample Hessians', 0d0)
do i=2,MXSAM-1
af = dble(i-2)/dble(max(MXSAM-3,1))
call readyy('Computing sample Hessians', af)
do j=2,MYSAM-1
! if ( i.eq.614 .and. j.eq.154 )
ip = i + (j-1)*MXSAM
if ( abs(xs(ip)-87270).lt.1d-8 .and. abs(ys(ip)-415570).lt.1d-8 ) then
continue
end if
zxx = 0d0
zxy = 0d0
zyx = 0d0
zyy = 0d0
UU = 0d0
VV = 0d0
zx = 0d0
zy = 0d0
S = 0d0
k = 0
ihasridge = 0
do
call comp_samplegradi(0,i,j,gradiR,SniR, dareaiR,dum)
if ( gradiR(1).eq.DMISS .or. gradiR(1).eq.DMISS ) exit
call comp_samplegradi(0,i-1,j,gradiL,SniL, dum,dareaiL)
if ( gradiL(1).eq.DMISS .or. gradiL(1).eq.DMISS ) exit
call comp_samplegradi(1,i,j,gradjR,SnjR, dareajR,dum)
if ( gradjR(1).eq.DMISS .or. gradjR(1).eq.DMISS ) exit
call comp_samplegradi(1,i,j-1,gradjL,SnjL,dum,dareajL)
if ( gradjL(1).eq.DMISS .or. gradjL(1).eq.DMISS ) exit
area = dareaiL + dareaiR + dareajL + dareajR
zxx = (gradiR(1)*SniR(1) - gradiL(1)*SniL(1) + gradjR(1)*SnjR(1) - gradjL(1)*SnjL(1)) / area
zxy = (gradiR(1)*SniR(2) - gradiL(1)*SniL(2) + gradjR(1)*SnjR(2) - gradjL(1)*SnjL(2)) / area
zyx = (gradiR(2)*SniR(1) - gradiL(2)*SniL(1) + gradjR(2)*SnjR(1) - gradjL(2)*SnjL(1)) / area
zyy = (gradiR(2)*SniR(2) - gradiL(2)*SniL(2) + gradjR(2)*SnjR(2) - gradjL(2)*SnjL(2)) / area
zx = ( 0.5d0*(zss(1,i+1,j)+zss(1,i,j))*SniR(1) &
- 0.5d0*(zss(1,i-1,j)+zss(1,i,j))*SniL(1) &
+ 0.5d0*(zss(1,i,j+1)+zss(1,i,j))*SnjR(1) &
- 0.5d0*(zss(1,i,j-1)+zss(1,i,j))*SnjL(1)) / area
zy = ( 0.5d0*(zss(1,i+1,j)+zss(1,i,j))*SniR(2) &
- 0.5d0*(zss(1,i-1,j)+zss(1,i,j))*SniL(2) &
+ 0.5d0*(zss(1,i,j+1)+zss(1,i,j))*SnjR(2) &
- 0.5d0*(zss(1,i,j-1)+zss(1,i,j))*SnjL(2)) / area
! Eigendecompostion
VV(1,1) = zxx; VV(1,2) = zxy
VV(2,1) = zyx; VV(2,2) = zyy
call jacobi(VV,2,2,S,UU,nrot)
!! checks
! if ( abs(zxy-zyx).gt.1d-8 ) then
! continue
! end if
!
!! Eigendecomposition: V = U
! VV = UU
!
! if ( abs(UU(1,1)*S(1)*VV(1,1) + UU(1,2)*S(2)*VV(1,2) - zxx).gt.1d-8 ) then
! continue
! end if
!
! if ( abs(UU(1,1)*S(1)*VV(2,1) + UU(1,2)*S(2)*VV(2,2) - zxy).gt.1d-8 ) then
! continue
! end if
!
! if ( abs(UU(2,1)*S(1)*VV(1,1) + UU(2,2)*S(2)*VV(1,2) - zyx).gt.1d-8 ) then
! continue
! end if
!
! if ( abs(UU(2,1)*S(1)*VV(2,1) + UU(2,2)*S(2)*VV(2,2) - zyy).gt.1d-8 ) then
! continue
! end if
if ( abs(S(1)).gt.abs(S(2)) ) then
k=1
else
k=2
end if
zss(2,i,j) = UU(1,k) ! maximum change direction vector
zss(3,i,j) = UU(2,k) ! maximum change direction vector
zss(4,i,j) = S(k)*area ! maximum change singular value times control volume area
! ridge detection
dum = UU(1,k)*zx + UU(2,k)*zy
zss(5,i,j) = -dum/( S(k)+1d-8 ) ! ridge distance in maximum change direction
exit
end do
end do
end do
call readyy('Compute sample Hessians', -1d0)
iHesstat = iHesstat_OK
ierror = 0
! error handling
1234 continue
return
end subroutine comp_sampleHessian
!> compute sample gradient at (j=constant) or (i=constant) edges
subroutine comp_samplegradi(IDIR, i, j, grad, Sn, DareaL, DareaR)
use m_samples, only: NS, MXSAM, MYSAM, xs, ys
use m_samples_refine
implicit none
integer, intent(in) :: IDIR !< 0: (j=constant), 1: (i=constant) edge
integer, intent(in) :: i, j !< edge indices
double precision, dimension(2), intent(out) :: grad !< edge-based gradient vector
double precision, dimension(2), intent(out) :: Sn !< edge surface vector (for divergence)
double precision, intent(out) :: DareaL, DareaR !< contribution to control volume area (for divergence)
integer :: ip0, ip1, ip0L, ip0R, ip1L, ip1R
grad = 0d0
Sn = 0d0
DareaL = 0d0
DareaR = 0d0
if ( IDIR.eq.0 ) then
! i-edge gradient at (i+1/2,j) location
! control volume:
!
! L:(i+1/2,j+1/2)
! / \
! / \
! 0:(i,j)-----1:(i+1,j)
! \ /
! \ /
! R:(i+1/2,j-1/2)
ip0 = i + MXSAM*(j-1) ! pointer to (i,j)
ip1 = i+1 + MXSAM*(j-1) ! pointer to (i+1,j)
ip0L = i + MXSAM*(min(j+1,MYSAM)-1) ! pointer to (i,j+1)
ip0R = i + MXSAM*(max(j-1,1) -1) ! pointer to (i,j-1)
ip1L = i+1 + MXSAM*(min(j+1,MYSAM)-1) ! pointer to (i+1,j+1)
ip1R = i+1 + MXSAM*(max(j-1,1) -1) ! pointer to (i+1,j-1)
call comp_grad(zss, ip0, ip1, ip0L, ip0R, ip1L, ip1R, grad(1), grad(2), Sn(1), Sn(2), DareaL, DareaR)
else if ( IDIR.eq.1 ) then
! j-edge gradient at (i,j+1/2) location
! control volume:
!
! 1:(i,j+1)
! / \
! / \
! L:(i-1/2,j+1/2)-----R:(i+1/2,j+1/2)
! \ /
! \ /
! 0:(i,j)
ip0 = i + MXSAM*(j-1) ! pointer to (i,j)
ip1 = i + MXSAM*(j ) ! pointer to (i,j+1)
ip0L = max(i-1,1) + MXSAM*(j-1) ! pointer to (i-1,j)
ip0R = min(i+1,MXSAM) + MXSAM*(j-1) ! pointer to (i+1,j)
ip1L = max(i-1,1) + MXSAM*(j ) ! pointer to (i-1,j+1)
ip1R = min(i+1,MXSAM) + MXSAM*(j ) ! pointer to (i+1,j+1)
call comp_grad(zss, ip0, ip1, ip0L, ip0R, ip1L, ip1R, grad(1), grad(2), Sn(1), Sn(2), DareaL, DareaR)
end if
return
end subroutine comp_samplegradi
!> compute the gradient in a control volume defined by the polygon (0-R-1-L)
!>
!> 0L-----1L
!> | |
!> | L |
!> | / \ |
!> |/ \|
!> 0-----1
!> |\ /|
!> | \ / |
!> | R |
!> | |
!> 0R-----1R
!>
!> 0 and 1 are sample points
!> L and R are interpolated at sample cell centers
subroutine comp_grad(zss, ip0, ip1, ip0L, ip0R, ip1L, ip1R, gradx, grady, Sx, Sy, DareaL, DareaR)
use m_samples, only: Ns, MXSAM, MYSAM, xs, ys
use m_samples_refine, only: NDIM
use m_missing
implicit none
double precision, dimension(NDIM,MXSAM*MYSAM) :: zss
integer, intent(in) :: ip0, ip1, ip0L, ip0R, ip1L, ip1R !> node numbers
double precision, intent(out) :: gradx, grady !> gradient vector components
double precision, intent(out) :: Sx, Sy !> edge (nx,ny)dS vector (for divergence)
double precision, intent(out) :: DareaL, DareaR !> contributions to control volume area (for divergence)
double precision :: x0, y0, z0, cx0, cy0
double precision :: x1, y1, z1, cx1, cy1
double precision :: xL, yL, zL, cxL, cyL
double precision :: xR, yR, zR, cxR, cyR
double precision :: darea
double precision, external :: getdx, getdy, dprodout
gradx = DMISS
grady = DMISS
Sx = 0d0
Sy = 0d0
dareaL = 0d0
dareaR = 0d0
x0 = xs(ip0)
y0 = ys(ip0)
z0 = zss(1,ip0)
x1 = xs(ip1)
y1 = ys(ip1)
z1 = zss(1,ip1)
if ( x0.eq.DMISS .or. y1.eq.DMISS .or. x1.eq.DMISS .or. y1.eq.DMISS ) goto 1234
xL = 0.25d0*(xs(ip0)+xs(ip1)+xs(ip0L)+xs(ip1L))
yL = 0.25d0*(ys(ip0)+ys(ip1)+ys(ip0L)+ys(ip1L))
zL = 0.25d0*(zss(1,ip0)+zss(1,ip1)+zss(1,ip0L)+zss(1,ip1L))
xR = 0.25d0*(xs(ip0)+xs(ip1)+xs(ip0R)+xs(ip1R))
yR = 0.25d0*(ys(ip0)+ys(ip1)+ys(ip0R)+ys(ip1R))
zR = 0.25d0*(zss(1,ip0)+zss(1,ip1)+zss(1,ip0R)+zss(1,ip1R))
call getdxdy(xL,yL,xR,yR,cy1,cx1) ; cx1 = -cx1
call getdxdy(x0,y0,x1,y1,cyL,cxL) ; cxL = -cxL
!cx1 = -0.5d0*getdy(xL,yL,xR,yR)
!cy1 = 0.5d0*getdx(xL,yL,xR,yR)
!cxL = -0.5d0*getdy(x0,y0,x1,y1)
!cyL = 0.5d0*getdx(x0,y0,x1,y1)
cx0 = -cx1
cy0 = -cy1
cxR = -cxL
cyR = -cyL
darea = 0.5d0*(cx0*x0+cy0*y0 + cx1*x1+cy1*y1 + cxL*xL+cyL*yL + cxR*xR+cyR*yR)
! gradx and grady can be composed
if ( zss(1,ip0) .ne.DMISS .and. zss(1,ip1) .ne.DMISS .and. &
zss(1,ip0L).ne.DMISS .and. zss(1,ip0R).ne.DMISS .and. &
zss(1,ip1L).ne.DMISS .and. zss(1,ip1R).ne.DMISS ) then
gradx = (cx1*z1 + cxL*zL + cx0*z0 + cxR*zR)/darea
grady = (cy1*z1 + cyL*zL + cy0*z0 + cyR*zR)/darea
end if
Sx = 2d0*cx1
Sy = 2d0*cy1
DareaL = 0.5d0*abs(dprodout(x0,y0,xR,yR,x0,y0,xL,yL))
DareaR = 0.5d0*abs(dprodout(x1,y1,xR,yR,x1,y1,xL,yL))
1234 continue
return
end subroutine comp_grad
!> smooth structured sample data and put it in zss(1,:,:)
!> D u/ D t = div grad u
subroutine smooth_samples()
use m_samples
use m_samples_refine
use m_missing
implicit none
double precision, dimension(:,:), allocatable :: zsdum
integer :: iter, i, j
integer :: ip0, ipiL, ipiR, ipjL, ipjR
double precision :: c0, ciL, ciR, cjL, cjR, af
integer :: ierror
double precision, parameter :: sigma = 0.5d0
ierror = 1
! check if samples are structured
if ( MXSAM*MYSAM.ne.NS ) goto 1234
! allocate
allocate(zsdum(MXSAM,MYSAM))
! initialize zss(1,:,:)
do i=1,MXSAM
do j=1,MYSAM
zss(1,i,j) = zs(i+MXSAM*(j-1))
end do
end do
call readyy('Smoothing samples', 0d0)
! Elliptic smoothing
do iter=1,Nsamplesmooth
af = dble(iter-1)/dble(max(Nsamplesmooth-1,1))
call readyy('Smoothing samples', af)
! copy zss(1,:,:) to zsdum
do j=1,MYSAM
do i=1,MXSAM
zsdum(i,j) = zss(1,i,j)
end do
end do
do j=2,MYSAM-1 ! inner nodes only
do i=2,MXSAM-1 ! innter nodes only
! compute weights
ciL = 1d0
ciR = 1d0
cjL = 1d0
cjR = 1d0
if ( zsdum(i-1,j).eq.DMISS ) ciL = 0d0
if ( zsdum(i+1,j).eq.DMISS ) ciR = 0d0
if ( zsdum(i,j-1).eq.DMISS ) cjL = 0d0
if ( zsdum(i,j+1).eq.DMISS ) cjR = 0d0
if ( ciL*ciR*cjL*cjR.eq.0d0 ) cycle ! inner samples only
c0 = ciL+ciR+cjL+cjR
if ( abs(c0).lt.0.5d0 ) cycle
zss(1,i,j) = (1d0-sigma) * zsdum(i,j) + &
sigma * ( &
ciL*zsdum(i-1,j) + &
ciR*zsdum(i+1,j) + &
cjL*zsdum(i,j-1) + &
cjR*zsdum(i,j+1) &
) / c0
end do
end do
end do
ierror = 0
Nsamplesmooth_last = Nsamplesmooth
call readyy('Smoothing samples', -1d0)
1234 continue
! deallocate
if ( allocated(zsdum) ) deallocate(zsdum)
return
end subroutine smooth_samples
!> compute the "best-fit" circumcenter of a polygon
subroutine comp_circumcenter(N, xp, yp, xf, yf, xc, yc)
use m_sferic
use m_missing
implicit none
integer, intent(in) :: N !< polygon dimension
double precision, dimension(N), intent(in) :: xp, yp !< polygon node coordinates
double precision, dimension(N), intent(in) :: xf, yf !< face coordinates
double precision, intent(out) :: xc, yc !< circumcenter coordinates
double precision, dimension(N) :: tx, ty
double precision, dimension(2,2) :: T
double precision, dimension(2) :: rhs
double precision :: dt, xhalf, yhalf, dfac, x0, y0, det
double precision :: xzw, yzw, SL, SM, XCR, YCR, CRP
integer :: i, in, ip1, j
integer :: JACROS, m, m2
integer, parameter :: jacenterinside=1
double precision, external :: getdx, getdy
x0 = DMISS
y0 = DMISS
if ( N.lt.2 ) goto 1234
x0 = minval(xp(1:N))
y0 = minval(yp(1:N))
! compute the tangent vectors
do i=1,N
ip1 = i+1; if ( ip1.gt.N ) ip1=ip1-N
call normalin(xp(i),yp(i),xp(ip1),yp(ip1),tx(i),ty(i))
end do
! make the matrix
T = 0d0
do i=1,N
T(1,1) = T(1,1) + tx(i)*tx(i)
T(1,2) = T(1,2) + tx(i)*ty(i)
T(2,1) = T(2,1) + ty(i)*tx(i)
T(2,2) = T(2,2) + ty(i)*ty(i)
end do
! make the right-hand side
rhs = 0d0
do i=1,N
ip1 = i+1; if ( ip1.gt.N ) ip1=ip1-N
! xhalf = 0.5d0*(getdx(x0,y0,xp(i),yp(i)) + getdx(x0,y0,xp(ip1),yp(ip1)))
! yhalf = 0.5d0*(getdy(x0,y0,xp(i),yp(i)) + getdy(x0,y0,xp(ip1),yp(ip1)))
call getdxdy(x0,y0,xf(i),yf(i),xhalf,yhalf)
!xhalf = getdx(x0,y0,xf(i),yf(i))
!yhalf = getdy(x0,y0,xf(i),yf(i))
dfac = tx(i)*xhalf + ty(i)*yhalf
rhs(1) = rhs(1) + tx(i)*dfac
rhs(2) = rhs(2) + ty(i)*dfac
end do
! solve the system
det = T(1,1)*T(2,2) - T(1,2)*T(2,1)
if ( abs(det).lt.1d-8 ) goto 1234
xc = ( T(2,2)*rhs(1) - T(1,2)*rhs(2) ) / det
yc = ( -T(2,1)*rhs(1) + T(1,1)*rhs(2) ) / det
if ( JSFERIC.ne.0 ) then
yc = yc / (Ra*dg2rd)
xc = xc / (Ra*dg2rd*cos((yc+y0)*dg2rd))
end if
xc = xc + x0
yc = yc + y0
if (jacenterinside == 1) then
call pinpok(xc,yc,N,xp,yp,in) ! circumcentre may not lie outside cell
if (in == 0) then
xzw = sum(xp(1:N))/dble(N)
yzw = sum(yp(1:N))/dble(N)
do m = 1,N
m2 = m + 1; if (m == N) m2 = 1
call CROSS(xzw, yzw, xc, yc, xp(m ), yp(m ), xp(m2), yp(m2),&
JACROS,SL,SM,XCR,YCR,CRP)
if (jacros == 1) then
xc = 0.5d0*( xp(m) + xp(m2) ) ! xcr
yc = 0.5d0*( yp(m) + yp(m2) ) ! ycr
exit
endif
enddo
endif
endif
1234 continue
return
end subroutine comp_circumcenter
! compose an orthogonal dual mesh (cell centers), while keeping the primary mesh (net nodes) fixed
subroutine make_orthocenters(dmaxnonortho,maxiter)
use m_netw
use m_flowgeom, only: xz, yz
use unstruc_display, only: ncolhl
implicit none
double precision, intent(in) :: dmaxnonortho !< maximum allowed non-orthogonality
integer, intent(in) :: maxiter !< maximum number of iterations
integer, parameter :: N6 = 6 ! maximum polygon dimension
integer, dimension(N6) :: nodelist
double precision, dimension(N6) :: xplist, yplist, xflist, yflist
double precision, dimension(:), allocatable :: xc, yc !< cell centers
double precision :: SL, SM, xcr, ycr, crp
double precision :: af, dmaxabscosphi, drmsabscosphi, dabscosphi
integer :: iter
integer :: i, ip1, ii, ic, ic1, j, ja3, k, kp1, L, N, jacros
integer :: ierror
double precision, parameter :: dsigma = 0.95d0
double precision, external :: dcosphi
ierror = 1
ic = 0
if ( nump.lt.1 ) goto 1234
if ( netstat.ne.NETSTAT_OK ) call findcells(0)
! allocate
allocate(xc(nump), yc(nump))
open(6)
call readyy(' ', -1d0)
call readyy('Computing orthocenters (press right mouse button to cancel)', 0d0)
! compute the initial cell centers
do iter=1,MAXITER
dmaxabscosphi = 0d0
drmsabscosphi = 0d0
do ic=1,nump
N = netcell(ic)%N
if ( N.gt.N6 ) then
call qnerror('make_orthocenters: N>N6', ' ', ' ')
goto 1234
end if
do i=1,N
ip1 = i+1; if ( ip1.gt.N ) ip1=ip1-N
k = netcell(ic)%nod(i)
kp1 = netcell(ic)%nod(ip1)
xplist(i) = xk(k)
yplist(i) = yk(k)
! find the link connected to this node
do j=0,N-1
ii = i+j; if ( ii.gt.N ) ii=ii-N
L = netcell(ic)%lin(ii)
if ( ( kn(1,L).eq.k .and. kn(2,L).eq.kp1 ) .or. ( kn(1,L).eq.kp1 .and. kn(2,L).eq.k ) ) then
exit ! found
end if
end do
if ( lnn(L).eq.2 ) then
! internal link
ic1 = lne(1,L)+lne(2,L)-ic
xflist(i) = xz(ic1)
yflist(i) = yz(ic1)
dabscosphi = abs(dcosphi(xz(ic),yz(ic),xz(ic1),yz(ic1),xk(k),yk(k),xk(kp1),yk(kp1)))
dmaxabscosphi = max(dmaxabscosphi, dabscosphi)
drmsabscosphi = drmsabscosphi + dabscosphi**2
else
! boundary link
xflist(i) = 0.5d0*(xk(k)+xk(kp1))
yflist(i) = 0.5d0*(yk(k)+yk(kp1))
end if
end do
call comp_circumcenter(N, xplist, yplist, xflist, yflist, xc(ic), yc(ic))
! call cirr(xc(ic),yc(ic),31)
end do ! do ic=1,nump
drmsabscosphi = sqrt(drmsabscosphi / dble(max(nump,1)))
! relaxation
xz(1:nump) = xz(1:nump) + dsigma*(xc(1:nump)-xz(1:nump))
yz(1:nump) = yz(1:nump) + dsigma*(yc(1:nump)-yz(1:nump))
! check residual
if ( drmsabscosphi.le.dmaxnonortho ) exit
! output information
af = dble(iter-1)/dble(MAXITER-1)
call readyy('Computing orthocenters (press right mouse button to cancel)', af)
WRITE(6,'(1H+"iter: ", I5, " max ortho: ", E10.4, " rms ortho: ", E10.4)') iter, dmaxabscosphi, drmsabscosphi
! check for right mouse button
call halt3(ja3)
if ( ja3.eq.3 ) then
ierror = 0
goto 1234
end if
end do ! do iter=1,MAXITER
ierror = 0
1234 continue
call readyy(' ', -1d0)
if ( ierror.ne.0 ) then
! call qnerror('make_orthocenters: error', ' ', ' ')
if ( ic.gt.0 .and. ic.lt.nump ) call cirr(xc(ic),yc(ic),ncolhl)
end if
! deallocate
if ( allocated(xc) ) deallocate(xc, yc)
close(6)
return
end subroutine make_orthocenters
!> merge polylines
subroutine merge_polylines()
use m_polygon
use m_missing
implicit none
double precision :: xstart1, ystart1, xend1, yend1, xstart2, ystart2, xend2, yend2
integer :: jpoint1, jstart1, jend1, jpoint2, jstart2, jend2
integer :: ipol1, ipol2
double precision, parameter :: dtol=1d-2
double precision, external :: dbdistance
jpoint1 = 1
do while ( jpoint1.lt.NPL )
call get_startend(NPL-jpoint1+1, xpl(jpoint1:NPL), ypl(jpoint1:NPL), jstart1, jend1)
jstart1 = jstart1 + jpoint1-1
jend1 = jend1 + jpoint1-1
xstart1 = xpl(jstart1)
ystart1 = ypl(jstart1)
xend1 = xpl(jend1)
yend1 = ypl(jend1)
! loop over the remaining polylines
jpoint2 = jend1+1
do while ( jpoint2.lt.NPL )
call get_startend(NPL-jpoint2+1, xpl(jpoint2:NPL), ypl(jpoint2:NPL), jstart2, jend2)
jstart2 = jstart2 + jpoint2-1
jend2 = jend2 + jpoint2-1
xstart2 = xpl(jstart2)
ystart2 = ypl(jstart2)
xend2 = xpl(jend2)
yend2 = ypl(jend2)
! check if polylines end/start points are coinciding
ipol1 = 0
ipol2 = 0
if ( dbdistance(xstart1,ystart1,xstart2,ystart2).le.dtol ) then
ipol1 = jstart1
ipol2 = jstart2
else if ( dbdistance(xstart1,ystart1,xend2,yend2).le.dtol ) then
ipol1 = jstart1
ipol2 = jend2
else if ( dbdistance(xend1,yend1,xstart2,ystart2).le.dtol ) then
ipol1 = jend1
ipol2 = jstart2
else if ( dbdistance(xend1,yend1,xend2,yend2).le.dtol ) then
ipol1 = jend1
ipol2 = jend2
end if
! merge polylines
if ( ipol1.gt.0 .and. ipol2.gt.0 ) then
! delete first coinciding node
call modln2(xpl,ypl,zpl,MAXPOL,NPL,ipol1,0d0,0d0,-2)
if ( ipol1.eq.jend1 ) ipol1 = ipol1-1
ipol2 = ipol2-1
! merge
call mergepoly(xpl,ypl,zpl,MAXPOL,NPL,ipol1,ipol2)
! polygons may have been flipped
call get_startend(NPL-jpoint1+1, xpl(jpoint1:NPL), ypl(jpoint1:NPL), jstart1, jend1)
jstart1 = jstart1 + jpoint1-1
jend1 = jend1 + jpoint1-1
xstart1 = xpl(jstart1)
ystart1 = ypl(jstart1)
xend1 = xpl(jend1)
yend1 = ypl(jend1)
jpoint2 = jend1+1
else
! advance pointer to second polyline
jpoint2 = jend2+1
end if
end do
! advance pointer to second polyline
jpoint1 = jend1+1
end do
! remove trailing missing values
if ( NPL.gt.1 ) then
do while ( ( xpl(NPL).eq.DMISS .or. ypl(NPL).eq.DMISS ) .and. NPL.gt.1 )
NPL=NPL-1
end do
end if
1234 continue
return
end subroutine merge_polylines
!> write matlab double array to file
subroutine matlab_write_double(matfile, varname, var, Ni, Nj)
implicit none
integer :: matfile !< matlab file unit number
character(len=*) :: varname !< variable name
integer :: Ni, Nj !< array sizes
double precision, dimension(Ni, Nj) :: var !< variable
integer i, j
write(matfile, *) trim(varname), ' = ['
do i=1,Ni
do j=1,Nj
if ( var(i,j).ne.-1234 ) then
! write(matfile, "(E20.8, $)") var(i,j)
write(matfile, "(D28.16, $)") var(i,j)
else
write(matfile, "(' NaN', $)")
end if
end do
write(matfile, *)
end do
write(matfile, "('];')")
end subroutine matlab_write_double
!> write matlab integer array to file
subroutine matlab_write_int(matfile, varname, var, Ni, Nj)
implicit none
integer :: matfile !< matlab file unit number
character(len=*) :: varname !< variable name
integer :: Ni, Nj !< array sizes
integer, dimension(Ni, Nj) :: var !< variable
integer i, j
write(matfile, *) trim(varname), ' = ['
do i=1,Ni
do j=1,Nj
if ( var(i,j).ne.-1234 ) then
write(matfile, "(I20, $)") var(i,j)
else
write(matfile, "(' NaN', $)")
end if
end do
write(matfile, *)
end do
write(matfile, "('];')")
end subroutine matlab_write_int
!> reverse indexing of selected polygon
subroutine flippo(ip)
use m_polygon
implicit none
integer, intent(in) :: ip !< polygon point
integer :: jpoint, jstart, jend, Num
integer :: i, j, ierror
double precision, dimension(:), allocatable :: xxp, yyp, zzp
jpoint = 1
jstart = 1
jend = NPL
if ( ip.eq.0 ) then
ierror = 0
else
ierror = 1
call get_polstartend(ip, jstart, jend)
if ( jstart.le.ip .and. jend.ge.ip ) then
ierror = 0
end if
end if
if ( ierror.eq.0 ) then
! call savepol()
! allocate
Num = jend-jstart+1
allocate(xxp(Num), yyp(Num), zzp(Num))
do j=1,Num
i = jend-j+1
xxp(j) = xpl(i)
yyp(j) = ypl(i)
zzp(j) = zpl(i)
end do
do i=jstart,jend
! xpl(i) = xph(jend-i+jstart)
! ypl(i) = yph(jend-i+jstart)
! zpl(i) = zph(jend-i+jstart)
j = i-jstart+1
xpl(i) = xxp(j)
ypl(i) = yyp(j)
zpl(i) = zzp(j)
end do
! deallocate
deallocate(xxp, yyp, zzp)
end if
return
end subroutine flippo
! make a heighest walk in a structured sample set
subroutine make_samplepath(xp,yp)
use m_netw
use m_samples
use m_arcinfo
use m_alloc
use m_missing
implicit none
double precision, intent(inout) :: xp, yp !< coordinates of start point
integer, dimension(:), allocatable :: ipsub
integer :: i, ierror, ip, ip0, ip1
integer :: ipnext, ipcur, ipprev
integer :: Nsub, isub
integer :: iter, idir, ipol1, ipol2
integer, parameter :: MAXITER = 10000
if ( MXSAM*MYSAM.ne.NS ) goto 1234 ! no structured sample data
! find first sample point
call ispoi1(xs,ys,NS,xp,yp,ip0)
if ( ip0.lt.1 .or. ip0.gt.NS ) return
! allocate
Nsub = 1
allocate(ipsub(Nsub))
ipol1 = 0
ipol2 = 0
ipcur = ip0
ipnext = ipcur
do idir=1,2
do iter=1,MAXITER
ipprev = ipcur
ipcur = ipnext
do
Nsub = ubound(ipsub,1)
call makestep_samplepath(ipprev, ipcur, ipnext, Nsub, ipsub, ierror)
if ( ierror.lt.0 ) then
call realloc(ipsub, Nsub)
else
exit
end if
end do
! remember first step
if ( iter.eq.1 ) ip1 = ipnext
if ( ipnext.lt.1 .or. ipnext.eq.ipcur ) exit
! add trajectory to polygon
if ( iter.eq.1 ) then
! create new polyline
if ( NPL.gt. 0 ) then
if ( xpl(NPL).ne.DMISS ) then
call increasepol(NPL+3, 1)
xpl(NPL+1) = DMISS
ypl(NPL+1) = DMISS
zpl(NPL+1) = DMISS
NPL = NPL+1
else
call increasepol(NPL+2, 1)
end if
else
call increasepol(NPL+2, 1)
end if
! add first point
xpl(NPL+1) = xs(ipcur)
ypl(NPL+1) = ys(ipcur)
zpl(NPL+1) = zs(ipcur)
NPL = NPL+1
! remember index of first point in polygon
if ( idir.eq.1 ) then
ipol1 = NPL
else
ipol2 = NPL
end if
else
! add to polyline
call increasepol(NPL+1, 1)
end if
! add new point
xpl(NPL+1) = xs(ipnext)
ypl(NPL+1) = ys(ipnext)
zpl(NPL+1) = zs(ipnext)
NPL = NPL+1
! disable samples in the subpath, except the next sample, and the current in the first pass
do isub=1,Nsub
ip = ipsub(isub)
if ( ip.ne.ipnext .and. (ip.ne.ip0 .or. idir.ne.1) ) then
zs(ip) = DMISS
end if
end do
end do ! do iter=1,MAXITER
! next path: reverse first step
ipcur = ip1
ipnext = ip0
end do ! do idir=1,2
! merge the two polylines
if ( ipol1.gt.0 .and. ipol2.gt.0 ) then
call mergepoly(xpl,ypl,zpl,MAXPOL,NPL,ipol1,ipol2)
end if
ierror = 0
1234 continue
! deallocate
if ( allocated(ipsub) ) deallocate(ipsub)
return
end subroutine make_samplepath
! make a step to the next sample in a sample path
subroutine makestep_samplepath(ipprev, ipcur, ipnext, Nsub, ipsub, ierror)
use m_samples
use m_samples_refine
use m_missing
implicit none
integer, intent(in) :: ipprev !< previous sample point
integer, intent(in) :: ipcur !< current sample point
integer, intent(out) :: ipnext !< next sample point
integer, intent(inout) :: Nsub !< array size of ipsub (in), number of samples in subpath to next sample point (out)
integer, dimension(Nsub), intent(out) :: ipsub !< samples in subpath to next sample point
integer, intent(out) :: ierror !< no errors (0), need to realloc ipsub (-newsize) or other error (1)
integer :: i, j, i0, i1, j0, j1, ip, iploc, icur, jcur, num, Nsub0
integer :: isub, jsub, i00, i11, j00, j11, ii, jj, ip1, ip2
double precision :: dcsphi, disub, djsub, zs_ave, zs_max
double precision :: Dh, Dzs
integer, parameter :: Nwidth=5 ! number of sample widths considered
integer :: Nlist, jatoosteep
integer, dimension(2*(Nwidth+1)) :: iplist
double precision, external :: dcosphi, dbdistance
ipnext = 0
ierror = 1
Nsub0 = Nsub
jcur = ipcur/MXSAM+1
icur = ipcur - (jcur-1)*MXSAM
i0 = max(icur-Nwidth,1)
i1 = min(icur+Nwidth,MXSAM)
j0 = max(jcur-Nwidth,1)
j1 = min(jcur+Nwidth,MYSAM)
zs_max = -1d99
! determine sample meshwidth
! i-dir
ip1 = i0 + (jcur-1)*MXSAM
ip2 = i1 + (jcur-1)*MXSAM
Dh = dbdistance(xs(ip1),ys(ip1),xs(ip2),ys(ip2))/max(dble(i1-i0),1d0)
! j-dir
ip1 = icur + (j1-1)*MXSAM
ip2 = icur + (j1-1)*MXSAM
Dh = max(dh,dbdistance(xs(ip1),ys(ip1),xs(ip2),ys(ip2))/max(dble(j1-j0),1d0))
do i=i0,i1
do j=j0,j1
! if ( i.ne.i0 .and. i.ne.i1 .and. j.ne.j0 .and. j.ne.j1 ) cycle
if ( i-i0.gt.1 .and. i1-i.gt.1 .and. j-j0.gt.1 .and. j1-j.gt.1 ) cycle
ip = i + (j-1)*MXSAM
if ( ip.eq.ipcur ) cycle
! next sample may never have DMISS coordinates/value
if ( xs(ip).eq.DMISS .or. zs(ip).eq.DMISS ) cycle
! check angle with previous step
if ( ipprev.ne.ipcur .and. ipprev.gt.0 ) then
dcsphi = dcosphi(xs(ipprev),ys(ipprev),xs(ipcur),ys(ipcur),xs(ipcur),ys(ipcur),xs(ip),ys(ip))
if ( dcsphi.lt.0.5d0 ) cycle
end if
! make subbath
Nlist = 0
i00 = min(icur,i)
i11 = max(icur,i)
j00 = min(jcur,j)
j11 = max(jcur,j)
do isub=i00,i11
if ( i.ne.icur ) then
djsub = dble(isub-icur)/dble(i-icur)*dble(j-jcur) + jcur
else
djsub = 0d0
end if
do jsub=j00,j11
if ( j.ne.jcur ) then
disub = dble(jsub-jcur)/dble(j-jcur)*dble(i-icur) + icur
else
disub = 0d0
end if
if ( abs(isub-disub).lt.1d0 .or. abs(jsub-djsub).lt.1d0 ) then
Nlist = Nlist+1
iplist(Nlist) = isub + (jsub-1)*MXSAM
end if
end do
end do
! compute average sample value
zs_ave = 0d0
num = 0
do ii=1,Nlist
iploc = iplist(ii)
jsub = iploc/MXSAM+1
isub = iploc-(jsub-1)*MXSAM
if ( zs(iploc).ne.DMISS ) then
num = num+1
zs_ave=zs_ave+zs(iploc)
end if
end do
zs_ave = zs_ave/dble(max(num,1))
!! plot samples in subpath
! do isub=1,Nlist
! ipsub = iplist(isub)
! call cirr(xs(ipsub),ys(ipsub),31)
! end do
! call qnerror(' ', ' ', ' ')
! do isub=1,Nlist
! ipsub = iplist(isub)
! call cirr(xs(ipsub),ys(ipsub),0)
! end do
! check for maximum average sample value
if ( zs_ave.gt.zs_max .and. num.gt.1 ) then
! 27-06-12: deactivated gradient check
!! gradient may not be too large
! jatoosteep = 0
! Dzs = maxval(zs(iplist(1:Nlist)), MASK=zs(iplist(1:Nlist)).ne.DMISS)
! Dzs = Dzs-minval(zs(iplist(1:Nlist)), MASK=zs(iplist(1:Nlist)).ne.DMISS)
! if ( abs(Dzs).gt.0.25d0*Dh ) then
! jatoosteep = 1
! cycle
! else
! jatoosteep = 0
! end if
! if ( icur.eq.1294 .and. jcur.eq.1051 ) then
! write(6,"(2I, $)") i-icur, j-jcur
! do ii=1,Nlist
! write(6,"(F15.5, $)") zs(iplist(ii))
! end do
! write(6,*)
! end if
ipnext = ip
zs_max = zs_ave
! reallocate if necessary
if ( Nlist.gt.ubound(ipsub,1) ) then
Nsub = int(1.2d0*dble(Nlist))+1
ierror = -Nsub
goto 1234
end if
Nsub = 0
do isub=1,Nlist
Nsub = Nsub+1
ipsub(isub) = iplist(isub)
end do
end if
end do
end do
! plot next sample
if ( ipnext.gt.0 ) then
call cirr(xs(ipnext),ys(ipnext),31)
call setcol(31)
call movabs(xs(ipcur),ys(ipcur))
call lnabs(xs(ipnext),ys(ipnext))
end if
ierror = 0
1234 continue
return
end subroutine makestep_samplepath
!> From: NUMERICAL RECIPES IN FORTRAN 77, sect. 11.1
!>
!> Computes all eigenvalues and eigenvectors of a real symmetric matrix a, which is of size n
!> by n, stored in a physical np by np array. On output, elements of a above the diagonal are
!> destroyed. d returns the eigenvalues of a in its first n elements. v is a matrix with the same
!> logical and physical dimensions as a, whose columns contain, on output, the normalized
!> eigenvectors of a. nrot returns the number of Jacobi rotations that were required.
SUBROUTINE jacobi(a,n,np,d,v,nrot)
INTEGER n,np,nrot,NMAX
double precision a(np,np),d(np),v(np,np)
PARAMETER (NMAX=500)
INTEGER i,ip,iq,j
double precision c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)
r12:do ip=1,n ! Initialize to the identity matrix.
r11:do iq=1,n
v(ip,iq)=0.
enddo r11
v(ip,ip)=1.
enddo r12
r13:do ip=1,n
b(ip)=a(ip,ip) ! Initialize b and d to the diagonal of a.
d(ip)=b(ip)
z(ip)=0. ! This vector will accumulate terms of the form tapq
enddo r13 ! as in equation (11.1.14).
nrot=0
r24:do i=1,50
sm=0.
r15:do ip=1,n-1 ! Sum off-diagonal elements.
r14:do iq=ip+1,n
sm=sm+abs(a(ip,iq))
enddo r14
enddo r15
if(sm.eq.0.)return ! The normal return, which relies on quadratic conver
if(i.lt.4)then ! gence to machine underflow.
tresh=0.2*sm/n**2 ! ...on the first three sweeps.
else
tresh=0. ! ...thereafter.
endif
r22:do ip=1,n-1
r21:do iq=ip+1,n
g=100.*abs(a(ip,iq))
! After four sweeps, skip the rotation if the o-diagonal element is small.
if((i.gt.4).and.(abs(d(ip))+g.eq.abs(d(ip))) .and.(abs(d(iq))+g.eq.abs(d(iq))))then
a(ip,iq)=0.
else if(abs(a(ip,iq)).gt.tresh)then
h=d(iq)-d(ip)
if(abs(h)+g.eq.abs(h))then
t=a(ip,iq)/h ! t = 1=(2)
else
theta=0.5*h/a(ip,iq) ! Equation (11.1.10).
t=1./(abs(theta)+sqrt(1.+theta**2))
if(theta.lt.0.)t=-t
endif
c=1./sqrt(1+t**2)
s=t*c
tau=s/(1.+c)
h=t*a(ip,iq)
z(ip)=z(ip)-h
z(iq)=z(iq)+h
d(ip)=d(ip)-h
d(iq)=d(iq)+h
a(ip,iq)=0.
r16:do j=1,ip-1 ! Case of rotations 1 j < p.
g=a(j,ip)
h=a(j,iq)
a(j,ip)=g-s*(h+g*tau)
a(j,iq)=h+s*(g-h*tau)
enddo r16
r17:do j=ip+1,iq-1 ! Case of rotations p < j < q.
g=a(ip,j)
h=a(j,iq)
a(ip,j)=g-s*(h+g*tau)
a(j,iq)=h+s*(g-h*tau)
enddo r17
r18:do j=iq+1,n ! Case of rotations q < j n.
g=a(ip,j)
h=a(iq,j)
a(ip,j)=g-s*(h+g*tau)
a(iq,j)=h+s*(g-h*tau)
enddo r18
r19:do j=1,n
g=v(j,ip)
h=v(j,iq)
v(j,ip)=g-s*(h+g*tau)
v(j,iq)=h+s*(g-h*tau)
enddo r19
nrot=nrot+1
endif
enddo r21
enddo r22
r23:do ip=1,n
b(ip)=b(ip)+z(ip)
d(ip)=b(ip) ! Update d with the sum of tapq,
z(ip)=0. ! and reinitialize z.
enddo r23
enddo r24
write(*,*) 'too many iterations in jacobi'
read(*,*)
return
END
!> detect ridges and reduce structured sample set
subroutine detect_ridges(jadeleteHessians)
use m_samples
use m_samples_refine
use m_missing
implicit none
integer, intent(in) :: jadeleteHessians !< delete Hessians upon completion (1) or not (0)
integer :: i, j, ip, jacancelled
integer :: ierror, Nsamplesmooth_bak
double precision :: Dh, dum
double precision, external :: dbdistance, comp_sampleDh
ierror = 1
! store settings
Nsamplesmooth_bak = Nsamplesmooth
! default value
Nsamplesmooth = 4
! check if the sample set is structured and non-empty
if ( MXSAM*MYSAM.ne.NS .or. NS.eq.0 ) goto 1234
! compute sample mesh width
Dh = min(dbdistance(xs(1),ys(1),xs(2),ys(2)), dbdistance(xs(1),ys(1),xs(1+MXSAM),ys(1+MXSAM)))
! store samples
call savesam()
call prepare_sampleHessian(ierror)
if ( ierror.ne.0 ) goto 1234
! plot ridges
call plot_ridges(ierror)
! if ( ierror.ne.0 ) goto 1234
! remove samples from sample set that are not associated with a ridge
do i=1,MXSAM
do j=1,MYSAM
ip = i+(j-1)*MXSAM
Dh = comp_sampleDh(i,j)
if ( abs(zss(5,i,j)).gt.0.5d0*Dh .or. zss(4,i,j).gt.-1d-8 .or. zss(5,i,j).eq.DMISS ) then
xs(ip) = DMISS
ys(ip) = DMISS
! zs(ip) = DMISS
end if
end do
end do
ierror = 0
1234 continue
! restore settings
Nsamplesmooth = Nsamplesmooth_bak
if ( jadeleteHessians.eq.1 ) then
call deallocate_sampleHessian()
end if
return
end subroutine detect_ridges
!> compute sample mesh width
double precision function comp_sampleDh(i,j)
use m_samples
implicit none
integer, intent(in) :: i,j !< sample indices
integer :: ip, ipiL, ipiR, ipjL, ipjR
double precision :: dum
double precision, external :: dbdistance
if ( MXSAM*MYSAM.ne.NS ) goto 1234 ! structured samples only
ip = i+(j-1)*MXSAM
ipiL = max(i-1,1) + (j-1)*MXSAM
ipiR = min(i+1,MXSAM) + (j-1)*MXSAM
ipjL = i + (max(j-1,1) -1)*MXSAM
ipjR = i + (min(j+1,MYSAM)-1)*MXSAM
comp_sampleDh = 0d0
dum = dbdistance(xs(ip),ys(ip),xs(ipiL),ys(ipiL))
if ( dum.gt.0d0 ) comp_sampleDh = max(comp_sampleDh,dum)
dum = dbdistance(xs(ip),ys(ip),xs(ipiR),ys(ipiR))
if ( dum.gt.0d0 ) comp_sampleDh = max(comp_sampleDh,dum)
dum = dbdistance(xs(ip),ys(ip),xs(ipjL),ys(ipjR))
if ( dum.gt.0d0 ) comp_sampleDh = max(comp_sampleDh,dum)
dum = dbdistance(xs(ip),ys(ip),xs(ipjR),ys(ipjR))
if ( dum.gt.0d0 ) comp_sampleDh = max(comp_sampleDh,dum)
1234 continue
return
end function comp_sampleDh
!> allocate sample Hessian data
subroutine allocate_sampleHessian()
use m_samples
use m_samples_refine
implicit none
call deallocate_sampleHessian()
allocate(zss(NDIM,MXSAM,MYSAM))
iHesstat = iHesstat_DIRTY
return
end subroutine allocate_sampleHessian
!> deallocate sample Hessian data
subroutine deallocate_sampleHessian()
use m_samples
use m_samples_refine
implicit none
if ( allocated(zss) ) deallocate(zss)
iHesstat = iHesstat_DIRTY
return
end subroutine deallocate_sampleHessian
!> prepare the sample Hessians
subroutine prepare_sampleHessian(ierror)
use m_samples_refine
implicit none
integer, intent(out) :: ierror !< error (1) or not (0)
integer :: jacancelled
ierror = 1
if ( iHesstat.ne.iHesstat_OK ) then
! (re)allocate
call allocate_sampleHessian()
! copy and possibly smooth sample data to zss(1,:,:)
call smooth_samples()
! compute sample Hessians
call comp_sampleHessian(ierror)
if ( ierror.ne.0 ) goto 1234
end if
iHesstat = iHesstat_OK
ierror = 0
1234 continue
return
end subroutine prepare_sampleHessian
!> snap spline to nearest land boundary
subroutine snap_spline(ispline)
use m_landboundary
use m_splines
use m_alloc
use unstruc_display, only: plotSplines, ncolsp
implicit none
integer, intent(in) :: ispline !< spline number
double precision, dimension(:,:), allocatable :: A, AtWA, AtWAi
double precision, dimension(:), allocatable :: xf, yf ! sample points
double precision, dimension(:), allocatable :: xb, yb ! sample points projected on land boundary
double precision, dimension(:), allocatable :: AtWxb, AtWyb ! (A, W xb) and (A, W yb)
double precision, dimension(:), allocatable :: rhsx, rhsy ! right-hand side vectors
double precision, dimension(:,:), allocatable :: B, C ! constraints matrics Bx+Cy=d
double precision, dimension(:), allocatable :: d ! constraints rhs
double precision, dimension(:), allocatable :: lambda ! Lagrangian multipliers
double precision, dimension(:,:), allocatable :: E ! E lambda = f
double precision, dimension(:), allocatable :: w ! weights
double precision, dimension(:), allocatable :: xspp, yspp ! second order spline derivatives
double precision :: x1, y1, xn, yn, dis, rL, curv, dsx, dsy, fac
double precision :: dn1x, dn1y, dn2x, dn2y, xx1, yy1, xx2, yy2 ! constraints: (x(1)-xx1)nx1 + (y(1)-yy1)ny1 = 0, etc.
double precision :: t0, t1 ! for timing
integer :: ierror
integer :: i, iL, iR, j, ja, k, num, Numnew, Numconstr
integer, parameter :: Nref = 19 ! number of additional points between spline control points for sampled spline
double precision, external :: dbdistance
ierror = 1
call nump(ispline,num)
! remember initial first and last spline node coordinates for contraints
Numconstr = 2
xx1 = xsp(ispline,1)
yy1 = ysp(ispline,1)
xx2 = xsp(ispline,num)
yy2 = ysp(ispline,num)
! do i=1,num
! x1 = xsp(ispline,i)
! y1 = ysp(ispline,i)
! call toland(x1, y1, 1, MXLAN, 2, xn, yn, dis, j, rL)
! xsp(ispline,i) = xn
! ysp(ispline,i) = yn
! end do
! compute the spline to fine-spline matrix
Numnew = 1
do
call realloc(A, (/Numnew, num/) )
call comp_Afinespline(num, Nref, Numnew, A, ierror)
! check if the arrays were large enough and reallocate if not so
if ( ierror.ne.2 ) then
exit
end if
end do
! allocate
allocate(xf(Numnew), yf(Numnew), xb(Numnew), yb(Numnew))
allocate(AtWA(num,num), AtWAi(num,num))
allocate(AtWxb(num), AtWyb(num))
allocate(rhsx(num), rhsy(num))
allocate(B(Numconstr,num), C(Numconstr,num), d(Numconstr), lambda(Numconstr))
allocate(E(Numconstr,Numconstr))
allocate(xspp(num), yspp(num))
allocate(w(Numnew))
! compute sample points
xf = matmul(A,xsp(ispline,1:num))
yf = matmul(A,ysp(ispline,1:num))
! compute weights
do i=1,Numnew
iL = max(i-1,1)
iR = min(i+1,Numnew)
w(i) = 1d0/sqrt(dbdistance(xf(iL),yf(iL),xf(ir),yf(iR))/dble(iR-iL))
end do
! compute normal vectors at contrained spline nodes
call spline(xsp(ispline,1:num), num, xspp)
call spline(ysp(ispline,1:num), num, yspp)
call comp_curv(num, xsp(ispline,1:num), ysp(ispline,1:num), xspp, yspp, 0d0, curv, dn1x, dn1y, dsx, dsy)
call comp_curv(num, xsp(ispline,1:num), ysp(ispline,1:num), xspp, yspp, dble(num-1), curv, dn2x, dn2y, dsx, dsy)
! DEBUG
! w = 1d0
! END DEBUG
! make matrix
do i=1,num
do j=1,num
AtWA(i,j) = 0d0
do k=1,Numnew
AtWA(i,j) = AtWA(i,j) + A(k,i)*w(k)*A(k,j)
end do
end do
end do
! compute inverse matrix
AtWAi = AtWA
rhsx = 0d0 ! dummy for now
call gaussj(AtWAi,num,num,rhsx,1,1)
! make the contraints
B = 0d0
C = 0d0
B(1,1) = dn1y; C(1,1) = -dn1x; d(1) = dn1y*xx1-dn1x*yy1
B(2,num) = dn2y; C(2,num)= -dn2x; d(2) = dn2y*xx2-dn2x*yy2
! compute Schur complement
E = matmul( B, matmul(AtWAi, transpose(B))) + matmul( C, matmul(AtWAi, transpose(C)))
lambda = 0d0
! invert Schur complement
call gaussj(E,Numconstr,Numconstr,lambda,1,1)
do
! compute projected sample points
call klok(t0)
do i=1,Numnew
call toland(xf(i), yf(i), 1, MXLAN, 2, xb(i), yb(i), dis, j, rL)
end do
call klok(t1)
write(6,"('elapsed time:', F7.2, ' sec.')") t1-t0
do i=1,num
AtWxb(i) = 0d0
AtWyb(i) = 0d0
do k=1,Numnew
AtWxb(i) = AtWxb(i) + A(k,i)*w(k)*xb(k)
AtWyb(i) = AtWyb(i) + A(k,i)*w(k)*yb(k)
end do
end do
do i=1,num
do j=1,num
end do
end do
!! plot projected sample points
! call movabs(xb(1),yb(1))
! do i=2,Numnew
! call clnabs(xb(i),yb(i),31)
! end do
! compute Lagrangian multipliers
lambda = matmul(E, matmul(matmul(B,AtWAi),AtWxb) + matmul(matmul(C,AtWAi),AtWyb) - d)
! make rhs
rhsx = AtWxb - matmul(transpose(B),lambda)
rhsy = AtWyb - matmul(transpose(C),lambda)
! whipe out spline
call plotsplines(ispline, ispline, 0)
! update spline control point coordinates
xsp(ispline,1:num) = matmul(AtWAi, rhsx)
ysp(ispline,1:num) = matmul(AtWAi, rhsy)
call plotsplines(ispline, ispline, ncolsp)
ja = 1
call confrm('Continue?', ja)
if ( ja.ne.1 ) exit
! compute sample points
xf = matmul(A,xsp(ispline,1:num))
yf = matmul(A,ysp(ispline,1:num))
end do
ierror = 0
1234 continue
! deallocate
if ( allocated(A) ) deallocate(A)
if ( allocated(xf) ) deallocate(xf)
if ( allocated(yf) ) deallocate(yf)
if ( allocated(xb) ) deallocate(xb)
if ( allocated(yb) ) deallocate(yb)
if ( allocated(AtWxb) ) deallocate(AtWxb)
if ( allocated(AtWyb) ) deallocate(AtWyb)
if ( allocated(AtWA) ) deallocate(AtWA)
if ( allocated(AtWAi) ) deallocate(AtWAi)
if ( allocated(rhsx) ) deallocate(rhsx)
if ( allocated(rhsy) ) deallocate(rhsy)
if ( allocated(B) ) deallocate(B)
if ( allocated(C) ) deallocate(C)
if ( allocated(d) ) deallocate(d)
if ( allocated(lambda) ) deallocate(lambda)
if ( allocated(E) ) deallocate(E)
if ( allocated(xspp) ) deallocate(xspp)
if ( allocated(yspp) ) deallocate(yspp)
if ( allocated(w) ) deallocate(w)
return
end subroutine snap_spline
!> sample a spline
subroutine sample_spline(num, xs, ys, numref, Nr, xr, yr, ierror)
use m_splines
use m_alloc
implicit none
integer, intent(in) :: num !< number of spline control points
double precision, dimension(num), intent(in) :: xs, ys !< spline control points coordinates
integer, intent(in) :: numref !< number of additional points between spline control points
integer, intent(inout) :: Nr !< array size (in), number of sample points (out)
double precision, dimension(Nr), intent(out) :: xr, yr !< sample point coordinates
integer, intent(out) :: ierror !< no error (0), memory error (2) or other error (1)
double precision, dimension(:), allocatable :: xh2, yh2
double precision :: tn
integer :: i, j, Nr_in
ierror = 1
Nr_in = Nr
if ( num.lt.1 ) goto 1234
! compute the number of samples
Nr = num + (num-1)*numref
! check array size
if ( Nr_in.lt.Nr ) then
ierror = 2
goto 1234
end if
! allocate
allocate(xh2(num))
allocate(yh2(num))
call spline(xs,num,xh2)
call spline(ys,num,yh2)
Nr = 0
do i = 1,num-1
do j = 1,numref+1
Nr = Nr+1
tn = (i - 1) + dble(j-1) / dble(numref+1)
call splint(xs,xh2,num,tn,xr(Nr))
call splint(ys,yh2,num,tn,yr(Nr))
end do
end do
! add last point
Nr = Nr+1
tn = dble(num-1)
call splint(xs,xh2,num,tn,xr(Nr))
call splint(ys,yh2,num,tn,yr(Nr))
ierror = 0
1234 continue
! deallocate
if ( allocated(xh2) ) deallocate(xh2)
if ( allocated(yh2) ) deallocate(yh2)
return
end subroutine sample_spline
!> find the start and end index of a polygon
subroutine get_polstartend(ipol, jstart, jend)
use m_polygon
implicit none
integer, intent(in) :: ipol !< index of a polygon node
integer, intent(out) :: jstart, jend !< start and end indices of polygon
integer :: jpoint
jpoint = 1
jstart = 1
jend = 0
do while ( ( ipol.lt.jstart .or. ipol.gt.jend ) .and. jpoint.le.NPL)
call get_startend(NPL-jpoint+1, xpl(jpoint:NPL), ypl(jpoint:NPL), jstart, jend)
jstart = jstart + jpoint-1
jend = jend + jpoint-1
jpoint = jend+2
end do
return
end subroutine get_polstartend
!> grow gridlayers from a net boundary
subroutine netboundtocurvi(kp)
use m_polygon
use m_grid
use m_gridsettings
use m_missing
use m_spline2curvi
use m_netw
implicit none
integer, intent(in) :: kp !< clicked node
double precision, dimension(:), allocatable :: edgevel
integer, dimension(:), allocatable :: ifront
double precision :: dt, dwidthloc
double precision :: crs, dis,xn,yn,rL
integer :: i, ic, j, jc, k1, k2, k3, L, Lloc, kother
integer :: istop, ierror, jacancelled
integer :: ja
integer :: iorient, iorient_new ! orientation of boundary (0: left, 1:right, -1:undetermined)
! integer :: NFAC_bak
double precision, external :: dbdistance, dprodout
ierror = 1
! store settings
! nfac_bak = nfac
! set default
! nfac = 1
if ( netstat.ne.netstat_OK ) call findcells(0)
call netboundtopoly_makemasks()
if ( kc(kp).ne.1 ) goto 1234 ! invalid point
call savepol()
call delpol()
call netboundtopoly(kp)
! goto 1234
! 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
mc = NPL
nc = nfac+1
if ( mc.lt.2 ) goto 1234 ! no curvigrid
call savegrd()
call increasegrid(mc,nc)
xc = DMISS
yc = DMISS
! check orientation of polygon
iorient = -1
do i=1,NPL-1
k1 = int(zpl(i))
k2 = int(zpl(i+1))
if ( k1.lt.1 .or. k2.lt.1 ) cycle ! no netnodes found
! determine the link
L = 0
do j=1,nmk(k1)
Lloc = nod(k1)%lin(j)
if ( kn(3,Lloc).ne.2 ) cycle ! not a 2D link
kother = kn(1,Lloc) + kn(2,Lloc) - k1
if ( kother.eq.k2 ) then
L = Lloc
exit
end if
end do
if ( L.eq.0 ) cycle ! no link found
if ( lnn(L).ne.1 ) cycle ! not a boundary link
! determine the adjacent net cell
ic = lne(1,L)
! determine orientation
crs = dprodout(xpl(i),ypl(i),xpl(i+1),ypl(i+1),xpl(i),ypl(i),xzw(ic),yzw(ic))
iorient_new = -1
if ( crs.gt.0d0 ) then
iorient_new = 1
else if ( crs.lt.0d0 ) then
iorient_new = 0
end if
if ( iorient.eq.-1 ) then
iorient = iorient_new
else
! compare
if ( iorient.ne.iorient_new ) then
call qnerror('pol2curvi: orientation error', ' ', ' ')
goto 1234
end if
end if
end do
! swith orientation if necessary
if ( iorient.ne.0 ) call flippo(0)
! copy polygon to first gridline
jc = 1
xc(1:NPL,jc) = xpl(1:NPL)
yc(1:NPL,jc) = ypl(1:NPL)
! check for circular connectivity
if ( dbdistance(xc(1,jc),yc(1,jc),xc(NPL,jc),yc(NPL,jc)).le.dtolLR ) then
jacirc = 1
else
jacirc = 0
end if
! allocate
if ( allocated(edgevel) ) deallocate(edgevel)
allocate(edgevel(mc-1))
if ( allocated(ifront) ) deallocate(ifront)
allocate(ifront(mc))
! set the front mask
ifront = 1
where ( xc(:,jc).eq.DMISS ) ifront = 0
! set edge velocity
edgevel = DMISS
if ( dunigridsize.le.0d0 ) then
do i=1,mc-1
! get the pointers to the netnodes from zpl
k1 = int(zpl(i))
k2 = int(zpl(i+1))
if ( k1.lt.1 .or. k2.lt.1 ) cycle ! no netnodes found
! determine the link
L = 0
do j=1,nmk(k1)
Lloc = nod(k1)%lin(j)
if ( kn(3,Lloc).ne.2 ) cycle ! not a 2D link
kother = kn(1,Lloc) + kn(2,Lloc) - k1
if ( kother.eq.k2 ) then
L = Lloc
exit
end if
end do
if ( L.eq.0 ) cycle ! no link found
if ( lnn(L).ne.1 ) cycle ! not a boundary link
! determine the adjacent net cell
ic = lne(1,L)
dwidthloc = 0d0
! determine cell height: take maximum distance to boundary link
do j=1,netcell(ic)%N
k3 = netcell(ic)%nod(j)
call dlinedis2(xk(k3),yk(k3),xk(k1),yk(k1),xk(k2),yk(k2),ja,dis,xn,yn,rL)
dwidthloc = max(dwidthloc, dis)
end do
edgevel(i) = dgrow*dwidthloc
end do
else ! user specified
edgevel = dunigridsize
end if
! update the front
do i=1,mc-1
if ( edgevel(i).eq.DMISS ) then
ifront(i) = 0
ifront(i+1) = 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
do i=1,mc-1
edgevel(i) = dgrow*edgevel(i)
end do
if ( dt.lt.1d-8 .or. istop.eq.1 ) exit
end do
ierror = 0
1234 continue
call restorepol()
! deallocate
if ( allocated(edgevel) ) deallocate(edgevel)
if ( allocated(ifront) ) deallocate(ifront)
! call netboundstopoly_deallocatemasks()
! restore settings
! nfac = nfac_bak
return
end subroutine netboundtocurvi
!> copy netboundary to polygon, starting from a specified point
subroutine netboundtopoly(kstart)
use m_polygon
use m_netw
use m_alloc
use m_missing
implicit none
integer, intent(in) :: kstart !< startnode
integer, dimension(:), allocatable :: klist ! list of new startnodes
integer :: nlist ! number of entries in list
integer :: ilist ! position in list
double precision :: crs
integer :: iorient ! orientation of branch, net on left (1) or right (0) or do not consider (-1)
integer :: i, iDi, i_, ic, inew, k, knext, L, Lprev, num
integer :: iorient_new, ja_addednode
integer :: knext_store, iorient_new_store, L_store
integer :: ierror
double precision, external :: dprodout
ierror = 1
! allocate
allocate(klist(1))
klist = 0
nlist = 0
! add startnode to list
nlist = nlist+1
if ( nlist.gt.size(klist) ) call realloc(klist, int(1.2d0*dble(nlist))+1, fill=0, keepExisting=.true.)
klist(nlist) = kstart
! process the startnode list
ilist = 0
do while ( ilist.lt.nlist )
ilist = ilist+1
! inialization
k = klist(ilist)
iorient = -1
inew = 1
! make a branch
num = 0
do
ja_addednode = 0
i = 1
if ( inew.ne.1 ) then
do while ( nod(k)%lin(i).ne.Lprev .and. i.lt.nmk(k) ); i=i+1; end do
if ( nod(k)%lin(i).ne.Lprev ) then ! should not happen
continue
return
end if
end if
if ( iorient.eq.1 ) then
iDi=1
else
iDi=-1
end if
! loop over links connected to k
do i_=1,nmk(k)
i = i+iDi
if ( i.gt.nmk(k) ) i=i-nmk(k)
if ( i.lt.1 ) i=i+nmk(k)
L = nod(k)%lin(i)
if ( Lc(L).ne.1 ) cycle
knext = kn(1,L) + kn(2,L) - k
! determine orientation
ic = lne(1,L)
crs = dprodout(xk(k),yk(k),xk(knext),yk(knext),xk(k),yk(k),xzw(ic),yzw(ic))
iorient_new = -1
if ( crs.gt.0d0 ) then
iorient_new = 1
else if ( crs.lt.0d0 ) then
iorient_new = 0
end if
! check if we have to add a branch (orientation differs or already added node)
if ( ( iorient_new.ne.iorient .and. iorient.ne.-1 ) .or. ja_addednode .eq. 1 ) then
! orientation differs: start a new branch later
inew = 1
! add new startnode to list
nlist = nlist+1
if ( nlist.gt.size(klist) ) call realloc(klist, int(1.2d0*dble(nlist))+1, fill=0, keepExisting=.true.)
klist(nlist) = k
cycle ! do not add this node to branch
end if
! add point to polygon
ja_addednode = 1
num = num+1
if ( inew.eq.1 ) then ! also add DMISS and first point
if ( NPL.gt.1 ) then
if ( xpl(NPL).ne.DMISS ) then
call increasepol(NPL+1, 1)
NPL = NPL+1
xpl(NPL) = DMISS
ypl(NPL) = DMISS
zpl(NPL) = DMISS
end if
end if
call increasepol(NPL+1,1)
NPL = NPL+1
xpl(NPL) = xk(k)
ypl(NPL) = yk(k)
zpl(NPL) = dble(k)
end if
call increasepol(NPL+1, 1)
NPL = NPL+1
xpl(NPL) = xk(knext)
ypl(NPL) = yk(knext)
zpl(NPL) = dble(knext)
! deactivate link
Lc(L) = 0
inew = 0
! remember the added new node
knext_store = knext
iorient_new_store = iorient_new
L_store = L
! set branche orientation if unset
if ( iorient.eq.-1 ) then
iorient = iorient_new
end if
end do ! do i=1,nmk(k)
if ( ja_addednode.eq.1 ) then
k = knext_store
iorient_new = iorient_new_store
Lprev = L_store
else
exit
end if
end do
if ( num.gt.0 .and. iorient.ne.0 ) then ! branch has ended: fix orientation if necessary
call flippo(NPL)
end if
end do ! do while ( ilist.lt.nlist )
! merge branches (unfortunately, the orientation may now change)
call merge_polylines()
ierror = 0
1234 continue
if ( allocated(klist) ) deallocate(klist)
return
end subroutine netboundtopoly
!> make the masks for netboundtopoly
subroutine netboundtopoly_makemasks()
use m_netw
use m_polygon
implicit none
integer :: inside, k1, k2, L
! make node and link masks
Lc = 0
kc = -1
inside = -1
do L=1,numL
if ( lnn(L).ne.1 ) cycle ! not a net boundary link
if ( kn(3,L).ne.2) cycle ! not a 2D link
k1 = kn(1,L)
k2 = kn(2,L)
if ( k1.lt.1 .or. k1.gt.numk .or. k2.lt.1 .or. k2.gt.numk ) then ! safety, should not happen
continue
cycle
end if
if ( kc(k1).eq.-1 ) then ! mask of node k1 not yet determined
call dbpinpol(xk(k1),yk(k1),inside)
if ( inside.eq.1 ) then
kc(k1) = 1
else
kc(k1) = 0
end if
end if
if ( kc(k1).eq.1 ) then
if ( kc(k2).eq.-1 ) then ! mask of node k1 not yet determined
call dbpinpol(xk(k2),yk(k2),inside)
if ( inside.eq.1 ) then
kc(k2) = 1
else
kc(k2) = 0
end if
end if
if ( kc(k2).eq.1 ) then ! both nodes inside selecting polygon
Lc(L) = 1
end if
end if
end do
return
end subroutine netboundtopoly_makemasks
!> compute the spline to fine-spline matrix A, such that
!> xf = A x, and
!> yf = A y,
!> where x and y are the spline control-point coordinates and
!> xf and yf are the sample point coordinates
subroutine comp_Afinespline(N, numref, Nr, A, ierror)
implicit none
integer, intent(in) :: N !< number of spline control points
integer, intent(in) :: numref !< number of additional points between spline control points
integer, intent(inout) :: Nr !< array size (in), number of sample points (out)
double precision, dimension(Nr,N), intent(out) :: A !< spline to fine-spline matrices
integer, intent(out) :: ierror !< no error (0), memory error (2) or other error (1)
integer :: j, Nr_in
double precision, dimension(:), allocatable :: xloc, yloc, xf, yf
ierror = 1
Nr_in = Nr
if ( N.lt.1 ) goto 1234
! compute the number of samples
Nr = N + (N-1)*numref
! check array size
if ( Nr_in.lt.Nr ) then
ierror = 2
goto 1234
end if
! allocate
allocate(xloc(N), yloc(N), xf(Nr), yf(Nr))
! compose the matrix
! note: although the y-coordinate spline is refined, it is not used
xloc = 0d0
yloc = 0d0
do j=1,N
xloc(j) = 1d0
call sample_spline(N, xloc, yloc, numref, Nr, xf, yf, ierror)
if ( ierror.ne.0 ) goto 1234
A(1:Nr, j) = xf
xloc(j) = 0d0
end do
ierror = 0
1234 continue
! deallocate
if ( allocated(xloc) ) deallocate(xloc)
if ( allocated(yloc) ) deallocate(yloc)
if ( allocated(xf) ) deallocate(xf)
if ( allocated(yf) ) deallocate(yf)
return
end subroutine comp_Afinespline
!> interpolation of sample data to network nodes, in curvilinear grid coordinates
subroutine sam2net_curvi(numk, xk, yk, zk)
! use network_data
use m_grid
use m_samples
use m_alloc
use m_missing
use m_polygon
implicit none
integer, intent(in) :: numk !< number of netnodes
double precision, dimension(numk), intent(in) :: xk, yk !< netnode coordinates
double precision, dimension(numk), intent(inout) :: zk !< netnode z-values
double precision, dimension(:,:), allocatable :: xietak ! network grid-coordinates, dim(2,numk)
double precision, dimension(:,:), allocatable :: xietas ! sample grid-coordinates, dim(2,NS)
double precision, dimension(:,:), allocatable :: xietac ! grid grid-coordinates, dim(2,mc*nc)
double precision, dimension(:), allocatable :: xik, etak ! network grid-coordinates, dim(numk)
double precision, dimension(:), allocatable :: xis, etas ! network grid-coordinates, dim(NS)
integer, dimension(:), allocatable :: imaskk ! network inside curvigrid (1) or not (0)
integer, dimension(:), allocatable :: imasks ! sample inside curvigrid (1) or not (0)
double precision :: xiloc, etaloc, zloc(1,1,1), etamin, etamax
integer :: ierror
integer :: i, ipoint, j, ja, jadl, jakdtree, k, N
logical :: Ldeletedpol
logical :: L1D
ierror = 1
Ldeletedpol = .false.
L1D = .false.
if ( mc*nc.eq.0 ) then
call qnerror('no curvilinear grid available', ' ', ' ')
goto 1234
end if
ja = 0
call confrm('1D interpolation (no cross-sections)?', ja)
if ( ja.eq.1 ) L1D = .true.
! regularize the curvigrid
call regularise_spline2curvigrid()
! allocate
allocate(xietak(2,numk))
allocate(xietas(2,NS))
allocate(xietac(2,mmax*nmax)) ! should correspond with xc,yc,zc array sizes
allocate(xik(numk),etak(numk))
allocate(xis(NS),etas(NS))
allocate(imaskk(numk), imasks(NS))
xietak = DMISS
xietas = DMISS
xietac = DMISS
! find nodes/samples inside curvigrid
call disable_outside_curvigrid(numk, NS, xk, yk, xs, ys, imaskk, imasks)
! assign (xi,eta) to the grid nodes
etamin = huge(1d0)
etamax = -etamin
do i=1,mc
xiloc = dble(i-1)
do j=1,nc
ipoint = i+mmax*(j-1)
etaloc = dble(j-1)
xietac(1,ipoint) = xiloc
xietac(2,ipoint) = etaloc
etamax = max(etaloc, etamax)
etamin = min(etaloc, etamin)
end do
end do
! find sample grid-coordinates
jadl = 0
jakdtree = 1
call TRIINTfast(xc,yc,xietac,mmax*nmax,2,xs,ys,xietas,NS,XPL,YPL,NPL,jadl,jakdtree) ! will alter grid
do i=1,NS
! apply inside-curvigrid mask
if ( imasks(i).ne.1 ) then
xietas(1,i) = DMISS
xietas(2,i) = DMISS
end if
if ( i.eq.16355 ) then
continue
end if
xiloc = xietas(1,i)
etaloc = xietas(2,i)
if ( xiloc.eq.DMISS .or. etaloc.eq.DMISS ) cycle ! no (xi,eta) found
! note that current xiloc and etaloc serve as first iterate in call to bilin_interp_loc
call bilin_interp_loc(mmax,nmax,mc, nc, 1, xc, yc, zc, xs(i), ys(i), xiloc, etaloc, zloc, ierror)
if ( ierror.eq.0 ) then
xietas(1,i) = xiloc
xietas(2,i) = etaloc
end if
end do
! find network grid-coordinates
jadl = 0
jakdtree = 1
if ( NPL.gt.0 ) call savegrd()
call TRIINTfast(xc,yc,xietac,mmax*nmax,2,xk,yk,xietak,numk,XPL,YPL,NPL,jadl,jakdtree)
if ( NPL.gt.0 ) call restoregrd()
do k=1,numk
! apply inside-curvigrid mask
if ( imaskk(k).ne.1 ) then
xietak(1,k) = DMISS
xietak(2,k) = DMISS
end if
if ( k.eq.603 ) then
continue
end if
xiloc = xietak(1,k)
etaloc = xietak(2,k)
if ( xiloc.eq.DMISS .or. etaloc.eq.DMISS ) cycle ! no (xi,eta) found
! note that current xiloc and etaloc serve as first iterate in call to bilin_interp_loc
call bilin_interp_loc(mmax,nmax,mc, nc, 1, xc, yc, zc, xk(k), yk(k), xiloc, etaloc, zloc, ierror)
if ( ierror.eq.0 ) then
xietak(1,k) = xiloc
xietak(2,k) = etaloc
end if
end do
!! DEBUG
! do i=1,NS
! zs(i) = xietas(1,i)
!! zs(i) = xietas(2,i)
! end do
!
! do k=1,numk
! zk(k) = xietak(1,k)
!! zk(k) = xietak(2,k)
! end do
!
! goto 1234
!! END DEBUG
do i=1,NS
xis(i) = xietas(1,i)
etas(i) = xietas(2,i)
end do
do k=1,numk
xik(k) = xietak(1,k)
etak(k) = xietak(2,k)
end do
if ( L1D ) then
! 1D interpolation: move samples to etamin and copy to etamax
call realloc(xis, 2*NS, keepExisting=.true.)
call realloc(etas, 2*NS, keepExisting=.true.)
call realloc(zs, 2*NS, keepExisting=.true.)
do i=1,NS
xiloc = xis(i)
etas(i) = etamin
xis( NS+i) = xiloc
etas(NS+i) = etamax
zs( NS+i) = zs(i)
end do
NS = 2*NS
end if
! delete polygon temporarily for (xi,eta) interpolation
call savepol()
call delpol()
Ldeletedpol = .true.
jadl = 0
jakdtree = 1 ! todo :
call triintfast(xis,etas,zs,NS,1,xik,etak,zk,numk,XPL,YPL,NPL,jadl,jakdtree)
ierror = 0
! error handling
1234 continue
! restore
if ( Ldeletedpol ) then
call restorepol()
end if
if ( L1D ) then
NS = NS/3
call realloc(zs, NS, keepExisting=.true.)
end if
! deallocate
if ( allocated(xietak) ) deallocate(xietak)
if ( allocated(xietas) ) deallocate(xietas)
if ( allocated(xietac) ) deallocate(xietac)
if ( allocated(xik) ) deallocate(xik)
if ( allocated(etak) ) deallocate(etak)
if ( allocated(xis) ) deallocate(xis)
if ( allocated(etas) ) deallocate(etas)
if ( allocated(imaskk) ) deallocate(imaskk)
if ( allocated(imasks) ) deallocate(imasks)
return
end subroutine sam2net_curvi
!> merge grids from spline2curvi
subroutine merge_spline2curvigrids()
use m_grid
use m_alloc
use m_missing
implicit none
double precision, dimension(:,:), allocatable :: xcnew, ycnew
integer, dimension(2) :: iupperold, ilowerold, iupper, ilower
integer :: i, j, iother, ipoint
integer :: istart, iend, jstart, jend, jDj
integer :: istartother, iendother, jstartother, jendother
integer :: jmin, jmax, jminother, jmaxother
integer :: istartnew, iendnew
logical :: Lconnected
double precision, parameter :: dtol = 1d-6
double precision, external :: dbdistance
! allocate
allocate(xcnew(1,1), ycnew(1,1))
ipoint = 1
jDj = 0
istartnew = 1
do while (ipoint.lt.mc)
! get start and end indices of this part of the first gridline
call get_startend(mc-ipoint+1, xc(ipoint:mc,1), yc(ipoint:mc,1), istart, iend)
istart = istart + ipoint - 1
iend = iend + ipoint - 1
if ( istart.ge.mc .or. istart.ge.iend ) then ! done
exit
end if
! see if this part is connected to another part
istartother = iend+2
iendother = istartother+(iend-istart)
Lconnected = .true.
jmin = nc+1
jmax = 0
jminother = nc+1
jmaxother = 0
do i=istart,iend
! get the grid sizes in j-direction
call get_startend(nc, xc(i,1:nc), yc(i,1:nc), jstart, jend)
jmin = min(jmin, jstart)
jmax = max(jmax, jend)
iother = iend+2+(iend-i)
if ( iother.gt.mc ) then ! no more grid available
Lconnected = .false.
else
if ( dbdistance(xc(i,1),yc(i,1),xc(iother,1),yc(iother,1)).gt.dtol ) then ! not on top of each other
Lconnected = .false.
else
! get the grid sizes in j-direction, other side
call get_startend(nc, xc(iother,1:nc), yc(iother,1:nc), jstartother, jendother)
jminother = min(jminother, jstartother) ! should be 1
jmaxother = max(jmaxother, jendother)
end if
end if
end do
iendnew = istartnew+iend-istart
if ( Lconnected ) then
ipoint = iendother+2
else
jmaxother = 1
ipoint = iend+2
end if
! reallocate
iupperold = ubound(xcnew)
ilowerold = lbound(xcnew)
iupper = (/ iendnew, max(jmax,iupperold(2)) /)
ilower = (/ 1, min(2-jmaxother,ilowerold(2)) /)
call realloc(xcnew, iupper, ilower, keepExisting=.true., fill=DMISS)
call realloc(ycnew, iupper, ilower, keepExisting=.true., fill=DMISS)
! fill
xcnew(istartnew:iendnew, 1:jmax) = xc(istart:iend,1:jmax)
ycnew(istartnew:iendnew, 1:jmax) = yc(istart:iend,1:jmax)
if ( Lconnected ) then
xcnew(istartnew:iendnew, 1:2-jmaxother:-1) = xc(iendother:istartother:-1,1:jmaxother)
ycnew(istartnew:iendnew, 1:2-jmaxother:-1) = yc(iendother:istartother:-1,1:jmaxother)
end if
istartnew = iendnew+2
end do
! increase grid
iupper = ubound(xcnew)
ilower = lbound(xcnew)
mc = iupper(1)-ilower(1)+1
nc = iupper(2)-ilower(2)+1
call increasegrid(mc, nc)
! fill
xc = DMISS
yc = DMISS
xc(1:mc,1:nc) = xcnew
yc(1:mc,1:nc) = ycnew
! deallocate
if ( allocated(xcnew) ) deallocate(xcnew)
if ( allocated(ycnew) ) deallocate(ycnew)
return
end subroutine merge_spline2curvigrids
!> regularise spline2curvi grid
!> note: there is an asymmetry, but this procedure is intended for regularisation only
subroutine regularise_spline2curvigrid()
use m_grid
use m_spline2curvi, only: dtolLR
use m_missing
implicit none
double precision :: xi
double precision :: dhmax, dtolLR_bak
integer :: i, j, iL, iR, iter
integer :: ih
integer :: ierror
double precision, parameter :: FAC = 1d-1 ! regularisation parameter
double precision, external :: dbdistance
call savegrd()
ierror = 1
! store settings
dtolLR_bak = dtolLR
! compute maximum mesh width and get dtolLR in the proper dimension
dhmax = 0d0
do i=1,mc
do j=1,nc-1
if ( xc(i,j).eq.DMISS .or. xc(i,j+1).eq.DMISS ) cycle
dhmax = max(dhmax, dbdistance(xc(i,j),yc(i,j),xc(i,j),yc(i,j+1)))
end do
end do
dtolLR = dtolLR*dhmax
do j=1,nc
i = 1
do while ( i.le.mc )
if ( xc(i,j).ne.DMISS .and. yc(i,j).ne.DMISS ) then
! get neighboring nodes
call get_LR(mc, xc(:,j), yc(:,j), i, iL, iR)
! regularise grid on right hand side of this node (asymmetric)
do ih = i+1, iR-1
xi = dble(ih-i)/dble(iR-i) * FAC
xc(ih,j) = (1d0-xi)*xc(i,j) + xi*xc(iR,j)
yc(ih,j) = (1d0-xi)*yc(i,j) + xi*yc(iR,j)
end do
else ! just advance pointer
iR = i+1
end if
i = max(iR, i+1)
end do
end do
ierror = 0
1234 continue
! restore settings
dtolLR = dtolLR_bak
return
end subroutine regularise_spline2curvigrid
!> disable network nodes/samples outside curvilinear grid
subroutine disable_outside_curvigrid(Nk, Ns, xk, yk, xs, ys, imaskk, imasks)
use m_grid
use m_polygon
use m_missing
implicit none
integer, intent(in) :: Nk !< number of network nodes
integer, intent(in) :: Ns !< number of samples
double precision, dimension(Nk), intent(in) :: xk, yk !< network node coordinates
double precision, dimension(Ns), intent(in) :: xs, ys !< sample coordinates
integer, dimension(Nk), intent(out) :: imaskk !< network nodes inside curvigrid (1) or not (0)
integer, dimension(Ns), intent(out) :: imasks !< samples inside curvigrid (1) or not (0)
integer :: i
integer :: in
integer :: ierror
ierror = 1
imaskk = 0
imasks = 0
! store polygon
call savepol()
! delete polygon
call delpol()
! copy curvigrid boundaries to polygon
call copycurvigridboundstopol()
in = -1
do i=1,Nk
call dbpinpol(xk(i), yk(i), in)
if ( in.eq.1) then
imaskk(i) = 1
end if
end do
do i=1,Ns
call dbpinpol(xs(i), ys(i), in)
if ( in.eq.1) then
imasks(i) = 1
end if
end do
ierror = 0
1234 continue
! restore polygon
call restorepol()
return
end subroutine disable_outside_curvigrid
!> copy curvigrid boundaries to polygon(s)
subroutine copycurvigridboundstopol()
use network_data
use m_grid
use m_polygon
implicit none
integer :: ierror
ierror = 1
! save net and curvigrid
call save()
call savegrd()
! delete net
call zeronet()
call gridtonet()
call copynetboundstopol(1,1)
ierror = 0
1234 continue
! resore net and curvigrid
call restore()
call restoregrd()
return
end subroutine copycurvigridboundstopol
!> write the network domains to file
!> it is assumed that the domain coloring "idomain" is available
subroutine partition_write_domains(netfilename,icgsolver)
use m_partitioninfo
use unstruc_netcdf, only: unc_write_net
use m_polygon, only: NPL
implicit none
character(len=*), intent(in) :: netfilename !< filename of whole network
integer, intent(in) :: icgsolver !< intended solver
integer, parameter :: maxnamelen=255
integer, parameter :: numlen=4 ! number of digits in domain number string/filename
character(len=maxnamelen) :: filename
character(len=numlen) :: sdmn_loc ! domain number string
integer :: idmn ! domain number
integer :: i, len, num, mdep
integer :: ierror
ierror = 1
! save network
call save()
! get file basename
filename = ''
len = index(netfilename, '_net')-1
if ( len.lt.1 ) then
call qnerror('write domains: net filename error', ' ', ' ')
goto 1234
end if
! set ghostlevel parameters
call partition_setghost_params(icgsolver)
! loop over all domains
do idmn=0,ndomains-1
! make the domain number string
if ( numlen.eq.4 ) then
write(sdmn_loc, '(I4.4)') idmn
else
call qnerror('write domains: partition filename error', ' ', ' ')
goto 1234
end if
filename = trim(netfilename(1:len)//'_'//sdmn_loc//'_net.nc')
! make the domain by deleting other parts of the net
call partition_make_domain(idmn, numlay_cellbased, numlay_nodebased, ierror)
if ( ierror.ne.0 ) goto 1234
! write network to file
call unc_write_net(filename, janetcell = 0, janetbnd = 1) ! Save net bnds to prevent unnecessary open bnds
! begin debug
! make and write the ghost lists
! filename = trim(netfilename(1:len)//'_'//sdmn_loc//'_gst.pli')
! call partition_make_ghostlists(idmn, ierror)
! if ( ierror.ne.0 ) cycle
! call write_ghosts(filename)
! end debug
! restore network
call restore()
end do
! write partitioning polygon
if ( NPL.gt.0 ) then
! use existing polygon
else
call generate_partition_pol_from_idomain()
end if
filename = trim(netfilename(1:len)//'_part.pol')
call newfil(MDEP,filename)
call wripol(mdep)
ierror = 0
1234 continue
return
end subroutine partition_write_domains
!> perform actions in batch
subroutine refine_from_commandline()
use network_data
use m_partitioninfo
use unstruc_netcdf, only: unc_write_net
use m_samples_refine
implicit none
integer :: MPOL
character(len=10) :: snum
character(len=128) :: filnam
!call generate_partitioning_from_pol()
!write(snum, "(I4.4)") ndomains
!call partition_write_domains('par'//trim(snum)//'_net.nc')
filnam = 'out_net.nc'
CALL REFINECELLSANDFACES2()
call unc_write_net(trim(filnam))
end subroutine refine_from_commandline
! make the dual mesh
subroutine make_dual_mesh()
use m_alloc
use m_missing
use network_data
use m_flowgeom, only: xz, yz
implicit none
double precision, dimension(:), allocatable :: xk_new, yk_new, zk_new
integer, dimension(:,:), allocatable :: kn_new
integer, dimension(:), allocatable :: newnode ! new node on link
integer :: numk_new, numL_new, numcur_k, numcur_L
integer :: k, kk, k1, k2, kL, kR, L, ic, icL, icR
if ( netstat.eq.NETSTAT_CELLS_DIRTY ) then
call findcells(0)
end if
call makenetnodescoding()
call save()
! allocate
allocate(xk_new(numk), yk_new(numk), zk_new(numk))
allocate(kn_new(3,numL))
allocate(newnode(numL))
xk_new = DMISS
yk_new = DMISS
yk_new = DMISS
kn_new = 0
newnode = 0
! copy netcell circumcenters to new nodes
numk_new=0
numcur_k = ubound(xk_new,1)
do ic=1,nump
numk_new = numk_new+1
call increasenodes(numk_new,numcur_k)
xk_new(numk_new) = xz(ic)
yk_new(numk_new) = yz(ic)
zk_new(numk_new) = DMISS
end do
! make new internal links
numL_new = 0
numcur_L = ubound(kn_new,2)
do L=1,numL
if ( lnn(L).gt.1 .and. kn(3,L).eq.2 ) then
numL_new = numL_new+1
call increaselinks(numL_new, numcur_L)
icL = lne(1,L)
icR = lne(2,L)
kn_new(1,numL_new) = icL
kn_new(2,numL_new) = icR
kn_new(3,numL_new) = 2
end if
end do
! add boundary nodes and links in cells
do L=1,numL
if ( lnn(L).eq.1 ) then
if ( newnode(L).eq.0 ) then
! add new node and administer
numk_new = numk_new+1
call increasenodes(numk_new, numcur_k)
k1 = kn(1,L)
k2 = kn(2,L)
xk_new(numk_new) = 0.5d0*(xk(k1)+xk(k2))
yk_new(numk_new) = 0.5d0*(yk(k1)+yk(k2))
zk_new(numk_new) = DMISS
newnode(L) = numk_new
! add link
numL_new = numL_new+1
call increaselinks(numL_new,numcur_L)
icL = lne(1,L)
kn_new(1,numL_new) = icL
kn_new(2,numL_new) = newnode(L)
kn_new(3,numL_new) = 2
end if
end if
end do
! add boundary links
do k=1,numk
if ( nb(k).eq.2 .or. nb(k).eq.3 ) then
icL = 0
icR = 0
kL = 0
kR = 0
do kk=1,nmk(k)
L = nod(k)%lin(kk)
if ( lnn(L).eq.1 ) then
if ( icL.eq.0 ) then
icL = lne(1,L)
kL = newnode(L)
else if ( icR.eq.0 ) then
icR = lne(1,L)
kR = newnode(L)
else
exit
end if
end if
end do
if ( kL.ne.0 .and. kR.ne.0 ) then
if ( icL.ne.icR ) then ! links in different cells
numL_new = numL_new+1
call increaselinks(numL_new,numcur_L)
kn_new(1,numL_new) = kL
kn_new(2,numL_new) = kR
kn_new(3,numL_new) = 2
else ! links in same cell: add common node
numk_new = numk_new+1
call increasenodes(numk_new,numcur_k)
xk_new(numk_new) = xk(k)
yk_new(numk_new) = yk(k)
zk_new(numk_new) = DMISS
numL_new = numL_new+2
call increaselinks(numL_new,numcur_L)
kn_new(1,numL_new-1) = kL
kn_new(2,numL_new-1) = numk_new
kn_new(3,numL_new-1) = 2
kn_new(1,numL_new) = numk_new
kn_new(2,numL_new) = kR
kn_new(3,numL_new) = 2
end if
end if
end if
end do
! delete old network
call zeronet()
! allocate new network
call increasenetw(numk_new, numL_new)
! set new network dimensions
numk = numk_new
numL = numL_new
! copy to new network
do k=1,numk
xk(k) = xk_new(k)
yk(k) = yk_new(k)
zk(k) = zk_new(k)
end do
do L=1,numL
kn(1:3,L) = kn_new(1:3,L)
end do
! refresh node administration
call setnodadm(0)
! mark cell administration as out-of-date
netstat = NETSTAT_CELLS_DIRTY
1234 continue
! deallocate
if ( allocated(xk_new) ) deallocate(xk_new)
if ( allocated(yk_new) ) deallocate(yk_new)
if ( allocated(zk_new) ) deallocate(zk_new)
if ( allocated(kn_new) ) deallocate(kn_new)
if ( allocated(newnode) ) deallocate(newnode)
return
contains
subroutine increasenodes(numk_new, numcur_k)
implicit none
integer, intent(in) :: numk_new !< new number of net nodes
integer, intent(inout) :: numcur_k !< current (in) and new (out) array size
if ( numk_new.gt.numcur_k ) then
numcur_k = int(1.2d0*dble(numk_new)+1d0)
call realloc(xk_new, numcur_k, keepExisting=.true., fill=DMISS)
call realloc(yk_new, numcur_k, keepExisting=.true., fill=DMISS)
call realloc(zk_new, numcur_k, keepExisting=.true., fill=DMISS)
end if
return
end subroutine
subroutine increaselinks(numL_new, numcur_L)
implicit none
integer, intent(in) :: numL_new !< new number of links
integer, intent(inout) :: numcur_L !< current (in) and new (out) array size
if ( numL_new.gt.numcur_L ) then
numcur_L = int(1.2d0*dble(numL_new)+1d0)
call realloc(kn_new, (/ 3, numcur_L/), keepExisting=.true., fill=0)
end if
return
end subroutine increaselinks
end subroutine make_dual_mesh
!> perform partitioning from command line
subroutine partition_from_commandline(fnam, md_Ndomains, md_jacontiguous, md_icgsolver)
use network_data
use m_partitioninfo
use m_polygon
implicit none
character(len=255), intent(in) :: fnam !< filename
integer, intent(in) :: md_Ndomains !< number of subdomains, Metis (>0) or polygon (0)
integer, intent(in) :: md_jacontiguous !< contiguous domains, Metis (1) or not (0)
integer, intent(in) :: md_icgsolver !< intended solver
call findcells(0)
call find1dcells()
if ( nump1d2d.lt.1 ) return
if ( md_Ndomains.gt.0 ) then ! use METIS
call partition_METIS_to_idomain(md_Ndomains, md_jacontiguous)
! generate partitioning polygons
Ndomains = md_Ndomains
call generate_partition_pol_from_idomain()
else if ( NPL.gt.1 ) then ! use polygons
! generate partitioning polygons
call generate_partitioning_from_pol()
end if
if ( ndomains.gt.1 ) then
call partition_write_domains(trim(fnam),md_icgsolver)
end if
return
end subroutine partition_from_commandline
!> Read options and files from command line
!> autostart/autostartstop is not filled in directly, needs to be merged with MDU-file option
function read_commandline() result(istat)
use m_commandline_option
use unstruc_model
use unstruc_display, only: jaGUI
use unstruc_messages
use string_module, only: str_lower
use m_samples_refine
USE m_partitioninfo
use unstruc_version_module
use dfm_error
use unstruc_api
implicit none
integer :: istat !< Returned result status
integer :: ncount
integer :: k, iastat
logical :: jawel
character(len=255) :: inarg, inarg0
! 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
istat = DFM_NOERR
ncount = command_argument_count()
iarg_autostart = -1
k = 0
numfiles = 0
do while ( k.lt.ncount )
k = k+1
call get_command_argument(k, inarg)
! read command line option and key-value pair(s)
call read_commandline_option(inarg, Soption, Nkeys, Skeys, ivals)
if (index(inarg,'batch') > 0) then
jabatch = 1
endif
select case (trim(Soption))
! Commandline switches
case ('pressakey' )
md_pressakey = 1
case ('autostart')
iarg_autostart = MD_AUTOSTART
case ('autostartstop')
iarg_autostart = MD_AUTOSTARTSTOP
case ('noautostart')
iarg_autostart = MD_NOAUTOSTART
case ('nodisplay')
jaGUI = 0
if ( iarg_autostart.eq.-1 ) then ! unset
iarg_autostart = MD_AUTOSTARTSTOP
end if
case ('partition')
md_japartition = 1
! default settings
md_ndomains = 0
md_jacontiguous = 0
md_icgsolver = 0
! key-value pairs
do ikey=1,Nkeys
if (trim(Skeys(ikey)) == 'ndomains') then
md_ndomains = ivals(ikey)
else if (trim(Skeys(ikey)) == 'contiguous') then
md_jacontiguous = ivals(ikey)
else if (trim(Skeys(ikey)) == 'icgsolver') then
md_icgsolver = ivals(ikey)
end if
end do
case ('t', 'threads')
k = k+1
inarg0 = inarg
call get_command_argument(k, inarg, status=iastat)
if (iastat == 0) then
read(inarg, *, iostat=iastat) md_numthreads
if (iastat /= 0 .or. md_numthreads < 0) then
write (*,*) 'Error in commandline option: '''//trim(inarg0)//' '//trim(inarg)//''', invalid number of threads.'
end if
else
write (*,*) 'Error in commandline option: '''//trim(inarg0)//''', missing number of threads.'
end if
case ('display')
do ikey=1,Nkeys
call str_lower(Skeys(ikey))
if (trim(Skeys(ikey)) == 'opengl') then
md_jaopengl = min(max(ivals(ikey),0),1)
end if
end do
case ('refine')
iarg_autostart = MD_AUTOSTARTSTOP
jaGUI = 0
md_jarefine = 1
irefinetype = ITYPE_WAVECOURANT
do ikey=1,Nkeys
call str_lower(Skeys(ikey))
if (trim(Skeys(ikey)) == 'hmin') then
hmin = dble(ivals(ikey))
else if (trim(Skeys(ikey)) == 'dtmax') then
Dt_maxcour = dble(ivals(ikey))
else if (trim(Skeys(ikey)) == 'maxlevel') then
MAXLEVEL = ivals(ikey)
else if (trim(Skeys(ikey)) == 'connect') then
jaconnect = max(min(ivals(ikey),1),0)
else if (trim(Skeys(ikey)) == 'directional') then
jadirectional = max(min(ivals(ikey),1),0)
else if (trim(Skeys(ikey)) == 'outsidecell') then
jaoutsidecell = max(min(ivals(ikey),1),0)
end if
end do
case ('h', 'help')
call print_help_commandline()
istat = DFM_EXIT ! Exit without any error.
return
case ('q', 'quiet')
loglevel_StdOut = LEVEL_ERROR
loglevel_file = LEVEL_ERROR
case ('verbose')
! --verbose:[level_stdout[:level_dia]], e.g., --verbose:INFO,DEBUG
! where level is in: {DEBUG|INFO|WARNING|ERROR|FATAL}
! One or even two optional verbosity levels, default is INFO
if (Nkeys == 1) then
SKeys(2) = SKeys(1) ! Only one level given, use same for stdout and log file.
elseif (Nkeys == 0) then
SKeys(1) = 'INFO' ! No specific levels given, use INFO for stdout, DEBUG for log file.
SKeys(2) = 'DEBUG'
end if
loglevel_StdOut = stringtolevel(Skeys(1))
loglevel_file = stringtolevel(Skeys(2))
! Note: if use input was wrong here, result will be LEVEL_NONE (==silent). Desirable?
case ('v', 'version')
call get_full_versionstring_unstruc_full(msgbuf)
write (*,*) trim(msgbuf)
write (*,*) 'Compiled with support for:'
if (jaGUI == 1) then
write (*,*) 'IntGUI: yes'
else
! Cheap trick for fast compilation of dflowfm-cli executable: it never included linking of Interacter, nor OpenGL,
! but since we don't want to completely recompile the kernel with HAVE_DISPLAY=0, we simply detect it at runtime with jaGUI==0.
write (*,*) 'IntGUI: no'
end if
#ifdef HAVE_OPENGL
if (jaGUI == 1) then
write (*,*) 'OpenGL: yes'
else
! Cheap trick for fast compilation of dflowfm-cli executable: it never included linking of Interacter, nor OpenGL,
! but since we don't want to completely recompile the kernel with HAVE_DISPLAY=0, we simply detect it at runtime with jaGUI==0.
write (*,*) 'OpenGL: no'
end if
#else
write (*,*) 'OpenGL: no'
#endif
#ifdef _OPENMP
write (*,*) 'OpenMP: yes'
#else
write (*,*) 'OpenMP: no'
#endif
#ifdef HAVE_MPI
write (*,*) 'MPI : yes'
#else
write (*,*) 'MPI : no'
#endif
#ifdef HAVE_PETSC
write (*,*) 'PETSc : yes'
#else
write (*,*) 'PETSc : no'
#endif
#ifdef HAVE_METIS
write (*,*) 'METIS : yes'
#else
write (*,*) 'METIS : no'
#endif
istat = DFM_EXIT ! Exit without any error.
return
case ('yolo')
stop
case ('test')
md_jatest = 1
! key-value pairs
do ikey=1,Nkeys
if (trim(Skeys(ikey)) == 'M') then
md_M = ivals(ikey)
else if (trim(Skeys(ikey)) == 'N') then
md_N = ivals(ikey)
else if (trim(Skeys(ikey)) == 'Nruns') then
md_Nruns = ivals(ikey)
end if
end do
jaGUI = 0
if ( iarg_autostart.eq.-1 ) then ! unset
iarg_autostart = MD_AUTOSTARTSTOP
end if
return
case ('solvertest')
md_soltest = 1
! key-value pairs
do ikey=1,Nkeys
if (trim(Skeys(ikey)) == 'CFL') then
md_CFL = ivals(ikey)
else if (trim(Skeys(ikey)) == 'icgsolver') then
md_icgsolver = ivals(ikey)
else if (trim(Skeys(ikey)) == 'maxmatvecs') then
md_maxmatvecs = ivals(ikey)
else if (trim(Skeys(ikey)) == 'epscg') then
md_epscg = ivals(ikey)
else if (trim(Skeys(ikey)) == 'epsdiff') then
md_epsdiff = ivals(ikey)
end if
end do
case default
INQUIRE(FILE = trim(inarg),EXIST = JAWEL)
if (JAWEL) then
numfiles = numfiles+1
if ( numfiles.le.maxnumfiles .and. len_trim(inarg).le.lenfile ) then
inputfiles(numfiles) = trim(inarg)
else
call mess(LEVEL_INFO, 'To many input files or filename '''//trim(inarg)//''' too long.')
end if
else
call mess(LEVEL_INFO, 'File not found: '''//trim(inarg)//'''. Ignoring this commandline argument.')
end if
end select
end do
if (numfiles == 0 .and. jaGUI /= 1) then
write (*,*) 'Error: Missing arguments.'
call print_help_commandline()
istat = DFM_MISSINGARGS
return
end if
end function read_commandline
subroutine print_help_commandline()
use unstruc_display, only: jaGUI
implicit none
character(len=255) :: progarg
integer :: is, ie, n, istat
character(len=1), external :: get_dirsep
! Some code to prettyprint the current executable name in help text
call get_command_argument(0, progarg, n, istat)
if (istat /= 0) then
progarg = 'dflowfm'
end if
is = index(progarg(1:n), get_dirsep(), .true.)
is = is+1
ie = index(progarg(1:n), '.exe', .true.)
if (ie==0) then
ie = n
else
ie = ie-1
end if
! Commandline switches
write (*,*) 'Usage: '//progarg(is:ie)//' [OPTIONS] [FILE]...'
write (*,*) 'Options:'
write (*,*) ' --autostart MDUFILE'
write (*,*) ' Auto-start the model run, and wait upon completion.'
write (*,*) ' '
write (*,*) ' --autostartstop MDUFILE'
write (*,*) ' Auto-start the model run, and exit upon completion.'
write (*,*) ' '
write (*,*) ' --noautostart MDUFILE'
write (*,*) ' Disable any AutoStart option in the MDU file (if any).'
write (*,*) ' '
if (jaGUI == 1) then ! Cheap trick at runtime instead of compiletime with HAVE_DISPLAY.
write (*,*) ' --nodisplay'
write (*,*) ' Disable GUI-screen output (only effective on Windows).'
write (*,*) ' '
end if
write (*,*) ' --partition:OPTS [POLFILE] NETFILE'
write (*,*) ' Partitions the unstructured grid in NETFILE into multiple files.'
write (*,*) ' '
write (*,*) ' POLFILE is an optional polygon file which defines the partitions.'
write (*,*) ' Only used when ndomain in OPTS is undefined or 0.'
write (*,*) ' '
write (*,*) ' OPTS is a colon-separated list opt1=val1:opt2=val2:...'
write (*,*) ' ndomains=N Number of partitions.'
write (*,*) ' contiguous=[01] Enforce contiguous grid cells in each domain.'
write (*,*) ' '
write (*,*) ' -t N, --threads N'
write (*,*) ' Set maximum number of OpenMP threads. N must be a positive integer.'
write (*,*) ' '
write (*,*) ' '
#ifdef HAVE_OPENGL
if (jaGUI == 1) then ! Cheap trick at runtime instead of compiletime with HAVE_DISPLAY.
write (*,*) ' --display:opengl=[01]'
write (*,*) ' Dis/enable OpenGL usage in GUI (only effective on Windows).'
write (*,*) ' '
endif
#endif
write (*,*) ' --refine:OPTS NETFILE'
write (*,*) ' Refine the unstructured grid in NETFILE from commandline.'
write (*,*) ' OPTS is a colon-separated list opt1=val1:opt2=val2:...'
write (*,*) ' hmin=VAL'
write (*,*) ' dtmax=VAL'
write (*,*) ' maxlevel=M'
write (*,*) ' connect=[01]'
write (*,*) ' directional=[01]'
write (*,*) ' outsidecell=[01]'
write (*,*) ' '
write (*,*) ' -q, --quiet'
write (*,*) ' Minimal output: Only (fatal) errors are shown.'
write (*,*) ' '
write (*,*) ' --verbose:[level_stdout[:level_dia]], e.g., --verbose:INFO:DEBUG'
write (*,*) ' Set verbosity level of output on standard out and in diagnostics file.'
write (*,*) ' where level is in: {DEBUG|INFO|WARNING|ERROR|FATAL}'
write (*,*) ' Levels are optional, default is INFO on screen, DEBUG in dia file.'
write (*,*) ' '
write (*,*) ' -h, --help'
write (*,*) ' Display this help information and exit.'
write (*,*) ' '
write (*,*) ' -v, --version'
write (*,*) ' Output version information and exit.'
end subroutine print_help_commandline
!> get mesh bounding box coordinates (useful for spherical, periodic coordinates)
!> 2D part of the mesh only
subroutine get_meshbounds(xboundmin, xboundmax)
use network_data
implicit none
double precision, intent(out) :: xboundmin, xboundmax !< mesh bounding box x-coordinates
double precision :: x1, x2
integer :: L
xboundmin = huge(1d0)
xboundmax = -huge(1d0)
do L=1,numL
if ( kn(3,L).eq.2 ) then
x1 = xk(kn(1,L))
x2 = xk(kn(2,L))
xboundmin = min(min(x1,x2), xboundmin)
xboundmax = max(max(x1,x2), xboundmax)
end if
end do
return
end subroutine get_meshbounds
!> rearrange netnodes for spherical, periodic coordinates
!> net nodes at the left are preferred
subroutine rearrange_worldmesh(xboundmin, xboundmax)
use m_sferic
use network_data
implicit none
double precision, intent(in) :: xboundmin, xboundmax !< mesh bounding box x-coordinates
integer :: k
if ( jsferic.eq.1 .and. xboundmax-xboundmin.gt.180d0) then
do k=1,numk
if ( xk(k)-360d0.ge.xboundmin ) then
xk(k) = xk(k)-360d0
end if
end do
end if
return
end subroutine rearrange_worldmesh
!> find netcells surrounding a netnode, order in link direction "nod()%cell"
!> cell "0" is a fictious boundary-cell
subroutine get_celllist(k, N, iclist)
use network_data
implicit none
integer, intent(in) :: k !< netnode
integer, intent(in) :: N !< array size
integer, dimension(N), intent(out) :: iclist !< list of netcells attached to the node
integer :: ierror ! error (1) or not (0)
integer :: i, ip1, ic1, ic2, j, ja, L, Lp1, NN
integer :: ii, iim1
ierror = 1
NN = nmk(k)
if ( NN.gt.N ) then
call qnerror('get_celllist: array size error', ' ', ' ')
goto 1234
end if
do i=1,NN
! find cell between ith and (i+1)rst link, 0 indicates no cell (boundary)
L = nod(k)%lin(i)
ip1 = i+1; if ( ip1.gt.NN ) ip1=ip1-NN
Lp1 = nod(k)%lin(ip1)
ic1 = lne(1,L)
if ( lnn(L).gt.1) then
ic2 = lne(2,L)
else
ic2 = 0 ! boundary netlink
end if
! check if cell ic1 contains link (i+1)
ja = 0
if ( lnn(L).gt.0 ) then
! find own link index
ii = 1
do while ( netcell(ic1)%lin(ii).ne.L .and. ii.lt.netcell(ic1)%N )
ii = ii+1
end do
! check if previous netlink in netcell ic1 is netlink (i+1)
iim1 = ii-1; if ( iim1.lt.1 ) iim1=iim1+netcell(ic1)%N
if ( netcell(ic1)%lin(iim1).eq.Lp1 ) then
ja = 1
end if
end if
if (ja.eq.1 ) then
! cell ic1 is between the ith and (i+1)rst link
iclist(i) = ic1
else
! if cell ic1 does not contain link (i+1), use ic2 (0 for boundary, or isolated, or 1D links)
iclist(i) = ic2
end if
end do
! determine if ic1 or ic2
ierror = 0
1234 continue
return
end subroutine get_celllist
!> make dual cell polygon around netnode k
subroutine make_dual_cell(k, N, rcel, xx, yy, num)
use network_data
use m_polygon
use m_missing
implicit none
integer, intent(in) :: k !< netnode number
integer, intent(in) :: N !< array size
double precision, intent(in) :: rcel !< dual-cell enlargement factor around dual-cell center
double precision, dimension(N), intent(out) :: xx, yy !< dual-cell polygon coordinates
integer, intent(out) :: num !< polygon dimension
integer :: ierror ! error (1) or not (0)
integer, dimension(N) :: iclist
double precision :: xc, yc, area
integer :: i, ic, k1, k2, L, NN, Nc
integer :: jacounterclockwise ! counterclockwise (1) or not (0) (not used here)
ierror = 1
!if ( k.eq.4399 ) then
! continue
!end if
NN = nmk(k)
if ( NN.gt.N ) then
call qnerror('make_dual_cell: array size error', ' ', ' ')
goto 1234
end if
! get ordered cell list
call get_celllist(k, N, iclist)
! construct dual cell polygon
num = 0
do i=1,NN
num = num+1
L = nod(k)%lin(i)
k1 = kn(1,L)
k2 = kn(2,L)
xx(num) = 0.5d0*(xk(k1)+xk(k2)) ! not safe for periodic, spherical coordinates
yy(num) = 0.5d0*(yk(k1)+yk(k2))
num = num+1
ic = iclist(i)
if ( ic.ne.0 ) then
Nc = netcell(ic)%N
xx(num) = xzw(ic)
yy(num) = yzw(ic)
else
xx(num) = xk(k)
yy(num) = yk(k)
end if
end do
! compute dual cell center
call comp_masscenter(num, xx, yy, xc, yc, area, jacounterclockwise)
! enlarge dual cell
do i=1,num
xx(i) = xc + RCEL*(xx(i)-xc)
yy(i) = yc + RCEL*(yy(i)-yc)
end do
!! BEGIN DEBUG
! !if ( k.eq.5 ) then
! call increasepol(NPL+num+1, 1)
! NPL = NPL+1
! xpl(NPL) = DMISS
! ypl(NPL) = DMISS
! zpl(NPL) = 0d0
! do i=1,num
! NPL = NPL+1
! xpl(NPL) = xx(i)
! ypl(NPL) = yy(i)
! zpl(NPL) = dble(k)
! end do
! !end if
!! END DEBUG
ierror = 0
1234 continue
return
end subroutine make_dual_cell
!
subroutine fix_global_polygons()
use m_sferic
use m_polygon
use m_missing
use m_partitioninfo
use network_data, only: numk, nump, xk, xzw, yzw
use unstruc_messages
implicit none
integer :: i, j, k
double precision :: x1, x2
double precision :: dist, dist1, dist2
double precision :: xmin, xmax
integer :: jpoint, jstart, jend
integer :: i1, i2, num, NPLnew, NPLnewest
integer :: im1, ip1, isign
integer :: jaleft, jaright, japole
integer :: numshifted ! number of shifted polygon nodes
integer :: in, idmn
double precision, parameter :: dtol = 1d-4
! check for spherical coordinates
if ( jsferic.ne.1 .or. NPL.le.2 ) return
! fix the polygon nodes on the poles
jpoint=1 ! first polygon node
jstart = 1
jend = 0
NPLnew = NPL
do while ( jpoint.le.NPL )
call get_startend(NPL-jpoint+1, xpl(jpoint:NPL), ypl(jpoint:NPL), jstart, jend)
jstart = jstart + jpoint-1
jend = jend + jpoint-1
jpoint = max(jend+2,jpoint+1) ! min: make sure we advance the pointer
i = jstart-1
do while ( i.lt.jend )
i = i+1
if ( abs(abs(ypl(i))-90d0).lt.dtol ) then
! add node
call increasepol(NPL+1,1)
do j=NPL,i,-1
xpl(j+1) = xpl(j)
ypl(j+1) = ypl(j)
zpl(j+1) = zpl(j)
end do
NPL = NPL+1
jend = jend+1
jpoint = jpoint+1
i = i+1
im1 = i-2; if ( im1.lt.jstart ) im1 = im1 + jend-jstart+1
ip1 = i+1; if ( ip1.gt.jend ) ip1 = ip1 - (jend-jstart+1)
! shift current node above previous node
xpl(i-1) = xpl(im1)
! place new node above next node
xpl(i) = xpl(ip1)
ypl(i) = ypl(i)
zpl(i) = zpl(i)
end if
end do
end do
numshifted = 0
jpoint=1 ! first polygon node
jstart = 1
jend = 0
NPLnew = NPL
do while ( jpoint.le.NPL )
call get_startend(NPL-jpoint+1, xpl(jpoint:NPL), ypl(jpoint:NPL), jstart, jend)
jstart = jstart + jpoint-1
jend = jend + jpoint-1
jpoint = max(jend+2,jpoint+1) ! min: make sure we advance the pointer
jaleft = 0
jaright = 0
japole = 0
do i=jstart,jend
ip1 = i+1
if ( ip1.gt.jend ) ip1 = ip1 - (jend-jstart+1)
! check if the linesegment (i,i+1) exists
if ( xpl(i).eq.DMISS .or. ypl(i).eq.DMISS .or. xpl(ip1).eq.DMISS .or. ypl(ip1).eq.DMISS ) cycle
! compute two other canditates for xpl(i+1)
x1 = xpl(ip1)-360
x2 = xpl(ip1)+360
! select candidate that is closest to xpl(i)
dist = abs(xpl(ip1)-xpl(i)) ! did not use getdx intentionally
dist1 = abs(x1-xpl(i))
dist2 = abs(x2-xpl(i))
if ( dist1.lt.dist .and. dist1.lt.dist2 ) then
if ( ip1.ne.jstart ) then
xpl(ip1) = x1 ! keep first polygon node, polygon around pole if it needs to be moved
else
japole = 1
end if
jaright = 1
else if ( dist2.lt.dist .and. dist2.lt.dist1 ) then
if ( ip1.ne.jstart ) then
xpl(ip1) = x2 ! keep first polygon node, polygon around pole if it needs to be moved
else
japole = 1
end if
jaleft = 1
end if
end do
if ( japole.eq.1 ) then ! special treatment
jaleft = 0
jaright = 0
end if
if ( jaleft.eq.1 .or. jaright.eq.1 ) then
! copy polygons to the left and to the right
num = jend-jstart+1
i1 = NPLnew+1
if ( jaleft.eq.1 ) then
i2 = i1 + num+1
else
i2 = i1
end if
! find new array size
if ( jaright.eq.1 ) then
NPLnewest = i2 + num+1
else
NPLnewest = i2
end if
call increasepol(NPLnewest,1)
xpl(NPLnew+1:) = DMISS
ypl(NPLnew+1:) = DMISS
zpl(NPLnew+1:) = DMISS
do i=jstart,jend
if ( xpl(i).ne.DMISS .and. ypl(i).ne.DMISS ) then
i1 = i1+1
i2 = i2+1
if ( jaleft.eq.1 ) then
xpl(i1) = xpl(i)-360
ypl(i1) = ypl(i)
zpl(i1) = zpl(i)
end if
if ( jaright.eq.1 ) then
xpl(i2) = xpl(i)+360
ypl(i2) = ypl(i)
zpl(i2) = zpl(i)
end if
end if
end do
NPLnew = NPLnewest
end if
end do
NPL = NPLnew
! check for poles
jpoint=1 ! first polygon node
jstart = 1
jend = 0
do
call get_startend(NPL-jpoint+1, xpl(jpoint:NPL), ypl(jpoint:NPL), jstart, jend)
jstart = jstart + jpoint-1
jend = jend + jpoint-1
jpoint = max(jend+2,jpoint+1) ! min: make sure we advance the pointer
! check if a polygon covers a pole
i = jend
x1 = xpl(jstart)-360
x2 = xpl(jstart)+360
dist = abs(xpl(jstart)-xpl(jend))
dist1 = abs(x1-xpl(jend))
dist2 = abs(x2-xpl(jend))
if ( dist1.lt.dist .or. dist2.lt.dist ) then
if ( dist1.lt.dist2 ) then
isign = -1
else
isign = 1
end if
! copy to left, to right and add two points at pole
num = jend-jstart+1
call increasepol(NPL+2*num+2,1)
do i=NPL,jend+1,-1
xpl(i+2*num+2) = xpl(i)
ypl(i+2*num+2) = ypl(i)
zpl(i+2*num+2) = zpl(i)
end do
do i=jend,jstart,-1
! copy to right
xpl(2*num+i) = xpl(i)+isign*360
ypl(2*num+i) = ypl(i)
zpl(2*num+i) = zpl(i)
! move original to center
xpl(num+i) = xpl(i)
ypl(num+i) = ypl(i)
zpl(num+i) = zpl(i)
! copy to left
xpl(i) = xpl(i)-isign*360
ypl(i) = ypl(i)
zpl(i) = zpl(i)
end do
! add two points at poles
xpl(jend+2*num+1) = xpl(jend+2*num)
xpl(jend+2*num+2) = xpl(jstart)
if ( ypl(jend+2*num).gt.0 ) then
ypl(jend+2*num+1) = 90d0
ypl(jend+2*num+2) = 90d0
else
ypl(jend+2*num+1) = -90d0
ypl(jend+2*num+2) = -90d0
end if
zpl(jend+2*num+1) = zpl(jend+2*num)
zpl(jend+2*num+2) = zpl(jstart)
NPL = NPL + 2*num+2
jend = jend + 2*num+2
jpoint = jpoint + 2*num+2
end if
if ( jpoint.gt.NPL ) exit
end do
! check if the right areas are selected and add bounding polygon if not so
xmin = 1d99
xmax = -xmin
do k=1,numk
xmin = min(xk(k),xmin)
xmax = max(xk(k),xmax)
end do
xmin = 0.5d0*(xmin+xmax)-180d0
xmax = xmin+360d0
! clean up
call dealloc_tpoly(partition_pol)
! copy back to tpoly-type again
call pol_to_tpoly(npartition_pol, partition_pol)
do idmn=1,Ndomains-1
! get polygons of this subdomain
! call delpol()
! call tpoly_to_pol(partition_pol,dble(idmn))
! find a cell in this subdomain
do i=1,nump
if ( idomain(i).eq.idmn ) then
! check if cell is inside
! in = -1
! call dbpinpol(xzw(i), yzw(i), in)
call dbpinpol_tpolies(partition_pol, xzw(i), yzw(i), in, dble(idmn))
! write(6,*) i, xzw(i), yzw(i), idomain(i)
! if cell is not inside: add bounding polygon
if ( in.eq.0 ) then
call mess(LEVEL_INFO, 'swapping in/out for paritioning polygons of subdomain ', idmn)
! write(6,*) i, xzw(i), yzw(i), idomain(i)
call delpol()
NPL = 5
call increasepol(NPL, 0)
xpl(1:NPL) = (/ xmin-90d0, xmin-90d0, xmin+360d0+90d0, xmin+360d0+90d0, xmin-90d0 /)
ypl(1:NPL) = (/ 90d0, -90d0, -90d0, 90d0, 90d0 /)
zpl(1:NPL) = dble(idmn)
call pol_to_tpoly(npartition_pol, partition_pol, keepExisting=.true.)
end if
exit
end if
end do
end do
! copy tpoly-type partition polygons to polygon
call delpol()
call tpoly_to_pol(partition_pol)
return
end subroutine fix_global_polygons
!> remove "dry"masked netcells (cellmask==1) from netcell administration
!> typically used in combination with a drypoints file (samples or polygons)
!> \see samples_to_cellmask and \see polygon_to_cellmask
!> note: we do not want to alter the netnodes and netlinks and will therefore not change kn and nod%lin
subroutine remove_masked_netcells()
use network_data
use m_flowgeom, only: xz, yz, ba
use m_alloc
implicit none
integer, dimension(:), allocatable :: numnew ! permutation array
integer :: i, ic, icL, icR, icnew, isL, isR, L, num, N, numpnew
num = 0
! check if cellmask array is allocated
if ( .not.allocated(cellmask) ) goto 1234
! check if cellmask array is sufficiently large
if ( ubound(cellmask,1).lt.nump1d2d ) goto 1234
allocate(numnew(nump1d2d))
numnew = 0
numpnew = 0
do ic=1,nump1d2d
if ( cellmask(ic).eq.0 ) then ! keep cell
num = num+1
numnew(ic) = num
! write entry in netcell, use property num<=ic
if ( num.ne.ic ) then
N = netcell(ic)%N
netcell(num)%N = N
! reallocate if necessary
if ( ubound(netcell(num)%nod,1).lt.N ) then
call realloc(netcell(num)%nod, N, keepExisting=.false.)
end if
if ( ubound(netcell(num)%lin,1).lt.N ) then
call realloc(netcell(num)%lin, N, keepExisting=.false.)
end if
! move data
do i=1,N
netcell(num)%nod(i) = netcell(ic)%nod(i)
netcell(num)%lin(i) = netcell(ic)%lin(i)
end do
end if
end if
if ( ic.eq.nump) then
! determine new nump
numpnew = num
end if
end do
! clean up remainder of netcell
do ic=num+1,nump1d2d
netcell(ic)%N = 0
deallocate(netcell(ic)%nod)
deallocate(netcell(ic)%lin)
end do
! change lnn, lne
do L=1,numL
if ( lnn(L).gt.1 ) then
! check if right cell still exists
icR = lne(2,L)
isR = sign(1,icR)
if ( numnew(iabs(icR)).eq.0 ) then
! remove right cell
lnn(L) = lnn(L)-1
lne(2,L) = 0
else
! use new right cell number
lne(2,L) = isR*numnew(iabs(icR))
end if
end if
! check if left cell still exists
icL = lne(1,L)
isL = sign(1,icL)
if ( icL.ne.0 ) then
if ( numnew(iabs(icL)).eq.0 ) then
! remove left cell
lnn(L) = lnn(L)-1
if ( lnn(L).eq.1 ) then
! move right cell
lne(1,L) = lne(2,L)
lne(2,L) = 0
else
lne(1,L) = 0
end if
else
! use new left cell number
lne(1,L) = isL*numnew(iabs(icL))
end if
end if
end do
! update cell centers and bed areas
do ic=1,nump1d2d
icnew = numnew(ic)
if ( icnew.ne.0 ) then ! use property icnew<=ic
xz(icnew) = xz(ic)
yz(icnew) = yz(ic)
xzw(icnew) = xzw(ic)
yzw(icnew) = yzw(ic)
ba(icnew) = ba(ic)
end if
end do
! update number of cells
nump1d2d = num
nump = numpnew
1234 continue
! deallocate
if ( allocated(numnew) ) deallocate(numnew)
return
end subroutine remove_masked_netcells
! remove a netcell
subroutine removecell(xp,yp)
use m_netw
implicit none
integer, save :: NEEDFINDCELLS=1
double precision, intent(in) :: xp, yp !< coordinates of input point
integer :: k, in
if ( nump.lt.1 ) NEEDFINDCELLS=1
if ( NEEDFINDCELLS.ne.0 .or. netstat.ne.NETSTAT_OK ) then
call findcells(100)
call makenetnodescoding()
NEEDFINDCELLS = 0
end if
! (re)allocate
if ( allocated(cellmask) ) deallocate(cellmask)
allocate(cellmask(nump))
cellmask = 0
! 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)
if ( in.gt.0 ) exit
end do
if ( in.eq.0 ) then ! no cell found
call qnerror('removecell: no cell found', ' ', ' ')
goto 1234
end if
! mask cell
cellmask(k) = 1
! remove masked cells
call remove_masked_netcells()
1234 continue
! deallocate
deallocate(cellmask)
return
end subroutine removecell
! update cellmask from samples
subroutine samples_to_cellmask()
use network_data
use M_SAMPLES
implicit none
integer :: i, in, k, kk, n, nn
double precision :: xx(6), yy(6)
if ( allocated(cellmask) ) deallocate(cellmask)
allocate(cellmask(nump1d2d)) ; cellmask = 0
zs(1:ns) = 1
do k = 1,nump
nn = netcell(k)%N
if (nn .lt.1 ) cycle
do n = 1,nn
kk = netcell(k)%nod(n)
xx(n) = xk(kk)
yy(n) = yk(kk)
enddo
in = -1
do i=1,NS ! generate cell mask
if (zs(i) == -1) cycle
call pinpok(xs(i), ys(i), nn, xx, yy, in)
if ( in.gt.0 ) then
! mask cell
cellmask(k) = 1; zs(i) = -1
exit
end if
end do
end do
return
end subroutine samples_to_cellmask
! update cellmask from samples
subroutine pol_to_cellmask()
use network_data
use m_polygon
implicit none
integer :: i, ic, in, k, KMOD
if ( allocated(cellmask) ) deallocate(cellmask)
allocate(cellmask(nump1d2d))
cellmask = 0
if ( NPL.eq.0 ) return ! no polygon
CALL READYY('Applying polygon cellmask',0d0)
KMOD = MAX(1,NUMP/100)
! generate cell mask
in = -1
do k = 1,nump
call dbpinpol_optinside_perpol(xzw(k), yzw(k), 1, in)
if ( in.gt.0 ) then
! mask cell
cellmask(k) = 1
end if
IF (MOD(k,KMOD) .EQ. 0) THEN
CALL READYY(' ',MIN( 1d0,dble(k)/nump ) )
ENDIF
end do
CALL READYY(' ',-1d0)
return
end subroutine pol_to_cellmask
!> read drypoints file and delete dry points from net geometry (netcells)
subroutine delete_drypoints_from_netgeom()
use unstruc_model
use unstruc_messages
implicit none
character(len=128) :: ext
integer :: minp, N1, N2
integer :: ierror ! error (1) or not (0)
logical :: jawel
ierror = 1
if (len_trim(md_dryptsfile) > 0) then
inquire(FILE = trim(md_dryptsfile), exist = jawel)
if (jawel) then
! Find file extention based on first full stop symbol '.' at the back of the string.
N1 = index(trim(md_dryptsfile),'.', .true.)
N2 = len_trim(md_dryptsfile)
EXT = ' '
if ( N2.gt.N1 ) then
EXT(1:N2-N1+1) = md_dryptsfile(N1:N2)
end if
if ( ext(1:4).eq.'.pol' .or. ext(1:4).eq.'.POL' ) then
call oldfil(minp, md_dryptsfile)
call savepol()
call reapol(minp, 0)
call pol_to_cellmask() ! third column in pol-file may be used to specify inside (1), or outside (0) mode, only 0 or 1 allowed.
call delpol()
ierror = 0
else if ( ext(1:4).eq.'.xyz' .or. ext(1:4).eq.'.XYZ' ) then
call oldfil(minp, md_dryptsfile)
call savesam()
call reasam(minp, 0)
call samples_to_cellmask()
call delsam(0)
ierror = 0
end if
call remove_masked_netcells()
end if
else
ierror = 0 ! nothing to do
end if
if ( ierror.ne. 0 ) then
call mess(LEVEL_ERROR, 'error reading dry-points file '// trim(md_dryptsfile))
end if
return
end subroutine delete_drypoints_from_netgeom
!> copy samples to polygon (for further operations)
subroutine copysamtopol()
use M_SAMPLES
use m_polygon
implicit none
integer, dimension(:), allocatable :: jacopy ! sample wil be copied (1) or not (0)
integer :: i, inside, numcopy
! allocate
allocate(jacopy(Ns))
jacopy = 1
numcopy = NS
! check if selecting polygon exists
if ( NPL.gt.2 ) then
! mark and count samples to be copied to polygon
inside = -1 ! initialization of dbpinpol
do i=1,NS
call dbpinpol(xs(i), ys(i), inside)
if ( inside.ne.1 ) then
jacopy(i) = 0
numcopy = numcopy-1
end if
end do
end if
! check if samples were selected
if ( numcopy.gt.0 ) then
! copy selected samples to polygon
call savepol()
call increasepol(numcopy,0)
NPL = 0
do i=1,NS
if ( jacopy(i).eq.1 ) then
NPL=NPL+1
xpl(NPL) = xs(i)
ypl(NPL) = ys(i)
zpl(NPL) = zs(i)
end if
end do
end if
! deallocate
if ( allocated(jacopy) ) deallocate(jacopy)
return
end subroutine copysamtopol
!> take difference of samples with second sample set within tooclose distance
subroutine samdif()
use m_polygon
use m_samples
use m_samples3
use network_data, only: tooclose
use m_kdtree2
use m_missing
implicit none
double precision :: dist
integer :: i, ipnt, ierror
integer :: numnoval
double precision, parameter :: VAL_NOPNT = 1234d0
double precision, parameter :: dtol = 1d-8
double precision, external :: dbdistance
if ( NS.lt.1 .or. NS3.lt.2 ) goto 1234
! build kdtree
call build_kdtree(treeglob,NS3, xs3, ys3, ierror)
! reallocate results vector (fixed size)
call realloc_results_kdtree(treeglob,1)
if ( ierror.ne.0 ) goto 1234
call savesam()
numnoval = 0 ! count number of samples without a polygon node
do i=1,Ns
! fill query vector
call make_queryvector_kdtree(treeglob,xs(i),ys(i))
! find nearest polygon point
call kdtree2_n_nearest(treeglob%tree,treeglob%qv,1,treeglob%results)
ipnt = treeglob%results(1)%idx
if ( ipnt.gt.0 .and. ipnt.le.Ns3 ) then ! safety
! check distance to nearest polygon node
dist = dbdistance(xs(i),ys(i),xs3(ipnt),ys3(ipnt))
if ( dist.lt.tooclose .and. zs(i).ne.DMISS .and. zs3(ipnt).ne.DMISS ) then
zs(i) = zs(i) - zs3(ipnt)
! remove (nearly) zero values
if ( abs(zs(i)).lt.dtol ) then
zs(i) = DMISS
end if
else
zs(i) = VAL_NOPNT
numnoval = numnoval+1
end if
else
zs(i) = VAL_NOPNT
numnoval = numnoval+1
end if
end do
call delpol()
if ( numnoval.gt.0 ) then
! copy unassociated samples to polygon
call increasepol(numnoval,0)
NPL = 0
do i=1,NS
if ( zs(i).eq.VAL_NOPNT ) then
zs(i) = DMISS
NPL=NPL+1
xpl(NPL) = xs(i)
ypl(NPL) = ys(i)
zpl(NPL) = zs(i)
end if
end do
end if
ierror = 0
1234 continue
! deallocate kdtree if it was created
if ( treeglob%itreestat.ne.ITREE_EMPTY ) call delete_kdtree2(treeglob)
return
end subroutine samdif