!----- AGPL --------------------------------------------------------------------
!
! Copyright (C) Stichting Deltares, 2017-2019.
!
! This file is part of Delft3D (D-Flow Flexible Mesh component).
!
! Delft3D is free software: you can redistribute it and/or modify
! it under the terms of the GNU Affero General Public License as
! published by the Free Software Foundation version 3.
!
! Delft3D is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU Affero General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License
! along with Delft3D. If not, see .
!
! contact: delft3d.support@deltares.nl
! Stichting Deltares
! P.O. Box 177
! 2600 MH Delft, The Netherlands
!
! All indications and logos of, and references to, "Delft3D",
! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting
! Deltares, and remain the property of Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
! $Id$
! $HeadURL$
module m_itdate
character(len=8) :: refdat
integer :: itdate !< should be user specified for (asc routines)
integer :: jul0, imonth0, iday0, iyear0
double precision :: Tzone ! doubling with "use m_flowtimes, only : tzone"
end module m_itdate
module timespace_parameters
! enumeration for filetypes van de providers
integer, parameter :: uniform = 1 ! kx values per tijdstap 1 dim arr uni
integer, parameter :: unimagdir = 2 ! kx values per tijdstap 1 dim arr, mag/dir transf op index 1,2 u,v
integer, parameter :: svwp = 3 ! 3 velden per tijdstap 3 dim array noint
integer, parameter :: arcinfo = 4 ! 1 veld per tijdstap 2 dim array bilin/direct
integer, parameter :: spiderweb = 5 ! 3 veld per tijdstap 3 dim array bilin/spw
integer, parameter :: curvi = 6 ! 1 veld per tijdstap 2 dim array bilin/findnm
integer, parameter :: triangulation = 7 ! 1 veld per tijdstap triang
integer, parameter :: triangulationmagdir = 8 ! 2 velden u,v per tijdstap 3 dim array triang, vectormax = 2
! op basis van windreeksen op stations mag/dir
integer, parameter :: poly_tim = 9 ! for line oriented bnd conditions, refs to uniform, fourier or harmonic
integer, parameter :: inside_polygon = 10 ! Constant value inside polygon, used for initial fields.
integer, parameter :: ncgrid = 11 ! NetCDF grid, rectangular type as arcinfo
integer, parameter :: ncflow = 12 ! NetCDF flow, with arbitrary type of input
integer, parameter :: ncwave = 14 ! NetCDF com file, with arbitrary type of input
integer, parameter :: bcascii = 17 ! .bc format as ASCII file
integer, parameter :: max_file_types = 103 ! max nr of supported types for end user in ext file.
! Enumeration for file types of sub-providers (not directly in ext file)
integer, parameter :: fourier = 101 ! period(hrs), ampl(m), phas(deg) NOTE: not directly used in ext file by users.
integer, parameter :: multiple_uni = 102 ! multiple time series, no spatial relation
integer, parameter :: qhtable = 103 ! used to link to dataprovider file
! het filetype legt vast : a) format file
! b) vectormax van grootheid / heden in file
! c) elementset waarop grootheid is gedefinieerd
! d) is daarmee bepalend voor de toepasbare interpolatiemethodes
!
integer :: mdia = 0 ! -1 ! -1 = write dia, 0 = do not write dia
! enumeration for interpolation methods of providers
integer, parameter :: justupdate = 0 ! provider just updates, another provider that
! pointers to this one does the actual interpolation
integer, parameter :: spaceandtime = 1 ! intp space and time (getval)
! keep 2 meteofields in memory
integer, parameter :: spacefirst = 2 ! first intp space (update), next intp. time (getval)
! keep 2 flowfields in memory
integer, parameter :: weightfactors = 3 ! save weightfactors, intp space and time (getval)
! keep 2 pointer- and weight sets in memory
end module timespace_parameters
!> Module which constructs and connects the target Items for FM.
!! This is the wrapper between FM and the EC-module.
module m_meteo
use m_ec_module
use m_ec_provider
use MessageHandling
use m_itdate, only: itdate
use m_flowtimes, only : tzone
use m_wind
use m_nudge
use m_flow
use m_waves
use m_ship
use m_flowexternalforcings
use processes_input, only: nofun, funame, funinp
use unstruc_messages
use time_module
use m_observations
use string_module
use m_sediment, only: stm_included, stmpar
implicit none
type(tEcInstance), pointer, save :: ecInstancePtr !< FM's instance of the EC-module.
character(maxMessageLen) :: message !< EC's message, to be passed to FM's log.
!
integer, dimension(:), allocatable, target :: item_tracerbnd !< dim(numtracers)
integer, dimension(:), allocatable, target :: item_sedfracbnd !< dim(numfracs) ! JRE DEBUG sedfrac
integer, dimension(:), allocatable, target :: item_waqfun !< dim(nofun)
integer, target :: item_windx !< Unique Item id of the ext-file's 'windx' quantity's x-component.
integer, target :: item_windy !< Unique Item id of the ext-file's 'windy' quantity's y-component.
integer, target :: item_windxy_x !< Unique Item id of the ext-file's 'windxy' quantity's x-component.
integer, target :: item_windxy_y !< Unique Item id of the ext-file's 'windxy' quantity's y-component.
integer, target :: item_apwxwy_p !< Unique Item id of the ext-file's 'airpressure_windx_windy' quantity 'p'.
integer, target :: item_apwxwy_x !< Unique Item id of the ext-file's 'airpressure_windx_windy' quantity 'x'.
integer, target :: item_apwxwy_y !< Unique Item id of the ext-file's 'airpressure_windx_windy' quantity 'y'.
integer, target :: item_apwxwy_c !< Unique Item id of the ext-file's 'space var Charnock' quantity 'C'.
integer, target :: item_waterlevelbnd !< Unique Item id of the ext-file's 'waterlevelbnd' quantity's ...-component.
integer, target :: item_atmosphericpressure !< Unique Item id of the ext-file's 'atmosphericpressure' quantity
integer, target :: item_velocitybnd !< Unique Item id of the ext-file's 'velocitybnd' quantity
integer, target :: item_salinitybnd !< Unique Item id of the ext-file's 'salinitybnd' quantity
integer, target :: item_temperaturebnd !< Unique Item id of the ext-file's 'temperaturebnd' quantity
integer, target :: item_sedimentbnd !< Unique Item id of the ext-file's 'sedimentbnd' quantity
integer, target :: item_tangentialvelocitybnd !< Unique Item id of the ext-file's 'tangentialvelocitybnd' quantity
integer, target :: item_uxuyadvectionvelocitybnd !< Unique Item id of the ext-file's 'uxuyadvectionvelocitybnd'
integer, target :: item_normalvelocitybnd !< Unique Item id of the ext-file's 'normalvelocitybnd' quantity
integer, target :: item_rainfall !< Unique Item id of the ext-file's 'rainfall' quantity
integer, target :: item_rainfall_rate !< Unique Item id of the ext-file's 'rainfall_rate' quantity
integer, target :: item_qhbnd !< Unique Item id of the ext-file's 'qhbnd' quantity
integer, target :: item_shiptxy !< Unique Item id of the ext-file's 'shiptxy' quantity
integer, target :: item_movingstationtxy !< Unique Item id of the ext-file's 'movingstationtxy' quantity
integer, target :: item_pump !< Unique Item id of the ext-file's 'pump' quantity
integer, target :: item_damlevel !< Unique Item id of the ext-file's 'damlevel' quantity
integer, target :: item_gateloweredgelevel !< Unique Item id of the ext-file's 'gateloweredgelevel' quantity
integer, target :: item_generalstructure !< Unique Item id of the ext-file's 'generalstructure' quantity
integer, target :: item_lateraldischarge !< Unique Item id of the ext-file's 'generalstructure' quantity
integer, target :: item_dacs_dewpoint !< Unique Item id of the ext-file's 'dewpoint' quantity
integer, target :: item_dacs_airtemperature !< Unique Item id of the ext-file's 'airtemperature' quantity
integer, target :: item_dacs_cloudiness !< Unique Item id of the ext-file's 'cloudiness' quantity
integer, target :: item_dacs_solarradiation !< Unique Item id of the ext-file's 'solarradiation' quantity
integer, target :: item_dac_dewpoint !< Unique Item id of the ext-file's 'dewpoint' quantity
integer, target :: item_dac_airtemperature !< Unique Item id of the ext-file's 'airtemperature' quantity
integer, target :: item_dac_cloudiness !< Unique Item id of the ext-file's 'cloudiness' quantity
integer, target :: item_hacs_humidity !< Unique Item id of the ext-file's 'humidity' quantity
integer, target :: item_hacs_airtemperature !< Unique Item id of the ext-file's 'airtemperature' quantity
integer, target :: item_hacs_cloudiness !< Unique Item id of the ext-file's 'cloudiness' quantity
integer, target :: item_hacs_solarradiation !< Unique Item id of the ext-file's 'solarradiation' quantity
integer, target :: item_hac_humidity !< Unique Item id of the ext-file's 'humidity' quantity
integer, target :: item_hac_airtemperature !< Unique Item id of the ext-file's 'airtemperature' quantity
integer, target :: item_hac_cloudiness !< Unique Item id of the ext-file's 'cloudiness' quantity
integer, target :: item_humidity !< 'humidity' quantity
integer, target :: item_airtemperature !< 'airtemperature' quantity
integer, target :: item_cloudiness !< 'cloudiness' quantity
integer, target :: item_solarradiation !< 'solarradiation' quantity
integer, target :: item_discharge_salinity_temperature_sorsin !< Unique Item id of the ext-file's 'discharge_salinity_temperature_sorsin' quantity
integer, target :: item_hrms !< Unique Item id of the ext-file's 'item_hrms' quantity
integer, target :: item_tp !< Unique Item id of the ext-file's 'item_tp' quantity
integer, target :: item_dir !< Unique Item id of the ext-file's 'item_dir' quantity
integer, target :: item_fx !< Unique Item id of the ext-file's 'item_fx' quantity
integer, target :: item_fy !< Unique Item id of the ext-file's 'item_fy' quantity
integer, target :: item_wsbu !< Unique Item id of the ext-file's 'item_wsbu' quantity
integer, target :: item_wsbv !< Unique Item id of the ext-file's 'item_wsbv' quantity
integer, target :: item_mx !< Unique Item id of the ext-file's 'item_mx' quantity
integer, target :: item_my !< Unique Item id of the ext-file's 'item_my' quantity
integer, target :: item_dissurf !< Unique Item id of the ext-file's 'item_dissurf' quantity
integer, target :: item_diswcap !< Unique Item id of the ext-file's 'item_diswcap' quantity
integer, target :: item_ubot !< Unique Item id of the ext-file's 'item_ubot' quantity
integer, target :: item_nudge_tem !< 3D temperature for nudging
integer, target :: item_nudge_sal !< 3D salinity for nudging
integer, target :: item_dambreakLevelsAndWidthsFromTable !< Dambreak heights and widths
!
integer :: n_qhbnd !< Number of already connected qh-boundaries.
interface ec_gettimespacevalue
module procedure ec_gettimespacevalue_by_itemID
module procedure ec_gettimespacevalue_by_name
end interface ec_gettimespacevalue
interface ec_gettimeseries
module procedure ec_gettimeseries_by_itemID
end interface ec_gettimeseries
public ec_gettimeseries
contains
!> Initialize the module variables.
subroutine init_variables()
ecInstancePtr => null()
message = ' '
!
item_windx = ec_undef_int
item_windy = ec_undef_int
item_windxy_x = ec_undef_int
item_windxy_y = ec_undef_int
item_apwxwy_p = ec_undef_int
item_apwxwy_x = ec_undef_int
item_apwxwy_y = ec_undef_int
item_apwxwy_c = ec_undef_int
item_waterlevelbnd = ec_undef_int
item_atmosphericpressure = ec_undef_int
item_velocitybnd = ec_undef_int
item_salinitybnd = ec_undef_int
item_temperaturebnd = ec_undef_int
item_sedimentbnd = ec_undef_int
item_tangentialvelocitybnd = ec_undef_int
item_uxuyadvectionvelocitybnd = ec_undef_int
item_normalvelocitybnd = ec_undef_int
item_rainfall = ec_undef_int
item_rainfall_rate = ec_undef_int
item_qhbnd = ec_undef_int
item_shiptxy = ec_undef_int
item_movingstationtxy = ec_undef_int
item_pump = ec_undef_int
item_lateraldischarge = ec_undef_int
item_damlevel = ec_undef_int
item_gateloweredgelevel = ec_undef_int
item_generalstructure = ec_undef_int
item_dacs_dewpoint = ec_undef_int
item_dacs_airtemperature = ec_undef_int
item_dac_cloudiness = ec_undef_int
item_dac_dewpoint = ec_undef_int
item_dac_airtemperature = ec_undef_int
item_dac_cloudiness = ec_undef_int
item_dacs_solarradiation = ec_undef_int
item_hacs_humidity = ec_undef_int
item_hacs_airtemperature = ec_undef_int
item_hacs_cloudiness = ec_undef_int
item_hacs_solarradiation = ec_undef_int
item_humidity = ec_undef_int
item_airtemperature = ec_undef_int
item_cloudiness = ec_undef_int
item_solarradiation = ec_undef_int
item_hac_humidity = ec_undef_int
item_hac_airtemperature = ec_undef_int
item_hac_cloudiness = ec_undef_int
item_nudge_tem = ec_undef_int
item_nudge_sal = ec_undef_int
item_discharge_salinity_temperature_sorsin = ec_undef_int
item_hrms = ec_undef_int
item_tp = ec_undef_int
item_dir = ec_undef_int
item_fx = ec_undef_int
item_fy = ec_undef_int
item_wsbu = ec_undef_int
item_wsbv = ec_undef_int
item_mx = ec_undef_int
item_my = ec_undef_int
item_dissurf = ec_undef_int
item_diswcap = ec_undef_int
item_ubot = ec_undef_int
item_dambreakLevelsAndWidthsFromTable = ec_undef_int
!
n_qhbnd = 0
!
! tracers
if ( allocated(item_tracerbnd) ) deallocate(item_tracerbnd)
allocate(item_tracerbnd(numtracers))
item_tracerbnd = ec_undef_int
!
! JRE DEBUG sedfrac bnd
if ( allocated(item_sedfracbnd) ) deallocate(item_sedfracbnd)
allocate(item_sedfracbnd(numfracs))
item_sedfracbnd = ec_undef_int
! TO ADD: initial concentration field?
if ( allocated(item_waqfun) ) deallocate(item_waqfun)
allocate(item_waqfun(nofun))
item_waqfun = ec_undef_int
!\ DEBUG sedfrac
end subroutine init_variables
! ==========================================================================
!> Translate FM's meteo1 'filetype' enum to EC's 'provFile' enum.
subroutine filetype_fm_to_ec(filetype, ec_filetype)
use timespace_parameters
implicit none
integer, intent(in) :: filetype
integer, intent(out) :: ec_filetype
!
select case (filetype)
case (uniform) ! 1
ec_filetype = provFile_uniform
case (unimagdir) ! 2
ec_filetype = provFile_unimagdir
case (svwp) ! 3
ec_filetype = provFile_svwp
case (arcinfo) ! 4
ec_filetype = provFile_arcinfo
case (spiderweb) ! 5
ec_filetype = provFile_spiderweb
case (curvi) ! 6
ec_filetype = provFile_curvi
case (triangulation) ! 7
ec_filetype = provFile_samples
case (triangulationmagdir) ! 8
ec_filetype = provFile_triangulationmagdir
case (poly_tim) ! 9
ec_filetype = provFile_poly_tim
case (ncgrid, ncwave) ! 11, 14
ec_filetype = provFile_netcdf
case (ncflow) ! 12
ec_filetype = provFile_undefined ! only used for timespaceinitialfield, no EC yet.
case (bcascii) ! 17
ec_filetype = provFile_bc
case (fourier) ! 101
ec_filetype = provFile_fourier
case default
ec_filetype = provFile_undefined
end select
end subroutine filetype_fm_to_ec
! ==========================================================================
!> Translate FM's meteo1 'method' enum to EC's 'interpolate' enum.
subroutine method_fm_to_ec(method, ec_method)
integer, intent(in) :: method
integer, intent(out) :: ec_method
integer :: interpMethod, exterpMethod
interpMethod = mod(method, 100)
exterpMethod = method / 100
!
select case (interpMethod)
case (0)
ec_method = interpolate_passthrough
case (1)
ec_method = interpolate_timespace
case (2)
ec_method = interpolate_spacetime
case (3)
if (exterpMethod == 0) then
ec_method = interpolate_spacetimeSaveWeightFactors
else
ec_method = extrapolate_spacetimeSaveWeightFactors
endif
case (4) ! TODO: EB: FM's 4 is inside_polygon method, does EC handle this correctly if FM filetype=10?
ec_method = interpolate_space ! only spatial, inside polygon
! TODO: EB: FM does note have an interpolate_time equivalent in its method, only via filetype=uniform
!case (5)
! ec_method = interpolate_time
case (5)
ec_method = interpolate_triangle ! only spatial, triangulation
case (6)
ec_method = interpolate_unknown ! Not yet supported: only spatial, averaging
!case (7) ! TODO: EB+AvD: index triangulation (for spatial sedmor fields) may be needed later,
! but now overlaps with interpolate_time_extrapolation_ok (for wave coupling) below.
! ec_method = interpolate_unknown ! Not yet supported: only spatial, index triangulation
case (8)
ec_method = interpolate_unknown ! Not yet supported: only spatial, smoothing
case (9)
ec_method = interpolate_unknown ! Not yet supported: only spatial, internal diffusion
case (10)
ec_method = interpolate_unknown ! Not yet supported: only initial vertical profiles
case (7) ! TODO: EB: FM method 7, where does this come from? ! see hrms method 7
ec_method = interpolate_time_extrapolation_ok
case default
ec_method = interpolate_unknown
end select
end subroutine method_fm_to_ec
! ==========================================================================
!> Translate FM's meteo1 'operand' enum to EC's 'operand' enum.
subroutine operand_fm_to_ec(operand, ec_operand)
character, intent(in) :: operand
integer, intent(out) :: ec_operand
!
select case (operand)
case ('O')
ec_operand = operand_replace
case ('+')
ec_operand = operand_add
case default
ec_operand = operand_undefined
end select
end subroutine operand_fm_to_ec
! ==========================================================================
!> Convert quantity names as given in user input (ext file)
!! to accepted Unstruc names (as used in Fortran code)
!! Note: for old-style ext quantities, fm_name==input_name, e.g. waterlevelbnd.
!subroutine bndname_to_fm(input_name, fm_name)
! character(len=*), intent(in) :: input_name !< given by the user
! character(len=*), intent(out) :: fm_name !< known within FM
!
! character(len=256) :: tempname
!
! fm_name = input_name
! tempname = input_name
! call str_upper(tempname)
! call remove_substr(tempname,'_')
! call remove_substr(tempname,'-')
! call remove_substr(tempname,' ')
!
! select case (trim(tempname))
! case ('WATERLEVEL','VELOCITY','SALINITY','TEMPERATURE','SEDIMENT','TANGENTIALVELOCITY','NORMALVELOCITY','QH','TRACER')
! ! These are new-ext-style quantities: FM needs additional 'bnd' behind quantityid
! fm_name = trim(tempname)//'bnd'
! call str_lower(fm_name)
! end select
!end subroutine bndname_to_fm
! ==========================================================================
!> Translate EC's ext.force-file's item name to the integer EC item handle and to
!> the data pointer(s), i.e. the array that will contain the values of the target item
function fm_ext_force_name_to_ec_item(trname, sfname, waqinput, qidname, &
itemPtr1, itemPtr2, itemPtr3, itemPtr4, &
dataPtr1, dataPtr2, dataPtr3, dataPtr4 ) result(success)
logical :: success
character(len=NAMTRACLEN), intent(in) :: trname, sfname
character(len=20) :: waqinput
character(len=NAMTRACLEN), intent(in) :: qidname
integer, pointer :: itemPtr1, itemPtr2, itemPtr3, itemPtr4
real(hp), dimension(:), pointer :: dataPtr1, dataPtr2, dataPtr3, dataPtr4
! for tracers:
integer :: itrac, isf, ifun
integer, external :: findname
success = .true.
itemPtr1 => null()
itemPtr2 => null()
itemPtr3 => null()
itemPtr4 => null()
dataPtr1 => null()
dataPtr2 => null()
dataPtr3 => null()
dataPtr4 => null()
select case (qidname)
case ('windx')
itemPtr1 => item_windx
dataPtr1 => wx
case ('windy')
itemPtr1 => item_windy
dataPtr1 => wy
case ('windxy', 'stressxy')
itemPtr1 => item_windxy_x
dataPtr1 => wx
itemPtr2 => item_windxy_y
dataPtr2 => wy
case ('airpressure_windx_windy', 'airpressure_stressx_stressy')
itemPtr1 => item_apwxwy_p
dataPtr1 => patm
itemPtr2 => item_apwxwy_x
dataPtr2 => ec_pwxwy_x
itemPtr3 => item_apwxwy_y
dataPtr3 => ec_pwxwy_y
case ('airpressure_windx_windy_charnock')
itemPtr1 => item_apwxwy_p
dataPtr1 => patm
itemPtr2 => item_apwxwy_x
dataPtr2 => ec_pwxwy_x
itemPtr3 => item_apwxwy_y
dataPtr3 => ec_pwxwy_y
itemPtr4 => item_apwxwy_c
dataPtr4 => ec_pwxwy_c
case ('waterlevelbnd', 'neumannbnd', 'riemannbnd', 'outflowbnd')
itemPtr1 => item_waterlevelbnd
dataPtr1 => zbndz
case ('velocitybnd', 'dischargebnd', 'criticaloutflowbnd','weiroutflowbnd', 'absgenbnd')
itemPtr1 => item_velocitybnd
dataPtr1 => zbndu
case ('salinitybnd')
itemPtr1 => item_salinitybnd
dataPtr1 => zbnds
case ('temperaturebnd')
itemPtr1 => item_temperaturebnd
dataPtr1 => zbndTM
case ('sedimentbnd')
itemPtr1 => item_sedimentbnd
dataPtr1 => zbndsd
case ('tangentialvelocitybnd')
itemPtr1 => item_tangentialvelocitybnd
dataPtr1 => zbndt
case ('uxuyadvectionvelocitybnd')
itemPtr1 => item_uxuyadvectionvelocitybnd
dataPtr1 => zbnduxy
case ('normalvelocitybnd')
itemPtr1 => item_normalvelocitybnd
dataPtr1 => zbndn
case ('airpressure','atmosphericpressure')
itemPtr1 => item_atmosphericpressure
dataPtr1 => patm
case ('rainfall')
itemPtr1 => item_rainfall
dataPtr1 => rain
case ('rainfall_rate')
itemPtr1 => item_rainfall_rate
dataPtr1 => rain
case ('qhbnd')
itemPtr1 => item_qhbnd
dataPtr1 => qhbndz
case ('shiptxy')
itemPtr1 => item_shiptxy
dataPtr1 => xyship
case ('movingstationtxy')
itemPtr1 => item_movingstationtxy
dataPtr1 => xyobs
case ('pump')
itemPtr1 => item_pump
!dataPtr1 => qpump
case ('damlevel')
itemPtr1 => item_damlevel
case ('dambreakLevelsAndWidths')
itemPtr1 => item_dambreakLevelsAndWidthsFromTable
dataPtr1 => dambreakLevelsAndWidthsFromTable
case ('lateraldischarge')
itemPtr1 => item_lateraldischarge
!dataPtr1 => zcdam
case ('gateloweredgelevel')
itemPtr1 => item_gateloweredgelevel
dataPtr1 => zgate
case ('generalstructure')
itemPtr1 => item_generalstructure
dataPtr1 => zcgen
case ('humidity_airtemperature_cloudiness')
itemPtr1 => item_hac_humidity
dataPtr1 => rhum
itemPtr2 => item_hac_airtemperature
dataPtr2 => tair
itemPtr3 => item_hac_cloudiness
dataPtr3 => clou
case ('humidity_airtemperature_cloudiness_solarradiation')
itemPtr1 => item_hacs_humidity
dataPtr1 => rhum
itemPtr2 => item_hacs_airtemperature
dataPtr2 => tair
itemPtr3 => item_hacs_cloudiness
dataPtr3 => clou
itemPtr4 => item_hacs_solarradiation
dataPtr4 => qrad
case ('dewpoint_airtemperature_cloudiness')
itemPtr1 => item_dac_dewpoint
dataPtr1 => rhum ! Relative humidity array used to store dewpoints
itemPtr2 => item_dac_airtemperature
dataPtr2 => tair
itemPtr3 => item_dac_cloudiness
dataPtr3 => clou
case ('dewpoint_airtemperature_cloudiness_solarradiation')
itemPtr1 => item_dacs_dewpoint
dataPtr1 => rhum ! Relative humidity array used to store dewpoints
itemPtr2 => item_dacs_airtemperature
dataPtr2 => tair
itemPtr3 => item_dacs_cloudiness
dataPtr3 => clou
itemPtr4 => item_dacs_solarradiation
dataPtr4 => qrad
case ('humidity')
itemPtr1 => item_humidity
dataPtr1 => rhum ! Relative humidity
case ('airtemperature')
itemPtr1 => item_airtemperature
dataPtr1 => tair
case ('cloudiness')
itemPtr1 => item_cloudiness
dataPtr1 => clou
case ('solarradiation')
itemPtr1 => item_solarradiation
dataPtr1 => qrad
case ('nudge_salinity_temperature')
itemPtr2 => item_nudge_sal
dataPtr2 => nudge_sal
itemPtr1 => item_nudge_tem
dataPtr1 => nudge_tem ! Relative humidity array used to store dewpoints
case ('discharge_salinity_temperature_sorsin')
itemPtr1 => item_discharge_salinity_temperature_sorsin
dataPtr1 => qstss
case ('hrms')
itemPtr1 => item_hrms
dataPtr1 => hwavcom
case ('tp', 'tps', 'rtp')
itemPtr1 => item_tp
dataPtr1 => twav
case ('dir')
itemPtr1 => item_dir
dataPtr1 => phiwav
case ('fx')
itemPtr1 => item_fx
dataPtr1 => sxwav
case ('fy')
itemPtr1 => item_fy
dataPtr1 => sywav
case ('wsbu')
itemPtr1 => item_wsbu
dataPtr1 => sbxwav
case ('wsbv')
itemPtr1 => item_wsbv
dataPtr1 => sbywav
case ('mx')
itemPtr1 => item_mx
dataPtr1 => mxwav
case ('my')
itemPtr1 => item_my
dataPtr1 => mywav
case ('dissurf')
itemPtr1 => item_dissurf
dataPtr1 => dsurf
case ('diswcap')
itemPtr1 => item_diswcap
dataPtr1 => dwcap
case ('ubot')
itemPtr1 => item_ubot
dataPtr1 => uorbwav
case ('tracerbnd')
! get tracer (boundary) number
itrac = findname(numtracers, trnames, trname)
itemPtr1 => item_tracerbnd(itrac)
dataPtr1 => bndtr(itrac)%z
case ('sedfracbnd')
! get sediment fraction (boundary) number
isf = findname(numfracs, sfnames, sfname)
itemPtr1 => item_sedfracbnd(isf)
dataPtr1 => bndsf(isf)%z
case ('waqfunction')
! get sediment fraction (boundary) number
ifun = findname(nofun, funame, waqinput)
itemPtr1 => item_waqfun(ifun)
dataPtr1 => funinp(ifun,:)
case default
call mess(LEVEL_FATAL, 'm_meteo::fm_ext_force_name_to_ec_item: Unsupported quantity specified in ext-file (construct target field): '//qidname)
success = .false.
end select
end function fm_ext_force_name_to_ec_item
! ==========================================================================
!> Construct and initialize a new Instance of the EC-module.
subroutine initialize_ec_module()
use m_sferic
implicit none
! FM re-initialize call: First destroy the EC-module instance.
if (associated(ecInstancePtr)) then
if (.not. ecFreeInstance(ecInstancePtr)) then
message = dumpECMessageStack(LEVEL_WARN,callback_msg)
end if
end if
! FM initialize call or second phase of re-initialize call.
if (.not. associated(ecInstancePtr)) then
call init_variables()
if (.not. ecCreateInstance(ecInstancePtr)) then
message = dumpECMessageStack(LEVEL_WARN,callback_msg)
end if
end if
if (jsferic == 1) then
ecInstancePtr%coordsystem = EC_COORDS_SFERIC
else
ecInstancePtr%coordsystem = EC_COORDS_CARTESIAN
endif
end subroutine initialize_ec_module
! ==========================================================================
!> Helper function for creating and initializing a target Item.
function createItem(instancePtr, itemId, quantityId, elementSetId, fieldId) result(success)
logical :: success !< function status
type(tEcInstance), pointer :: instancePtr !<
integer, intent(inout) :: itemId !< Unique Item id.
integer, intent(inout) :: quantityId !< Unique Quantity id.
integer, intent(inout) :: elementSetId !< Unique ElementSet id.
integer, intent(inout) :: fieldId !< Unique Field id.
!
success = .true.
if (itemId == ec_undef_int) then ! if Target Item already exists, do NOT create a new one ...
itemId = ecCreateItem(ecInstancePtr)
success = ecSetItemRole(instancePtr, itemId, itemType_target)
if (success) success = ecSetItemQuantity(instancePtr, itemId, quantityId)
end if
! ... but we would like to use the newest targetFIELD for this item, since old targetFIELDs can refer to the
! wrong data location (Arr1DPtr). This happens in the case that the demand-side arrays are reallocated while
! building the targets! Same is done for the elementset, so we are sure to always connect the latest
! elementset to this target.
if (success) success = ecSetItemElementSet(instancePtr, itemId, elementSetId)
if (success) success = ecSetItemTargetField(instancePtr, itemId, fieldId)
end function createItem
! ==========================================================================
!> Helper function for initializing a Converter.
function initializeConverter(instancePtr, converterId, convtype, operand, method, srcmask) result(success)
logical :: success !< function status
type(tEcInstance), pointer :: instancePtr !<
integer :: converterId !<
integer :: convtype !<
integer :: operand !<
integer :: method !<
type (tEcMask), optional :: srcmask !<
!
success = ecSetConverterType(instancePtr, converterId, convtype)
if (success) success = ecSetConverterOperand(instancePtr, converterId, operand)
if (success) success = ecSetConverterInterpolation(instancePtr, converterId, method)
if (present(srcmask)) then
if (success) success = ecSetConverterMask(instancePtr, converterId, srcmask)
end if
end function initializeConverter
! ==========================================================================
!> Helper function for initializing a Connection.
function initializeConnection(instancePtr, connectionId, sourceItemId, targetItemId) result(success)
logical :: success !< function status
type(tEcInstance), pointer :: instancePtr !<
integer, intent(inout) :: connectionId !<
integer, intent(inout) :: sourceItemId !<
integer, intent(inout) :: targetItemId !<
!
success = ecAddConnectionSourceItem(instancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionTargetItem(instancePtr, connectionId, targetItemId)
if (success) success = ecAddItemConnection(instancePtr, targetItemId, connectionId)
end function initializeConnection
! ==========================================================================
!> Helper function for Connection initialization.
function checkFileType(actualfiletype, requiredfiletype, name) result(success)
logical :: success !< function status
integer, intent(in) :: actualfiletype !< EC-module's filetype enumeration.
integer, intent(in) :: requiredfiletype !< EC-module's filetype enumeration.
character(*), intent(in) :: name !< Name for the target Quantity.
!
success = .true.
if (.not. actualfiletype == requiredfiletype) then
message = 'm_meteo::checkFileType: Unsupported filetype for quantity '//name//'.'
success = .false.
end if
end function checkFileType
! ==========================================================================
!> Replacement function for FM's meteo1 'addtimespacerelation' function.
logical function ec_addtimespacerelation(name, x, y, mask, vectormax, filename, filetype, method, operand, &
xyen, z, pzmin, pzmax, pkbot, pktop, targetIndex, forcingfile, srcmaskfile, dtnodal, quiet, varname, maxSearchRadius)
use m_ec_module , only: ecFindFileReader ! TODO: Refactor this private data access (UNST-703).
use m_ec_filereader_read, only: ecParseARCinfoMask
use m_flow, only: kmx, kbot, ktop
use m_sferic, only: jsferic
use m_missing, only: dmiss
character(len=*), intent(inout) :: name !< Name for the target Quantity, possibly compounded with a tracer name.
real(hp), dimension(:), intent(in) :: x !< Array of x-coordinates for the target ElementSet.
real(hp), dimension(:), intent(in) :: y !< Array of y-coordinates for the target ElementSet.
integer, intent(in) :: vectormax !< Vector max (length of data values at each element location).
integer, dimension(:), intent(in) :: mask !< Array of masking values for the target ElementSet.
character(len=*), intent(in) :: filename !< File name of meteo data file.
integer, intent(in) :: filetype !< FM's filetype enumeration.
integer, intent(in) :: method !< FM's method enumeration.
character(len=1), intent(in) :: operand !< FM's operand enumeration.
real(hp), optional, intent(in) :: xyen(:,:) !< FM's distance tolerance / cellsize of ElementSet.
real(hp), dimension(:), optional, target, intent(in) :: z !< FM's array of z/sigma coordinates
real(hp), dimension(:), optional, pointer :: pzmin !< FM's array of minimal z coordinate
real(hp), dimension(:), optional, pointer :: pzmax !< FM's array of maximum z coordinate
integer, dimension(:), optional, pointer :: pkbot
integer, dimension(:), optional, pointer :: pktop
integer, optional, intent(in) :: targetIndex !< target position or rank of (complete!) vector in target array
character(len=*), optional, intent(in) :: forcingfile !< file containing the forcing data for pli-file 'filename'
character(len=*), optional, intent(in) :: srcmaskfile !< file containing mask applicable to the arcinfo source data
real(hp), optional, intent(in) :: dtnodal !< update interval for nodal factors
logical, optional, intent(in) :: quiet !< When .true., in case of errors, do not write the errors to screen/dia at the end of the routine.
character(len=*), optional, intent(in) :: varname !< variable name within filename
real(hp), optional, intent(in) :: maxSearchRadius !< max search radius in case method==11
!
integer :: ec_filetype !< EC-module's provFile_ enumeration.
integer :: ec_convtype !< EC-module's convType_ enumeration.
integer :: ec_method !< EC-module's interpolate_ enumeration.
integer :: ec_operand !< EC-module's operand_ enumeration.
!
integer :: fileReaderId !< Unique FileReader id.
integer :: quantityId !< Unique Quantity id.
integer :: elementSetId !< Unique ElementSet id.
integer :: fieldId !< Unique Field id.
integer :: fieldId_2 !< Unique Field id.
integer :: fieldId_3 !< Unique Field id.
integer :: fieldId_4 !< Unique Field id.
integer :: converterId !< Unique Converter id.
integer :: connectionId !< Unique Connection id.
integer :: sourceItemId !< Unique source item id.
integer :: sourceItemId_2 !< Unique additional source item id.
integer :: sourceItemId_3 !< Unique additional third source item id.
integer :: sourceItemId_4 !< Unique additional fourth source item id.
!
character(len=maxnamelen) :: sourceItemName !< name of source item (as created by provider)
character(len=maxnamelen) :: target_name !< Unstruc target name derived from user-specified name
character(len=maxnamelen) :: location !< location (name) as specified in the LOCATION field of the new EXT-file
integer, pointer :: targetItemPtr1 => null() !< pointer to the target item id
integer, pointer :: targetItemPtr2 => null() !< pointer to optional second target item id (e.g. in case of windxy)
integer, pointer :: targetItemPtr3 => null() !< pointer to optional third target item id (e.g. in case of spiderweb)
integer, pointer :: targetItemPtr4 => null() !< pointer to optional fourth target item id (e.g. in case of hacs)
real(hp), dimension(:), pointer :: dataPtr1 => null() !< Pointer to FM's 1D data arrays.
real(hp), dimension(:), pointer :: dataPtr2 => null() !< Pointer to FM's optional extra 1D data array (e.g. in case of windxy)
real(hp), dimension(:), pointer :: dataPtr3 => null() !< Pointer to FM's optional third 1D data array (e.g. in case of spiderweb)
real(hp), dimension(:), pointer :: dataPtr4 => null() !< Pointer to FM's optional fourth 1D data array (e.g. in case of hacs)
type(tEcFileReader) , pointer :: fileReaderPtr => null() !<
logical :: success
logical :: quiet_
character(len=NAMTRACLEN) :: trname, sfname, qidname
character (len=20) :: waqinput
integer, external :: findname
type (tEcMask) :: srcmask
logical :: exist, opened, withCharnock, withStress
double precision :: relrow, relcol
integer :: row0, row1, col0, col1, ncols, nrows
character(len=128) :: txt1, txt2, txt3
ec_addtimespacerelation = .false.
if (present(quiet)) then
quiet_ = quiet
else
quiet_ = .false. ! Default: print errors at the end of routine, if no success
end if
! ========================================================
! Translate FM's enumerations to EC-module's enumerations.
! ========================================================
call filetype_fm_to_ec(filetype, ec_filetype)
if (ec_filetype == provFile_undefined) then
write (msgbuf, '(a,i0,a)') 'm_meteo::ec_addtimespacerelation: Unsupported filetype ''', filetype, &
''' for quantity '''//trim(name)//''' and file '''//trim(filename)//'''.'
call err_flush()
return
end if
call method_fm_to_ec(method, ec_method)
if (ec_method == interpolate_unknown) then
write (msgbuf, '(a,i0,a)') 'm_meteo::ec_addtimespacerelation: Unsupported method ''', method, &
''' for quantity '''//trim(name)//''' and file '''//trim(filename)//'''.'
call err_flush()
return
end if
call operand_fm_to_ec(operand, ec_operand)
if (ec_operand == operand_undefined) then
write (msgbuf, '(a,a,a)') 'm_meteo::ec_addtimespacerelation: Unsupported operand ''', operand, &
''' for quantity '''//trim(name)//''' and file '''//trim(filename)//'''.'
call err_flush()
return
end if
! =================================================
! Convert ext file names to accepted Unstruc names.
! =================================================
! Name conversion: (targetname=qidname==name for all names, except name=tracerbndfoo --> qidname=tracerbnd)
qidname = name
call get_tracername(name, trname, qidname)
call get_sedfracname(name, sfname, qidname)
call get_waqinputname(name, waqinput, qidname)
target_name = qidname
call clearECMessage()
! ============================================================
! If BC-Type file, create filereader and source items here
! ============================================================
location = filename
if (ec_filetype == provFile_bc) then
if (.not.ecCreateInitializeBCFileReader(ecInstancePtr, forcingfile, location, qidname, &
itdate, tzone, ec_second, fileReaderId)) then
goto 1234
end if
else
! ============================================================
! For the remaining types, construct the fileReader and source Items here.
! ============================================================
! first see if the file has already been opened
inquire(file=trim(fileName), exist = exist, opened = opened)
if (opened .and. ec_fileType==provFile_spiderweb) then ! double file access not allowed when using the Gnu compiler
fileReaderPtr => ecFindFileReader(ecInstancePtr, fileName)
if (.not.associated(fileReaderPtr)) then
continue
end if
fileReaderId = fileReaderPtr%id
else
fileReaderId = ecCreateFileReader(ecInstancePtr)
fileReaderPtr => ecFindFileReader(ecInstancePtr, fileReaderId) ! TODO: Refactor this private data access (UNST-703).
fileReaderPtr%vectormax = vectormax
if (present(forcingfile)) then
if (present(dtnodal)) then
success = ecSetFileReaderProperties(ecInstancePtr, fileReaderId, ec_filetype, filename, itdate, tzone, ec_second, name, forcingfile=forcingfile, dtnodal=dtnodal)
else
success = ecSetFileReaderProperties(ecInstancePtr, fileReaderId, ec_filetype, filename, itdate, tzone, ec_second, name, forcingfile=forcingfile)
end if
!message = dumpECMessageStack(LEVEL_WARN,callback_msg)
if (.not. success) then
goto 1234
end if
if (ecAtLeastOnePointIsCorrection) then ! TODO: Refactor this shortcut (UNST-180).
ecAtLeastOnePointIsCorrection = .false. ! TODO: Refactor this shortcut (UNST-180).
ec_addtimespacerelation = .true.
return
end if
else
if (present(dtnodal)) then
success = ecSetFileReaderProperties(ecInstancePtr, fileReaderId, ec_filetype, filename, itdate, tzone, ec_second, name, dtnodal=dtnodal, varname=varname)
else
success = ecSetFileReaderProperties(ecInstancePtr, fileReaderId, ec_filetype, filename, itdate, tzone, ec_second, name, varname=varname)
end if
if (.not. success) then
! message = ecGetMessage()
! message = dumpECMessageStack(LEVEL_WARN,callback_msg)
! NOTE: do all error dumping (if any) at the end of this routine at label 1234
! NOTE: in relation to WAVE: all calling WAVE-related routines now pass quiet=.true. to this addtimespace routine.
! When running online with WAVE and the first WAVE calculation is after the first DFlowFM calculation,
! this message will be generated. This must be a warning: notify the user that DFlowFM is going to do
! a calculation with zero wave values. This message should be written every time step, until proper
! wave data is available. The user has to check whether this behaviour is as expected.
goto 1234
end if
end if
end if
end if
! ==============================
! Construct the target Quantity.
! ==============================
quantityId = ecCreateQuantity(ecInstancePtr)
if (.not. ecSetQuantity(ecInstancePtr, quantityId, name=target_name, units=' ', vectormax=vectormax)) then
goto 1234
end if
! ================================
! Construct the target ElementSet.
! ================================
elementSetId = ecCreateElementSet(ecInstancePtr)
if (ec_filetype == provFile_poly_tim) then
success = ecSetElementSetType(ecInstancePtr, elementSetId, elmSetType_polytim)
else
if (jsferic==0) then
success = ecSetElementSetType(ecInstancePtr, elementSetId, elmSetType_cartesian)
else
success = ecSetElementSetType(ecInstancePtr, elementSetId, elmSetType_spheric)
end if
end if
if (success) success = ecSetElementSetXArray(ecInstancePtr, elementSetId, x)
if (success) success = ecSetElementSetYArray(ecInstancePtr, elementSetId, y)
if (success) success = ecSetElementSetMaskArray(ecInstancePtr, elementSetId, mask)
if (success) success = ecSetElementSetNumberOfCoordinates(ecInstancePtr, elementSetId, size(x))
if (present(xyen)) then
if (success) success = ecSetElementSetXyen(ecInstancePtr, elementSetId, xyen)
end if
if (present(z)) then ! 3D
if (present(pzmin) .and. present(pzmax)) then ! implicitly means: target elt z-type == SIGMA
if (success) success = ecSetElementSetZArray(ecInstancePtr, elementSetId, z, pzmin=pzmin, pzmax=pzmax, Lpointer_=.true.)
if (success) success = ecSetElementSetvptyp(ecInstancePtr, elementSetID, BC_VPTYP_PERCBED) ! sigma layers
else if (present(pkbot) .and. present(pktop)) then ! implicitly means: target elt z-type == Z WITH sparse kbot/ktop storage
if (success) success = ecSetElementSetZArray(ecInstancePtr, elementSetId, z, Lpointer_=.true.)
if (success) success = ecSetElementSetKbotKtop(ecInstancePtr, elementSetId, pkbot, pktop, Lpointer_=.true.)
if (success) success = ecSetElementSetvptyp(ecInstancePtr, elementSetID, BC_VPTYP_ZDATUM) ! z-layers
else
! ERROR .. TODO: LR
end if
! add 3D settings if needed
if (ec_filetype == provFile_poly_tim .and. (target_name == 'salinitybnd' .or. target_name == 'temperaturebnd' .or. target_name == 'tracerbnd')) then ! TODO JRE sediment
if (success) success = ecSetElementSetMaskArray(ecInstancePtr, elementSetId, mask)
if (success) success = ecSetElementSetNumberOfCoordinates(ecInstancePtr, elementSetId, size(x))
end if
end if
if (.not. success) then
goto 1234
end if
! ==============================================
! Construct the target field and the target item
! ==============================================
! determine which target item (id) will be created, and which FM data array has to be used
! JRE DEBUG sedfrac
if (.not. fm_ext_force_name_to_ec_item(trname, sfname, waqinput, qidname, &
targetItemPtr1, targetItemPtr2, targetItemPtr3, targetItemPtr4, &
dataPtr1 , dataPtr2 , dataPtr3 , dataPtr4 )) then
return
end if
! Create the field and the target item, and if needed additional ones.
fieldId = ecCreateField(ecInstancePtr)
success = ecSetField1dArray(ecInstancePtr, fieldId, dataPtr1)
if (success) success = ecSetFieldMissingValue(ecInstancePtr, fieldId, dmiss)
if (success) success = createItem(ecInstancePtr, targetItemPtr1, quantityId, elementSetId, fieldId)
if (associated(targetItemPtr2)) then
! second field (e.g. for 'windxy')
fieldId_2 = ecCreateField(ecInstancePtr)
if (success) success = ecSetField1dArray(ecInstancePtr, fieldId_2, dataPtr2)
if (success) success = ecSetFieldMissingValue(ecInstancePtr, fieldId_2, dmiss)
if (success) success = createItem(ecInstancePtr, targetItemPtr2, quantityId, elementSetId, fieldId_2)
end if
if (associated(targetItemPtr3)) then
! third field (e.g. for 'airpressure_windx_windy'
fieldId_3 = ecCreateField(ecInstancePtr)
if (success) success = ecSetField1dArray(ecInstancePtr, fieldId_3, dataPtr3)
if (success) success = ecSetFieldMissingValue(ecInstancePtr, fieldId_3, dmiss)
if (success) success = createItem(ecInstancePtr, targetItemPtr3, quantityId, elementSetId, fieldId_3)
end if
if (associated(targetItemPtr4)) then
! third field (e.g. for 'humidity_airtemperatur_cloudiness_solarradiation'
fieldId_4 = ecCreateField(ecInstancePtr)
if (success) success = ecSetField1dArray(ecInstancePtr, fieldId_4, dataPtr4)
if (success) success = ecSetFieldMissingValue(ecInstancePtr, fieldId_4, dmiss)
if (success) success = createItem(ecInstancePtr, targetItemPtr4, quantityId, elementSetId, fieldId_4)
end if
if (.not. success) then
goto 1234
end if
! ==========================
! Construct a new Converter.
! ==========================
call ec_filetype_to_conv_type(ec_filetype, ec_convtype)
if (ec_convtype == convType_undefined) then
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported converter.')
return
end if
converterId = ecCreateConverter(ecInstancePtr)
select case(target_name)
case ('shiptxy', 'movingstationtxy', 'discharge_salinity_temperature_sorsin', 'pump', 'damlevel', 'gateloweredgelevel', 'generalstructure', 'lateraldischarge','dambreakLevelsAndWidths')
! for the FM 'target' arrays, the index is provided by the caller
if (.not. present(targetIndex)) then
message = 'Internal program error: missing targetIndex for quantity '''//trim(target_name)
call mess(LEVEL_ERROR, message)
return
end if
success = initializeConverter(ecInstancePtr, converterId, ec_convtype, operand_replace_element, ec_method)
if (success) success = ecSetConverterElement(ecInstancePtr, converterId, targetIndex)
case ('qhbnd')
! count qh boundaries
n_qhbnd = n_qhbnd + 1
success = initializeConverter(ecInstancePtr, converterId, ec_convtype, operand_replace_element, interpolate_passthrough)
! Each qhbnd polytim file replaces exactly one element in the target data array.
! Converter will put qh value in target_array(n_qhbnd)
if (success) success = ecSetConverterElement(ecInstancePtr, converterId, n_qhbnd)
case ('windx', 'windy', 'windxy', 'stressxy', 'airpressure', 'atmosphericpressure', 'airpressure_windx_windy', &
'airpressure_windx_windy_charnock', 'airpressure_stressx_stressy','humidity','airtemperature','cloudiness','solarradiation' )
if (present(srcmaskfile)) then
if (ec_filetype == provFile_arcinfo .or. ec_filetype == provFile_curvi) then
if (.not.ecParseARCinfoMask(srcmaskfile, srcmask, fileReaderPtr)) then
write (msgbuf, '(3a)') 'Error while reading mask file ''', trim(srcmaskfile),'''.'
call err_flush()
return
endif
if (.not.initializeConverter(ecInstancePtr, converterId, ec_convtype, ec_operand, ec_method, srcmask=srcmask)) then
write (msgbuf, '(5a)') 'Error while setting mask to converter (file=''', trim(srcmaskfile), ''', associated with meteo file ''', trim(filename), '''.'
call err_flush()
return
end if
end if
else
success = initializeConverter(ecInstancePtr, converterId, ec_convtype, ec_operand, ec_method)
end if
case default
success = initializeConverter(ecInstancePtr, converterId, ec_convtype, ec_operand, ec_method)
end select
if (.not. success) then
goto 1234
end if
! ================================================================
! Construct a new Connection, and connect source and target Items.
! ================================================================
connectionId = ecCreateConnection(ecInstancePtr)
if (.not. ecSetConnectionConverter(ecInstancePtr, connectionId, converterId)) then
goto 1234
end if
! determine the source item's name
! note 1: this can be determined (and be improved) when creating the file reader
! note 2: the source item's name is set in the select case switch below. In some cases
! of this switch ('special cases') the source-target connections is established
! immediatly, and sourceItemName is NOT set.
! So the generic 'connect source and target' statements after the switch are
! only executed if sourceItemName IS set.
!
sourceItemName = ' '
sourceItemId = 0
sourceItemId_2 = 0
sourceItemId_3 = 0
sourceItemId_4 = 0
select case (target_name)
case ('shiptxy' , 'movingstationtxy', 'discharge_salinity_temperature_sorsin')
if (.not. checkFileType(ec_filetype, provFile_uniform, target_name)) then
return
end if
! the file reader will have created an item called 'uniform_item'
sourceItemName = 'uniform_item'
case ('pump','generalstructure','damlevel','gateloweredgelevel','lateraldischarge','dambreakLevelsAndWidths')
if (checkFileType(ec_filetype, provFile_uniform, target_name)) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
if (sourceItemId==ec_undef_int) then
! Add something to the EC message stack about missing source item
return
endif
if (.not.ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)) return
else if (checkFileType(ec_filetype, provFile_fourier, target_name)) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'period')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'magnitude')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'phase')
if ((sourceItemId==ec_undef_int) .or. (sourceItemId_2==ec_undef_int) .or. (sourceItemId_3==ec_undef_int)) then
! Add something to the EC message stack about missing source item
return
else
if (.not.ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)) return
if (.not.ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)) return
if (.not.ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)) return
endif
else if (checkFileType(ec_filetype, provFile_poly_tim, target_name)) then
sourceItemName = 'polytim_item'
else
! Add something to the EC message stack about mismatching filetype bla bla
return
endif
if (.not.ecAddConnectionTargetItem(ecInstancePtr, connectionId, targetItemPtr1)) return
if (.not.ecAddItemConnection(ecInstancePtr, targetItemPtr1, connectionId)) return
case ('velocitybnd', 'dischargebnd', 'waterlevelbnd', 'salinitybnd', 'tracerbnd', &
'neumannbnd', 'riemannbnd', 'absgenbnd', 'outflowbnd', &
'temperaturebnd', 'sedimentbnd', 'tangentialvelocitybnd', 'uxuyadvectionvelocitybnd', &
'normalvelocitybnd', 'qhbnd','criticaloutflowbnd','weiroutflowbnd', 'sedfracbnd') !JRE DEBUG sedfrac
if (.not. checkFileType(ec_filetype, provFile_poly_tim, target_name)) then
return
end if
! the file reader will have created an item called 'polytim_item'
sourceItemName = 'polytim_item'
case ('rainfall')
! the name of the source item depends on the file reader
if (ec_filetype == provFile_uniform) then
sourceItemName = 'uniform_item'
else if (ec_filetype == provFile_bc) then
sourceItemName = 'RAINFALL'
else if (ec_filetype == provFile_netcdf) then
sourceItemName = 'precipitation_amount'
else if (ec_filetype == provFile_curvi) then
sourceItemName = 'curvi_source_item_1'
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity rainfall.')
return
end if
case ('rainfall_rate')
! the name of the source item depends on the file reader
if (ec_filetype == provFile_uniform) then
sourceItemName = 'uniform_item'
else if (ec_filetype == provFile_bc) then
sourceItemName = 'RAINFALL_RATE'
else if (ec_filetype == provFile_netcdf) then
sourceItemName = 'rainfall_rate'
else if (ec_filetype == provFile_curvi) then
sourceItemName = 'curvi_source_item_1'
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity rainfall_rate.')
return
end if
case ('hrms', 'tp', 'tps', 'rtp', 'dir', 'fx', 'fy', 'wsbu', 'wsbv', 'mx', 'my', 'dissurf','diswcap','ubot')
! the name of the source item created by the file reader will be the same as the ext.force. quant name
sourceItemName = target_name
case ('airpressure', 'atmosphericpressure')
if (ec_filetype == provFile_arcinfo) then
sourceItemName = 'wind_p'
else if (ec_filetype == provFile_curvi) then
sourceItemName = 'curvi_source_item_1'
else if (ec_filetype == provFile_uniform) then
sourceItemName = 'uniform_item'
else if (ec_filetype == provFile_spiderweb) then
sourceItemName = 'p_drop'
else if (ec_filetype == provFile_netcdf) then
! the arc-info file contains 'air_pressure', which is also the standard_name
sourceItemName = 'air_pressure'
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity wind_p.')
return
end if
case ('windx')
! the name of the source item depends on the file reader
if (ec_filetype == provFile_arcinfo) then
sourceItemName = 'wind_u'
else if (ec_filetype == provFile_curvi) then
sourceItemName = 'curvi_source_item_1'
else if (ec_filetype == provFile_uniform) then
sourceItemName = 'uniform_item'
else if (ec_filetype == provFile_netcdf) then
sourceItemName = 'eastward_wind'
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity windx.')
return
end if
case ('windy')
! the name of the source item depends on the file reader
if (ec_filetype == provFile_arcinfo) then
sourceItemName = 'wind_v'
else if (ec_filetype == provFile_curvi) then
sourceItemName = 'curvi_source_item_1'
else if (ec_filetype == provFile_uniform) then
sourceItemName = 'uniform_item'
else if (ec_filetype == provFile_netcdf) then
sourceItemName = 'northward_wind'
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity windy.')
return
end if
case ('stressxy')
if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_downward_eastward_stress')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_downward_northward_stress')
if (sourceItemId == ec_undef_int .or. sourceItemId_2 == ec_undef_int) then
goto 1234
end if
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: stressxy only implemented for NetCDF.')
return
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_windxy_x)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_windxy_y)
if (success) success = ecAddItemConnection(ecInstancePtr, item_windxy_x, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_windxy_y, connectionId)
case ('windxy')
! special case: m:n converter, (for now) handle here in case switch
if (ec_filetype == provFile_unimagdir) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
success = (sourceItemId /= ec_undef_int)
if (.not. success) then
goto 1234
end if
else if (ec_filetype == provFile_uniform) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
success = (sourceItemId /= ec_undef_int)
if (.not. success) then
goto 1234
end if
else if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'eastward_wind')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'northward_wind')
success = (sourceItemId /= ec_undef_int .and. sourceItemId_2 /= ec_undef_int)
if (.not. success) then
goto 1234
end if
else if (ec_filetype == provFile_spiderweb) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'windspeed')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'winddirection')
success = (sourceItemId /= ec_undef_int .and. sourceItemId_2 /= ec_undef_int)
if (.not. success) then
goto 1234
end if
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity windxy.')
return
end if
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (sourceItemId_2>0) then
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_windxy_x)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_windxy_y)
if (success) success = ecAddItemConnection(ecInstancePtr, item_windxy_x, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_windxy_y, connectionId)
case ('airpressure_windx_windy', 'airpressure_windx_windy_charnock', 'airpressure_stressx_stressy')
withCharnock = (target_name == 'airpressure_windx_windy_charnock')
withStress = (target_name == 'airpressure_stressx_stressy')
! special case: m:n converter, (for now) handle seperately
if (ec_filetype == provFile_curvi) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_1')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_2')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_3')
else if (ec_filetype == provFile_spiderweb) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'windspeed')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'winddirection')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'p_drop')
else if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'air_pressure')
if ( .not. withStress) then
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'eastward_wind')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'northward_wind')
else
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_downward_eastward_stress')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_downward_northward_stress')
endif
if (withCharnock) then
sourceItemId_4 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'charnock')
if (sourceItemId_4 == ec_undef_int) goto 1234
endif
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity ' // trim(target_name) // '.')
return
end if
if (sourceItemId == ec_undef_int .or. sourceItemId_2 == ec_undef_int .or. sourceItemId_3 == ec_undef_int) then
goto 1234
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
if (success .and. withCharnock) then
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_4)
endif
if (ec_filetype == provFile_curvi .or. ec_filetype == provFile_netcdf) then
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_p)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_x)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_y)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_p, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_x, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_y, connectionId)
if (withCharnock) then
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_c)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_c, connectionId)
endif
else if (ec_filetype == provFile_spiderweb) then
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_x)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_y)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_apwxwy_p)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_x, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_y, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_apwxwy_p, connectionId)
end if
if (.not. success) then
goto 1234
end if
case ('humidity_airtemperature_cloudiness')
! special case: m:n converter, (for now) handle seperately
if (ec_filetype == provFile_curvi .or. ec_filetype == provFile_uniform) then
if (ec_filetype == provFile_curvi) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_1')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_2')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_3')
if (sourceItemId == ec_undef_int .or. sourceItemId_2 == ec_undef_int .or. sourceItemId_3 == ec_undef_int) then
goto 1234
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
else if (ec_filetype == provFile_uniform) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
if (sourceItemId == ec_undef_int) then
goto 1234
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hac_humidity)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hac_airtemperature)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hac_cloudiness)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hac_humidity, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hac_airtemperature, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hac_cloudiness, connectionId)
if (.not. success) then
goto 1234
end if
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity humidity_airtemperature_cloudiness.')
return
end if
case ('humidity_airtemperature_cloudiness_solarradiation')
! special case: m:n converter, (for now) handle seperately
if (ec_filetype == provFile_curvi) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_1')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_2')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_3')
sourceItemId_4 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'curvi_source_item_4')
if (sourceItemId == ec_undef_int .or. sourceItemId_2 == ec_undef_int .or. &
sourceItemId_3 == ec_undef_int .or. sourceItemId_4 == ec_undef_int ) then
goto 1234
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_4)
else if (ec_filetype == provFile_uniform) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
if (sourceItemId == ec_undef_int) then
goto 1234
end if
success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
else if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'humidity')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'air_temperature')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'cloud_area_fraction')
sourceItemId_4 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_net_downward_shortwave_flux')
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_4)
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity '//trim(target_name)//'.')
return
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hacs_humidity)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hacs_airtemperature)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hacs_cloudiness)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_hacs_solarradiation)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hacs_humidity, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hacs_airtemperature, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hacs_cloudiness, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_hacs_solarradiation, connectionId)
if (.not. success) then
goto 1234
end if
case ('dewpoint_airtemperature_cloudiness')
if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'dew_point_temperature')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'air_temperature')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'cloud_area_fraction')
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
if (.not. success) goto 1234
else if (ec_filetype == provFile_uniform) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
success = (sourceItemId /= ec_undef_int)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity '//trim(target_name)//'.')
return
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dac_dewpoint)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dac_airtemperature)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dac_cloudiness)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dac_dewpoint, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dac_airtemperature, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dac_cloudiness, connectionId)
case ('dewpoint_airtemperature_cloudiness_solarradiation')
if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'dew_point_temperature')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'air_temperature')
sourceItemId_3 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'cloud_area_fraction')
sourceItemId_4 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'surface_net_downward_shortwave_flux')
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_3)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_4)
else if (ec_filetype == provFile_uniform) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'uniform_item')
success = (sourceItemId /= ec_undef_int)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity '//trim(target_name)//'.')
return
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dacs_dewpoint)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dacs_airtemperature)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dacs_cloudiness)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_dacs_solarradiation)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dacs_dewpoint, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dacs_airtemperature, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dacs_cloudiness, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_dacs_solarradiation, connectionId)
case ('humidity')
sourceItemName = 'relative_humidity'
case ('airtemperature')
sourceItemName = 'air_temperature'
case ('cloudiness')
sourceItemName = 'cloudfraction'
case ('solarradiation')
sourceItemName = 'sw_radiation_flux'
case ('nudge_salinity_temperature')
if (ec_filetype == provFile_netcdf) then
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'sea_water_potential_temperature')
sourceItemId_2 = ecFindItemInFileReader(ecInstancePtr, fileReaderId, 'sea_water_salinity')
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId)
if (success) success = ecAddConnectionSourceItem(ecInstancePtr, connectionId, sourceItemId_2)
else
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported filetype for quantity '//trim(target_name)//'.')
return
end if
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_nudge_tem)
if (success) success = ecAddConnectionTargetItem(ecInstancePtr, connectionId, item_nudge_sal)
if (success) success = ecAddItemConnection(ecInstancePtr, item_nudge_tem, connectionId)
if (success) success = ecAddItemConnection(ecInstancePtr, item_nudge_sal, connectionId)
case ('waqfunction')
if (.not. checkFileType(ec_filetype, provFile_uniform, target_name)) then
return
end if
! the file reader will have created an item called 'polytim_item'
sourceItemName = 'uniform_item'
case default
call mess(LEVEL_FATAL, 'm_meteo::ec_addtimespacerelation: Unsupported quantity specified in ext-file (connect source and target): '//trim(target_name)//'.')
return
end select
if (sourceItemName /= ' ') then
! not a special case, connect source and target
sourceItemId = ecFindItemInFileReader(ecInstancePtr, fileReaderId, sourceItemName)
if (sourceItemId == ec_undef_int) then
goto 1234
end if
if (.not. initializeConnection(ecInstancePtr, connectionId, sourceItemId , targetItemPtr1)) then
goto 1234
end if
if (present(targetIndex)) then
if (.not. checkVectorMax(ecInstancePtr, sourceItemId , targetItemPtr1)) then
goto 1234
endif
endif
end if
success = ecSetConnectionIndexWeights(ecInstancePtr, connectionId)
if ( target_name=='nudge_salinity_temperature' ) then
call ecConverterGetBbox(ecInstancePtr, SourceItemID, 0, col0, col1, row0, row1, ncols, nrows)
relcol = dble(col1-col0+1)/dble(ncols)
relrow = dble(row1-row0+1)/dble(nrows)
write(txt1,"('nudge_salinity_temperature: bounding box')")
write(txt2,"('col0-col1 X row0-row1 = ', I0, '-', I0, ' X ', I0, '-', I0, ', ncols X nrows = ', I0, ' X ', I0)") col0, col1, row0, row1, ncols, nrows
write(txt3,"('relcol X relrow = ', F4.2, ' X ', F4.2, ' = ', F4.2)") relcol, relrow, relcol*relrow
call mess(LEVEL_INFO, trim(txt1) // ' ' // trim(txt2) // ', ' // trim(txt3))
end if
ec_addtimespacerelation = .true.
return
! Error handling.
1234 continue
ec_addtimespacerelation = .false.
! message = ecGetMessage()
if (.not. quiet_) then
! TODO: AvD: I'd rather have a full message stack that will combine EC + meteo + dflowfm, and any caller may print any pending messages.
! For now: Print the EC message stack here, and leave the rest to the caller.
! TODO: RL: the message below is from m_meteo::message, whereas timespace::getmeteoerror() returns timespace::errormessage. So now this message here is lost/never printed at call site.
message = dumpECMessageStack(LEVEL_WARN, callback_msg)
! Leave this concluding message for the caller to print or not. (via getmeteoerror())
call setECMessage(message)
end if
message = 'm_meteo::ec_addtimespacerelation: Error while initializing '''//trim(name)//''' from file: '''//trim(filename)//''''
if (present(forcingfile)) then
message = trim(message)//' ('''//trim(forcingfile)//''')'
endif
end function ec_addtimespacerelation
! ==========================================================================
function checkVectorMax(ecInstancePtr, sourceItemId , targetItemId) result (success)
logical :: success !< function result
type(tEcInstance), pointer :: ecInstancePtr !< the instance pointer
integer, intent(in) :: sourceItemId !< the source item ID
integer, intent(in) :: targetItemId !< the target item ID
type(tEcItem), pointer :: itemPtrSrc !< Item corresponding to sourceItemId
type(tEcItem), pointer :: itemPtrTgt !< Item corresponding to targetItemId
integer :: vectorMaxSrc !< vectorMax for source item
integer :: vectorMaxTgt !< vectorMax for target item
success = .true.
itemPtrSrc => ecSupportFindItem(ecInstancePtr, sourceItemId)
itemPtrTgt => ecSupportFindItem(ecInstancePtr, targetItemId)
vectorMaxSrc = itemPtrSrc%quantityPtr%vectorMax
vectorMaxTgt = itemPtrTgt%quantityPtr%vectorMax
if (vectorMaxSrc /= vectorMaxTgt) then
success = .false.
call mess(LEVEL_WARN, "There was a problem with a source of type " // trim(itemPtrSrc%quantityPtr%name) &
// " with source file '" // trim(itemPtrSrc%elementsetPtr%name) // "'")
call mess(LEVEL_ERROR, "Vector max differs for " // trim(itemPtrTgt%quantityPtr%name) &
// " values (resp. source, target): ", vectorMaxSrc, vectorMaxTgt)
endif
end function checkVectorMax
! ==========================================================================
function ec_gettimeseries_by_itemID(instancePtr, itemId, t0, t1, dt, target_array) result(success)
logical :: success !< function status
type(tEcInstance), pointer :: instancePtr !< intent(in)
integer, intent(in) :: itemID !< unique Item id
real(hp), intent(in) :: t0,t1,dt !< get data corresponding to this number of timesteps since FM's refdate
real(hp), dimension(:), allocatable, intent(inout) :: target_array !< kernel's data array for the requested values
real(hp), dimension(:), pointer :: arr1dPtr => null()
real(hp) :: tt
integer :: it, nt, blksize
tt = t0
it = 0
nt = ceiling((t1-t0)/dt)+1
if (allocated(target_array)) deallocate(target_array)
allocate(target_array(nt*blksize))
arr1dPtr => ecItemGetArr1DPtr(instancePtr, itemId, 2)
blksize = size(arr1dPtr)
call clearECMessage()
do while (t0+it*dt Convenience wrapper around ec_gettimespacevalue_by_itemID.
function ec_gettimespacevalue_by_name(instancePtr, group_name, timesteps) result(success)
logical :: success !< function status
type(tEcInstance), pointer :: instancePtr !< intent(in)
character(len=*), intent(in) :: group_name !< unique group name
real(hp), intent(in) :: timesteps !< get data corresponding to this number of timesteps since FM's refdate
double precision, dimension(:), pointer :: ptm, prh, ptd
!
success = .false.
!
if (trim(group_name) == 'rainfall') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_rainfall , timesteps)) return
! rain = rain * 86400.0 ! EC delivers rainfall intensity in mm/s, convert to mm/day
! Hi Robert, if you change some input definition in 2017, than please repair code from 2009 till now
! foreseeing problems like this, I first called this quantity rainfall_mmperday.
! Then someone changed the name in 2015
! Now you change the unit in 2017.
! I give a course this Thursday, please no surprises
end if
if (trim(group_name) == 'rainfall_rate') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_rainfall_rate , timesteps)) return
end if
if (trim(group_name) == 'humidity_airtemperature_cloudiness') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_hac_humidity , timesteps)) return
end if
if (trim(group_name) == 'humidity_airtemperature_cloudiness_solarradiation') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_hacs_humidity , timesteps)) return
end if
if (trim(group_name) == 'dewpoint_airtemperature_cloudiness') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_dac_dewpoint , timesteps)) return
end if
if (trim(group_name) == 'dewpoint_airtemperature_cloudiness_solarradiation') then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_dacs_dewpoint , timesteps)) return
end if
if ((trim(group_name) == 'dewpoint_airtemperature_cloudiness' .and. item_dac_dewpoint/=ec_undef_int) &
.or. &
(trim(group_name) == 'dewpoint_airtemperature_cloudiness_solarradiation' .and. item_dacs_dewpoint/=ec_undef_int)) then
! Conversion of dewpoint to relative humidity
ptd => rhum
prh => rhum
ptm => tair
call dewpt2rhum(ptd,ptm,prh) ! convert dewpoint temperatures to relative humidity (percentage)
end if
if (index(group_name, 'airpressure_windx_windy') == 1) then
if (.not.ec_gettimespacevalue_by_itemID(instancePtr, item_apwxwy_p, timesteps)) return
end if
success = .true.
end function ec_gettimespacevalue_by_name
subroutine dewpt2rhum(td,tm,rh)
! in-place conversion of dewpoint temperature to relative humidity, given the air temperature
! $$RH(T,T_d) = \exp\left[\frac{BT}{C+T} - \frac{BT_d}{C+T_d}\right] \times 100$$
implicit none
double precision, dimension(:), pointer :: td !< dewpoint temperature
double precision, dimension(:), pointer :: tm !< air temperature
double precision, dimension(:), pointer :: rh !< relative humidity
double precision, parameter :: B = 17.502 ! exactly as in
double precision, parameter :: C = -32.19
double precision, parameter :: T_0 = 273.16
integer :: i, n
td => rh ! Dewpoint temperature was stored in the array where relative humidity will be stored
n = size(td)
do i=1,n
rh(i) = exp(B*td(i)/(C+td(i)+T_0) - B*tm(i)/(C+tm(i)+T_0)) * 100.d0
end do
end subroutine dewpt2rhum
end module m_meteo
! ==========================================================================
!>
module timespace_read
!!--description-----------------------------------------------------------------
!
!!--pseudo code and references--------------------------------------------------
!
! Stef.Hummel@WlDelft.nl
! Herman.Kernkamp@WlDelft.nl
! Adri.Mourits@WlDelft.nl
!
!!--declarations----------------------------------------------------------------
use precision
implicit none
integer, parameter :: maxnamelen = 256
double precision, parameter :: dmiss_default = -999.0_fp ! Default missing value in meteo arrays
double precision, parameter :: xymiss = -999.0_fp ! Default missing value in elementset
character(300), target :: errormessage = ' ' ! When an error occurs, a message is set in message.
! function getmeteoerror returns the message
double precision :: pi ! pi
double precision :: d2r ! degrees to radials
double precision :: r2d ! degrees to radials
double precision, private, parameter :: earthrad = 6378137.0_fp ! Mathworld, IUGG
contains
!
!
! ==========================================================================
!>
!> Parses an UDUnit-conventions datetime unit string.
!! TODO: replace this by calling C-API from UDUnits(-2).
function parse_ud_timeunit(timeunitstr, iunit, iyear, imonth, iday, ihour, imin, isec) result(ierr)
character(len=*), intent(in) :: timeunitstr !< Time unit by UDUnits conventions, e.g. 'seconds since 2012-01-01 00:00:00.0 +0000'.
integer, intent(out) :: iunit !< Unit in seconds, i.e. 'hours since..' has iunit=3600.
integer, intent(out) :: iyear !< Year in reference datetime.
integer, intent(out) :: imonth !< Month in reference datetime.
integer, intent(out) :: iday !< Day in reference datetime.
integer, intent(out) :: ihour !< Hour in reference datetime.
integer, intent(out) :: imin !< Minute in reference datetime.
integer, intent(out) :: isec !< Seconds in reference datetime.
integer :: ierr !< Error status, only 0 when successful.
integer :: i, n, ifound, iostat
character(len=7) :: unitstr
ierr = 0
unitstr = ' '
n = len_trim(timeunitstr)
ifound = 0
do i = 1,n
if (timeunitstr(i:i) == ' ') then ! First space found
if (timeunitstr(i+1:min(n, i+5)) == 'since') then
unitstr = timeunitstr(1:i-1)
ifound = 1
else
ierr = 1
end if
exit ! Found or error, look no further.
end if
end do
if (ifound == 1) then
select case(trim(unitstr))
case('seconds')
iunit = 1
case('minutes')
iunit = 60
case('hours')
iunit = 3600
case('days')
iunit = 86400
case('weeks')
iunit = 604800
case default
iunit = -1
end select
read (timeunitstr(i+7:n), '(I4,1H,I2,1H,I2,1H,I2,1H,I2,1H,I2)', iostat = iostat) iyear, imonth, iday, ihour, imin, isec
end if
end function parse_ud_timeunit
end module timespace_read
!
!
!
! ==========================================================================
! ==========================================================================
! ==========================================================================
!>
!> Deze module doet ruimte/tijdinterpolatie
!! Voor een gegeven quantity met ruimtedefinitie in een elementset,
!! worden de bijdragen van alle dataproviders aan die quantity gesommeerd.
!! Hierbij heeft iedere dataprovider een eigen tijd/ruimtedefinitie.
!! Zitten meerdere quantities of dezelfde tijd/ruimtedefinitie dan hoeft de tijd/ruimteinterpolatie
!! maar 1 keer uitgevoerd te worden.
!! De gevraagde grootheid moet dan niet als scalair maar als vector aangeboden worden.
module timespace_data
!!--description-----------------------------------------------------------------
!
!!--pseudo code and references--------------------------------------------------
!
! Stef.Hummel@deltares.nl
! Herman.Kernkamp@deltares.nl
! Adri.Mourits@deltares.nl
! Edwin.Spee@deltares.nl
!
!!--declarations----------------------------------------------------------------
use precision
use timespace_read
use timespace_parameters
implicit none
double precision :: timelast = -1d10 ! time of most recent value requested
! if time =< timelast, no updates
double precision :: t01ini = -1d10 ! initial time for dataproviders t0 and t1 fields
! AvD: NOTE
! De pointers in alle onderstaande types worden puur gebruikt om dynamisch
! te kunnen alloceren. In Fortran 95 mag je namelijk geen allocatables in
! user-defined types opnemen. In Fortran 2003 mag dit wel, dus waarom
! binnenkort niet overstappen?
! Naar allocatables mag je ook pointeren (xyen => provider%xyen), en verder
! gebruiken we uberhaupt geen pointer(omleg-)functionaliteit. Performance
! schijnt ook slechter te zijn van pointers.
! allocables hoef je ook niet te nullifyen om de allocated check te laten
! slagen. Dit geldt wel voor de associated check van pointers.
contains
!
!
! ==========================================================================
!>
!> Read the next quantity block that is found in a file.
!! The (external forcing) file is opened elsewhere and read block-by-block
!! by consecutive calls to this routine.
subroutine readprovider(minp,qid,filename,filetype,method,operand,transformcoef,ja,varname,smask, maxSearchRadius)
use m_strucs, only: generalkeywrd, numgeneralkeywrd
use MessageHandling, only : LEVEL_INFO, mess
! globals
integer, intent(in) :: minp !< File handle to already opened input file.
integer, intent(out) :: filetype !< File type of current quantity.
integer, intent(out) :: method !< Time-interpolation method for current quantity.
character (len=*), intent(out) :: filename !< Name of data file for current quantity.
character (len=*), intent(out) :: qid !< Identifier of current quantity (i.e., 'waterlevelbnd')
character (len=1), intent(out) :: operand !< Operand w.r.t. previous data ('O'verride or '+'Append)
real(kind=hp), intent(out) :: transformcoef(:) !< Transformation coefficients
integer, intent(out) :: ja !< Whether a block was successfully read or not.
character (len=*), intent(out) :: varname !< variable name within filename; only in case of NetCDF
character (len=*), intent(out), optional :: smask !< Name of mask-file applied to source arcinfo meteo-data
real(kind=hp), intent(out), optional :: maxSearchRadius !< max search radius for method == 11
! locals
character (len=maxnamelen) :: rec, keywrd
integer :: l1, l2, jaopt, k, extrapolation
logical, save :: alreadyPrinted = .false. !< flag to avoid printing the same message many times
if (minp == 0) then
ja = 0
return
end if
keywrd = 'QUANTITY'
call zoekja(minp,rec,keywrd, ja)
if (ja .eq. 1) then
l1 = index(rec,'=') + 1
call checkForSpacesInProvider(rec, l1, l2) ! l2 = l1 + #spaces after the equal-sign
read(rec(l2:),'(a)',err=990) qid
else
return
end if
keywrd = 'FILENAME'
call zoekja(minp,rec,keywrd, ja)
if (ja .eq. 1) then
l1 = index(rec,'=') + 1
call checkForSpacesInProvider(rec, l1, l2) ! l2 = l1 + #spaces after the equal-sign
read(rec(l2:),'(a)',err=990) filename
else
return
end if
keywrd = 'VARNAME'
call zoekopt(minp, rec, keywrd, ja)
if (ja == 1) then
varname = adjustl(rec)
else
varname = ' '
end if
if (present(smask)) then ! todo: shouldn't this argument be compulsory ? .....
keywrd = 'SOURCEMASK'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) smask
else
smask = ''
end if
endif
keywrd = 'FILETYPE'
call zoekja(minp,rec,keywrd, ja)
if (ja .eq. 1) then
l1 = index(rec,'=') + 1
call checkForSpacesInProvider(rec, l1, l2) ! l2 = l1 + #spaces after the equal-sign
read(rec(l2:),*, err=990) filetype
else
return
end if
keywrd = 'METHOD'
method = spaceandtime ! default : spaceandtime
call zoekja(minp,rec,keywrd, ja)
if (ja .eq. 1) then
l1 = index(rec,'=') + 1
call checkForSpacesInProvider(rec, l1, l2) ! l2 = l1 + #spaces after the equal-sign
read(rec(l2:),*, err=990) method
else
return
end if
if (method == 11) then
if (.not. alreadyPrinted) then
call mess(LEVEL_INFO, 'METHOD=11 is obsolete; use METHOD=3 and EXTRAPOLATION_METHOD=1')
alreadyPrinted = .true.
endif
method = 100 + weightfactors
else
keywrd = 'EXTRAPOLATION_METHOD'
call zoekopt(minp, rec, keywrd, ja)
if (ja == 1) then
read(rec,*,err=990) extrapolation
method = method + 100 * extrapolation
endif
endif
if (present(maxSearchRadius)) then
keywrd = 'MAXSEARCHRADIUS'
call zoekopt(minp, rec, keywrd, ja)
if (ja == 1) then
read(rec,*,err=990) maxSearchRadius
else
maxSearchRadius = -1.0_hp
end if
end if
keywrd = 'OPERAND'
OPERAND = 'O' ! hk : default =O
call zoekja(minp,rec,keywrd, ja)
if (ja .eq. 1) then
l1 = index(rec,'=') + 1
call checkForSpacesInProvider(rec, l1, l2) ! l2 = l1 + #spaces after the equal-sign
read(rec(l2:l2),'(a1)', err=990) operand
else
return
end if
transformcoef = -999d0
keywrd = 'VALUE'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(1)
end if
keywrd = 'FACTOR'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(2)
end if
keywrd = 'IFRCTYP'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(3)
end if
keywrd = 'AVERAGINGTYPE'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(4)
end if
keywrd = 'TRACERFALLVELOCITY'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(4)
end if
keywrd = 'RELATIVESEARCHCELLSIZE'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(5)
end if
keywrd = 'EXTRAPOLTOL'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(6)
end if
keywrd = 'PERCENTILEMINMAX'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(7)
end if
! constant keywrd = 'DISCHARGE'/'SALINITY'/'TEMPERATURE' removed, now always via time series, in future also via new ext [discharge]
keywrd = 'AREA' ! Area for source-sink pipe
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(4)
end if
keywrd = 'TREF' ! relaxation time for riemann boundary
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(7)
end if
!
keywrd = 'NUMMIN' ! minimum number of points in averaging
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(8)
end if
keywrd = 'startlevelsuctionside'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(4)
end if
keywrd = 'stoplevelsuctionside'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(5)
end if
keywrd = 'startleveldeliveryside'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(6)
end if
keywrd = 'stopleveldeliveryside'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(7)
end if
keywrd = 'UNIFORMSALINITYABOVEZ'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(3)
end if
keywrd = 'UNIFORMSALINITYBELOWZ'
call zoekopt(minp, rec, trim(keywrd), jaopt)
if (jaopt == 1) then
read (rec,*) transformcoef(3)
end if
if (qid == 'generalstructure') then
do k = 1,numgeneralkeywrd ! generalstructure
call readandchecknextrecord(minp, rec, generalkeywrd(k), ja)
if (ja == 1) then
L1 = index(rec,'=') + 1
read (rec(L1:),*) transformcoef(k)
else
call qnerror('Looking for '//trim(generalkeywrd(k))//', but getting ', rec, ' ')
end if
enddo
endif
return
990 call readerror('reading '//trim(keywrd)//' but getting ', rec, minp)
end subroutine readprovider
!
!
! ==========================================================================
!>
subroutine checkForSpacesInProvider(rec, eqsign, eqsignsp)
! I/O
character (len=256), intent(in) :: rec !< Name of record that includes the keyword and record
integer, intent(in) :: eqsign !< Location of the equal-sign in the entire record string
integer, intent(out) :: eqsignsp !< Location of the equal-sign plus first spaces after equal-sign
! Locals
integer :: i ! Counter
eqsignsp = eqsign
do i = 0, 256-eqsign
if (rec(eqsign+i:eqsign+i) .eq. ' ') then
eqsignsp = eqsignsp + 1
else
exit
end if
enddo
end subroutine checkForSpacesInProvider
!
!
! ==========================================================================
!>
subroutine read1polylin(minp,xs,ys,ns)
use m_alloc
integer :: minp
double precision, allocatable :: xs(:)
double precision, allocatable :: ys(:)
integer :: ns
character (len=maxnamelen) :: rec
integer :: k
ns = 0
10 read(minp,'(a)',end = 999) rec
if (rec(1:1) == '*' ) goto 10
read(minp,'(a)',end = 999) rec
read(rec ,* ,err = 888) ns
if (.not. allocated(xs)) then
allocate(xs(ns))
else if (ns > size(xs)) then
call realloc(xs, ns, keepExisting=.false.)
end if
if (.not. allocated(ys)) then
allocate(ys(ns))
else if (ns > size(ys)) then
call realloc(ys, ns, keepExisting=.false.)
end if
do k = 1,ns
read(minp,'(a)',end = 999) rec
read(rec ,* ,err = 777) xs(k), ys(k)
enddo
call doclose(minp)
return
999 call eoferror(minp)
return
888 call readerror('reading nrows but getting ', rec, minp)
return
777 call readerror('reading x, y but getting ', rec, minp)
return
end subroutine read1polylin
!
!
! ==========================================================================
!>
subroutine settimespacerefdat(refda, jul00, tz, timjan)
use m_itdate
character (len=8) :: refda
integer :: jul00
double precision :: tz, timjan
integer, external :: julday
integer :: juljan
refdat = refda
read (refdat,*) itdate
read(refdat(1:4),*) iyear0
read(refdat(5:6),*) imonth0
read(refdat(7:8),*) iday0
jul0 = julday(imonth0,iday0,iyear0)
jul00 = jul0
Tzone = tz
juljan = julday(1,1,iyear0)
timjan = (jul0 - juljan)*24.d0
end subroutine settimespacerefdat
!
!
! ==========================================================================
!>
function getmeteoerror( ) result(retval)
implicit none
character(300), pointer :: retval
retval => errormessage
end function getmeteoerror
!
!
! ==========================================================================
!>
subroutine meteo_tidepotential(jul0, TIME , xz , yz , Np, TIDEP, ndx, dstart, dstop , eps) ! call schrama's routines on reduced set
use m_sferic
use m_flowparameters, only: jaselfal, jamaptidep
use m_partitioninfo
integer :: jul0, ndx ! interpolate results in ndx
integer, intent(in) :: Np !< number of potentials in tidep
double precision, dimension(Np, Ndx), intent(inout) :: tidep !< potentials, first is total
double precision :: time, dstart, dstop , eps
double precision :: xz(ndx), yz(ndx), xx(4), yy(4)!, DAREA, DLENGTH, DLENMX
double precision, allocatable, save :: xz2(:,:), yz2(:,:), td2(:,:), self(:,:), avhs(:,:)!, area(:,:)
double precision :: xmn, xmx, ymn, ymx, di, dj, f11,f21,f12,f22
integer :: i,j,n,ierr, m1,m2,n1,n2
integer, save :: ndx2
integer, save :: i1
integer, save :: i2
integer, save :: j1
integer, save :: j2
integer, save :: INI = 0
if (INI == 0 ) then
INI = 1
XMN = 1D30 ; YMN = 1D30 ; XMX = -1D30 ; YMX = -1D30
DO I = 1,ndx
xmn = min(xz(i),xmn)
xmx = max(xz(i),xmx)
ymn = min(yz(i),ymn)
ymx = max(yz(i),ymx)
ENDDO
i1 = floor(xmn); i2 = floor(xmx) + 1
j1 = floor(ymn); j2 = floor(ymx) + 1
if ( jaselfal .eq.1 .or. jaselfal .eq.2 ) then
! globally reduce i1, i2, j1, j2
i1 = -i1
j1 = -j1
call reduce_int4_max(i1,i2,j1,j2)
i1 = -i1
j1 = -j1
end if
IF (ALLOCATED (XZ2) ) DEALLOCATE (XZ2,YZ2,TD2)
allocate ( xz2(i1:i2,j1:j2), stat=ierr) ! tot aerr
allocate ( yz2(i1:i2,j1:j2), stat=ierr)
allocate ( td2(i1:i2,j1:j2), stat=ierr)
if ((jaselfal == 1) .OR. (jaselfal == 2)) then
! if (allocated(self) ) deallocate ( self, avhs, area ) MVL ask Camille
if (allocated(self) ) deallocate ( self, avhs )
allocate ( self(i1:i2,j1:j2), stat=ierr)
allocate (avhs(i1:i2,j1:j2), stat=ierr)
! allocate ( area(i1:i2,j1:j2), stat=ierr)
do i = i1,i2
do j = j1,j2
xx(1) = dble(i)-0.5d0 ; yy(1) = dble(j)-0.5d0
xx(2) = dble(i)+0.5d0 ; yy(2) = dble(j)-0.5d0
xx(3) = dble(i)+0.5d0 ; yy(3) = dble(j)+0.5d0
xx(4) = dble(i)-0.5d0 ; yy(4) = dble(j)+0.5d0
! call dAREAN( XX, YY, 4, DAREA, DLENGTH, DLENMX )
! area(i,j) = darea
enddo
enddo
endif
do i = i1,i2
do j = j1,j2
xz2(i,j) = i*dg2rd
yz2(i,j) = j*dg2rd
enddo
enddo
ndx2 = (i2-i1+1)*( j2-j1+1)
end if
call tforce( jul0, TIME , xz2 , yz2 , Td2, ndx2, dstart, dstop , eps)
if ((jaselfal == 1) .OR. (jaselfal == 2)) then
call aggregatewaterlevels(avhs, i1,i2,j1,j2 )
call selfattraction(avhs, self, i1,i2,j1,j2, jaselfal )
endif
do n = 1,ndx
m1 = floor(xz(n)) ; m2 = m1+1
n1 = floor(yz(n)) ; n2 = n1+1
di = xz(n) - m1
dj = yz(n) - n1
f11 = (1d0-di)*(1d0-dj)
f21 = ( di)*(1d0-dj)
f22 = ( di)*( dj)
f12 = (1d0-di)*( dj)
if ((jaselfal == 1) .OR. (jaselfal == 2)) then
tidep(1,n) = ( td2(m1,n1) + self(m1,n1) )*f11 + &
( td2(m2,n1) + self(m2,n1) )*f21 + &
( td2(m2,n2) + self(m2,n2) )*f22 + &
( td2(m1,n2) + self(m1,n2) )*f12
! for output only
if ( jamaptidep.gt.0 .and. Np.gt.1 ) then ! store SAL potential seperately
tidep(2,n) = ( self(m1,n1) )*f11 + &
( self(m2,n1) )*f21 + &
( self(m2,n2) )*f22 + &
( self(m1,n2) )*f12
end if
else
tidep(1,n) = td2(m1,n1) *f11 + &
td2(m2,n1) *f21 + &
td2(m2,n2) *f22 + &
td2(m1,n2) *f12
endif
enddo
end subroutine meteo_tidepotential
subroutine aggregatewaterlevels(avhs, i1,i2,j1,j2 )
!Compute the water level from the unstructured to the one degree regular grid
use m_flow
use m_flowgeom
use m_partitioninfo
use kdtree2Factory
use unstruc_messages
implicit none
integer :: i1, i2, j1, j2, k, k1, LL, i, j, iL, iR, ierr
integer, save :: ini = 0
double precision :: alf, x, y
double precision :: avhs(i1:i2,j1:j2), area(i1:i2,j1:j2)
double precision, dimension(:,:), allocatable :: xx, yy
integer, dimension(:,:), allocatable :: kk
double precision, dimension(:,:,:), allocatable, save :: workin, workout ! work arrays for parallel communication
integer :: Ni, Nj
integer :: jakdtree = 1
integer :: ierror
character(len=1024) :: str
double precision :: t0, t1
double precision :: wo
double precision, allocatable, save :: jasea(:,:)
Ni = i2-i1+1
Nj = j2-j1+1
if (ini ==0) then
call klok(t0)
allocate ( jasea(i1:i2,j1:j2), stat=ierr)
if ( jakdtree.eq.1 ) then
call realloc(xx, (/ Ni, Nj /), keepExisting=.false., fill=0d0)
call realloc(yy, (/ Ni, Nj /), keepExisting=.false., fill=0d0)
call realloc(kk, (/ Ni, Nj /), keepExisting=.false., fill=0)
do j=j1,j2
do i=i1,i2
xx(i-i1+1,j-j1+1) = dble(i)
yy(i-i1+1,j-j1+1) = dble(j)
end do
end do
call find_flowcells_kdtree(treeglob,Ni*Nj,xx,yy,kk,jakdtree,ierror)
if ( ierror.ne.0 ) then
jakdtree = 0
end if
if ( allocated(xx) ) deallocate(xx)
if ( allocated(yy) ) deallocate(yy)
end if
if ( jampi.eq.0 ) then ! sequential
do j = j1,j2
do i = i1,i2
if( jakdtree.eq.1 ) then
k = kk(i-i1+1,j-j1+1)
else
x = dble(i)
y = dble(j)
call in_flowcell(x, y, K)
end if
if (k > 0) then
jasea(i,j) = 1
else
jasea(i,j) = 0
endif
enddo
enddo
else
! allocate work arrays
if ( allocated(workin) ) deallocate(workin)
allocate(workin(2,Ni,Nj))
workin = 0d0
if ( allocated(workout) ) deallocate(workout)
allocate(workout(2,Ni,Nj))
do j = j1,j2
do i = i1,i2
if( jakdtree.eq.1 ) then
k = kk(i-i1+1,j-j1+1)
else
x = dble(i)
y = dble(j)
call in_flowcell(x, y, K)
end if
if ( k.le.Ndxi ) then
k1 = k
else ! boundary nodes: take connected internal node for domain number (boundary nodes are always in own domain)
LL = iabs(nd(k)%ln(1)) !< only one link connected to boundary node
k1 = ln(1,LL) + ln(2,LL) - k
end if
if ( k > 0 ) then
if ( idomain(k1).eq.my_rank ) then
! jasea(i,j) = 1
workin(1,i-i1+1,j-j1+1) = 1d0
workin(2,i-i1+1,j-j1+1) = 0d0 ! dummy
else
workin(1,i-i1+1,j-j1+1) = 0d0
workin(2,i-i1+1,j-j1+1) = 0d0 ! dummy
end if
else
! jasea(i,j) = 0
workin(1,i-i1+1,j-j1+1) = 0d0
workin(2,i-i1+1,j-j1+1) = 0d0 ! dummy
endif
enddo
enddo
call reduce_double_sum(2*Ni*Nj, workin, workout) ! workin too large, but only once
do j=j1,j2
do i=i1,i2
wo = workout(1,i-i1+1,j-j1+1)
if ( wo.eq.0 ) then
jasea(i,j) = 0
else
jasea(i,j) = 1
end if
end do
end do
end if
call klok(t1)
write(str,"('SAL/aggregate waterlevels, elapsed time: ', G15.5, 's.')") t1-t0
call mess(LEVEL_INFO, trim(str))
ini = 1
endif
if ( allocated(kk) ) deallocate(kk)
jasea = 1
avhs = 0d0
area = 0d0
if ( jampi.eq.0 ) then
do k = 1,ndx
i = nint(xz(k))
j = nint(yz(k))
if (hs(k)>0.0) then
avhs(i,j) = avhs(i,j) + s1(k)*ba(k)
area(i,j) = area(i,j) + ba(k)
endif
enddo
else ! parallel
workin = 0d0
do k = 1,Ndx
i = nint(xz(k))
j = nint(yz(k))
if ( k.le.Ndxi ) then ! internal nodes
k1 = k
else ! boundary nodes: take connected internal node for domain number (boundary nodes are always in own domain)
LL = iabs(nd(k)%ln(1)) !< only one link connected to boundary node
k1 = ln(1,LL) + ln(2,LL) - k
end if
if (hs(k)>0.0 .and. idomain(k1).eq.my_rank ) then
! avhs(i,j) = avhs(i,j) + s1(k)*ba(k)
! area(i,j) = area(i,j) + ba(k)
workin(1,i-i1+1,j-j1+1) = workin(1,i-i1+1,j-j1+1) + s1(k)*ba(k)
workin(2,i-i1+1,j-j1+1) = workin(2,i-i1+1,j-j1+1) + ba(k)
endif
enddo
call reduce_double_sum(2*Ni*Nj, workin, workout)
do j=j1,j2
do i=i1,i2
avhs(i,j) = workout(1,i-i1+1,j-j1+1)
area(i,j) = workout(2,i-i1+1,j-j1+1)
end do
end do
end if
do j = j1,j2
do i = i1,i2
if (area(i,j) > 0.0) then
avhs(i,j) = avhs(i,j) / area(i,j)
endif
enddo
enddo
do j = j1,j2
do i = i1,i2
if (area(i,j) == 0.0 .and. jasea(i,j) == 1) then
call findleftright(area,i,j,i1,i2,j1,j2,iL,iR,alf)
avhs(i,j) = (1d0-alf)*avhs(iL,j) + alf*avhs(iR,j)
endif
enddo
enddo
!Used for testing
!avhs=1d0
!Create output file
! open (unit=3, file='d:\output_avhs2.txt',status='unknown',position='append')
! write(unit=3,fmt=*) i1
! write(unit=3,fmt=*) i2
! write(unit=3,fmt=*) j1
! write(unit=3,fmt=*) j2
! do i=i1,i2
! do j=j1,j2
! write(unit=3,fmt=*) avhs(i,j)
! enddo
! enddo
! close(3)
end subroutine aggregatewaterlevels
subroutine findleftright(area,ii,ji,i1,i2,j1,j2,iL,iR,alf)
implicit none
integer, intent(in) :: i1,i2, ii, j1, j2, ji
double precision, intent(in) :: area(i1:i2,j1:j2)
integer, intent(out) :: iL, iR
double precision, intent(out) :: alf
integer :: i, dr, dl, findr, findl, disR, disL, stopsearch
stopsearch = 0
findr = 0
dr = 0
i = ii
do while (findr==0)
if (area(i,ji)/=0) then
iR = i
findr = 1
endif
if (i==i1) then
i = i2
dr = 1
else
i = i-1
endif
if (i==ii) then
findr = 1
iR = ii
iL = ii
alf = 0
stopsearch = 1
endif
enddo
if (stopsearch==0) then
findl = 0
dl = 0
i = ii
do while (findl==0)
if (area(i,ji)/=0) then
iL = i
findl = 1
endif
if (i==i2) then
i = i1
dl = 1
else
i = i+1
endif
enddo
if (dl==0) then
disL = ii - iL
else
disL = (ii-i2)-(iL-i1)
endif
if (dr==0) then
disR = ii - iR
else
disR = (ii-i1)-(iR-i2)
endif
alf = dble(disL) / dble(disL-disR)
endif
end subroutine findleftright
subroutine selfattraction(avhs, self, i1,i2,j1,j2, jaselfal )
use m_partitioninfo, only: my_rank
implicit none
! Input\Output parameter
integer, intent(in) :: i1,i2,j1,j2, jaselfal
double precision, intent(in) :: avhs(i1:i2,j1:j2)
double precision, intent(out) :: self(i1:i2,j1:j2)
! Local parameters
double precision, parameter :: Me=5.9726d24, R=6371d3, g=9.81d0, pi=4d0*atan(1.0), rhow=1.0240164d3 ,rhoe=3d0*Me/(4d0*pi*R*R*R)
integer :: nlat, nlon, n15, lsave, lwork, ldwork, lwk, liwk, lshaec, lshsec
integer :: i, j, ierror, isym, nt, l, mdab, ndab, k1, k2
! double precision, dimension(0:1024) :: llnh, llnk
double precision, dimension(:), allocatable :: llnh, llnk
double precision, dimension(:), allocatable :: work, wk, iwk, wshaec, wshsec
double precision, dimension(:), allocatable :: dwork
double precision, dimension(:,:), allocatable :: a, b
! double precision, dimension(0:180,0:359) :: avhs1, self1
double precision, dimension(:,:), allocatable :: avhs1, self1
! Initialisation
nlat=181
nlon=360
n15=nlon+15
lsave=nlat*(nlat+1)+3*((nlat-2)*(2*nlat-nlat-1)+n15)
lshaec=lsave
lshsec=lsave
lwork=(nlat+1)*(nlon+3*nlat)+nlat*(2*nlat+1)
ldwork=nlat+1
lwk=46*nlat*(nlon+1)
liwk=14*nlat*(nlon+1)
mdab=nlat
ndab=nlat
! allocate
allocate(work(1:lwork))
allocate(dwork(1:ldwork))
allocate(wk(1:lwk))
allocate(iwk(1:liwk))
allocate(wshaec(1:lsave))
allocate(wshsec(1:lsave))
allocate (a(1:mdab,1:ndab))
allocate (b(1:mdab,1:ndab))
allocate(llnh(0:1024))
allocate(llnk(0:1024))
allocate(avhs1(0:180,0:359))
allocate(self1(0:180,0:359))
!Water level need to be defined in an array avhs1,
! where avhs1(i,j) contains the waterlevel on the point with longitude phi(j)=(j-1)*2*pi/nlon
! and colatitude theta(i)=(i-1)*pi/(nlat)
!For a one degree grid, we have nlon=360 and nlat=181
!If avhs is smaller then 0 is chosen at the location of the missing values
avhs1 = 0d0
k1=0
do i = i1,min0(i2,i1+360-1)
do j = j1,j2
avhs1(j+90,k1)=avhs(i,j)
enddo
k1=k1+1
enddo
!Load Love numbers
call loadlovenumber(llnh,llnk)
!Computation
isym=0
nt=1
!Spherical harmonic analysis
call shaeci(nlat,nlon,wshaec,lshaec,dwork,ldwork,ierror)
call shaec(nlat,nlon,isym,nt,avhs1,nlat,nlon,a,b,mdab,ndab, &
wshaec,lshaec,work,lwork,ierror)
!Multiplication in spherical harmonic space (=convolution)
if (jaselfal == 2) then
do l=1,ndab
a(1:mdab,l)=3*g*rhow/rhoe/(2*l-1)*a(1:mdab,l)
b(1:mdab,l)=3*g*rhow/rhoe/(2*l-1)*b(1:mdab,l)
end do
end if
if (jaselfal == 1) then
do l=1,ndab
a(1:mdab,l)=3*g*rhow*(1+llnk(l-1)-llnh(l-1))/rhoe/(2*l-1)*a(1:mdab,l)
b(1:mdab,l)=3*g*rhow*(1+llnk(l-1)-llnh(l-1))/rhoe/(2*l-1)*b(1:mdab,l)
end do
end if
!Spherical harmonic synthesis
call shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
call shsec(nlat,nlon,isym,nt,self1,nlat,nlon,a,b,mdab,ndab, &
wshsec,lshsec,work,lwork,ierror)
!self1 is defined on the same grid than avhs1, we put it back in the same grid than avhs
self = 0d0
k1=0
do i = i1,i2
if (k1>=360) then
k1=0
endif
do j = j1,j2
if (j+90>=0 .AND. j-90<=180) then
self(i,j)=self1(j+90,k1)
endif
enddo
k1=k1+1
enddo
!Create output file
! open (unit=1, file='d:\output_SALtide2.txt',status='unknown',position='append')
! open (unit=2, file='d:\output_tide2.txt',status='unknown',position='append')
! do i=1,nlat
! do j=1,nlon
! write(unit=1,fmt=*) self1(i-1,j-1)/g
! write(unit=2,fmt=*) avhs1(i-1,j-1)
! enddo
! enddo
! close(1)
! close(2)
! open (unit=3, file='d:\output_avhs.txt',status='unknown',position='append')
! do i=i1,i2
! do j=j1,j2
! write(unit=3,fmt=*) avhs(i,j)
! enddo
! enddo
! close(3)
! deallocate
if (allocated(work) ) deallocate(work)
if (allocated(dwork) ) deallocate(dwork)
if (allocated(wk) ) deallocate(wk)
if (allocated(iwk) ) deallocate(iwk)
if (allocated(wshaec) ) deallocate(wshaec)
if (allocated(wshsec) ) deallocate(wshsec)
if (allocated(a) ) deallocate (a)
if (allocated(b) ) deallocate (b)
if (allocated(llnh) ) deallocate(llnh)
if (allocated(llnk) ) deallocate(llnk)
if (allocated(avhs1) ) deallocate(avhs1)
if (allocated(self1) ) deallocate(self1)
end subroutine selfattraction
subroutine loadlovenumber(llnh,llnk)
!Define the second load Love number h' and k' up to degree 1024
implicit none
! Input\Output parameter
double precision, dimension(0:1024), intent(out) :: llnh, llnk
!Fill arrays
llnh( 0 )= 0.0000000000D+00
llnh( 1 )= -0.1285877758D+01
llnh( 2 )= -0.9915810331D+00
llnh( 3 )= -0.1050767745D+01
llnh( 4 )= -0.1053393012D+01
llnh( 5 )= -0.1086317605D+01
llnh( 6 )= -0.1143860336D+01
llnh( 7 )= -0.1212408459D+01
llnh( 8 )= -0.1283943275D+01
llnh( 9 )= -0.1354734845D+01
llnh( 10 )= -0.1423282851D+01
llnh( 11 )= -0.1489094554D+01
llnh( 12 )= -0.1552074997D+01
llnh( 13 )= -0.1612273740D+01
llnh( 14 )= -0.1669763369D+01
llnh( 15 )= -0.1724635488D+01
llnh( 16 )= -0.1776963521D+01
llnh( 17 )= -0.1826825601D+01
llnh( 18 )= -0.1874298467D+01
llnh( 19 )= -0.1919461416D+01
llnh( 20 )= -0.1962393632D+01
llnh( 21 )= -0.2003182253D+01
llnh( 22 )= -0.2041915786D+01
llnh( 23 )= -0.2078680486D+01
llnh( 24 )= -0.2113573061D+01
llnh( 25 )= -0.2146680270D+01
llnh( 26 )= -0.2178105661D+01
llnh( 27 )= -0.2207927152D+01
llnh( 28 )= -0.2236242846D+01
llnh( 29 )= -0.2263132641D+01
llnh( 30 )= -0.2288687940D+01
llnh( 31 )= -0.2312991757D+01
llnh( 32 )= -0.2336112443D+01
llnh( 33 )= -0.2358128831D+01
llnh( 34 )= -0.2379107893D+01
llnh( 35 )= -0.2399120761D+01
llnh( 36 )= -0.2418226351D+01
llnh( 37 )= -0.2436482905D+01
llnh( 38 )= -0.2453948379D+01
llnh( 39 )= -0.2470670195D+01
llnh( 40 )= -0.2486697757D+01
llnh( 41 )= -0.2502076334D+01
llnh( 42 )= -0.2516847401D+01
llnh( 43 )= -0.2531050008D+01
llnh( 44 )= -0.2544719530D+01
llnh( 45 )= -0.2557890739D+01
llnh( 46 )= -0.2570594319D+01
llnh( 47 )= -0.2582859779D+01
llnh( 48 )= -0.2594714216D+01
llnh( 49 )= -0.2606182782D+01
llnh( 50 )= -0.2617289738D+01
llnh( 51 )= -0.2628056023D+01
llnh( 52 )= -0.2638502978D+01
llnh( 53 )= -0.2648649164D+01
llnh( 54 )= -0.2658512061D+01
llnh( 55 )= -0.2668109142D+01
llnh( 56 )= -0.2677455130D+01
llnh( 57 )= -0.2686564655D+01
llnh( 58 )= -0.2695451439D+01
llnh( 59 )= -0.2704127764D+01
llnh( 60 )= -0.2712605707D+01
llnh( 61 )= -0.2720896238D+01
llnh( 62 )= -0.2729009765D+01
llnh( 63 )= -0.2736955903D+01
llnh( 64 )= -0.2744743969D+01
llnh( 65 )= -0.2752382423D+01
llnh( 66 )= -0.2759879282D+01
llnh( 67 )= -0.2767242102D+01
llnh( 68 )= -0.2774478021D+01
llnh( 69 )= -0.2781593811D+01
llnh( 70 )= -0.2788595709D+01
llnh( 71 )= -0.2795489680D+01
llnh( 72 )= -0.2802281343D+01
llnh( 73 )= -0.2808976028D+01
llnh( 74 )= -0.2815578704D+01
llnh( 75 )= -0.2822094093D+01
llnh( 76 )= -0.2828526669D+01
llnh( 77 )= -0.2834880683D+01
llnh( 78 )= -0.2841160150D+01
llnh( 79 )= -0.2847368769D+01
llnh( 80 )= -0.2853510163D+01
llnh( 81 )= -0.2859587939D+01
llnh( 82 )= -0.2865604931D+01
llnh( 83 )= -0.2871564378D+01
llnh( 84 )= -0.2877469169D+01
llnh( 85 )= -0.2883322045D+01
llnh( 86 )= -0.2889125648D+01
llnh( 87 )= -0.2894882413D+01
llnh( 88 )= -0.2900594702D+01
llnh( 89 )= -0.2906264743D+01
llnh( 90 )= -0.2911894687D+01
llnh( 91 )= -0.2917486512D+01
llnh( 92 )= -0.2923042145D+01
llnh( 93 )= -0.2928563403D+01
llnh( 94 )= -0.2934052041D+01
llnh( 95 )= -0.2939509674D+01
llnh( 96 )= -0.2944937877D+01
llnh( 97 )= -0.2950338132D+01
llnh( 98 )= -0.2955711880D+01
llnh( 99 )= -0.2961060436D+01
llnh( 100 )= -0.2966385090D+01
llnh( 101 )= -0.2971687056D+01
llnh( 102 )= -0.2976967512D+01
llnh( 103 )= -0.2982227536D+01
llnh( 104 )= -0.2987468183D+01
llnh( 105 )= -0.2992690446D+01
llnh( 106 )= -0.2997895290D+01
llnh( 107 )= -0.3003083596D+01
llnh( 108 )= -0.3008256228D+01
llnh( 109 )= -0.3013413998D+01
llnh( 110 )= -0.3018557697D+01
llnh( 111 )= -0.3023688044D+01
llnh( 112 )= -0.3028805745D+01
llnh( 113 )= -0.3033911465D+01
llnh( 114 )= -0.3039005849D+01
llnh( 115 )= -0.3044089483D+01
llnh( 116 )= -0.3049162947D+01
llnh( 117 )= -0.3054226779D+01
llnh( 118 )= -0.3059281508D+01
llnh( 119 )= -0.3064327612D+01
llnh( 120 )= -0.3069365560D+01
llnh( 121 )= -0.3074395793D+01
llnh( 122 )= -0.3079418737D+01
llnh( 123 )= -0.3084434789D+01
llnh( 124 )= -0.3089444323D+01
llnh( 125 )= -0.3094447698D+01
llnh( 126 )= -0.3099445739D+01
llnh( 127 )= -0.3104437859D+01
llnh( 128 )= -0.3109424785D+01
llnh( 129 )= -0.3114406817D+01
llnh( 130 )= -0.3119384228D+01
llnh( 131 )= -0.3124357299D+01
llnh( 132 )= -0.3129326253D+01
llnh( 133 )= -0.3134291331D+01
llnh( 134 )= -0.3139252753D+01
llnh( 135 )= -0.3144210746D+01
llnh( 136 )= -0.3149165487D+01
llnh( 137 )= -0.3154117170D+01
llnh( 138 )= -0.3159065971D+01
llnh( 139 )= -0.3164012071D+01
llnh( 140 )= -0.3168955611D+01
llnh( 141 )= -0.3173896746D+01
llnh( 142 )= -0.3178835615D+01
llnh( 143 )= -0.3183772364D+01
llnh( 144 )= -0.3188707103D+01
llnh( 145 )= -0.3193639953D+01
llnh( 146 )= -0.3198571025D+01
llnh( 147 )= -0.3203500433D+01
llnh( 148 )= -0.3208428262D+01
llnh( 149 )= -0.3213354609D+01
llnh( 150 )= -0.3218279559D+01
llnh( 151 )= -0.3223203202D+01
llnh( 152 )= -0.3228125600D+01
llnh( 153 )= -0.3233046832D+01
llnh( 154 )= -0.3237966958D+01
llnh( 155 )= -0.3242886050D+01
llnh( 156 )= -0.3247804156D+01
llnh( 157 )= -0.3252721331D+01
llnh( 158 )= -0.3257637624D+01
llnh( 159 )= -0.3262553244D+01
llnh( 160 )= -0.3267467917D+01
llnh( 161 )= -0.3272381835D+01
llnh( 162 )= -0.3277295035D+01
llnh( 163 )= -0.3282207554D+01
llnh( 164 )= -0.3287119415D+01
llnh( 165 )= -0.3292030647D+01
llnh( 166 )= -0.3296941273D+01
llnh( 167 )= -0.3301851314D+01
llnh( 168 )= -0.3306760804D+01
llnh( 169 )= -0.3311669742D+01
llnh( 170 )= -0.3316578148D+01
llnh( 171 )= -0.3321486032D+01
llnh( 172 )= -0.3326393422D+01
llnh( 173 )= -0.3331300520D+01
llnh( 174 )= -0.3336207644D+01
llnh( 175 )= -0.3341113629D+01
llnh( 176 )= -0.3346019149D+01
llnh( 177 )= -0.3350924191D+01
llnh( 178 )= -0.3355828764D+01
llnh( 179 )= -0.3360732862D+01
llnh( 180 )= -0.3365636499D+01
llnh( 181 )= -0.3370539656D+01
llnh( 182 )= -0.3375442336D+01
llnh( 183 )= -0.3380344530D+01
llnh( 184 )= -0.3385246241D+01
llnh( 185 )= -0.3390147452D+01
llnh( 186 )= -0.3395048158D+01
llnh( 187 )= -0.3399948348D+01
llnh( 188 )= -0.3404848021D+01
llnh( 189 )= -0.3409747153D+01
llnh( 190 )= -0.3414645740D+01
llnh( 191 )= -0.3419543764D+01
llnh( 192 )= -0.3424441221D+01
llnh( 193 )= -0.3429338088D+01
llnh( 194 )= -0.3434234352D+01
llnh( 195 )= -0.3439129995D+01
llnh( 196 )= -0.3444025009D+01
llnh( 197 )= -0.3448919371D+01
llnh( 198 )= -0.3453813064D+01
llnh( 199 )= -0.3458706066D+01
llnh( 200 )= -0.3463598369D+01
llnh( 201 )= -0.3468489946D+01
llnh( 202 )= -0.3473380779D+01
llnh( 203 )= -0.3478270847D+01
llnh( 204 )= -0.3483160133D+01
llnh( 205 )= -0.3488048612D+01
llnh( 206 )= -0.3492936263D+01
llnh( 207 )= -0.3497823067D+01
llnh( 208 )= -0.3502708995D+01
llnh( 209 )= -0.3507594040D+01
llnh( 210 )= -0.3512478162D+01
llnh( 211 )= -0.3517361345D+01
llnh( 212 )= -0.3522243562D+01
llnh( 213 )= -0.3527124799D+01
llnh( 214 )= -0.3532005020D+01
llnh( 215 )= -0.3536884206D+01
llnh( 216 )= -0.3541762329D+01
llnh( 217 )= -0.3546639373D+01
llnh( 218 )= -0.3551515301D+01
llnh( 219 )= -0.3556390096D+01
llnh( 220 )= -0.3561263723D+01
llnh( 221 )= -0.3566136170D+01
llnh( 222 )= -0.3571007398D+01
llnh( 223 )= -0.3575877387D+01
llnh( 224 )= -0.3580747513D+01
llnh( 225 )= -0.3585615132D+01
llnh( 226 )= -0.3590481365D+01
llnh( 227 )= -0.3595346263D+01
llnh( 228 )= -0.3600209792D+01
llnh( 229 )= -0.3605071936D+01
llnh( 230 )= -0.3609932657D+01
llnh( 231 )= -0.3614791931D+01
llnh( 232 )= -0.3619649732D+01
llnh( 233 )= -0.3624506035D+01
llnh( 234 )= -0.3629360805D+01
llnh( 235 )= -0.3634214026D+01
llnh( 236 )= -0.3639065656D+01
llnh( 237 )= -0.3643915683D+01
llnh( 238 )= -0.3648764066D+01
llnh( 239 )= -0.3653610782D+01
llnh( 240 )= -0.3658455800D+01
llnh( 241 )= -0.3663299103D+01
llnh( 242 )= -0.3668140651D+01
llnh( 243 )= -0.3672980417D+01
llnh( 244 )= -0.3677818461D+01
llnh( 245 )= -0.3682654761D+01
llnh( 246 )= -0.3687489030D+01
llnh( 247 )= -0.3692321405D+01
llnh( 248 )= -0.3697151858D+01
llnh( 249 )= -0.3701980361D+01
llnh( 250 )= -0.3706806936D+01
llnh( 251 )= -0.3711631455D+01
llnh( 252 )= -0.3716453939D+01
llnh( 253 )= -0.3721274358D+01
llnh( 254 )= -0.3726092689D+01
llnh( 255 )= -0.3730908892D+01
llnh( 256 )= -0.3735722950D+01
llnh( 257 )= -0.3740534821D+01
llnh( 258 )= -0.3745344490D+01
llnh( 259 )= -0.3750151923D+01
llnh( 260 )= -0.3754957088D+01
llnh( 261 )= -0.3759759956D+01
llnh( 262 )= -0.3764560505D+01
llnh( 263 )= -0.3769358699D+01
llnh( 264 )= -0.3774154515D+01
llnh( 265 )= -0.3778947920D+01
llnh( 266 )= -0.3783738888D+01
llnh( 267 )= -0.3788527389D+01
llnh( 268 )= -0.3793313390D+01
llnh( 269 )= -0.3798096866D+01
llnh( 270 )= -0.3802877791D+01
llnh( 271 )= -0.3807656137D+01
llnh( 272 )= -0.3812431870D+01
llnh( 273 )= -0.3817204958D+01
llnh( 274 )= -0.3821975383D+01
llnh( 275 )= -0.3826743110D+01
llnh( 276 )= -0.3831508110D+01
llnh( 277 )= -0.3836271873D+01
llnh( 278 )= -0.3841032150D+01
llnh( 279 )= -0.3845788986D+01
llnh( 280 )= -0.3850542997D+01
llnh( 281 )= -0.3855294157D+01
llnh( 282 )= -0.3860042438D+01
llnh( 283 )= -0.3864787807D+01
llnh( 284 )= -0.3869530239D+01
llnh( 285 )= -0.3874269702D+01
llnh( 286 )= -0.3879006179D+01
llnh( 287 )= -0.3883739635D+01
llnh( 288 )= -0.3888470049D+01
llnh( 289 )= -0.3893197379D+01
llnh( 290 )= -0.3897921616D+01
llnh( 291 )= -0.3902642720D+01
llnh( 292 )= -0.3907360668D+01
llnh( 293 )= -0.3912075438D+01
llnh( 294 )= -0.3916786993D+01
llnh( 295 )= -0.3921495314D+01
llnh( 296 )= -0.3926200363D+01
llnh( 297 )= -0.3930902125D+01
llnh( 298 )= -0.3935600573D+01
llnh( 299 )= -0.3940295676D+01
llnh( 300 )= -0.3944987404D+01
llnh( 301 )= -0.3949675741D+01
llnh( 302 )= -0.3954360653D+01
llnh( 303 )= -0.3959042119D+01
llnh( 304 )= -0.3963720107D+01
llnh( 305 )= -0.3968394592D+01
llnh( 306 )= -0.3973065547D+01
llnh( 307 )= -0.3977732958D+01
llnh( 308 )= -0.3982396782D+01
llnh( 309 )= -0.3987056997D+01
llnh( 310 )= -0.3991713583D+01
llnh( 311 )= -0.3996366510D+01
llnh( 312 )= -0.4001015766D+01
llnh( 313 )= -0.4005661299D+01
llnh( 314 )= -0.4010303104D+01
llnh( 315 )= -0.4014941156D+01
llnh( 316 )= -0.4019575415D+01
llnh( 317 )= -0.4024205867D+01
llnh( 318 )= -0.4028832484D+01
llnh( 319 )= -0.4033455241D+01
llnh( 320 )= -0.4038074113D+01
llnh( 321 )= -0.4042689078D+01
llnh( 322 )= -0.4047300107D+01
llnh( 323 )= -0.4051907177D+01
llnh( 324 )= -0.4056510264D+01
llnh( 325 )= -0.4061109341D+01
llnh( 326 )= -0.4065704388D+01
llnh( 327 )= -0.4070295381D+01
llnh( 328 )= -0.4074882284D+01
llnh( 329 )= -0.4079465087D+01
llnh( 330 )= -0.4084043760D+01
llnh( 331 )= -0.4088618279D+01
llnh( 332 )= -0.4093188619D+01
llnh( 333 )= -0.4097757745D+01
llnh( 334 )= -0.4102319954D+01
llnh( 335 )= -0.4106878131D+01
llnh( 336 )= -0.4111431810D+01
llnh( 337 )= -0.4115981211D+01
llnh( 338 )= -0.4120526303D+01
llnh( 339 )= -0.4125067085D+01
llnh( 340 )= -0.4129603517D+01
llnh( 341 )= -0.4134135580D+01
llnh( 342 )= -0.4138663260D+01
llnh( 343 )= -0.4143186527D+01
llnh( 344 )= -0.4147705363D+01
llnh( 345 )= -0.4152219750D+01
llnh( 346 )= -0.4156729818D+01
llnh( 347 )= -0.4161235270D+01
llnh( 348 )= -0.4165736154D+01
llnh( 349 )= -0.4170232508D+01
llnh( 350 )= -0.4174724295D+01
llnh( 351 )= -0.4179211503D+01
llnh( 352 )= -0.4183694105D+01
llnh( 353 )= -0.4188172090D+01
llnh( 354 )= -0.4192645419D+01
llnh( 355 )= -0.4197114075D+01
llnh( 356 )= -0.4201578059D+01
llnh( 357 )= -0.4206037324D+01
llnh( 358 )= -0.4210491862D+01
llnh( 359 )= -0.4214941658D+01
llnh( 360 )= -0.4219386679D+01
llnh( 361 )= -0.4223826915D+01
llnh( 362 )= -0.4228262339D+01
llnh( 363 )= -0.4232692981D+01
llnh( 364 )= -0.4237118729D+01
llnh( 365 )= -0.4241539614D+01
llnh( 366 )= -0.4245955590D+01
llnh( 367 )= -0.4250366666D+01
llnh( 368 )= -0.4254772819D+01
llnh( 369 )= -0.4259174029D+01
llnh( 370 )= -0.4263570269D+01
llnh( 371 )= -0.4267961523D+01
llnh( 372 )= -0.4272347781D+01
llnh( 373 )= -0.4276728990D+01
llnh( 374 )= -0.4281105174D+01
llnh( 375 )= -0.4285476289D+01
llnh( 376 )= -0.4289842325D+01
llnh( 377 )= -0.4294203252D+01
llnh( 378 )= -0.4298559055D+01
llnh( 379 )= -0.4302909733D+01
llnh( 380 )= -0.4307255251D+01
llnh( 381 )= -0.4311595601D+01
llnh( 382 )= -0.4315930729D+01
llnh( 383 )= -0.4320260674D+01
llnh( 384 )= -0.4324585375D+01
llnh( 385 )= -0.4328909213D+01
llnh( 386 )= -0.4333223786D+01
llnh( 387 )= -0.4337533117D+01
llnh( 388 )= -0.4341837175D+01
llnh( 389 )= -0.4346135928D+01
llnh( 390 )= -0.4350429387D+01
llnh( 391 )= -0.4354717544D+01
llnh( 392 )= -0.4359000351D+01
llnh( 393 )= -0.4363277792D+01
llnh( 394 )= -0.4367549884D+01
llnh( 395 )= -0.4371816587D+01
llnh( 396 )= -0.4376077888D+01
llnh( 397 )= -0.4380333776D+01
llnh( 398 )= -0.4384584234D+01
llnh( 399 )= -0.4388829242D+01
llnh( 400 )= -0.4393068797D+01
llnh( 401 )= -0.4397302881D+01
llnh( 402 )= -0.4401531470D+01
llnh( 403 )= -0.4405754548D+01
llnh( 404 )= -0.4409972120D+01
llnh( 405 )= -0.4414184146D+01
llnh( 406 )= -0.4418390628D+01
llnh( 407 )= -0.4422591551D+01
llnh( 408 )= -0.4426786883D+01
llnh( 409 )= -0.4430976616D+01
llnh( 410 )= -0.4435160749D+01
llnh( 411 )= -0.4439339273D+01
llnh( 412 )= -0.4443512157D+01
llnh( 413 )= -0.4447679385D+01
llnh( 414 )= -0.4451840955D+01
llnh( 415 )= -0.4455997001D+01
llnh( 416 )= -0.4460147471D+01
llnh( 417 )= -0.4464291999D+01
llnh( 418 )= -0.4468430796D+01
llnh( 419 )= -0.4472563895D+01
llnh( 420 )= -0.4476691221D+01
llnh( 421 )= -0.4480812807D+01
llnh( 422 )= -0.4484928622D+01
llnh( 423 )= -0.4489038649D+01
llnh( 424 )= -0.4493142872D+01
llnh( 425 )= -0.4497241313D+01
llnh( 426 )= -0.4501333913D+01
llnh( 427 )= -0.4505420682D+01
llnh( 428 )= -0.4509501609D+01
llnh( 429 )= -0.4513576672D+01
llnh( 430 )= -0.4517645867D+01
llnh( 431 )= -0.4521709169D+01
llnh( 432 )= -0.4525766592D+01
llnh( 433 )= -0.4529818089D+01
llnh( 434 )= -0.4533863683D+01
llnh( 435 )= -0.4537903321D+01
llnh( 436 )= -0.4541938182D+01
llnh( 437 )= -0.4545970060D+01
llnh( 438 )= -0.4549992311D+01
llnh( 439 )= -0.4554008601D+01
llnh( 440 )= -0.4558018930D+01
llnh( 441 )= -0.4562023294D+01
llnh( 442 )= -0.4566021693D+01
llnh( 443 )= -0.4570014092D+01
llnh( 444 )= -0.4574000505D+01
llnh( 445 )= -0.4577980892D+01
llnh( 446 )= -0.4581955270D+01
llnh( 447 )= -0.4585923636D+01
llnh( 448 )= -0.4589885948D+01
llnh( 449 )= -0.4593842227D+01
llnh( 450 )= -0.4597792434D+01
llnh( 451 )= -0.4601736614D+01
llnh( 452 )= -0.4605674684D+01
llnh( 453 )= -0.4609606692D+01
llnh( 454 )= -0.4613532603D+01
llnh( 455 )= -0.4617452421D+01
llnh( 456 )= -0.4621366116D+01
llnh( 457 )= -0.4625273717D+01
llnh( 458 )= -0.4629175176D+01
llnh( 459 )= -0.4633070515D+01
llnh( 460 )= -0.4636959727D+01
llnh( 461 )= -0.4640842768D+01
llnh( 462 )= -0.4644719655D+01
llnh( 463 )= -0.4648590372D+01
llnh( 464 )= -0.4652454903D+01
llnh( 465 )= -0.4656313259D+01
llnh( 466 )= -0.4660165448D+01
llnh( 467 )= -0.4664011409D+01
llnh( 468 )= -0.4667851182D+01
llnh( 469 )= -0.4671684743D+01
llnh( 470 )= -0.4675512056D+01
llnh( 471 )= -0.4679333175D+01
llnh( 472 )= -0.4683148017D+01
llnh( 473 )= -0.4686956657D+01
llnh( 474 )= -0.4690759028D+01
llnh( 475 )= -0.4694555138D+01
llnh( 476 )= -0.4698344998D+01
llnh( 477 )= -0.4702128578D+01
llnh( 478 )= -0.4705905867D+01
llnh( 479 )= -0.4709676879D+01
llnh( 480 )= -0.4713441602D+01
llnh( 481 )= -0.4717200013D+01
llnh( 482 )= -0.4720952106D+01
llnh( 483 )= -0.4724697898D+01
llnh( 484 )= -0.4728437390D+01
llnh( 485 )= -0.4732170536D+01
llnh( 486 )= -0.4735897325D+01
llnh( 487 )= -0.4739617794D+01
llnh( 488 )= -0.4743331898D+01
llnh( 489 )= -0.4747041742D+01
llnh( 490 )= -0.4750747006D+01
llnh( 491 )= -0.4754442562D+01
llnh( 492 )= -0.4758131783D+01
llnh( 493 )= -0.4761815020D+01
llnh( 494 )= -0.4765491574D+01
llnh( 495 )= -0.4769161760D+01
llnh( 496 )= -0.4772825594D+01
llnh( 497 )= -0.4776483086D+01
llnh( 498 )= -0.4780134175D+01
llnh( 499 )= -0.4783778934D+01
llnh( 500 )= -0.4787417346D+01
llnh( 501 )= -0.4791049345D+01
llnh( 502 )= -0.4794674951D+01
llnh( 503 )= -0.4798294201D+01
llnh( 504 )= -0.4801907068D+01
llnh( 505 )= -0.4805513523D+01
llnh( 506 )= -0.4809113591D+01
llnh( 507 )= -0.4812707285D+01
llnh( 508 )= -0.4816294557D+01
llnh( 509 )= -0.4819875456D+01
llnh( 510 )= -0.4823449917D+01
llnh( 511 )= -0.4827017975D+01
llnh( 512 )= -0.4830579617D+01
llnh( 513 )= -0.4834134846D+01
llnh( 514 )= -0.4837683664D+01
llnh( 515 )= -0.4841226070D+01
llnh( 516 )= -0.4844762004D+01
llnh( 517 )= -0.4848291562D+01
llnh( 518 )= -0.4851814662D+01
llnh( 519 )= -0.4855331349D+01
llnh( 520 )= -0.4858841570D+01
llnh( 521 )= -0.4862345359D+01
llnh( 522 )= -0.4865842727D+01
llnh( 523 )= -0.4869333622D+01
llnh( 524 )= -0.4872818085D+01
llnh( 525 )= -0.4876296108D+01
llnh( 526 )= -0.4879767676D+01
llnh( 527 )= -0.4883232788D+01
llnh( 528 )= -0.4886691441D+01
llnh( 529 )= -0.4890143646D+01
llnh( 530 )= -0.4893589383D+01
llnh( 531 )= -0.4897028646D+01
llnh( 532 )= -0.4900461459D+01
llnh( 533 )= -0.4903887800D+01
llnh( 534 )= -0.4907307694D+01
llnh( 535 )= -0.4910721080D+01
llnh( 536 )= -0.4914128000D+01
llnh( 537 )= -0.4917528444D+01
llnh( 538 )= -0.4920922416D+01
llnh( 539 )= -0.4924309950D+01
llnh( 540 )= -0.4927690936D+01
llnh( 541 )= -0.4931065502D+01
llnh( 542 )= -0.4934433516D+01
llnh( 543 )= -0.4937797571D+01
llnh( 544 )= -0.4941156429D+01
llnh( 545 )= -0.4944505566D+01
llnh( 546 )= -0.4947848246D+01
llnh( 547 )= -0.4951184474D+01
llnh( 548 )= -0.4954514217D+01
llnh( 549 )= -0.4957837546D+01
llnh( 550 )= -0.4961154421D+01
llnh( 551 )= -0.4964464816D+01
llnh( 552 )= -0.4967768764D+01
llnh( 553 )= -0.4971066281D+01
llnh( 554 )= -0.4974357343D+01
llnh( 555 )= -0.4977641966D+01
llnh( 556 )= -0.4980920106D+01
llnh( 557 )= -0.4984191792D+01
llnh( 558 )= -0.4987457081D+01
llnh( 559 )= -0.4990715853D+01
llnh( 560 )= -0.4993968216D+01
llnh( 561 )= -0.4997214147D+01
llnh( 562 )= -0.5000453623D+01
llnh( 563 )= -0.5003686648D+01
llnh( 564 )= -0.5006913204D+01
llnh( 565 )= -0.5010133371D+01
llnh( 566 )= -0.5013347076D+01
llnh( 567 )= -0.5016554357D+01
llnh( 568 )= -0.5019755183D+01
llnh( 569 )= -0.5022949569D+01
llnh( 570 )= -0.5026137554D+01
llnh( 571 )= -0.5029319047D+01
llnh( 572 )= -0.5032494140D+01
llnh( 573 )= -0.5035663150D+01
llnh( 574 )= -0.5038825376D+01
llnh( 575 )= -0.5041981220D+01
llnh( 576 )= -0.5045130584D+01
llnh( 577 )= -0.5048273555D+01
llnh( 578 )= -0.5051410090D+01
llnh( 579 )= -0.5054540239D+01
llnh( 580 )= -0.5057663933D+01
llnh( 581 )= -0.5060781203D+01
llnh( 582 )= -0.5063892095D+01
llnh( 583 )= -0.5066996544D+01
llnh( 584 )= -0.5070094560D+01
llnh( 585 )= -0.5073186208D+01
llnh( 586 )= -0.5076271426D+01
llnh( 587 )= -0.5079350236D+01
llnh( 588 )= -0.5082422642D+01
llnh( 589 )= -0.5085488664D+01
llnh( 590 )= -0.5088548256D+01
llnh( 591 )= -0.5091601476D+01
llnh( 592 )= -0.5094648290D+01
llnh( 593 )= -0.5097688683D+01
llnh( 594 )= -0.5100722685D+01
llnh( 595 )= -0.5103750327D+01
llnh( 596 )= -0.5106771540D+01
llnh( 597 )= -0.5109786384D+01
llnh( 598 )= -0.5112799670D+01
llnh( 599 )= -0.5115803150D+01
llnh( 600 )= -0.5118799395D+01
llnh( 601 )= -0.5121789292D+01
llnh( 602 )= -0.5124772858D+01
llnh( 603 )= -0.5127750116D+01
llnh( 604 )= -0.5130721005D+01
llnh( 605 )= -0.5133685604D+01
llnh( 606 )= -0.5136643859D+01
llnh( 607 )= -0.5139595762D+01
llnh( 608 )= -0.5142541391D+01
llnh( 609 )= -0.5145480724D+01
llnh( 610 )= -0.5148413704D+01
llnh( 611 )= -0.5151340435D+01
llnh( 612 )= -0.5154260814D+01
llnh( 613 )= -0.5157174876D+01
llnh( 614 )= -0.5160082667D+01
llnh( 615 )= -0.5162984187D+01
llnh( 616 )= -0.5165879425D+01
llnh( 617 )= -0.5168768373D+01
llnh( 618 )= -0.5171651043D+01
llnh( 619 )= -0.5174527467D+01
llnh( 620 )= -0.5177397602D+01
llnh( 621 )= -0.5180261493D+01
llnh( 622 )= -0.5183119109D+01
llnh( 623 )= -0.5185970497D+01
llnh( 624 )= -0.5188815635D+01
llnh( 625 )= -0.5191654520D+01
llnh( 626 )= -0.5194487149D+01
llnh( 627 )= -0.5197313595D+01
llnh( 628 )= -0.5200133751D+01
llnh( 629 )= -0.5202947738D+01
llnh( 630 )= -0.5205755473D+01
llnh( 631 )= -0.5208556983D+01
llnh( 632 )= -0.5211352324D+01
llnh( 633 )= -0.5214141419D+01
llnh( 634 )= -0.5216924343D+01
llnh( 635 )= -0.5219701054D+01
llnh( 636 )= -0.5222471563D+01
llnh( 637 )= -0.5225235884D+01
llnh( 638 )= -0.5227994025D+01
llnh( 639 )= -0.5230746030D+01
llnh( 640 )= -0.5233491832D+01
llnh( 641 )= -0.5236231461D+01
llnh( 642 )= -0.5238964942D+01
llnh( 643 )= -0.5241692271D+01
llnh( 644 )= -0.5244413412D+01
llnh( 645 )= -0.5247128424D+01
llnh( 646 )= -0.5249837269D+01
llnh( 647 )= -0.5252540015D+01
llnh( 648 )= -0.5255236616D+01
llnh( 649 )= -0.5257927067D+01
llnh( 650 )= -0.5260611388D+01
llnh( 651 )= -0.5263289623D+01
llnh( 652 )= -0.5265961712D+01
llnh( 653 )= -0.5268633068D+01
llnh( 654 )= -0.5271293569D+01
llnh( 655 )= -0.5273947990D+01
llnh( 656 )= -0.5276596206D+01
llnh( 657 )= -0.5279238426D+01
llnh( 658 )= -0.5281874571D+01
llnh( 659 )= -0.5284504655D+01
llnh( 660 )= -0.5287128701D+01
llnh( 661 )= -0.5289746751D+01
llnh( 662 )= -0.5292358757D+01
llnh( 663 )= -0.5294964725D+01
llnh( 664 )= -0.5297564727D+01
llnh( 665 )= -0.5300158699D+01
llnh( 666 )= -0.5302746668D+01
llnh( 667 )= -0.5305328668D+01
llnh( 668 )= -0.5307904687D+01
llnh( 669 )= -0.5310474675D+01
llnh( 670 )= -0.5313038743D+01
llnh( 671 )= -0.5315596857D+01
llnh( 672 )= -0.5318148939D+01
llnh( 673 )= -0.5320695164D+01
llnh( 674 )= -0.5323235360D+01
llnh( 675 )= -0.5325769682D+01
llnh( 676 )= -0.5328298064D+01
llnh( 677 )= -0.5330820487D+01
llnh( 678 )= -0.5333337033D+01
llnh( 679 )= -0.5335847660D+01
llnh( 680 )= -0.5338352356D+01
llnh( 681 )= -0.5340851158D+01
llnh( 682 )= -0.5343344088D+01
llnh( 683 )= -0.5345831113D+01
llnh( 684 )= -0.5348312329D+01
llnh( 685 )= -0.5350787595D+01
llnh( 686 )= -0.5353257028D+01
llnh( 687 )= -0.5355720597D+01
llnh( 688 )= -0.5358178333D+01
llnh( 689 )= -0.5360630227D+01
llnh( 690 )= -0.5363076250D+01
llnh( 691 )= -0.5365516440D+01
llnh( 692 )= -0.5367950847D+01
llnh( 693 )= -0.5370379412D+01
llnh( 694 )= -0.5372802182D+01
llnh( 695 )= -0.5375219136D+01
llnh( 696 )= -0.5377630301D+01
llnh( 697 )= -0.5380035657D+01
llnh( 698 )= -0.5382435244D+01
llnh( 699 )= -0.5384829094D+01
llnh( 700 )= -0.5387217124D+01
llnh( 701 )= -0.5389599434D+01
llnh( 702 )= -0.5391975954D+01
llnh( 703 )= -0.5394346756D+01
llnh( 704 )= -0.5396711759D+01
llnh( 705 )= -0.5399071078D+01
llnh( 706 )= -0.5401424638D+01
llnh( 707 )= -0.5403772479D+01
llnh( 708 )= -0.5406119229D+01
llnh( 709 )= -0.5408456158D+01
llnh( 710 )= -0.5410787342D+01
llnh( 711 )= -0.5413112829D+01
llnh( 712 )= -0.5415432725D+01
llnh( 713 )= -0.5417746886D+01
llnh( 714 )= -0.5420055451D+01
llnh( 715 )= -0.5422358379D+01
llnh( 716 )= -0.5424655695D+01
llnh( 717 )= -0.5426947346D+01
llnh( 718 )= -0.5429233415D+01
llnh( 719 )= -0.5431513881D+01
llnh( 720 )= -0.5433788773D+01
llnh( 721 )= -0.5436058059D+01
llnh( 722 )= -0.5438321777D+01
llnh( 723 )= -0.5440579909D+01
llnh( 724 )= -0.5442832493D+01
llnh( 725 )= -0.5445079538D+01
llnh( 726 )= -0.5447321025D+01
llnh( 727 )= -0.5449556959D+01
llnh( 728 )= -0.5451787383D+01
llnh( 729 )= -0.5454012244D+01
llnh( 730 )= -0.5456231645D+01
llnh( 731 )= -0.5458445490D+01
llnh( 732 )= -0.5460653885D+01
llnh( 733 )= -0.5462856815D+01
llnh( 734 )= -0.5465054208D+01
llnh( 735 )= -0.5467246209D+01
llnh( 736 )= -0.5469432635D+01
llnh( 737 )= -0.5471613649D+01
llnh( 738 )= -0.5473789425D+01
llnh( 739 )= -0.5475959565D+01
llnh( 740 )= -0.5478124308D+01
llnh( 741 )= -0.5480283586D+01
llnh( 742 )= -0.5482437461D+01
llnh( 743 )= -0.5484585919D+01
llnh( 744 )= -0.5486728976D+01
llnh( 745 )= -0.5488866669D+01
llnh( 746 )= -0.5490998937D+01
llnh( 747 )= -0.5493125867D+01
llnh( 748 )= -0.5495247398D+01
llnh( 749 )= -0.5497363593D+01
llnh( 750 )= -0.5499474396D+01
llnh( 751 )= -0.5501579935D+01
llnh( 752 )= -0.5503680091D+01
llnh( 753 )= -0.5505774872D+01
llnh( 754 )= -0.5507864419D+01
llnh( 755 )= -0.5509948597D+01
llnh( 756 )= -0.5512027498D+01
llnh( 757 )= -0.5514101090D+01
llnh( 758 )= -0.5516169407D+01
llnh( 759 )= -0.5518232431D+01
llnh( 760 )= -0.5520290171D+01
llnh( 761 )= -0.5522342671D+01
llnh( 762 )= -0.5524389920D+01
llnh( 763 )= -0.5526435070D+01
llnh( 764 )= -0.5528472978D+01
llnh( 765 )= -0.5530504862D+01
llnh( 766 )= -0.5532531569D+01
llnh( 767 )= -0.5534553070D+01
llnh( 768 )= -0.5536569379D+01
llnh( 769 )= -0.5538580560D+01
llnh( 770 )= -0.5540586509D+01
llnh( 771 )= -0.5542587346D+01
llnh( 772 )= -0.5544583018D+01
llnh( 773 )= -0.5546573556D+01
llnh( 774 )= -0.5548558957D+01
llnh( 775 )= -0.5550539231D+01
llnh( 776 )= -0.5552514398D+01
llnh( 777 )= -0.5554484460D+01
llnh( 778 )= -0.5556449473D+01
llnh( 779 )= -0.5558409336D+01
llnh( 780 )= -0.5560364185D+01
llnh( 781 )= -0.5562313913D+01
llnh( 782 )= -0.5564258612D+01
llnh( 783 )= -0.5566198240D+01
llnh( 784 )= -0.5568132825D+01
llnh( 785 )= -0.5570062431D+01
llnh( 786 )= -0.5571986955D+01
llnh( 787 )= -0.5573906479D+01
llnh( 788 )= -0.5575821017D+01
llnh( 789 )= -0.5577730521D+01
llnh( 790 )= -0.5579635046D+01
llnh( 791 )= -0.5581534623D+01
llnh( 792 )= -0.5583429246D+01
llnh( 793 )= -0.5585318843D+01
llnh( 794 )= -0.5587203534D+01
llnh( 795 )= -0.5589083215D+01
llnh( 796 )= -0.5590958026D+01
llnh( 797 )= -0.5592827913D+01
llnh( 798 )= -0.5594692837D+01
llnh( 799 )= -0.5596552884D+01
llnh( 800 )= -0.5598408013D+01
llnh( 801 )= -0.5600258261D+01
llnh( 802 )= -0.5602103603D+01
llnh( 803 )= -0.5603944084D+01
llnh( 804 )= -0.5605779692D+01
llnh( 805 )= -0.5607610469D+01
llnh( 806 )= -0.5609436368D+01
llnh( 807 )= -0.5611257443D+01
llnh( 808 )= -0.5613073624D+01
llnh( 809 )= -0.5614885059D+01
llnh( 810 )= -0.5616691617D+01
llnh( 811 )= -0.5618493398D+01
llnh( 812 )= -0.5620290369D+01
llnh( 813 )= -0.5622082588D+01
llnh( 814 )= -0.5623870004D+01
llnh( 815 )= -0.5625652635D+01
llnh( 816 )= -0.5627430515D+01
llnh( 817 )= -0.5629203619D+01
llnh( 818 )= -0.5630973564D+01
llnh( 819 )= -0.5632739215D+01
llnh( 820 )= -0.5634498385D+01
llnh( 821 )= -0.5636252874D+01
llnh( 822 )= -0.5638002692D+01
llnh( 823 )= -0.5639747990D+01
llnh( 824 )= -0.5641488433D+01
llnh( 825 )= -0.5643224238D+01
llnh( 826 )= -0.5644955371D+01
llnh( 827 )= -0.5646681860D+01
llnh( 828 )= -0.5648403688D+01
llnh( 829 )= -0.5650120894D+01
llnh( 830 )= -0.5651833499D+01
llnh( 831 )= -0.5653541488D+01
llnh( 832 )= -0.5655244889D+01
llnh( 833 )= -0.5656943648D+01
llnh( 834 )= -0.5658637872D+01
llnh( 835 )= -0.5660327454D+01
llnh( 836 )= -0.5662012541D+01
llnh( 837 )= -0.5663693098D+01
llnh( 838 )= -0.5665369003D+01
llnh( 839 )= -0.5667040432D+01
llnh( 840 )= -0.5668707291D+01
llnh( 841 )= -0.5670369673D+01
llnh( 842 )= -0.5672027532D+01
llnh( 843 )= -0.5673680874D+01
llnh( 844 )= -0.5675329711D+01
llnh( 845 )= -0.5676974102D+01
llnh( 846 )= -0.5678614009D+01
llnh( 847 )= -0.5680249399D+01
llnh( 848 )= -0.5681880401D+01
llnh( 849 )= -0.5683506937D+01
llnh( 850 )= -0.5685128983D+01
llnh( 851 )= -0.5686746614D+01
llnh( 852 )= -0.5688359836D+01
llnh( 853 )= -0.5689968657D+01
llnh( 854 )= -0.5691573040D+01
llnh( 855 )= -0.5693173037D+01
llnh( 856 )= -0.5694768667D+01
llnh( 857 )= -0.5696359900D+01
llnh( 858 )= -0.5697946740D+01
llnh( 859 )= -0.5699529279D+01
llnh( 860 )= -0.5701107407D+01
llnh( 861 )= -0.5702681211D+01
llnh( 862 )= -0.5704250662D+01
llnh( 863 )= -0.5705815820D+01
llnh( 864 )= -0.5707376645D+01
llnh( 865 )= -0.5708933156D+01
llnh( 866 )= -0.5710485372D+01
llnh( 867 )= -0.5712033286D+01
llnh( 868 )= -0.5713576887D+01
llnh( 869 )= -0.5715116238D+01
llnh( 870 )= -0.5716651343D+01
llnh( 871 )= -0.5718182133D+01
llnh( 872 )= -0.5719708718D+01
llnh( 873 )= -0.5721231370D+01
llnh( 874 )= -0.5722752079D+01
llnh( 875 )= -0.5724266184D+01
llnh( 876 )= -0.5725776091D+01
llnh( 877 )= -0.5727281862D+01
llnh( 878 )= -0.5728783383D+01
llnh( 879 )= -0.5730280793D+01
llnh( 880 )= -0.5731774031D+01
llnh( 881 )= -0.5733263026D+01
llnh( 882 )= -0.5734747963D+01
llnh( 883 )= -0.5736228729D+01
llnh( 884 )= -0.5737705360D+01
llnh( 885 )= -0.5739177941D+01
llnh( 886 )= -0.5740646299D+01
llnh( 887 )= -0.5742110595D+01
llnh( 888 )= -0.5743570865D+01
llnh( 889 )= -0.5745026960D+01
llnh( 890 )= -0.5746479033D+01
llnh( 891 )= -0.5747927018D+01
llnh( 892 )= -0.5749370943D+01
llnh( 893 )= -0.5750810827D+01
llnh( 894 )= -0.5752246701D+01
llnh( 895 )= -0.5753678496D+01
llnh( 896 )= -0.5755106289D+01
llnh( 897 )= -0.5756530074D+01
llnh( 898 )= -0.5757949836D+01
llnh( 899 )= -0.5759365629D+01
llnh( 900 )= -0.5760777429D+01
llnh( 901 )= -0.5762185269D+01
llnh( 902 )= -0.5763589050D+01
llnh( 903 )= -0.5764989015D+01
llnh( 904 )= -0.5766384906D+01
llnh( 905 )= -0.5767776906D+01
llnh( 906 )= -0.5769164942D+01
llnh( 907 )= -0.5770549045D+01
llnh( 908 )= -0.5771929251D+01
llnh( 909 )= -0.5773305592D+01
llnh( 910 )= -0.5774678021D+01
llnh( 911 )= -0.5776046522D+01
llnh( 912 )= -0.5777411181D+01
llnh( 913 )= -0.5778771903D+01
llnh( 914 )= -0.5780128791D+01
llnh( 915 )= -0.5781481778D+01
llnh( 916 )= -0.5782830973D+01
llnh( 917 )= -0.5784176296D+01
llnh( 918 )= -0.5785517731D+01
llnh( 919 )= -0.5786855440D+01
llnh( 920 )= -0.5788189236D+01
llnh( 921 )= -0.5789519318D+01
llnh( 922 )= -0.5790845543D+01
llnh( 923 )= -0.5792167984D+01
llnh( 924 )= -0.5793486673D+01
llnh( 925 )= -0.5794801520D+01
llnh( 926 )= -0.5796112641D+01
llnh( 927 )= -0.5797420004D+01
llnh( 928 )= -0.5798723616D+01
llnh( 929 )= -0.5800025860D+01
llnh( 930 )= -0.5801322181D+01
llnh( 931 )= -0.5802614805D+01
llnh( 932 )= -0.5803903742D+01
llnh( 933 )= -0.5805188958D+01
llnh( 934 )= -0.5806470481D+01
llnh( 935 )= -0.5807748369D+01
llnh( 936 )= -0.5809022517D+01
llnh( 937 )= -0.5810293038D+01
llnh( 938 )= -0.5811559908D+01
llnh( 939 )= -0.5812823154D+01
llnh( 940 )= -0.5814082757D+01
llnh( 941 )= -0.5815338711D+01
llnh( 942 )= -0.5816591047D+01
llnh( 943 )= -0.5817839765D+01
llnh( 944 )= -0.5819084925D+01
llnh( 945 )= -0.5820326443D+01
llnh( 946 )= -0.5821564407D+01
llnh( 947 )= -0.5822798792D+01
llnh( 948 )= -0.5824029580D+01
llnh( 949 )= -0.5825256834D+01
llnh( 950 )= -0.5826480495D+01
llnh( 951 )= -0.5827700679D+01
llnh( 952 )= -0.5828917318D+01
llnh( 953 )= -0.5830130356D+01
llnh( 954 )= -0.5831339955D+01
llnh( 955 )= -0.5832546036D+01
llnh( 956 )= -0.5833748572D+01
llnh( 957 )= -0.5834947646D+01
llnh( 958 )= -0.5836143208D+01
llnh( 959 )= -0.5837335326D+01
llnh( 960 )= -0.5838523975D+01
llnh( 961 )= -0.5839709120D+01
llnh( 962 )= -0.5840890822D+01
llnh( 963 )= -0.5842069117D+01
llnh( 964 )= -0.5843243948D+01
llnh( 965 )= -0.5844415380D+01
llnh( 966 )= -0.5845583345D+01
llnh( 967 )= -0.5846747902D+01
llnh( 968 )= -0.5847909107D+01
llnh( 969 )= -0.5849066883D+01
llnh( 970 )= -0.5850221245D+01
llnh( 971 )= -0.5851372233D+01
llnh( 972 )= -0.5852519933D+01
llnh( 973 )= -0.5853664111D+01
llnh( 974 )= -0.5854805079D+01
llnh( 975 )= -0.5855942632D+01
llnh( 976 )= -0.5857076840D+01
llnh( 977 )= -0.5858207705D+01
llnh( 978 )= -0.5859335263D+01
llnh( 979 )= -0.5860459528D+01
llnh( 980 )= -0.5861580446D+01
llnh( 981 )= -0.5862698053D+01
llnh( 982 )= -0.5863812452D+01
llnh( 983 )= -0.5864923445D+01
llnh( 984 )= -0.5866033059D+01
llnh( 985 )= -0.5867137708D+01
llnh( 986 )= -0.5868239098D+01
llnh( 987 )= -0.5869337290D+01
llnh( 988 )= -0.5870432164D+01
llnh( 989 )= -0.5871523895D+01
llnh( 990 )= -0.5872612338D+01
llnh( 991 )= -0.5873697645D+01
llnh( 992 )= -0.5874779683D+01
llnh( 993 )= -0.5875858528D+01
llnh( 994 )= -0.5876934214D+01
llnh( 995 )= -0.5878006676D+01
llnh( 996 )= -0.5879076002D+01
llnh( 997 )= -0.5880142202D+01
llnh( 998 )= -0.5881205128D+01
llnh( 999 )= -0.5882264991D+01
llnh( 1000 )= -0.5883321683D+01
llnh( 1001 )= -0.5884375272D+01
llnh( 1002 )= -0.5885425704D+01
llnh( 1003 )= -0.5886473023D+01
llnh( 1004 )= -0.5887517204D+01
llnh( 1005 )= -0.5888558321D+01
llnh( 1006 )= -0.5889596323D+01
llnh( 1007 )= -0.5890631250D+01
llnh( 1008 )= -0.5891663079D+01
llnh( 1009 )= -0.5892691857D+01
llnh( 1010 )= -0.5893717531D+01
llnh( 1011 )= -0.5894740186D+01
llnh( 1012 )= -0.5895759785D+01
llnh( 1013 )= -0.5896776265D+01
llnh( 1014 )= -0.5897789840D+01
llnh( 1015 )= -0.5898800343D+01
llnh( 1016 )= -0.5899807814D+01
llnh( 1017 )= -0.5900812292D+01
llnh( 1018 )= -0.5901813724D+01
llnh( 1019 )= -0.5902812170D+01
llnh( 1020 )= -0.5903807651D+01
llnh( 1021 )= -0.5904800116D+01
llnh( 1022 )= -0.5905789619D+01
llnh( 1023 )= -0.5906776200D+01
llnh( 1024 )= -0.5907759788D+01
llnk( 0 )= -1.0000000000D+00
llnk( 1 )= -0.1000000000D+01
llnk( 2 )= -0.3054020195D+00
llnk( 3 )= -0.1960294041D+00
llnk( 4 )= -0.1336652689D+00
llnk( 5 )= -0.1047066267D+00
llnk( 6 )= -0.9033564429D-01
llnk( 7 )= -0.8206984804D-01
llnk( 8 )= -0.7655494644D-01
llnk( 9 )= -0.7243844815D-01
llnk( 10 )= -0.6913401466D-01
llnk( 11 )= -0.6635869819D-01
llnk( 12 )= -0.6395689877D-01
llnk( 13 )= -0.6183296641D-01
llnk( 14 )= -0.5992172201D-01
llnk( 15 )= -0.5817772516D-01
llnk( 16 )= -0.5656704205D-01
llnk( 17 )= -0.5506474110D-01
llnk( 18 )= -0.5365205058D-01
llnk( 19 )= -0.5231479422D-01
llnk( 20 )= -0.5104204279D-01
llnk( 21 )= -0.4982562670D-01
llnk( 22 )= -0.4865919131D-01
llnk( 23 )= -0.4753764652D-01
llnk( 24 )= -0.4645728556D-01
llnk( 25 )= -0.4541483359D-01
llnk( 26 )= -0.4440818528D-01
llnk( 27 )= -0.4343487603D-01
llnk( 28 )= -0.4249347823D-01
llnk( 29 )= -0.4158232061D-01
llnk( 30 )= -0.4070034557D-01
llnk( 31 )= -0.3984645832D-01
llnk( 32 )= -0.3901937759D-01
llnk( 33 )= -0.3821827509D-01
llnk( 34 )= -0.3744217649D-01
llnk( 35 )= -0.3669034206D-01
llnk( 36 )= -0.3596186474D-01
llnk( 37 )= -0.3525594412D-01
llnk( 38 )= -0.3457187576D-01
llnk( 39 )= -0.3390882631D-01
llnk( 40 )= -0.3326609909D-01
llnk( 41 )= -0.3264299923D-01
llnk( 42 )= -0.3203883174D-01
llnk( 43 )= -0.3145293280D-01
llnk( 44 )= -0.3088463896D-01
llnk( 45 )= -0.3033334191D-01
llnk( 46 )= -0.2979842108D-01
llnk( 47 )= -0.2927929373D-01
llnk( 48 )= -0.2877539004D-01
llnk( 49 )= -0.2828615868D-01
llnk( 50 )= -0.2781108192D-01
llnk( 51 )= -0.2734963353D-01
llnk( 52 )= -0.2690133637D-01
llnk( 53 )= -0.2646570945D-01
llnk( 54 )= -0.2604229418D-01
llnk( 55 )= -0.2563066630D-01
llnk( 56 )= -0.2523039452D-01
llnk( 57 )= -0.2484107774D-01
llnk( 58 )= -0.2446233127D-01
llnk( 59 )= -0.2409377795D-01
llnk( 60 )= -0.2373506405D-01
llnk( 61 )= -0.2338584530D-01
llnk( 62 )= -0.2304579309D-01
llnk( 63 )= -0.2271459030D-01
llnk( 64 )= -0.2239193633D-01
llnk( 65 )= -0.2207753919D-01
llnk( 66 )= -0.2177111937D-01
llnk( 67 )= -0.2147240908D-01
llnk( 68 )= -0.2118115170D-01
llnk( 69 )= -0.2089710139D-01
llnk( 70 )= -0.2062002059D-01
llnk( 71 )= -0.2034968220D-01
llnk( 72 )= -0.2008586807D-01
llnk( 73 )= -0.1982836895D-01
llnk( 74 )= -0.1957698319D-01
llnk( 75 )= -0.1933151728D-01
llnk( 76 )= -0.1909178544D-01
llnk( 77 )= -0.1885760922D-01
llnk( 78 )= -0.1862881706D-01
llnk( 79 )= -0.1840524275D-01
llnk( 80 )= -0.1818672781D-01
llnk( 81 )= -0.1797312161D-01
llnk( 82 )= -0.1776427277D-01
llnk( 83 )= -0.1756004164D-01
llnk( 84 )= -0.1736029175D-01
llnk( 85 )= -0.1716489163D-01
llnk( 86 )= -0.1697371498D-01
llnk( 87 )= -0.1678663942D-01
llnk( 88 )= -0.1660354744D-01
llnk( 89 )= -0.1642432560D-01
llnk( 90 )= -0.1624886478D-01
llnk( 91 )= -0.1607705911D-01
llnk( 92 )= -0.1590880688D-01
llnk( 93 )= -0.1574400976D-01
llnk( 94 )= -0.1558257306D-01
llnk( 95 )= -0.1542440486D-01
llnk( 96 )= -0.1526941673D-01
llnk( 97 )= -0.1511752309D-01
llnk( 98 )= -0.1496864146D-01
llnk( 99 )= -0.1482269168D-01
llnk( 100 )= -0.1467959656D-01
llnk( 101 )= -0.1453928135D-01
llnk( 102 )= -0.1440167387D-01
llnk( 103 )= -0.1426670401D-01
llnk( 104 )= -0.1413430411D-01
llnk( 105 )= -0.1400440861D-01
llnk( 106 )= -0.1387695416D-01
llnk( 107 )= -0.1375187918D-01
llnk( 108 )= -0.1362912416D-01
llnk( 109 )= -0.1350863142D-01
llnk( 110 )= -0.1339034516D-01
llnk( 111 )= -0.1327421107D-01
llnk( 112 )= -0.1316017669D-01
llnk( 113 )= -0.1304819106D-01
llnk( 114 )= -0.1293820488D-01
llnk( 115 )= -0.1283017014D-01
llnk( 116 )= -0.1272404038D-01
llnk( 117 )= -0.1261977050D-01
llnk( 118 )= -0.1251731678D-01
llnk( 119 )= -0.1241663664D-01
llnk( 120 )= -0.1231768886D-01
llnk( 121 )= -0.1222043336D-01
llnk( 122 )= -0.1212483127D-01
llnk( 123 )= -0.1203084476D-01
llnk( 124 )= -0.1193843710D-01
llnk( 125 )= -0.1184757260D-01
llnk( 126 )= -0.1175821983D-01
llnk( 127 )= -0.1167033892D-01
llnk( 128 )= -0.1158389997D-01
llnk( 129 )= -0.1149887118D-01
llnk( 130 )= -0.1141522155D-01
llnk( 131 )= -0.1133292103D-01
llnk( 132 )= -0.1125194019D-01
llnk( 133 )= -0.1117225053D-01
llnk( 134 )= -0.1109382428D-01
llnk( 135 )= -0.1101663454D-01
llnk( 136 )= -0.1094065488D-01
llnk( 137 )= -0.1086585976D-01
llnk( 138 )= -0.1079222424D-01
llnk( 139 )= -0.1071972412D-01
llnk( 140 )= -0.1064833570D-01
llnk( 141 )= -0.1057803597D-01
llnk( 142 )= -0.1050880250D-01
llnk( 143 )= -0.1044061352D-01
llnk( 144 )= -0.1037344765D-01
llnk( 145 )= -0.1030728418D-01
llnk( 146 )= -0.1024210288D-01
llnk( 147 )= -0.1017788410D-01
llnk( 148 )= -0.1011460854D-01
llnk( 149 )= -0.1005225749D-01
llnk( 150 )= -0.9990812687D-02
llnk( 151 )= -0.9930256346D-02
llnk( 152 )= -0.9870571027D-02
llnk( 153 )= -0.9811739803D-02
llnk( 154 )= -0.9753746115D-02
llnk( 155 )= -0.9696573861D-02
llnk( 156 )= -0.9640207245D-02
llnk( 157 )= -0.9584630905D-02
llnk( 158 )= -0.9529829829D-02
llnk( 159 )= -0.9475790189D-02
llnk( 160 )= -0.9422496073D-02
llnk( 161 )= -0.9369934305D-02
llnk( 162 )= -0.9318091242D-02
llnk( 163 )= -0.9266953580D-02
llnk( 164 )= -0.9216508278D-02
llnk( 165 )= -0.9166742633D-02
llnk( 166 )= -0.9117644217D-02
llnk( 167 )= -0.9069200890D-02
llnk( 168 )= -0.9021400853D-02
llnk( 169 )= -0.8974232435D-02
llnk( 170 )= -0.8927684326D-02
llnk( 171 )= -0.8881745447D-02
llnk( 172 )= -0.8836405029D-02
llnk( 173 )= -0.8791653407D-02
llnk( 174 )= -0.8747481667D-02
llnk( 175 )= -0.8703874181D-02
llnk( 176 )= -0.8660824198D-02
llnk( 177 )= -0.8618321971D-02
llnk( 178 )= -0.8576358051D-02
llnk( 179 )= -0.8534923154D-02
llnk( 180 )= -0.8494008256D-02
llnk( 181 )= -0.8453604422D-02
llnk( 182 )= -0.8413702992D-02
llnk( 183 )= -0.8374295452D-02
llnk( 184 )= -0.8335373508D-02
llnk( 185 )= -0.8296928978D-02
llnk( 186 )= -0.8258953895D-02
llnk( 187 )= -0.8221440446D-02
llnk( 188 )= -0.8184381010D-02
llnk( 189 )= -0.8147768058D-02
llnk( 190 )= -0.8111594272D-02
llnk( 191 )= -0.8075852456D-02
llnk( 192 )= -0.8040535598D-02
llnk( 193 )= -0.8005636771D-02
llnk( 194 )= -0.7971149225D-02
llnk( 195 )= -0.7937066335D-02
llnk( 196 )= -0.7903381636D-02
llnk( 197 )= -0.7870088750D-02
llnk( 198 )= -0.7837181442D-02
llnk( 199 )= -0.7804653597D-02
llnk( 200 )= -0.7772499254D-02
llnk( 201 )= -0.7740712516D-02
llnk( 202 )= -0.7709287634D-02
llnk( 203 )= -0.7678218959D-02
llnk( 204 )= -0.7647500968D-02
llnk( 205 )= -0.7617128214D-02
llnk( 206 )= -0.7587095379D-02
llnk( 207 )= -0.7557397242D-02
llnk( 208 )= -0.7528028665D-02
llnk( 209 )= -0.7498984668D-02
llnk( 210 )= -0.7470260263D-02
llnk( 211 )= -0.7441850636D-02
llnk( 212 )= -0.7413751027D-02
llnk( 213 )= -0.7385956807D-02
llnk( 214 )= -0.7358463369D-02
llnk( 215 )= -0.7331266234D-02
llnk( 216 )= -0.7304360991D-02
llnk( 217 )= -0.7277743343D-02
llnk( 218 )= -0.7251409005D-02
llnk( 219 )= -0.7225353835D-02
llnk( 220 )= -0.7199573711D-02
llnk( 221 )= -0.7174064656D-02
llnk( 222 )= -0.7148822685D-02
llnk( 223 )= -0.7123843938D-02
llnk( 224 )= -0.7099129566D-02
llnk( 225 )= -0.7074666551D-02
llnk( 226 )= -0.7050455306D-02
llnk( 227 )= -0.7026492490D-02
llnk( 228 )= -0.7002774540D-02
llnk( 229 )= -0.6979298005D-02
llnk( 230 )= -0.6956059431D-02
llnk( 231 )= -0.6933055469D-02
llnk( 232 )= -0.6910282814D-02
llnk( 233 )= -0.6887738228D-02
llnk( 234 )= -0.6865418504D-02
llnk( 235 )= -0.6843320529D-02
llnk( 236 )= -0.6821441187D-02
llnk( 237 )= -0.6799777491D-02
llnk( 238 )= -0.6778326425D-02
llnk( 239 )= -0.6757085071D-02
llnk( 240 )= -0.6736050549D-02
llnk( 241 )= -0.6715220049D-02
llnk( 242 )= -0.6694590762D-02
llnk( 243 )= -0.6674159952D-02
llnk( 244 )= -0.6653925199D-02
llnk( 245 )= -0.6633883871D-02
llnk( 246 )= -0.6614032563D-02
llnk( 247 )= -0.6594369232D-02
llnk( 248 )= -0.6574891356D-02
llnk( 249 )= -0.6555596461D-02
llnk( 250 )= -0.6536482218D-02
llnk( 251 )= -0.6517546015D-02
llnk( 252 )= -0.6498785614D-02
llnk( 253 )= -0.6480198683D-02
llnk( 254 )= -0.6461782835D-02
llnk( 255 )= -0.6443535971D-02
llnk( 256 )= -0.6425455846D-02
llnk( 257 )= -0.6407540263D-02
llnk( 258 )= -0.6389786969D-02
llnk( 259 )= -0.6372194033D-02
llnk( 260 )= -0.6354759310D-02
llnk( 261 )= -0.6337480778D-02
llnk( 262 )= -0.6320356275D-02
llnk( 263 )= -0.6303384010D-02
llnk( 264 )= -0.6286561980D-02
llnk( 265 )= -0.6269888285D-02
llnk( 266 )= -0.6253360871D-02
llnk( 267 )= -0.6236978078D-02
llnk( 268 )= -0.6220737994D-02
llnk( 269 )= -0.6204638851D-02
llnk( 270 )= -0.6188678733D-02
llnk( 271 )= -0.6172856062D-02
llnk( 272 )= -0.6157169047D-02
llnk( 273 )= -0.6141616004D-02
llnk( 274 )= -0.6126195168D-02
llnk( 275 )= -0.6110905001D-02
llnk( 276 )= -0.6095743854D-02
llnk( 277 )= -0.6080714363D-02
llnk( 278 )= -0.6065808661D-02
llnk( 279 )= -0.6051025499D-02
llnk( 280 )= -0.6036365150D-02
llnk( 281 )= -0.6021826113D-02
llnk( 282 )= -0.6007406839D-02
llnk( 283 )= -0.5993105878D-02
llnk( 284 )= -0.5978921847D-02
llnk( 285 )= -0.5964853301D-02
llnk( 286 )= -0.5950898825D-02
llnk( 287 )= -0.5937057006D-02
llnk( 288 )= -0.5923326579D-02
llnk( 289 )= -0.5909706151D-02
llnk( 290 )= -0.5896194416D-02
llnk( 291 )= -0.5882789995D-02
llnk( 292 )= -0.5869491718D-02
llnk( 293 )= -0.5856298304D-02
llnk( 294 )= -0.5843208448D-02
llnk( 295 )= -0.5830220904D-02
llnk( 296 )= -0.5817334546D-02
llnk( 297 )= -0.5804548161D-02
llnk( 298 )= -0.5791860577D-02
llnk( 299 )= -0.5779270522D-02
llnk( 300 )= -0.5766776986D-02
llnk( 301 )= -0.5754378816D-02
llnk( 302 )= -0.5742074899D-02
llnk( 303 )= -0.5729864025D-02
llnk( 304 )= -0.5717745257D-02
llnk( 305 )= -0.5705717481D-02
llnk( 306 )= -0.5693779662D-02
llnk( 307 )= -0.5681930652D-02
llnk( 308 )= -0.5670169557D-02
llnk( 309 )= -0.5658495321D-02
llnk( 310 )= -0.5646906981D-02
llnk( 311 )= -0.5635403426D-02
llnk( 312 )= -0.5623983856D-02
llnk( 313 )= -0.5612647214D-02
llnk( 314 )= -0.5601392619D-02
llnk( 315 )= -0.5590219039D-02
llnk( 316 )= -0.5579125640D-02
llnk( 317 )= -0.5568111507D-02
llnk( 318 )= -0.5557175755D-02
llnk( 319 )= -0.5546317422D-02
llnk( 320 )= -0.5535535712D-02
llnk( 321 )= -0.5524829768D-02
llnk( 322 )= -0.5514198739D-02
llnk( 323 )= -0.5503641734D-02
llnk( 324 )= -0.5493157962D-02
llnk( 325 )= -0.5482746632D-02
llnk( 326 )= -0.5472406939D-02
llnk( 327 )= -0.5462138054D-02
llnk( 328 )= -0.5451939170D-02
llnk( 329 )= -0.5441809594D-02
llnk( 330 )= -0.5431748532D-02
llnk( 331 )= -0.5421755212D-02
llnk( 332 )= -0.5411828857D-02
llnk( 333 )= -0.5401975569D-02
llnk( 334 )= -0.5392181719D-02
llnk( 335 )= -0.5382453176D-02
llnk( 336 )= -0.5372788210D-02
llnk( 337 )= -0.5363186748D-02
llnk( 338 )= -0.5353648059D-02
llnk( 339 )= -0.5344171504D-02
llnk( 340 )= -0.5334756310D-02
llnk( 341 )= -0.5325401926D-02
llnk( 342 )= -0.5316107680D-02
llnk( 343 )= -0.5306872920D-02
llnk( 344 )= -0.5297696936D-02
llnk( 345 )= -0.5288579215D-02
llnk( 346 )= -0.5279519432D-02
llnk( 347 )= -0.5270516389D-02
llnk( 348 )= -0.5261569543D-02
llnk( 349 )= -0.5252678535D-02
llnk( 350 )= -0.5243842709D-02
llnk( 351 )= -0.5235061516D-02
llnk( 352 )= -0.5226334273D-02
llnk( 353 )= -0.5217660524D-02
llnk( 354 )= -0.5209039665D-02
llnk( 355 )= -0.5200471169D-02
llnk( 356 )= -0.5191954431D-02
llnk( 357 )= -0.5183488963D-02
llnk( 358 )= -0.5175074221D-02
llnk( 359 )= -0.5166709698D-02
llnk( 360 )= -0.5158394787D-02
llnk( 361 )= -0.5150129056D-02
llnk( 362 )= -0.5141911977D-02
llnk( 363 )= -0.5133743148D-02
llnk( 364 )= -0.5125621837D-02
llnk( 365 )= -0.5117547698D-02
llnk( 366 )= -0.5109520206D-02
llnk( 367 )= -0.5101538932D-02
llnk( 368 )= -0.5093603358D-02
llnk( 369 )= -0.5085713032D-02
llnk( 370 )= -0.5077867507D-02
llnk( 371 )= -0.5070066320D-02
llnk( 372 )= -0.5062309014D-02
llnk( 373 )= -0.5054595077D-02
llnk( 374 )= -0.5046924184D-02
llnk( 375 )= -0.5039295844D-02
llnk( 376 )= -0.5031709627D-02
llnk( 377 )= -0.5024165063D-02
llnk( 378 )= -0.5016661793D-02
llnk( 379 )= -0.5009199414D-02
llnk( 380 )= -0.5001777482D-02
llnk( 381 )= -0.4994395567D-02
llnk( 382 )= -0.4987053274D-02
llnk( 383 )= -0.4979750283D-02
llnk( 384 )= -0.4972486128D-02
llnk( 385 )= -0.4965268840D-02
llnk( 386 )= -0.4958081936D-02
llnk( 387 )= -0.4950932817D-02
llnk( 388 )= -0.4943821092D-02
llnk( 389 )= -0.4936746301D-02
llnk( 390 )= -0.4929708210D-02
llnk( 391 )= -0.4922706445D-02
llnk( 392 )= -0.4915740611D-02
llnk( 393 )= -0.4908810284D-02
llnk( 394 )= -0.4901915260D-02
llnk( 395 )= -0.4895055124D-02
llnk( 396 )= -0.4888229556D-02
llnk( 397 )= -0.4881438160D-02
llnk( 398 )= -0.4874680679D-02
llnk( 399 )= -0.4867956758D-02
llnk( 400 )= -0.4861266098D-02
llnk( 401 )= -0.4854608317D-02
llnk( 402 )= -0.4847983151D-02
llnk( 403 )= -0.4841390266D-02
llnk( 404 )= -0.4834829391D-02
llnk( 405 )= -0.4828300135D-02
llnk( 406 )= -0.4821802243D-02
llnk( 407 )= -0.4815335427D-02
llnk( 408 )= -0.4808899393D-02
llnk( 409 )= -0.4802493803D-02
llnk( 410 )= -0.4796118410D-02
llnk( 411 )= -0.4789772949D-02
llnk( 412 )= -0.4783457104D-02
llnk( 413 )= -0.4777170573D-02
llnk( 414 )= -0.4770913098D-02
llnk( 415 )= -0.4764684685D-02
llnk( 416 )= -0.4758484990D-02
llnk( 417 )= -0.4752313124D-02
llnk( 418 )= -0.4746169197D-02
llnk( 419 )= -0.4740053059D-02
llnk( 420 )= -0.4733964341D-02
llnk( 421 )= -0.4727902849D-02
llnk( 422 )= -0.4721868283D-02
llnk( 423 )= -0.4715860425D-02
llnk( 424 )= -0.4709879012D-02
llnk( 425 )= -0.4703923846D-02
llnk( 426 )= -0.4697994583D-02
llnk( 427 )= -0.4692091066D-02
llnk( 428 )= -0.4686213045D-02
llnk( 429 )= -0.4680360271D-02
llnk( 430 )= -0.4674532484D-02
llnk( 431 )= -0.4668729492D-02
llnk( 432 )= -0.4662951085D-02
llnk( 433 )= -0.4657196996D-02
llnk( 434 )= -0.4651467004D-02
llnk( 435 )= -0.4645760890D-02
llnk( 436 )= -0.4640080410D-02
llnk( 437 )= -0.4634428369D-02
llnk( 438 )= -0.4628793378D-02
llnk( 439 )= -0.4623181470D-02
llnk( 440 )= -0.4617592432D-02
llnk( 441 )= -0.4612026079D-02
llnk( 442 )= -0.4606482171D-02
llnk( 443 )= -0.4600960531D-02
llnk( 444 )= -0.4595460979D-02
llnk( 445 )= -0.4589983282D-02
llnk( 446 )= -0.4584527233D-02
llnk( 447 )= -0.4579092710D-02
llnk( 448 )= -0.4573679458D-02
llnk( 449 )= -0.4568287340D-02
llnk( 450 )= -0.4562916080D-02
llnk( 451 )= -0.4557565629D-02
llnk( 452 )= -0.4552235678D-02
llnk( 453 )= -0.4546926139D-02
llnk( 454 )= -0.4541636751D-02
llnk( 455 )= -0.4536367408D-02
llnk( 456 )= -0.4531117888D-02
llnk( 457 )= -0.4525888082D-02
llnk( 458 )= -0.4520677720D-02
llnk( 459 )= -0.4515486721D-02
llnk( 460 )= -0.4510314872D-02
llnk( 461 )= -0.4505162010D-02
llnk( 462 )= -0.4500027980D-02
llnk( 463 )= -0.4494912622D-02
llnk( 464 )= -0.4489815761D-02
llnk( 465 )= -0.4484737267D-02
llnk( 466 )= -0.4479676977D-02
llnk( 467 )= -0.4474634684D-02
llnk( 468 )= -0.4469610304D-02
llnk( 469 )= -0.4464603661D-02
llnk( 470 )= -0.4459614543D-02
llnk( 471 )= -0.4454642899D-02
llnk( 472 )= -0.4449688484D-02
llnk( 473 )= -0.4444751266D-02
llnk( 474 )= -0.4439830996D-02
llnk( 475 )= -0.4434927562D-02
llnk( 476 )= -0.4430040859D-02
llnk( 477 )= -0.4425170710D-02
llnk( 478 )= -0.4420316957D-02
llnk( 479 )= -0.4415479491D-02
llnk( 480 )= -0.4410658186D-02
llnk( 481 )= -0.4405852880D-02
llnk( 482 )= -0.4401063430D-02
llnk( 483 )= -0.4396289728D-02
llnk( 484 )= -0.4391531676D-02
llnk( 485 )= -0.4386789086D-02
llnk( 486 )= -0.4382061813D-02
llnk( 487 )= -0.4377349779D-02
llnk( 488 )= -0.4372652829D-02
llnk( 489 )= -0.4367973960D-02
llnk( 490 )= -0.4363312569D-02
llnk( 491 )= -0.4358660920D-02
llnk( 492 )= -0.4354023941D-02
llnk( 493 )= -0.4349402011D-02
llnk( 494 )= -0.4344794018D-02
llnk( 495 )= -0.4340200286D-02
llnk( 496 )= -0.4335620759D-02
llnk( 497 )= -0.4331055332D-02
llnk( 498 )= -0.4326503816D-02
llnk( 499 )= -0.4321966182D-02
llnk( 500 )= -0.4317442332D-02
llnk( 501 )= -0.4312932067D-02
llnk( 502 )= -0.4308435312D-02
llnk( 503 )= -0.4303951987D-02
llnk( 504 )= -0.4299481991D-02
llnk( 505 )= -0.4295025176D-02
llnk( 506 )= -0.4290581476D-02
llnk( 507 )= -0.4286150784D-02
llnk( 508 )= -0.4281732974D-02
llnk( 509 )= -0.4277328005D-02
llnk( 510 )= -0.4272935697D-02
llnk( 511 )= -0.4268555976D-02
llnk( 512 )= -0.4264188766D-02
llnk( 513 )= -0.4259833966D-02
llnk( 514 )= -0.4255491492D-02
llnk( 515 )= -0.4251161154D-02
llnk( 516 )= -0.4246842949D-02
llnk( 517 )= -0.4242536837D-02
llnk( 518 )= -0.4238242629D-02
llnk( 519 )= -0.4233960267D-02
llnk( 520 )= -0.4229689632D-02
llnk( 521 )= -0.4225430669D-02
llnk( 522 )= -0.4221183310D-02
llnk( 523 )= -0.4216947377D-02
llnk( 524 )= -0.4212722872D-02
llnk( 525 )= -0.4208509690D-02
llnk( 526 )= -0.4204307736D-02
llnk( 527 )= -0.4200116898D-02
llnk( 528 )= -0.4195937125D-02
llnk( 529 )= -0.4191768337D-02
llnk( 530 )= -0.4187610437D-02
llnk( 531 )= -0.4183463316D-02
llnk( 532 )= -0.4179326948D-02
llnk( 533 )= -0.4175201222D-02
llnk( 534 )= -0.4171086099D-02
llnk( 535 )= -0.4166981404D-02
llnk( 536 )= -0.4162887134D-02
llnk( 537 )= -0.4158803202D-02
llnk( 538 )= -0.4154729536D-02
llnk( 539 )= -0.4150666091D-02
llnk( 540 )= -0.4146612671D-02
llnk( 541 )= -0.4142569363D-02
llnk( 542 )= -0.4138535935D-02
llnk( 543 )= -0.4134515728D-02
llnk( 544 )= -0.4130507039D-02
llnk( 545 )= -0.4126503797D-02
llnk( 546 )= -0.4122510270D-02
llnk( 547 )= -0.4118526386D-02
llnk( 548 )= -0.4114552039D-02
llnk( 549 )= -0.4110587257D-02
llnk( 550 )= -0.4106631920D-02
llnk( 551 )= -0.4102685926D-02
llnk( 552 )= -0.4098749247D-02
llnk( 553 )= -0.4094821847D-02
llnk( 554 )= -0.4090903630D-02
llnk( 555 )= -0.4086994545D-02
llnk( 556 )= -0.4083094472D-02
llnk( 557 )= -0.4079203396D-02
llnk( 558 )= -0.4075321316D-02
llnk( 559 )= -0.4071448028D-02
llnk( 560 )= -0.4067583587D-02
llnk( 561 )= -0.4063727921D-02
llnk( 562 )= -0.4059880939D-02
llnk( 563 )= -0.4056042583D-02
llnk( 564 )= -0.4052212762D-02
llnk( 565 )= -0.4048391527D-02
llnk( 566 )= -0.4044578730D-02
llnk( 567 )= -0.4040774354D-02
llnk( 568 )= -0.4036978296D-02
llnk( 569 )= -0.4033190534D-02
llnk( 570 )= -0.4029410975D-02
llnk( 571 )= -0.4025639600D-02
llnk( 572 )= -0.4021876379D-02
llnk( 573 )= -0.4018121658D-02
llnk( 574 )= -0.4014374533D-02
llnk( 575 )= -0.4010635431D-02
llnk( 576 )= -0.4006904167D-02
llnk( 577 )= -0.4003180813D-02
llnk( 578 )= -0.3999465257D-02
llnk( 579 )= -0.3995757506D-02
llnk( 580 )= -0.3992057412D-02
llnk( 581 )= -0.3988364979D-02
llnk( 582 )= -0.3984680200D-02
llnk( 583 )= -0.3981002957D-02
llnk( 584 )= -0.3977333187D-02
llnk( 585 )= -0.3973670940D-02
llnk( 586 )= -0.3970016087D-02
llnk( 587 )= -0.3966368605D-02
llnk( 588 )= -0.3962728432D-02
llnk( 589 )= -0.3959095565D-02
llnk( 590 )= -0.3955469896D-02
llnk( 591 )= -0.3951851444D-02
llnk( 592 )= -0.3948240106D-02
llnk( 593 )= -0.3944635840D-02
llnk( 594 )= -0.3941038624D-02
llnk( 595 )= -0.3937448450D-02
llnk( 596 )= -0.3933865180D-02
llnk( 597 )= -0.3930288852D-02
llnk( 598 )= -0.3926725182D-02
llnk( 599 )= -0.3923164225D-02
llnk( 600 )= -0.3919609022D-02
llnk( 601 )= -0.3916060603D-02
llnk( 602 )= -0.3912518941D-02
llnk( 603 )= -0.3908984017D-02
llnk( 604 )= -0.3905455707D-02
llnk( 605 )= -0.3901934071D-02
llnk( 606 )= -0.3898419000D-02
llnk( 607 )= -0.3894910446D-02
llnk( 608 )= -0.3891408443D-02
llnk( 609 )= -0.3887912933D-02
llnk( 610 )= -0.3884423810D-02
llnk( 611 )= -0.3880941150D-02
llnk( 612 )= -0.3877464789D-02
llnk( 613 )= -0.3873994730D-02
llnk( 614 )= -0.3870530985D-02
llnk( 615 )= -0.3867073514D-02
llnk( 616 )= -0.3863622258D-02
llnk( 617 )= -0.3860177173D-02
llnk( 618 )= -0.3856738235D-02
llnk( 619 )= -0.3853305441D-02
llnk( 620 )= -0.3849878697D-02
llnk( 621 )= -0.3846458016D-02
llnk( 622 )= -0.3843043331D-02
llnk( 623 )= -0.3839634656D-02
llnk( 624 )= -0.3836231919D-02
llnk( 625 )= -0.3832835028D-02
llnk( 626 )= -0.3829444026D-02
llnk( 627 )= -0.3826058954D-02
llnk( 628 )= -0.3822679633D-02
llnk( 629 )= -0.3819306152D-02
llnk( 630 )= -0.3815938396D-02
llnk( 631 )= -0.3812576353D-02
llnk( 632 )= -0.3809220046D-02
llnk( 633 )= -0.3805869353D-02
llnk( 634 )= -0.3802524327D-02
llnk( 635 )= -0.3799184885D-02
llnk( 636 )= -0.3795851005D-02
llnk( 637 )= -0.3792522658D-02
llnk( 638 )= -0.3789199831D-02
llnk( 639 )= -0.3785882531D-02
llnk( 640 )= -0.3782570655D-02
llnk( 641 )= -0.3779264191D-02
llnk( 642 )= -0.3775963147D-02
llnk( 643 )= -0.3772667476D-02
llnk( 644 )= -0.3769377113D-02
llnk( 645 )= -0.3766092076D-02
llnk( 646 )= -0.3762812304D-02
llnk( 647 )= -0.3759537833D-02
llnk( 648 )= -0.3756268585D-02
llnk( 649 )= -0.3753004510D-02
llnk( 650 )= -0.3749745613D-02
llnk( 651 )= -0.3746491901D-02
llnk( 652 )= -0.3743243283D-02
llnk( 653 )= -0.3740005626D-02
llnk( 654 )= -0.3736767845D-02
llnk( 655 )= -0.3733535132D-02
llnk( 656 )= -0.3730307327D-02
llnk( 657 )= -0.3727084607D-02
llnk( 658 )= -0.3723866873D-02
llnk( 659 )= -0.3720654107D-02
llnk( 660 )= -0.3717446303D-02
llnk( 661 )= -0.3714243463D-02
llnk( 662 )= -0.3711045523D-02
llnk( 663 )= -0.3707852455D-02
llnk( 664 )= -0.3704664303D-02
llnk( 665 )= -0.3701480968D-02
llnk( 666 )= -0.3698302457D-02
llnk( 667 )= -0.3695128771D-02
llnk( 668 )= -0.3691959874D-02
llnk( 669 )= -0.3688795678D-02
llnk( 670 )= -0.3685636275D-02
llnk( 671 )= -0.3682481602D-02
llnk( 672 )= -0.3679331555D-02
llnk( 673 )= -0.3676186270D-02
llnk( 674 )= -0.3673045561D-02
llnk( 675 )= -0.3669909551D-02
llnk( 676 )= -0.3666778150D-02
llnk( 677 )= -0.3663651302D-02
llnk( 678 )= -0.3660529071D-02
llnk( 679 )= -0.3657411389D-02
llnk( 680 )= -0.3654298215D-02
llnk( 681 )= -0.3651189465D-02
llnk( 682 )= -0.3648085315D-02
llnk( 683 )= -0.3644985621D-02
llnk( 684 )= -0.3641890453D-02
llnk( 685 )= -0.3638799641D-02
llnk( 686 )= -0.3635713278D-02
llnk( 687 )= -0.3632631311D-02
llnk( 688 )= -0.3629553745D-02
llnk( 689 )= -0.3626480539D-02
llnk( 690 )= -0.3623411645D-02
llnk( 691 )= -0.3620347077D-02
llnk( 692 )= -0.3617286859D-02
llnk( 693 )= -0.3614230904D-02
llnk( 694 )= -0.3611179235D-02
llnk( 695 )= -0.3608131812D-02
llnk( 696 )= -0.3605088635D-02
llnk( 697 )= -0.3602049657D-02
llnk( 698 )= -0.3599014895D-02
llnk( 699 )= -0.3595984357D-02
llnk( 700 )= -0.3592957941D-02
llnk( 701 )= -0.3589935718D-02
llnk( 702 )= -0.3586917596D-02
llnk( 703 )= -0.3583903622D-02
llnk( 704 )= -0.3580893698D-02
llnk( 705 )= -0.3577887909D-02
llnk( 706 )= -0.3574886158D-02
llnk( 707 )= -0.3571888466D-02
llnk( 708 )= -0.3568899450D-02
llnk( 709 )= -0.3565910323D-02
llnk( 710 )= -0.3562925154D-02
llnk( 711 )= -0.3559943972D-02
llnk( 712 )= -0.3556966859D-02
llnk( 713 )= -0.3553993656D-02
llnk( 714 )= -0.3551024466D-02
llnk( 715 )= -0.3548059237D-02
llnk( 716 )= -0.3545097968D-02
llnk( 717 )= -0.3542140587D-02
llnk( 718 )= -0.3539187147D-02
llnk( 719 )= -0.3536237614D-02
llnk( 720 )= -0.3533291992D-02
llnk( 721 )= -0.3530350229D-02
llnk( 722 )= -0.3527412335D-02
llnk( 723 )= -0.3524478279D-02
llnk( 724 )= -0.3521548076D-02
llnk( 725 )= -0.3518621713D-02
llnk( 726 )= -0.3515699144D-02
llnk( 727 )= -0.3512780363D-02
llnk( 728 )= -0.3509865386D-02
llnk( 729 )= -0.3506954146D-02
llnk( 730 )= -0.3504046711D-02
llnk( 731 )= -0.3501142980D-02
llnk( 732 )= -0.3498243029D-02
llnk( 733 )= -0.3495346825D-02
llnk( 734 )= -0.3492454277D-02
llnk( 735 )= -0.3489565504D-02
llnk( 736 )= -0.3486680283D-02
llnk( 737 )= -0.3483798748D-02
llnk( 738 )= -0.3480921125D-02
llnk( 739 )= -0.3478046974D-02
llnk( 740 )= -0.3475176495D-02
llnk( 741 )= -0.3472309608D-02
llnk( 742 )= -0.3469446344D-02
llnk( 743 )= -0.3466586679D-02
llnk( 744 )= -0.3463730607D-02
llnk( 745 )= -0.3460878143D-02
llnk( 746 )= -0.3458029208D-02
llnk( 747 )= -0.3455183869D-02
llnk( 748 )= -0.3452342050D-02
llnk( 749 )= -0.3449503792D-02
llnk( 750 )= -0.3446669019D-02
llnk( 751 )= -0.3443837835D-02
llnk( 752 )= -0.3441010114D-02
llnk( 753 )= -0.3438185843D-02
llnk( 754 )= -0.3435365132D-02
llnk( 755 )= -0.3432547840D-02
llnk( 756 )= -0.3429734036D-02
llnk( 757 )= -0.3426923672D-02
llnk( 758 )= -0.3424116757D-02
llnk( 759 )= -0.3421313262D-02
llnk( 760 )= -0.3418513177D-02
llnk( 761 )= -0.3415716524D-02
llnk( 762 )= -0.3412923273D-02
llnk( 763 )= -0.3410136336D-02
llnk( 764 )= -0.3407350916D-02
llnk( 765 )= -0.3404568130D-02
llnk( 766 )= -0.3401788745D-02
llnk( 767 )= -0.3399012718D-02
llnk( 768 )= -0.3396240047D-02
llnk( 769 )= -0.3393470771D-02
llnk( 770 )= -0.3390704781D-02
llnk( 771 )= -0.3387942162D-02
llnk( 772 )= -0.3385182859D-02
llnk( 773 )= -0.3382426879D-02
llnk( 774 )= -0.3379674202D-02
llnk( 775 )= -0.3376924820D-02
llnk( 776 )= -0.3374178738D-02
llnk( 777 )= -0.3371435939D-02
llnk( 778 )= -0.3368696456D-02
llnk( 779 )= -0.3365960182D-02
llnk( 780 )= -0.3363227225D-02
llnk( 781 )= -0.3360497473D-02
llnk( 782 )= -0.3357770991D-02
llnk( 783 )= -0.3355047725D-02
llnk( 784 )= -0.3352327686D-02
llnk( 785 )= -0.3349610914D-02
llnk( 786 )= -0.3346897303D-02
llnk( 787 )= -0.3344186906D-02
llnk( 788 )= -0.3341479724D-02
llnk( 789 )= -0.3338775700D-02
llnk( 790 )= -0.3336074863D-02
llnk( 791 )= -0.3333377225D-02
llnk( 792 )= -0.3330682695D-02
llnk( 793 )= -0.3327991302D-02
llnk( 794 )= -0.3325303130D-02
llnk( 795 )= -0.3322618041D-02
llnk( 796 )= -0.3319936145D-02
llnk( 797 )= -0.3317257379D-02
llnk( 798 )= -0.3314581695D-02
llnk( 799 )= -0.3311909149D-02
llnk( 800 )= -0.3309239696D-02
llnk( 801 )= -0.3306573350D-02
llnk( 802 )= -0.3303910077D-02
llnk( 803 )= -0.3301249895D-02
llnk( 804 )= -0.3298592786D-02
llnk( 805 )= -0.3295938770D-02
llnk( 806 )= -0.3293287792D-02
llnk( 807 )= -0.3290639881D-02
llnk( 808 )= -0.3287994967D-02
llnk( 809 )= -0.3285353159D-02
llnk( 810 )= -0.3282714334D-02
llnk( 811 )= -0.3280078559D-02
llnk( 812 )= -0.3277445795D-02
llnk( 813 )= -0.3274816076D-02
llnk( 814 )= -0.3272189346D-02
llnk( 815 )= -0.3269565604D-02
llnk( 816 )= -0.3266944867D-02
llnk( 817 )= -0.3264327100D-02
llnk( 818 )= -0.3261713686D-02
llnk( 819 )= -0.3259103619D-02
llnk( 820 )= -0.3256495012D-02
llnk( 821 )= -0.3253889400D-02
llnk( 822 )= -0.3251286777D-02
llnk( 823 )= -0.3248687255D-02
llnk( 824 )= -0.3246090539D-02
llnk( 825 )= -0.3243496801D-02
llnk( 826 )= -0.3240905999D-02
llnk( 827 )= -0.3238318138D-02
llnk( 828 )= -0.3235733197D-02
llnk( 829 )= -0.3233151191D-02
llnk( 830 )= -0.3230572128D-02
llnk( 831 )= -0.3227995977D-02
llnk( 832 )= -0.3225422751D-02
llnk( 833 )= -0.3222852394D-02
llnk( 834 )= -0.3220284979D-02
llnk( 835 )= -0.3217720406D-02
llnk( 836 )= -0.3215158781D-02
llnk( 837 )= -0.3212600066D-02
llnk( 838 )= -0.3210044148D-02
llnk( 839 )= -0.3207491153D-02
llnk( 840 )= -0.3204940999D-02
llnk( 841 )= -0.3202393742D-02
llnk( 842 )= -0.3199849338D-02
llnk( 843 )= -0.3197307775D-02
llnk( 844 )= -0.3194769052D-02
llnk( 845 )= -0.3192233205D-02
llnk( 846 )= -0.3189700191D-02
llnk( 847 )= -0.3187169971D-02
llnk( 848 )= -0.3184642524D-02
llnk( 849 )= -0.3182117988D-02
llnk( 850 )= -0.3179596231D-02
llnk( 851 )= -0.3177077300D-02
llnk( 852 )= -0.3174561186D-02
llnk( 853 )= -0.3172047887D-02
llnk( 854 )= -0.3169537359D-02
llnk( 855 )= -0.3167029632D-02
llnk( 856 )= -0.3164524709D-02
llnk( 857 )= -0.3162022553D-02
llnk( 858 )= -0.3159523159D-02
llnk( 859 )= -0.3157026583D-02
llnk( 860 )= -0.3154532729D-02
llnk( 861 )= -0.3152041656D-02
llnk( 862 )= -0.3149553327D-02
llnk( 863 )= -0.3147067778D-02
llnk( 864 )= -0.3144584964D-02
llnk( 865 )= -0.3142104892D-02
llnk( 866 )= -0.3139627563D-02
llnk( 867 )= -0.3137152962D-02
llnk( 868 )= -0.3134681067D-02
llnk( 869 )= -0.3132211915D-02
llnk( 870 )= -0.3129745502D-02
llnk( 871 )= -0.3127281759D-02
llnk( 872 )= -0.3124820761D-02
llnk( 873 )= -0.3122362718D-02
llnk( 874 )= -0.3119909222D-02
llnk( 875 )= -0.3117456503D-02
llnk( 876 )= -0.3115006490D-02
llnk( 877 )= -0.3112559221D-02
llnk( 878 )= -0.3110114595D-02
llnk( 879 )= -0.3107672711D-02
llnk( 880 )= -0.3105233507D-02
llnk( 881 )= -0.3102796921D-02
llnk( 882 )= -0.3100363082D-02
llnk( 883 )= -0.3097931893D-02
llnk( 884 )= -0.3095503371D-02
llnk( 885 )= -0.3093077570D-02
llnk( 886 )= -0.3090654347D-02
llnk( 887 )= -0.3088233816D-02
llnk( 888 )= -0.3085815991D-02
llnk( 889 )= -0.3083400748D-02
llnk( 890 )= -0.3080988196D-02
llnk( 891 )= -0.3078578271D-02
llnk( 892 )= -0.3076170985D-02
llnk( 893 )= -0.3073766340D-02
llnk( 894 )= -0.3071364353D-02
llnk( 895 )= -0.3068964958D-02
llnk( 896 )= -0.3066568203D-02
llnk( 897 )= -0.3064174074D-02
llnk( 898 )= -0.3061782549D-02
llnk( 899 )= -0.3059393659D-02
llnk( 900 )= -0.3057007375D-02
llnk( 901 )= -0.3054623711D-02
llnk( 902 )= -0.3052242585D-02
llnk( 903 )= -0.3049864141D-02
llnk( 904 )= -0.3047488140D-02
llnk( 905 )= -0.3045114846D-02
llnk( 906 )= -0.3042744119D-02
llnk( 907 )= -0.3040375970D-02
llnk( 908 )= -0.3038010418D-02
llnk( 909 )= -0.3035647475D-02
llnk( 910 )= -0.3033287098D-02
llnk( 911 )= -0.3030929263D-02
llnk( 912 )= -0.3028574024D-02
llnk( 913 )= -0.3026221302D-02
llnk( 914 )= -0.3023871162D-02
llnk( 915 )= -0.3021523546D-02
llnk( 916 )= -0.3019178525D-02
llnk( 917 )= -0.3016836027D-02
llnk( 918 )= -0.3014496035D-02
llnk( 919 )= -0.3012158656D-02
llnk( 920 )= -0.3009823741D-02
llnk( 921 )= -0.3007491429D-02
llnk( 922 )= -0.3005161605D-02
llnk( 923 )= -0.3002834314D-02
llnk( 924 )= -0.3000509569D-02
llnk( 925 )= -0.2998187291D-02
llnk( 926 )= -0.2995867561D-02
llnk( 927 )= -0.2993550344D-02
llnk( 928 )= -0.2991235634D-02
llnk( 929 )= -0.2988925225D-02
llnk( 930 )= -0.2986615660D-02
llnk( 931 )= -0.2984308615D-02
llnk( 932 )= -0.2982004089D-02
llnk( 933 )= -0.2979702045D-02
llnk( 934 )= -0.2977402494D-02
llnk( 935 )= -0.2975105470D-02
llnk( 936 )= -0.2972810888D-02
llnk( 937 )= -0.2970518821D-02
llnk( 938 )= -0.2968229240D-02
llnk( 939 )= -0.2965942158D-02
llnk( 940 )= -0.2963657551D-02
llnk( 941 )= -0.2961375403D-02
llnk( 942 )= -0.2959095731D-02
llnk( 943 )= -0.2956818525D-02
llnk( 944 )= -0.2954543818D-02
llnk( 945 )= -0.2952271541D-02
llnk( 946 )= -0.2950001748D-02
llnk( 947 )= -0.2947734412D-02
llnk( 948 )= -0.2945469512D-02
llnk( 949 )= -0.2943207084D-02
llnk( 950 )= -0.2940947077D-02
llnk( 951 )= -0.2938689563D-02
llnk( 952 )= -0.2936434487D-02
llnk( 953 )= -0.2934181799D-02
llnk( 954 )= -0.2931931606D-02
llnk( 955 )= -0.2929683842D-02
llnk( 956 )= -0.2927438481D-02
llnk( 957 )= -0.2925195572D-02
llnk( 958 )= -0.2922955070D-02
llnk( 959 )= -0.2920716941D-02
llnk( 960 )= -0.2918481269D-02
llnk( 961 )= -0.2916248012D-02
llnk( 962 )= -0.2914017179D-02
llnk( 963 )= -0.2911788782D-02
llnk( 964 )= -0.2909562774D-02
llnk( 965 )= -0.2907339192D-02
llnk( 966 )= -0.2905117982D-02
llnk( 967 )= -0.2902899173D-02
llnk( 968 )= -0.2900682799D-02
llnk( 969 )= -0.2898468796D-02
llnk( 970 )= -0.2896257166D-02
llnk( 971 )= -0.2894047930D-02
llnk( 972 )= -0.2891841138D-02
llnk( 973 )= -0.2889636618D-02
llnk( 974 )= -0.2887434580D-02
llnk( 975 )= -0.2885234873D-02
llnk( 976 )= -0.2883037537D-02
llnk( 977 )= -0.2880842566D-02
llnk( 978 )= -0.2878649974D-02
llnk( 979 )= -0.2876459766D-02
llnk( 980 )= -0.2874271894D-02
llnk( 981 )= -0.2872086376D-02
llnk( 982 )= -0.2869903273D-02
llnk( 983 )= -0.2867722443D-02
llnk( 984 )= -0.2865545315D-02
llnk( 985 )= -0.2863369328D-02
llnk( 986 )= -0.2861195689D-02
llnk( 987 )= -0.2859024433D-02
llnk( 988 )= -0.2856855469D-02
llnk( 989 )= -0.2854688909D-02
llnk( 990 )= -0.2852524645D-02
llnk( 991 )= -0.2850362774D-02
llnk( 992 )= -0.2848203196D-02
llnk( 993 )= -0.2846045956D-02
llnk( 994 )= -0.2843891068D-02
llnk( 995 )= -0.2841738481D-02
llnk( 996 )= -0.2839588248D-02
llnk( 997 )= -0.2837440365D-02
llnk( 998 )= -0.2835294724D-02
llnk( 999 )= -0.2833151463D-02
llnk( 1000 )= -0.2831010498D-02
llnk( 1001 )= -0.2828871870D-02
llnk( 1002 )= -0.2826735533D-02
llnk( 1003 )= -0.2824601509D-02
llnk( 1004 )= -0.2822469774D-02
llnk( 1005 )= -0.2820340370D-02
llnk( 1006 )= -0.2818213253D-02
llnk( 1007 )= -0.2816088447D-02
llnk( 1008 )= -0.2813965924D-02
llnk( 1009 )= -0.2811845711D-02
llnk( 1010 )= -0.2809727762D-02
llnk( 1011 )= -0.2807612130D-02
llnk( 1012 )= -0.2805498780D-02
llnk( 1013 )= -0.2803387663D-02
llnk( 1014 )= -0.2801278909D-02
llnk( 1015 )= -0.2799172307D-02
llnk( 1016 )= -0.2797068067D-02
llnk( 1017 )= -0.2794966114D-02
llnk( 1018 )= -0.2792866401D-02
llnk( 1019 )= -0.2790768970D-02
llnk( 1020 )= -0.2788673820D-02
llnk( 1021 )= -0.2786580911D-02
llnk( 1022 )= -0.2784490270D-02
llnk( 1023 )= -0.2782401919D-02
llnk( 1024 )= -0.2780315803D-02
end subroutine loadlovenumber
!
!
! ==========================================================================
!>
subroutine tforce( jul0, TIME , xzeta , yzeta , TIDEP, IDIM1, dstart, dstop , eps)
!
! ====================================================================
!
! Programmer E.J.O. Schrama
!
! Original URL: https://repos.deltares.nl/repos/simona/bo_omgeving/simona/src/waqua/waqpro/routines/wastfr.f
! $Revision: 1850 $, $Date: 2008-04-18 09:19:37 +0200 (Fri, 18 Apr 2008) $
!
! Version 1.1 Date 22-05-2008 c81402: extended for evaluation of
! tidal forces on grids (AVe,
! VORtech)
! Version 1.0 Date 24-01-2008 initial version
!
! Copyright (c) "E.J.O. Schrama".
! Permission to copy or distribute this software or documentation
! in hard copy or soft copy granted only by written license
! obtained from "Rijkswaterstaat".
! All rights reserved. No part of this publication may be
! reproduced, stored in a retrieval system (e.g., in memory, disk,
! or core) or be transmitted by any means, electronic, mechanical,
! photocopy, recording, or otherwise, without written permission
! from the publisher.
!
! ********************************************************************
!
! DESCRIPTION
!
! Computes the tidal potential for each active grid point
!
! ********************************************************************
!
! COMMON BLOCKS
!
implicit none
!
! **********************************************************************
!
! INPUT / OUTPUT PARAMETERS
!
integer idim1, jul0
double precision :: rmjdat, dstart, dstop, eps, TIME
double precision xzeta(idim1), yzeta(idim1), tidep(idim1)
DOUBLE PRECISION, allocatable, SAVE :: tideuc(:,:,:), tideus(:,:,:) ! (idim1, 0:3,2:3),
INTEGER, SAVE :: IRC = 0
CHARACTER(len=40), dimension(484) :: RECS ! ZAT IN FILE 'HARMONICS'
!
! dstart i starting Doodson number
! dstop i stopping Doodson number
! eps i tolerance level for tidal force formula
! harfil i file with tidal harmonics
! idim1 i first dimension of fullbox array (nmax for SIMONA)
! i second dimension of fullbox array (mmax+6 for SIMONA)
! irc i input parameter for tforce
! irc = 0: initialisation phase
! irc = 1: simulation phase
! luhar i logical unit number to read file with tidal harmonics
! name i character string containing the name of the
! the calling subroutine.
! Only used for error messages.
! rmjdat i modified julian day (24-jan-2008 0:00 UTC : 54489.00000)
! tidep o tidal potential
! tideuc i o cosine component of tidal potential (array)
! tideus i o sine component of tidal potential (array)
! xzeta i latitude (in radians) of grid-points in physiscal plane
! yzeta i longitude (in radians) of grid-points in physiscal plane
!
! ********************************************************************
!
! LOCAL PARAMETERS
!
integer maxdat, maxfld, idebug, i1, i1dbg, i2dbg, N
double precision :: pi, g, rmu, re, d2r, reps
parameter (idebug=0, i1dbg=0, i2dbg=0)
parameter (maxdat=500) ! maximal # records in table
parameter (maxfld=7) ! maximal # fields in table
parameter (pi = 3.14159265358979, re = 6378137d0, &
d2r = pi/180d0, rmu = 3.9860044d14, &
g = rmu / re / re, reps = 1d-5 )
integer ntable, nskip
integer itable(maxdat,maxfld)
double precision :: amps(maxdat), plsmin(6), rklove(3), rhlove(3), &
factor(2:3), pol1(0:3,2:3), cm1(0:3), sm1(0:3)
integer i,j,nq,mq, IERR
integer kk(10 )
double precision :: fnm, pnm, har, argum, argfct, dtab1, dtab2, &
dtab, rlslat, rlslon, rlat, rlong, potent
double precision :: elmnts(6), can(maxdat), san(maxdat)
double precision :: cansum(0:3,2:3), sansum(0:3,2:3)
character*80 record
logical permnt
DOUBLE PRECISION, SAVE :: FACTORIAL(0:6)
!
! amps table with scaled amplitudes for selected tidal components
! argfct multiplication factor needed to compute argument
! argum argument for time-dependent harmonic components ca,sa
! can table with scaled harmonic components
! dcos(argument) * amp(i)
! cansum selected sum of elements of can for fixed mq,nq
! cm1 cosine-component of potential
! d2r conversion factor pi/180
! dtab Doodson number: dtab1 + dtab2 / 1000d0
! dtab1 first 3 digits of Doodson number
! dtab2 second 3 digits of Doodson number
! elmnts array needed for calculation of can, san
! factor table with multiplication factors needed to compute
! tidal potential
! fnm global normalization factor (fnm) found in cartwright 1993
! needed for pol1
! g gravity acceleration
! har amplitude of tidal component
! i loop variable
! i1 loop variable
! idebug flag wheter debug output is printed
! itable CTE table read from harmonics.table with the selected CTE
! lines
! j loop variable
! kk array of fields for CTE table
! maxdat maximum number of CTE lines
! maxfld maximum number of fields for each CTE line
! mq order of cm1, sm1 and pol1 (table(i,1))
! nq degree of Legendre polynomial (table(i,7))
! nr number of CTE line
! nskip number of skipped CTE lines in harmonics.table
! ntable number of selected CTE lines
! permnt flag whether tidal line should be skipped
! pi 3.14159265358979
! plsmin array with +/- signs for all fields
! pnm output value of legpol1
! pol1 Legendre polynomial array
! potent tidal potential
! re radius of the earth
! record character array
! reps real value 1d-5 used for inequalities
! rhlove Love numbers describing the indirect potential effects
! rklove Love numbers describing the geometric-radial effects
! rlat northern latitude in radians
! rlong eastern longitude in radians
! rlslat previous value of rlat
! rlslon previous value of rlong
! rmu gravitational constant (3.9860044d14)
! san table with scaled harmonic components
! dsin(argument) * amp(i)
! sansum selected sum of elements of san for fixed mq,nq
! sm1 sine-component of potential
!
! ********************************************************************
!
! I / O
!
! harfil = WAQPRO**/harmonics.table I CTE table (unit luhar)
!
! ********************************************************************
!
! SUBROUTINES CALLED
!
!
! ASTROL This copied from richard's subroutine astrol, in goes the
! modified Julian date, out comes an array of six double
! precision variables used for Doodson number computations
! LEGPOL1 compute unnormalized associated legendre polynomials up to
! degree 3 and order 3
!
! ********************************************************************
!
! ERROR MESSAGES
!
! ********************************************************************
!
! PSEUDO CODE
!
! save static variables
!
! if (first call) then
! initialise
! read CTE-table (table, amps, ntable)
! if (Dstart <= d(i) <= Dstop and H(i) >= eps) then
! read tidal line
! amps(i) = har * g * factor
! end if
!
! computation and storage of tideuc,tideus at each grid-point:
! do (all grid-points)
! do nq = 2, 3
! do mq = 0, nq
! if (changed latitude) then
! update pol1(m,n) (call legpol1)
! end if
! if (changed longitude) then
! update cm1(m) = cos(), sm1(m) = sin()
! end if
! compute tideuc(nm,mq,nq), tideus(nm,mq,nq)
! store tideuc,tideus
! enddo
! enddo
! enddo
! end
!
! update elements-table (call astrol)
! compute arrays can, san:
! do (all tidal components)
! compute argum
! can(i) = dcos(argum) * amps(i)
! san(i) = dsin(argum) * amps(i)
! enddo
! compute arrays cansum, sansum:
! do nq = 2, 3
! do mq = 0, nq
! do (all tidal components)
! if ( itable(i,7).eq.nq .and. itable(i,1).eq.mq) then
! cansum(mq, nq) = cansum(mq, nq) + can(i)
! sansum(mq, nq) = sansum(mq, nq) + san(i)
! end if
! enddo
! enddo
! enddo
!
! computation of the tidal potential at each grid-point:
! do (all grid-points)
! do nq = 2, 3
! do mq = 0, nq
! potent = potent + tideuc(nm, mq, nq) * cansum(mq,nq) +
! tideus(nm, mq, nq) * sansum(mq,nq)
! enddo
! enddo
! tidep(n,m) = potent
! enddo
!
! ********************************************************************
!
! DATA STATEMENTS
!
data plsmin / +1d0, +1d0, +1d0, +1d0, -1d0, +1d0 /
!
save itable, ntable, pol1, cm1, sm1, amps
!
!c ====================================================================
!
! --- initialisation phase
!
! --- compute modified Julian date (rmjdat)
! rmjdat = itdjul - 2400001.0 + time / (24 * 60)
rmjdat = jul0 - 2400001.0 + time / (24 * 60)
if (irc.eq.0 ) then
IRC = 1
FACTORIAL(0) = 1D0
FACTORIAL(1) = 1D0
FACTORIAL(2) = 2D0
FACTORIAL(3) = 6D0
FACTORIAL(4) = 24D0
FACTORIAL(5) = 120D0
FACTORIAL(6) = 720D0
if (allocated (tideuc) ) deallocate(tideuc, tideus)
ALLOCATE ( tideuc(0:3,2:3,IDIM1), STAT = IERR); tideuc = 0d0
ALLOCATE ( tideus(0:3,2:3,IDIM1), STAT = IERR); tideus = 0d0
call iniharmonics(recs)
if (idebug.ge.10) then
write(6,*) '*** Start reading the harmonics ' // &
'table ***'
write(6,*)
end if
!
! --- k and h love numbers for degree 2 and 3
!
rklove(1) = 0d0
rklove(2) = 0.303d0
rklove(3) = 0.0937d0
rhlove(1) = 0d0
rhlove(2) = 0.612d0
rhlove(3) = 0.293d0
!
do nq = 2, 3
factor(nq) = (1d0 + rklove(nq) - rhlove(nq))
enddo
!
ntable = 0
nskip = 0
N = 0
10 continue
N = N + 1
IF (N > 484) GOTO 20
RECORD = RECS(N)
! read(luhar,'(a)',end=20) record
if (idebug.ge.10) write(6,*) record
if (record(1:1).eq.'%') go to 10
read(record,*) (kk(i),i = 1, 7), har
!
! in the CTE tables there is a null line for theoretic
! --- reasons, never use this line to compute the tidal
! potential.
!
permnt = kk(1).eq.0 .and. kk(2).eq.0 .and. &
kk(3).eq.0 .and. kk(4).eq.0 .and. &
kk(5).eq.0 .and. kk(6).eq.0
!
! --- dtab is the doodson number for a table entry,
! select the lines where dstart <= dtab <= dstop
!
dtab1 = kk(1)*100d0 + (kk(2)+5d0)*10d0 + (kk(3)+5d0)
dtab2 = (kk(4)+5d0)*100d0 + (kk(5)+5d0)*10d0 + (kk(6)+5d0)
dtab = dtab1 + dtab2 / 1000d0
if (.not.permnt .and. abs(har).ge.eps .and. dstart.le.dtab .and. dtab.le.dstop ) then
ntable = ntable + 1
if (ntable.gt.maxdat) then
irc = -2
return
end if
do i = 1, 7
itable(ntable,i) = kk(i)
end do
nq = kk(7)
amps(ntable) = har * g * factor(nq)
else
nskip = nskip + 1
end if
go to 10
20 continue
! rewind(luhar)
rlslat = -9999d0
rlslon = -9999d0
if (idebug.ge.10) then
write(6,*) 'ntable = ',ntable,' nskip = ',nskip
end if
!
! --- storage of uc, us
!
do 90 i1 = 1, idim1
rlat = yzeta(i1)
rlong = xzeta(i1)
! compute legendre polynomials times the global
! --- normalization factor
! (fnm) found in cartwright 1993, also compute the
! astronomical elements
!
if (abs(rlat-rlslat).gt.reps) then
do nq = 2, 3
do mq = 0, nq
fnm = 2d0 / dble(2*nq+1) * factorial(nq+mq) / factorial(nq-mq)
fnm = sqrt(1d0 / (2d0 * pi * fnm)) * ((-1d0)**mq)
call legpol1( rlat, nq, mq, pnm )
pol1(mq, nq) = fnm * pnm
enddo
enddo
end if
if (abs(rlong-rlslon).gt.reps ) then
do mq = 0, 3
cm1(mq) = +cos(dble(mq) * rlong)
sm1(mq) = +sin(dble(mq) * rlong)
enddo
end if
!
! --- compute arrays with tideuc, tideus
!
do nq = 2, 3
do mq = 0, nq
if (mod(nq+mq, 2).eq.0) then
tideuc(mq, nq, I1) = +cm1(mq) * pol1(mq, nq)
tideus(mq, nq, I1) = -sm1(mq) * pol1(mq, nq)
else
tideuc(mq, nq, I1) = +sm1(mq) * pol1(mq, nq)
tideus(mq, nq, I1) = +cm1(mq) * pol1(mq, nq)
end if
if (idebug.ge.2 .and. i1.eq.i1dbg) then
write(6,123) 'mq,nq=',mq,nq, &
': rlat=',rlat,', rlong=',rlong, &
', pol1=',pol1(mq,nq),', cm1=',cm1(mq),',', &
'sm1=',sm1(mq), &
', tideuc=',tideuc(mq,nq,I1), &
', tideus=',tideus(mq,nq,I1)
123 format(a,2i2,4(a,f8.4),a,/,12x,3(a,f8.4))
end if
enddo
enddo
!
! --- and finally save the last known latitude and
! longitude
!
rlslat = rlat
rlslon = rlong
90 continue
end if
!
! --- end of initialisation phase
!
! ------------------------------------------------------------------------
!
! --- update elements-table
!
call astrol( rmjdat, elmnts )
!
! --- compute tabels can, san
!
do i = 1, ntable
argum = 0d0
do j = 1, 6
argfct = dble(itable(i, j))
argum = argum + argfct * elmnts(j) * plsmin(j)
end do
! argum = mod(argum, 360d0)
! if (argum.lt.0d0) argum = argum + 360d0
argum = argum * d2r
can(i) = cos(argum) * amps(i)
san(i) = sin(argum) * amps(i)
enddo
!
! --- compute tables cansum, sansum
!
do nq = 2, 3
do mq = 0, nq
cansum(mq, nq) = 0d0
sansum(mq, nq) = 0d0
do i = 1, ntable
if ( itable(i,7).eq.nq .and. itable(i,1).eq.mq) then
cansum(mq, nq) = cansum(mq, nq) + can(i)
sansum(mq, nq) = sansum(mq, nq) + san(i)
end if
enddo
enddo
enddo
!
! --- computation of the tidal potential at each grid-point:
!
do 190 i1 = 1, idim1
potent = 0d0
do nq = 2, 3
do mq = 0, nq
potent = potent + tideuc(mq, nq, I1) * cansum(mq,nq)
potent = potent + tideus(mq, nq, I1) * sansum(mq,nq)
! if (idebug.ge.2 .and. i1.eq.i1dbg) then
! write(6,'(a,2i2,2(2(a,f10.6)))') 'mq,nq=',mq,nq, &
! ': term uc=',tideuc(i1,mq,nq),'*', &
! cansum(mq,nq), &
! ', us=',tideus(i1,mq,nq),'*', &
! sansum(mq,nq)
!end if
enddo
enddo
tidep(i1) = potent
190 continue
! if (idebug.ge.1 .and. i1dbg.ge.1) write(6,*) 'tidep=', tidep(i1dbg)
end subroutine tforce
!
!
! ==========================================================================
!>
subroutine astrol( mjdate,six )
! ====================================================================
!
! Programmer R. D. Ray
!
! Version 1.0 Date dec. 1990 initial version
!
! ********************************************************************
!
! DESCRIPTION
!
! This copied from richard's subroutine astrol, in goes the
! modified Julian date, out comes an array of six double precision
! variables used for Doodson number computations
!
! Computes the basic astronomical mean longitudes s, h, p, N.
! Note N is not N', i.e. N is decreasing with time.
! These formulae are for the period 1990 - 2010, and were derived
! by David Cartwright (personal comm., Nov. 1990).
! TIME is UTC in decimal MJD.
! All longitudes returned in degrees.
! R. D. Ray Dec. 1990
!
! Non-vectorized version.
!
! ********************************************************************
!
! COMMON BLOCKS
!
implicit none
!
! ********************************************************************
!
! INPUT / OUTPUT PARAMETERS
!
double precision :: six(6),mjdate
!
! mjdate i modified julian day (24-jan-2008 0:00 UTC : 54489.00000)
! six o array of six double precision variables used for Doodson
! number computations
! see also Cartwright 1993, summer school lecture notes,
! page 108
! six(1) (tau) mean time angle in lunar days
! six(2) (q) mean longitude of moon
! six(3) (q') mean longitude of sun
! six(4) (p) mean longitude of lunar perigee
! six(5) (N) mean longitude of ascending lunar node
! six(6) (p') mean longitude of the Sun at perihelion
!
! ********************************************************************
!
! LOCAL PARAMETERS
!
! --- constant values:
!
double precision :: circle
parameter (CIRCLE=360.0D0)
!
! circle number of degrees in a circle
!
! --- variables:
!
double precision :: T,TIME,UT
integer i
!
! T translated time: TIME - 51544.4993D0
! TIME input time (mjdate)
! UT fractional part of mjdate: (mjdate - int(mjdate))
!
!=======================================================================
!
! --- start of code
!
TIME = mjdate
T = TIME - 51544.4993D0 ! reference to 2000/1/1 1200 o'clock
!
! --- perform translations using translation table of symbols:
!
! nr Cartwright Doodson Brown
! 1 tau tau 360*t-D+180
! 2 q s L
! 3 q' h L'
! 4 p p \overline(\omega)
! 5 N -N' \Omega
! 6 p' p_1 \overline{\omega}'
!
six(2) = 218.3164D0 + 13.17639648D0 * T
six(3) = 280.4661D0 + 0.98564736D0 * T
six(4) = 83.3535D0 + 0.11140353D0 * T
six(5) = 125.0445D0 - 0.05295377D0 * T
six(6) = 282.9384D0 + 0.0000471d0 * T
!
! --- get them in the right quadrant
!
do i = 2, 6
six(i) = mod(six(i), circle)
if (six(i).lt.0d0) six(i) = six(i) + circle
end do
!
! argument 1 in the doodson number denotes the mean lunar time.
! According to equation 13 and the inline remark after equation 14
! it is computed by
! alpha_G = 360 * "Universal time in fractions of a day" + q'(T) - 180
! tau = alpha_G - q
!
UT = (mjdate - int(mjdate))
six(1) = 360d0 * UT + six(3) - 180d0 - six(2)
end subroutine astrol
!
!
! ==========================================================================
!>
subroutine legpol1( theta,n,m,pnm )
! ====================================================================
!
! Programmer E. Schrama
!
! ********************************************************************
!
! DESCRIPTION
!
! A routine to compute unnormalized associated legendre polynomials
! up to degree 3 and order 3.
!
! ********************************************************************
!
! COMMON BLOCKS
!
implicit none
!
! ********************************************************************
!
! INPUT / OUTPUT PARAMETERS
!
integer n,m
double precision :: theta,pnm
!
! m i degree of Legendre polynomial
! n i order of Legendre polynomial
! pnm o value of Legendre polynomial
! theta i phase
!
! ********************************************************************
!
! LOCAL PARAMETERS
!
double precision :: cp,sp
!
! cp cos(theta)
! sp sin(theta)
!
!=======================================================================
!
pnm = 1d38
cp = cos( theta )
sp = sin( theta )
!
! --- I think this comes from (Lambeck,1988), what again are the rules for
! obtaining associated Legendre functions?
!
if (n.eq.0 ) then
if (m.eq.0 ) pnm = 1d0
ELSE if (n.eq.1 ) then
if (m.eq.0 ) pnm = sp
if (m.eq.1 ) pnm = cp
ELSE if (n.eq.2 ) then
if (m.eq.0 ) pnm = 1.5d0*sp*sp - 0.5d0
if (m.eq.1 ) pnm = 3.0d0*sp*cp
if (m.eq.2 ) pnm = 3.0d0*cp*cp
ELSE IF (n.eq.3 ) then
if (m.eq.0 ) pnm = 2.5d0*sp*sp*sp - 1.5d0*sp
if (m.eq.1 ) pnm = cp * (7.5d0*sp*sp - 1.5d0)
if (m.eq.2 ) pnm = 15d0*cp*cp*sp
if (m.eq.3 ) pnm = 15d0*cp*cp*cp
end if
end subroutine legpol1
!
!
! ==========================================================================
!>
SUBROUTINE INIHARMONICS(RECS)
CHARACTER(len=40), dimension(484) :: RECS ! ZAT IN FILE 'HARMONICS'
!%refsys 2000
!%mjd0 47893.00000000
!%mjd1 55196.00000000
!%dmjd .11410938
!%ndata 64000
!%gmearth 3.9860044d14
!%reearth 6378137
RECS( 1) = ' 0 0 0 0 0 0 2 -.31459'
RECS( 2) = ' 0 0 0 0 1 0 2 .02793'
RECS( 3) = ' 0 0 0 0 2 0 2 -.00028'
RECS( 4) = ' 0 0 0 2 1 0 2 .00004'
RECS( 5) = ' 0 0 1 0 -1 -1 2 -.00004'
RECS( 6) = ' 0 0 1 0 0 -1 2 -.00492'
RECS( 7) = ' 0 0 1 0 0 1 2 .00026'
RECS( 8) = ' 0 0 1 0 1 -1 2 .00004'
RECS( 9) = ' 0 0 2 -2 -1 0 2 .00002'
RECS( 10) = ' 0 0 2 -2 0 0 2 -.00031'
RECS( 11) = ' 0 0 2 0 0 0 2 -.03099'
RECS( 12) = ' 0 0 2 0 0 -2 2 -.00012'
RECS( 13) = ' 0 0 2 0 1 0 2 .00076'
RECS( 14) = ' 0 0 2 0 2 0 2 .00017'
RECS( 15) = ' 0 0 3 0 0 -1 2 -.00181'
RECS( 16) = ' 0 0 3 0 1 -1 2 .00003'
RECS( 17) = ' 0 0 4 0 0 -2 2 -.00007'
RECS( 18) = ' 0 1 -3 1 -1 1 2 .00002'
RECS( 19) = ' 0 1 -3 1 0 1 2 -.00029'
RECS( 20) = ' 0 1 -2 -1 -2 0 2 .00002'
RECS( 21) = ' 0 1 -2 -1 -1 0 2 .00006'
RECS( 22) = ' 0 1 -2 1 -1 0 2 .00048'
RECS( 23) = ' 0 1 -2 1 0 0 2 -.00673'
RECS( 24) = ' 0 1 -2 1 1 0 2 .00044'
RECS( 25) = ' 0 1 -1 -1 0 1 2 -.00021'
RECS( 26) = ' 0 1 -1 0 0 0 2 .00019'
RECS( 27) = ' 0 1 -1 1 0 -1 2 .00005'
RECS( 28) = ' 0 1 0 -1 -2 0 2 -.00003'
RECS( 29) = ' 0 1 0 -1 -1 0 2 .00231'
RECS( 30) = ' 0 1 0 -1 0 0 2 -.03518'
RECS( 31) = ' 0 1 0 -1 1 0 2 .00228'
RECS( 32) = ' 0 1 0 1 0 0 2 .00188'
RECS( 33) = ' 0 1 0 1 1 0 2 .00077'
RECS( 34) = ' 0 1 0 1 2 0 2 .00021'
RECS( 35) = ' 0 1 1 -1 0 -1 2 .00018'
RECS( 36) = ' 0 1 2 -1 0 0 2 .00049'
RECS( 37) = ' 0 1 2 -1 1 0 2 .00024'
RECS( 38) = ' 0 1 2 -1 2 0 2 .00004'
RECS( 39) = ' 0 1 3 -1 0 -1 2 .00002'
RECS( 40) = ' 0 2 -4 2 0 0 2 -.00011'
RECS( 41) = ' 0 2 -3 0 0 1 2 -.00039'
RECS( 42) = ' 0 2 -3 0 1 1 2 .00002'
RECS( 43) = ' 0 2 -2 0 -1 0 2 -.00042'
RECS( 44) = ' 0 2 -2 0 0 0 2 -.00584'
RECS( 45) = ' 0 2 -2 0 1 0 2 .00037'
RECS( 46) = ' 0 2 -2 2 0 0 2 .00004'
RECS( 47) = ' 0 2 -1 -2 0 1 2 -.00004'
RECS( 48) = ' 0 2 -1 -1 0 0 2 .00003'
RECS( 49) = ' 0 2 -1 0 0 -1 2 .00007'
RECS( 50) = ' 0 2 -1 0 0 1 2 -.00020'
RECS( 51) = ' 0 2 -1 0 1 1 2 -.00004'
RECS( 52) = ' 0 2 0 -2 -1 0 2 .00015'
RECS( 53) = ' 0 2 0 -2 0 0 2 -.00288'
RECS( 54) = ' 0 2 0 -2 1 0 2 .00019'
RECS( 55) = ' 0 2 0 0 0 0 2 -.06660'
RECS( 56) = ' 0 2 0 0 1 0 2 -.02761'
RECS( 57) = ' 0 2 0 0 2 0 2 -.00258'
RECS( 58) = ' 0 2 0 0 3 0 2 .00006'
RECS( 59) = ' 0 2 1 -2 0 -1 2 .00003'
RECS( 60) = ' 0 2 1 0 0 -1 2 .00023'
RECS( 61) = ' 0 2 1 0 1 -1 2 .00006'
RECS( 62) = ' 0 2 2 -2 0 0 2 .00020'
RECS( 63) = ' 0 2 2 -2 1 0 2 .00008'
RECS( 64) = ' 0 2 2 0 2 0 2 .00003'
RECS( 65) = ' 0 3 -5 1 0 1 2 -.00002'
RECS( 66) = ' 0 3 -4 1 0 0 2 -.00018'
RECS( 67) = ' 0 3 -3 -1 0 1 2 -.00007'
RECS( 68) = ' 0 3 -3 1 0 1 2 -.00011'
RECS( 69) = ' 0 3 -3 1 1 1 2 -.00005'
RECS( 70) = ' 0 3 -2 -1 -1 0 2 -.00009'
RECS( 71) = ' 0 3 -2 -1 0 0 2 -.00092'
RECS( 72) = ' 0 3 -2 -1 1 0 2 .00006'
RECS( 73) = ' 0 3 -2 1 0 0 2 -.00242'
RECS( 74) = ' 0 3 -2 1 1 0 2 -.00100'
RECS( 75) = ' 0 3 -2 1 2 0 2 -.00009'
RECS( 76) = ' 0 3 -1 -1 0 1 2 -.00013'
RECS( 77) = ' 0 3 -1 -1 1 1 2 -.00004'
RECS( 78) = ' 0 3 -1 0 0 0 2 .00007'
RECS( 79) = ' 0 3 -1 0 1 0 2 .00003'
RECS( 80) = ' 0 3 -1 1 0 -1 2 .00003'
RECS( 81) = ' 0 3 0 -3 0 0 2 -.00023'
RECS( 82) = ' 0 3 0 -3 1 -1 2 .00003'
RECS( 83) = ' 0 3 0 -3 1 1 2 .00003'
RECS( 84) = ' 0 3 0 -1 0 0 2 -.01275'
RECS( 85) = ' 0 3 0 -1 1 0 2 -.00529'
RECS( 86) = ' 0 3 0 -1 2 0 2 -.00050'
RECS( 87) = ' 0 3 0 1 2 0 2 .00005'
RECS( 88) = ' 0 3 0 1 3 0 2 .00002'
RECS( 89) = ' 0 3 1 -1 0 -1 2 .00011'
RECS( 90) = ' 0 3 1 -1 1 -1 2 .00004'
RECS( 91) = ' 0 4 -4 0 0 0 2 -.00008'
RECS( 92) = ' 0 4 -4 2 0 0 2 -.00006'
RECS( 93) = ' 0 4 -4 2 1 0 2 -.00003'
RECS( 94) = ' 0 4 -3 0 0 1 2 -.00014'
RECS( 95) = ' 0 4 -3 0 1 1 2 -.00006'
RECS( 96) = ' 0 4 -2 -2 0 0 2 -.00011'
RECS( 97) = ' 0 4 -2 0 0 0 2 -.00204'
RECS( 98) = ' 0 4 -2 0 1 0 2 -.00084'
RECS( 99) = ' 0 4 -2 0 2 0 2 -.00008'
RECS(100) = ' 0 4 -1 -2 0 1 2 -.00003'
RECS(101) = ' 0 4 -1 0 0 -1 2 .00003'
RECS(102) = ' 0 4 0 -2 0 0 2 -.00169'
RECS(103) = ' 0 4 0 -2 1 0 2 -.00070'
RECS(104) = ' 0 4 0 -2 2 0 2 -.00007'
RECS(105) = ' 1 -4 0 3 -1 0 2 .00014'
RECS(106) = ' 1 -4 0 3 0 0 2 .00075'
RECS(107) = ' 1 -4 1 1 0 1 2 -.00003'
RECS(108) = ' 1 -4 2 1 -1 0 2 .00036'
RECS(109) = ' 1 -4 2 1 0 0 2 .00194'
RECS(110) = ' 1 -4 3 1 0 -1 2 .00015'
RECS(111) = ' 1 -4 4 -1 -1 0 2 .00007'
RECS(112) = ' 1 -4 4 -1 0 0 2 .00037'
RECS(113) = ' 1 -4 5 -1 0 -1 2 .00004'
RECS(114) = ' 1 -3 -1 2 0 1 2 -.00009'
RECS(115) = ' 1 -3 0 0 -2 0 2 -.00004'
RECS(116) = ' 1 -3 0 2 -2 0 2 -.00003'
RECS(117) = ' 1 -3 0 2 -1 0 2 .00125'
RECS(118) = ' 1 -3 0 2 0 0 2 .00664'
RECS(119) = ' 1 -3 1 0 0 1 2 -.00011'
RECS(120) = ' 1 -3 1 1 0 0 2 -.00007'
RECS(121) = ' 1 -3 1 2 0 -1 2 .00010'
RECS(122) = ' 1 -3 2 0 -2 0 2 -.00004'
RECS(123) = ' 1 -3 2 0 -1 0 2 .00151'
RECS(124) = ' 1 -3 2 0 0 0 2 .00801'
RECS(125) = ' 1 -3 2 2 0 0 2 -.00007'
RECS(126) = ' 1 -3 3 0 -1 -1 2 .00010'
RECS(127) = ' 1 -3 3 0 0 -1 2 .00054'
RECS(128) = ' 1 -3 4 -2 -1 0 2 .00005'
RECS(129) = ' 1 -3 4 -2 0 0 2 .00024'
RECS(130) = ' 1 -3 4 0 0 0 2 -.00008'
RECS(131) = ' 1 -3 4 0 1 0 2 .00003'
RECS(132) = ' 1 -2 -2 1 -2 0 2 -.00004'
RECS(133) = ' 1 -2 -2 3 0 0 2 -.00016'
RECS(134) = ' 1 -2 -1 1 -1 1 2 -.00007'
RECS(135) = ' 1 -2 -1 1 0 1 2 -.00042'
RECS(136) = ' 1 -2 0 -1 -3 0 2 -.00004'
RECS(137) = ' 1 -2 0 -1 -2 0 2 -.00019'
RECS(138) = ' 1 -2 0 1 -2 0 2 -.00029'
RECS(139) = ' 1 -2 0 0 0 1 2 .00004'
RECS(140) = ' 1 -2 0 1 -1 0 2 .00947'
RECS(141) = ' 1 -2 0 1 0 0 2 .05019'
RECS(142) = ' 1 -2 0 3 0 0 2 -.00014'
RECS(143) = ' 1 -2 1 -1 0 1 2 -.00009'
RECS(144) = ' 1 -2 1 0 -1 0 2 -.00005'
RECS(145) = ' 1 -2 1 0 0 0 2 -.00027'
RECS(146) = ' 1 -2 1 1 -1 -1 2 .00007'
RECS(147) = ' 1 -2 1 1 0 -1 2 .00046'
RECS(148) = ' 1 -2 2 -1 -2 0 2 -.00005'
RECS(149) = ' 1 -2 2 -1 -1 0 2 .00180'
RECS(150) = ' 1 -2 2 -1 0 0 2 .00953'
RECS(151) = ' 1 -2 2 1 0 0 2 -.00055'
RECS(152) = ' 1 -2 2 1 1 0 2 .00017'
RECS(153) = ' 1 -2 3 -1 -1 -1 2 .00008'
RECS(154) = ' 1 -2 3 -1 0 -1 2 .00044'
RECS(155) = ' 1 -2 3 1 0 -1 2 -.00004'
RECS(156) = ' 1 -2 4 -1 0 0 2 -.00012'
RECS(157) = ' 1 -1 -2 0 -2 0 2 -.00012'
RECS(158) = ' 1 -1 -2 2 -1 0 2 -.00014'
RECS(159) = ' 1 -1 -2 2 0 0 2 -.00079'
RECS(160) = ' 1 -1 -1 0 -1 1 2 -.00011'
RECS(161) = ' 1 -1 -1 0 0 1 2 -.00090'
RECS(162) = ' 1 -1 -1 1 0 0 2 .00004'
RECS(163) = ' 1 -1 0 0 -2 0 2 -.00152'
RECS(164) = ' 1 -1 0 0 -1 0 2 .04946'
RECS(165) = ' 1 -1 0 0 0 0 2 .26216'
RECS(166) = ' 1 -1 0 2 -1 0 2 .00005'
RECS(167) = ' 1 -1 0 2 0 0 2 -.00169'
RECS(168) = ' 1 -1 0 2 1 0 2 -.00028'
RECS(169) = ' 1 -1 1 0 -1 -1 2 .00008'
RECS(170) = ' 1 -1 1 0 0 -1 2 .00076'
RECS(171) = ' 1 -1 2 -2 0 0 2 -.00015'
RECS(172) = ' 1 -1 2 0 -1 0 2 .00010'
RECS(173) = ' 1 -1 2 0 0 0 2 -.00343'
RECS(174) = ' 1 -1 2 0 1 0 2 .00075'
RECS(175) = ' 1 -1 2 0 2 0 2 .00005'
RECS(176) = ' 1 -1 3 0 0 -1 2 -.00022'
RECS(177) = ' 1 -1 4 -2 0 0 2 -.00007'
RECS(178) = ' 1 0 -3 1 0 1 2 -.00009'
RECS(179) = ' 1 0 -2 1 -1 0 2 -.00044'
RECS(180) = ' 1 0 -2 1 0 0 2 -.00193'
RECS(181) = ' 1 0 -1 0 0 0 2 .00005'
RECS(182) = ' 1 0 -1 1 0 1 2 .00010'
RECS(183) = ' 1 0 0 -1 -2 0 2 .00012'
RECS(184) = ' 1 0 0 -1 -1 0 2 -.00137'
RECS(185) = ' 1 0 0 -1 0 0 2 -.00741'
RECS(186) = ' 1 0 0 1 -1 0 2 .00059'
RECS(187) = ' 1 0 0 1 0 0 2 -.02062'
RECS(188) = ' 1 0 0 1 1 0 2 -.00414'
RECS(189) = ' 1 0 0 1 2 0 2 .00012'
RECS(190) = ' 1 0 1 0 0 0 2 .00012'
RECS(191) = ' 1 0 1 1 0 -1 2 -.00013'
RECS(192) = ' 1 0 2 -1 -1 0 2 .00011'
RECS(193) = ' 1 0 2 -1 0 0 2 -.00394'
RECS(194) = ' 1 0 2 -1 1 0 2 -.00087'
RECS(195) = ' 1 0 3 -1 0 -1 2 -.00017'
RECS(196) = ' 1 0 3 -1 1 -1 2 -.00004'
RECS(197) = ' 1 1 -4 0 0 2 2 .00029'
RECS(198) = ' 1 1 -3 0 -1 1 2 -.00006'
RECS(199) = ' 1 1 -3 0 0 1 2 .00713'
RECS(200) = ' 1 1 -2 0 -2 0 2 .00010'
RECS(201) = ' 1 1 -2 0 -1 0 2 -.00137'
RECS(202) = ' 1 1 -2 0 0 0 2 .12199'
RECS(203) = ' 1 1 -2 0 0 2 2 -.00007'
RECS(204) = ' 1 1 -2 2 0 0 2 -.00018'
RECS(205) = ' 1 1 -2 2 1 0 2 -.00004'
RECS(206) = ' 1 1 -1 0 0 -1 2 -.00102'
RECS(207) = ' 1 1 -1 0 0 1 2 -.00288'
RECS(208) = ' 1 1 -1 0 1 1 2 .00008'
RECS(209) = ' 1 1 0 -2 -1 0 2 -.00007'
RECS(210) = ' 1 1 0 0 -2 0 2 -.00005'
RECS(211) = ' 1 1 0 0 -1 0 2 .00730'
RECS(212) = ' 1 1 0 0 0 0 2 -.36872'
RECS(213) = ' 1 1 0 0 1 0 2 -.05002'
RECS(214) = ' 1 1 0 0 2 0 2 .00108'
RECS(215) = ' 1 1 1 0 0 -1 2 -.00292'
RECS(216) = ' 1 1 1 0 1 -1 2 -.00005'
RECS(217) = ' 1 1 2 -2 0 0 2 -.00018'
RECS(218) = ' 1 1 2 -2 1 0 2 -.00005'
RECS(219) = ' 1 1 2 0 0 -2 2 -.00007'
RECS(220) = ' 1 1 2 0 0 0 2 -.00525'
RECS(221) = ' 1 1 2 0 1 0 2 .00020'
RECS(222) = ' 1 1 2 0 2 0 2 .00010'
RECS(223) = ' 1 1 3 0 0 -1 2 -.00030'
RECS(224) = ' 1 2 -3 1 0 1 2 -.00017'
RECS(225) = ' 1 2 -2 -1 -1 0 2 -.00012'
RECS(226) = ' 1 2 -2 1 -1 0 2 .00012'
RECS(227) = ' 1 2 -2 1 0 0 2 -.00394'
RECS(228) = ' 1 2 -2 1 1 0 2 -.00078'
RECS(229) = ' 1 2 -1 -1 0 1 2 -.00013'
RECS(230) = ' 1 2 -1 0 0 0 2 .00011'
RECS(231) = ' 1 2 0 -1 -1 0 2 .00060'
RECS(232) = ' 1 2 0 -1 0 0 2 -.02062'
RECS(233) = ' 1 2 0 -1 1 0 2 -.00409'
RECS(234) = ' 1 2 0 -1 2 0 2 .00008'
RECS(235) = ' 1 2 0 1 0 0 2 .00032'
RECS(236) = ' 1 2 0 1 1 0 2 .00020'
RECS(237) = ' 1 2 0 1 2 0 2 .00012'
RECS(238) = ' 1 2 1 -1 0 -1 2 .00011'
RECS(239) = ' 1 2 2 -1 0 0 2 .00008'
RECS(240) = ' 1 2 2 -1 1 0 2 .00006'
RECS(241) = ' 1 3 -4 2 0 0 2 -.00006'
RECS(242) = ' 1 3 -3 0 0 1 2 -.00023'
RECS(243) = ' 1 3 -3 0 1 1 2 -.00004'
RECS(244) = ' 1 3 -2 0 -1 0 2 -.00011'
RECS(245) = ' 1 3 -2 0 0 0 2 -.00342'
RECS(246) = ' 1 3 -2 0 1 0 2 -.00067'
RECS(247) = ' 1 3 -1 0 0 -1 2 .00007'
RECS(248) = ' 1 3 0 -2 -1 0 2 .00004'
RECS(249) = ' 1 3 0 -2 0 0 2 -.00169'
RECS(250) = ' 1 3 0 -2 1 0 2 -.00034'
RECS(251) = ' 1 3 0 0 0 0 2 -.01128'
RECS(252) = ' 1 3 0 0 1 0 2 -.00723'
RECS(253) = ' 1 3 0 0 2 0 2 -.00151'
RECS(254) = ' 1 3 0 0 3 0 2 -.00010'
RECS(255) = ' 1 3 1 0 0 -1 2 .00004'
RECS(256) = ' 1 4 -4 1 0 0 2 -.00011'
RECS(257) = ' 1 4 -3 -1 0 1 2 -.00004'
RECS(258) = ' 1 4 -2 -1 0 0 2 -.00054'
RECS(259) = ' 1 4 -2 -1 1 0 2 -.00010'
RECS(260) = ' 1 4 -2 1 0 0 2 -.00041'
RECS(261) = ' 1 4 -2 1 1 0 2 -.00026'
RECS(262) = ' 1 4 -2 1 2 0 2 -.00005'
RECS(263) = ' 1 4 0 -3 0 0 2 -.00014'
RECS(264) = ' 1 4 0 -1 0 0 2 -.00216'
RECS(265) = ' 1 4 0 -1 1 0 2 -.00138'
RECS(266) = ' 1 4 0 -1 2 0 2 -.00029'
RECS(267) = ' 2 -4 0 4 0 0 2 .00018'
RECS(268) = ' 2 -4 2 2 0 0 2 .00077'
RECS(269) = ' 2 -4 3 2 0 -1 2 .00006'
RECS(270) = ' 2 -4 4 0 0 0 2 .00048'
RECS(271) = ' 2 -4 5 0 0 -1 2 .00006'
RECS(272) = ' 2 -3 0 3 -1 0 2 -.00007'
RECS(273) = ' 2 -3 0 3 0 0 2 .00180'
RECS(274) = ' 2 -3 1 1 0 1 2 -.00009'
RECS(275) = ' 2 -3 1 3 0 -1 2 .00004'
RECS(276) = ' 2 -3 2 1 -1 0 2 -.00017'
RECS(277) = ' 2 -3 2 1 0 0 2 .00467'
RECS(278) = ' 2 -3 3 1 0 -1 2 .00035'
RECS(279) = ' 2 -3 4 -1 -1 0 2 -.00003'
RECS(280) = ' 2 -3 4 -1 0 0 2 .00090'
RECS(281) = ' 2 -3 5 -1 0 -1 2 .00010'
RECS(282) = ' 2 -2 -2 4 0 0 2 -.00006'
RECS(283) = ' 2 -2 -1 2 0 1 2 -.00022'
RECS(284) = ' 2 -2 0 0 -2 0 2 -.00010'
RECS(285) = ' 2 -2 0 2 -1 0 2 -.00060'
RECS(286) = ' 2 -2 0 2 0 0 2 .01601'
RECS(287) = ' 2 -2 1 0 0 1 2 -.00027'
RECS(288) = ' 2 -2 1 1 0 0 2 -.00017'
RECS(289) = ' 2 -2 1 2 0 -1 2 .00025'
RECS(290) = ' 2 -2 2 0 -1 0 2 -.00072'
RECS(291) = ' 2 -2 2 0 0 0 2 .01932'
RECS(292) = ' 2 -2 3 -1 0 0 2 -.00004'
RECS(293) = ' 2 -2 3 0 -1 -1 2 -.00005'
RECS(294) = ' 2 -2 3 0 0 -1 2 .00130'
RECS(295) = ' 2 -2 4 -2 0 0 2 .00059'
RECS(296) = ' 2 -2 4 0 0 -2 2 .00005'
RECS(297) = ' 2 -2 5 -2 0 -1 2 .00005'
RECS(298) = ' 2 -1 -2 1 -2 0 2 -.00010'
RECS(299) = ' 2 -1 -2 3 0 0 2 -.00039'
RECS(300) = ' 2 -1 -1 1 -1 1 2 .00003'
RECS(301) = ' 2 -1 -1 1 0 1 2 -.00102'
RECS(302) = ' 2 -1 0 -1 -2 0 2 -.00046'
RECS(303) = ' 2 -1 0 1 -2 0 2 .00007'
RECS(304) = ' 2 -1 0 0 0 1 2 .00009'
RECS(305) = ' 2 -1 0 1 -1 0 2 -.00451'
RECS(306) = ' 2 -1 0 1 0 0 2 .12099'
RECS(307) = ' 2 -1 1 -1 0 1 2 -.00023'
RECS(308) = ' 2 -1 1 0 0 0 2 -.00065'
RECS(309) = ' 2 -1 1 1 -1 -1 2 -.00004'
RECS(310) = ' 2 -1 1 1 0 -1 2 .00113'
RECS(311) = ' 2 -1 2 -1 -1 0 2 -.00086'
RECS(312) = ' 2 -1 2 -1 0 0 2 .02298'
RECS(313) = ' 2 -1 2 1 0 0 2 .00010'
RECS(314) = ' 2 -1 2 1 1 0 2 -.00008'
RECS(315) = ' 2 -1 3 -1 -1 -1 2 -.00004'
RECS(316) = ' 2 -1 3 -1 0 -1 2 .00106'
RECS(317) = ' 2 0 -3 2 0 1 2 -.00008'
RECS(318) = ' 2 0 -2 0 -2 0 2 -.00028'
RECS(319) = ' 2 0 -2 2 -1 0 2 .00007'
RECS(320) = ' 2 0 -2 2 0 0 2 -.00190'
RECS(321) = ' 2 0 -1 0 -1 1 2 .00005'
RECS(322) = ' 2 0 -1 0 0 1 2 -.00217'
RECS(323) = ' 2 0 -1 1 0 0 2 .00010'
RECS(324) = ' 2 0 0 0 -2 0 2 .00033'
RECS(325) = ' 2 0 0 0 -1 0 2 -.02358'
RECS(326) = ' 2 0 0 0 0 0 2 .63194'
RECS(327) = ' 2 0 0 2 0 0 2 .00036'
RECS(328) = ' 2 0 0 2 1 0 2 .00013'
RECS(329) = ' 2 0 1 0 -1 -1 2 -.00004'
RECS(330) = ' 2 0 1 0 0 -1 2 .00192'
RECS(331) = ' 2 0 2 -2 0 0 2 -.00036'
RECS(332) = ' 2 0 2 0 0 0 2 .00072'
RECS(333) = ' 2 0 2 0 1 0 2 -.00036'
RECS(334) = ' 2 0 2 0 2 0 2 .00012'
RECS(335) = ' 2 0 3 0 0 -1 2 .00005'
RECS(336) = ' 2 1 -3 1 0 1 2 -.00022'
RECS(337) = ' 2 1 -2 1 -1 0 2 .00021'
RECS(338) = ' 2 1 -2 1 0 0 2 -.00466'
RECS(339) = ' 2 1 -1 -1 0 1 2 -.00007'
RECS(340) = ' 2 1 -1 0 0 0 2 .00010'
RECS(341) = ' 2 1 0 -1 -1 0 2 .00065'
RECS(342) = ' 2 1 0 -1 0 0 2 -.01786'
RECS(343) = ' 2 1 0 1 -1 0 2 -.00008'
RECS(344) = ' 2 1 0 1 0 0 2 .00447'
RECS(345) = ' 2 1 0 1 1 0 2 .00197'
RECS(346) = ' 2 1 0 1 2 0 2 .00028'
RECS(347) = ' 2 1 2 -1 0 0 2 .00085'
RECS(348) = ' 2 1 2 -1 1 0 2 .00041'
RECS(349) = ' 2 1 2 -1 2 0 2 .00005'
RECS(350) = ' 2 2 -4 0 0 2 2 .00070'
RECS(351) = ' 2 2 -3 0 0 1 2 .01719'
RECS(352) = ' 2 2 -2 0 -1 0 2 .00066'
RECS(353) = ' 2 2 -2 0 0 0 2 .29401'
RECS(354) = ' 2 2 -2 2 0 0 2 .00004'
RECS(355) = ' 2 2 -1 0 0 -1 2 -.00246'
RECS(356) = ' 2 2 -1 0 0 1 2 .00062'
RECS(357) = ' 2 2 -1 0 1 1 2 -.00004'
RECS(358) = ' 2 2 0 0 -1 0 2 -.00103'
RECS(359) = ' 2 2 0 0 0 0 2 .07992'
RECS(360) = ' 2 2 0 0 1 0 2 .02382'
RECS(361) = ' 2 2 0 0 2 0 2 .00259'
RECS(362) = ' 2 2 1 0 0 -1 2 .00063'
RECS(363) = ' 2 2 2 -2 0 0 2 .00004'
RECS(364) = ' 2 2 2 0 0 0 2 .00053'
RECS(365) = ' 2 3 -3 1 0 1 2 .00003'
RECS(366) = ' 2 3 -2 -1 -1 0 2 .00006'
RECS(367) = ' 2 3 -2 -1 0 0 2 .00004'
RECS(368) = ' 2 3 -2 1 0 0 2 .00085'
RECS(369) = ' 2 3 -2 1 1 0 2 .00037'
RECS(370) = ' 2 3 -2 1 2 0 2 .00004'
RECS(371) = ' 2 3 0 -1 -1 0 2 -.00009'
RECS(372) = ' 2 3 0 -1 0 0 2 .00447'
RECS(373) = ' 2 3 0 -1 1 0 2 .00195'
RECS(374) = ' 2 3 0 -1 2 0 2 .00022'
RECS(375) = ' 2 3 0 1 0 0 2 -.00003'
RECS(376) = ' 2 4 -3 0 0 1 2 .00005'
RECS(377) = ' 2 4 -2 0 0 0 2 .00074'
RECS(378) = ' 2 4 -2 0 1 0 2 .00032'
RECS(379) = ' 2 4 -2 0 2 0 2 .00003'
RECS(380) = ' 2 4 0 -2 0 0 2 .00037'
RECS(381) = ' 2 4 0 -2 1 0 2 .00016'
RECS(382) = ' 2 4 0 0 0 0 2 .00117'
RECS(383) = ' 2 4 0 0 1 0 2 .00101'
RECS(384) = ' 2 4 0 0 2 0 2 .00033'
RECS(385) = ' 2 4 0 0 3 0 2 .00005'
RECS(386) = ' 0 0 0 1 0 0 3 -.00021'
RECS(387) = ' 0 0 2 -1 0 0 3 -.00004'
RECS(388) = ' 0 1 -2 0 0 0 3 .00004'
RECS(389) = ' 0 1 0 0 -1 0 3 .00019'
RECS(390) = ' 0 1 0 0 0 0 3 -.00375'
RECS(391) = ' 0 1 0 0 1 0 3 -.00059'
RECS(392) = ' 0 1 0 0 2 0 3 .00005'
RECS(393) = ' 0 2 -2 1 0 0 3 -.00012'
RECS(394) = ' 0 2 0 -1 0 0 3 -.00061'
RECS(395) = ' 0 2 0 -1 1 0 3 -.00010'
RECS(396) = ' 0 3 -2 0 0 0 3 -.00010'
RECS(397) = ' 0 3 0 -2 0 0 3 -.00007'
RECS(398) = ' 0 3 0 0 0 0 3 -.00031'
RECS(399) = ' 0 3 0 0 1 0 3 -.00019'
RECS(400) = ' 0 3 0 0 2 0 3 -.00004'
RECS(401) = ' 0 4 0 -1 0 0 3 -.00008'
RECS(402) = ' 0 4 0 -1 1 0 3 -.00005'
RECS(403) = ' 1 -4 0 2 0 0 3 .00006'
RECS(404) = ' 1 -4 2 0 0 0 3 .00006'
RECS(405) = ' 1 -3 0 1 -1 0 3 .00014'
RECS(406) = ' 1 -3 0 1 0 0 3 .00035'
RECS(407) = ' 1 -3 2 -1 0 0 3 .00006'
RECS(408) = ' 1 -2 0 0 -2 0 3 .00004'
RECS(409) = ' 1 -2 0 0 -1 0 3 .00051'
RECS(410) = ' 1 -2 0 0 0 0 3 .00128'
RECS(411) = ' 1 -2 0 2 0 0 3 .00008'
RECS(412) = ' 1 -2 2 0 0 0 3 .00011'
RECS(413) = ' 1 -1 0 -1 0 0 3 -.00007'
RECS(414) = ' 1 -1 0 1 -1 0 3 -.00009'
RECS(415) = ' 1 -1 0 1 0 0 3 .00065'
RECS(416) = ' 1 -1 0 1 1 0 3 -.00009'
RECS(417) = ' 1 -1 2 -1 0 0 3 .00013'
RECS(418) = ' 1 0 0 0 -1 0 3 -.00059'
RECS(419) = ' 1 0 0 0 0 0 3 .00399'
RECS(420) = ' 1 0 0 0 1 0 3 -.00052'
RECS(421) = ' 1 1 -2 1 0 0 3 .00004'
RECS(422) = ' 1 1 0 -1 -1 0 3 -.00003'
RECS(423) = ' 1 1 0 -1 0 0 3 .00022'
RECS(424) = ' 1 1 0 -1 1 0 3 -.00003'
RECS(425) = ' 1 1 0 1 0 0 3 .00008'
RECS(426) = ' 1 1 0 1 1 0 3 .00003'
RECS(427) = ' 1 2 -2 0 0 0 3 .00005'
RECS(428) = ' 1 2 0 0 -1 0 3 -.00005'
RECS(429) = ' 1 2 0 0 0 0 3 .00146'
RECS(430) = ' 1 2 0 0 1 0 3 .00059'
RECS(431) = ' 1 2 0 0 2 0 3 .00005'
RECS(432) = ' 1 3 -2 1 0 0 3 .00005'
RECS(433) = ' 1 3 0 -1 0 0 3 .00024'
RECS(434) = ' 1 3 0 -1 1 0 3 .00010'
RECS(435) = ' 1 4 -2 0 0 0 3 .00004'
RECS(436) = ' 1 4 0 0 0 0 3 .00005'
RECS(437) = ' 1 4 0 0 1 0 3 .00005'
RECS(438) = ' 2 -4 2 1 0 0 3 -.00006'
RECS(439) = ' 2 -3 0 2 0 0 3 -.00019'
RECS(440) = ' 2 -3 2 0 -1 0 3 -.00003'
RECS(441) = ' 2 -3 2 0 0 0 3 -.00019'
RECS(442) = ' 2 -2 0 1 -1 0 3 -.00018'
RECS(443) = ' 2 -2 0 1 0 0 3 -.00107'
RECS(444) = ' 2 -2 2 -1 -1 0 3 -.00003'
RECS(445) = ' 2 -2 2 -1 0 0 3 -.00020'
RECS(446) = ' 2 -1 0 0 -2 0 3 .00004'
RECS(447) = ' 2 -1 0 0 -1 0 3 -.00066'
RECS(448) = ' 2 -1 0 0 0 0 3 -.00389'
RECS(449) = ' 2 -1 0 2 0 0 3 .00007'
RECS(450) = ' 2 -1 2 0 0 0 3 .00010'
RECS(451) = ' 2 0 -2 1 0 0 3 .00005'
RECS(452) = ' 2 0 0 -1 -1 0 3 .00004'
RECS(453) = ' 2 0 0 -1 0 0 3 .00022'
RECS(454) = ' 2 0 0 1 -1 0 3 -.00003'
RECS(455) = ' 2 0 0 1 0 0 3 .00059'
RECS(456) = ' 2 0 0 1 1 0 3 .00011'
RECS(457) = ' 2 0 2 -1 0 0 3 .00011'
RECS(458) = ' 2 1 0 0 -1 0 3 -.00021'
RECS(459) = ' 2 1 0 0 0 0 3 .00359'
RECS(460) = ' 2 1 0 0 1 0 3 .00067'
RECS(461) = ' 2 2 -2 1 0 0 3 .00004'
RECS(462) = ' 2 2 0 -1 0 0 3 .00019'
RECS(463) = ' 2 2 0 -1 1 0 3 .00004'
RECS(464) = ' 2 3 -2 0 0 0 3 .00004'
RECS(465) = ' 2 3 0 0 0 0 3 .00033'
RECS(466) = ' 2 3 0 0 1 0 3 .00021'
RECS(467) = ' 2 3 0 0 2 0 3 .00004'
RECS(468) = ' 2 4 0 -1 0 0 3 .00005'
RECS(469) = ' 3 -2 0 2 0 0 3 -.00036'
RECS(470) = ' 3 -2 2 0 0 0 3 -.00036'
RECS(471) = ' 3 -1 0 1 -1 0 3 .00012'
RECS(472) = ' 3 -1 0 1 0 0 3 -.00210'
RECS(473) = ' 3 -1 2 -1 0 0 3 -.00039'
RECS(474) = ' 3 0 -2 2 0 0 3 .00005'
RECS(475) = ' 3 0 0 0 -1 0 3 .00043'
RECS(476) = ' 3 0 0 0 0 0 3 -.00765'
RECS(477) = ' 3 1 -2 1 0 0 3 .00011'
RECS(478) = ' 3 1 0 -1 0 0 3 .00043'
RECS(479) = ' 3 1 0 1 0 0 3 -.00016'
RECS(480) = ' 3 1 0 1 1 0 3 -.00007'
RECS(481) = ' 3 2 0 0 -1 0 3 .00004'
RECS(482) = ' 3 2 0 0 0 0 3 -.00100'
RECS(483) = ' 3 2 0 0 1 0 3 -.00044'
RECS(484) = ' 3 2 0 0 2 0 3 -.00005'
END SUBROUTINE INIHARMONICS
end module timespace_data
!
!
!
! ==========================================================================
! ==========================================================================
! ==========================================================================
!>
Module M_arcuv ! plotbuitenbeentje
implicit none
double precision, allocatable :: arcuv(:,:,:)
End module M_arcuv
!
!
!
! ==========================================================================
! ==========================================================================
! ==========================================================================
!>
module m_spiderweb ! plot spiderweb
implicit none
double precision, allocatable :: spw(:,:,:)
end module m_spiderweb
!
!
!
! ==========================================================================
! ==========================================================================
! ==========================================================================
!>
!!--description-----------------------------------------------------------------
! NONE
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
module timespace_triangle
use precision
use timespace_data
use m_alloc
implicit none
integer :: nsold ! nr of samples in previous triangulation
integer :: numtri
integer , allocatable, dimension(:, :) :: indx
double precision, allocatable, dimension(:) :: xcent
double precision, allocatable, dimension(:) :: ycent
interface triint
module procedure triint_z1D
module procedure triint_z2D
module procedure triint_z3D
end interface triint
interface get_extend
module procedure get_extend1D
module procedure get_extend2D
end interface get_extend
interface find_nearest
module procedure find_nearest1D
module procedure find_nearest2D
module procedure find_nearest1D_missing_value
module procedure find_nearest2D_missing_value
end interface find_nearest
contains
!
!
! ==========================================================================
!>
subroutine pinpok(xl, yl, n, x, y, inside)
! Author: H. Kernkamp
implicit none
double precision , intent(in) :: xl, yl ! point under consideration
integer , intent(in) :: n
double precision, dimension(n), intent(in) :: x, y ! polygon(n)
integer , intent(out) :: inside
integer :: i, i1, i2, np, rechts
double precision :: rl, rm, x1, x2, y1, y2
if (n .le. 2) then
inside = 1
else
np = 0
5 continue
np = np + 1
if (np .le. n) then
if ( x(np) .ne. dmiss_default) goto 5
end if
np = np - 1
inside = 0
rechts = 0
i = 0
10 continue
i1 = mod(i,np) + 1
i2 = mod(i1,np) + 1
x1 = x(i1)
x2 = x(i2)
y1 = y(i1)
y2 = y(i2)
if (xl .ge. min(x1,x2) .and. xl .le. max(x1,x2) ) then
if (xl .eq. x1 .and. yl .eq. y1 .or. & ! tussen of op lijnstuk
(x1 .eq. x2 .and. & ! op punt 1
yl .ge. min(y1,y2) .and. yl .le. max(y1,y2) ) .or. & ! op verticale lijn
(yl .eq. y1 .and. y1 .eq. y2) ) then ! op horizontale lijn
inside = 1
return
else if (x1 .ne. x2) then ! scheve lijn
rl = ( xl - x1 ) / ( x2 - x1 )
rm = ( y1 - yl ) + rl * ( y2 - y1 )
if (rm .eq. 0) then ! op scheve lijn
inside = 1
return
else if (rm .gt. 0d0) then ! onder scheve lijn
if (xl .eq. x1 .or. xl .eq. x2) then
if (x1 .gt. xl .or. x2 .gt. xl) then
rechts = rechts + 1
end if
end if
inside = 1 - inside
end if
end if
end if
i = i + 1
if (i .lt. np) goto 10
if (mod(rechts,2) .ne. 0) inside = 1 - inside
end if
end subroutine pinpok
!
!
! ==========================================================================
!>
! This subroutine interpolates one unstructured dataset xss, yss, zss, kcss, nss to another x, y, z, kcs, nx
! It is the only one in this module that is of practical interest to the meteo module.
! The rest of the subroutines in this module are assisting this one.
! JDLA = 1 (re)triangulates
subroutine triint_z2D( xss, yss, zss, kcsss, nss, &
x , y , z , kcs , kx , mnx, jdla , indxn, wfn )
implicit none
! Global variables
integer, intent(in) :: nss ! Dimension of samples
double precision, dimension(:), intent(in) :: xss ! samples
double precision, dimension(:), intent(in) :: yss
double precision, dimension(:), intent(in) :: zss ! dimension: nss*kx
integer , dimension(:), intent(in) :: kcsss ! samples mask
integer, intent(in) :: mnx ! Dimension of grid
integer, intent(in) :: kx ! vectormax
double precision, dimension(:), intent(in) :: x ! grid
double precision, dimension(:), intent(in) :: y
double precision, dimension(:,:), intent(out) :: z ! dimension: nx*kx
integer , dimension(:), intent(in) :: kcs ! grid mask
integer, intent(in) :: jdla ! refresh delauney yes /no
integer , optional :: indxn(:,:) ! if present get weightfactors and indices
double precision, optional :: wfn (:,:)
call triint_z1D( xss, yss, zss, kcsss, nss, &
x , y , z , kcs , kx , mnx, jdla, indxn, wfn )
end subroutine triint_z2D
!
!
! ==========================================================================
!>
subroutine triint_z3D( xss, yss, zss, kcsss, nss, &
x , y , z , kcs , kx , mnx, jdla, indxn, wfn )
implicit none
! Global variables
integer, intent(in) :: nss ! Dimension of samples
double precision, dimension(:), intent(in) :: xss ! samples
double precision, dimension(:), intent(in) :: yss
double precision, dimension(:), intent(in) :: zss ! dimension: nss*kx
integer , dimension(:), intent(in) :: kcsss ! samples mask
integer, intent(in) :: mnx ! Dimension of grid
integer, intent(in) :: kx ! vectormax
double precision, dimension(:), intent(in) :: x ! grid
double precision, dimension(:), intent(in) :: y
double precision, dimension(:,:,:), intent(out) :: z ! dimension: nx*kx
integer , dimension(:), intent(in) :: kcs ! grid mask
integer, intent(in) :: jdla ! refresh delauney yes /no
integer , optional :: indxn(:,:) ! if present get weightfactors and indices
double precision, optional :: wfn (:,:)
call triint_z1D( xss, yss, zss, kcsss, nss, &
x , y , z , kcs , kx , mnx, jdla, indxn, wfn )
end subroutine triint_z3D
!
!
! ==========================================================================
!>
subroutine triint_z1D( xss, yss, zss, kcsss, nss, &
x , y , z , kcs , kx , mnx, jdla, indxn, wfn )
use m_ec_basic_interpolation, only: dlaun
implicit none
! Global variables
integer, intent(in) :: nss ! Dimension of samples
double precision, dimension(:), intent(in) :: xss ! samples
double precision, dimension(:), intent(in) :: yss
double precision, dimension(:), intent(in) :: zss ! dimension: nss*kx
integer , dimension(:), intent(in) :: kcsss ! samples mask
integer, intent(in) :: mnx ! Dimension of grid
integer, intent(in) :: kx ! vectormax
double precision, dimension(:), intent(in) :: x ! grid
double precision, dimension(:), intent(in) :: y
double precision, dimension(kx*mnx), intent(out):: z ! dimension: mnx*kx
integer , dimension(:), intent(in) :: kcs ! grid mask
integer, intent(in) :: jdla ! refresh delauney yes /no
integer , optional :: indxn(:,:) ! if present get weightfactors and indices
double precision, optional :: wfn (:,:)
! Local variables
double precision, dimension(8) :: x_set
double precision, dimension(8) :: y_set
integer , dimension(8) :: kcs_set = 1
double precision, dimension(4) :: x_extr
double precision, dimension(4) :: y_extr
double precision, dimension(4) :: z_extr
double precision, dimension(3) :: zp
integer , dimension(3) :: indxp
double precision, dimension(:), allocatable :: xs
double precision, dimension(:), allocatable :: ys
double precision, dimension(:), allocatable :: zs
integer , dimension(:), allocatable :: kcss
integer :: ns
integer :: k, n, jgetw, ierr ! , MOUT
logical :: extra = .false. ! nu even niet
!! executable statements -------------------------------------------------------
!
! JDLA=1, DO DE LAUNEY
! JSLO=1, ALSO SLOPES RD4
if (nss<1) then
return
end if
call realloc(xs,nss+8,1)
call realloc(ys,nss+8,1)
call realloc(zs,nss+8,1)
call realloc(kcss,nss+8,1)
ns = 0
do k = 1,nss
if (kcsss(k) == 1) then
ns = ns + 1
xs(ns) = xss(k)
ys(ns) = yss(k)
do n = 1,kx
zs(kx*(ns-1)+n) = zss(kx*(k-1)+n)
enddo
kcss(ns) = 1
end if
enddo
if (extra) then
call get_extend(mnx, x, y, kcs, x_set(1:4), y_set(1:4))
call get_extend(ns, xs, ys, kcss, x_set(5:8), y_set(5:8))
call get_extend(8, x_set, y_set, kcs_set, x_extr, y_extr)
call extrapolate(ns, xs, ys, zs, kcss, 4, x_extr, y_extr, z_extr)
xs(ns + 1:ns + 4) = x_extr
ys(ns + 1:ns + 4) = y_extr
zs(ns + 1:ns + 4) = z_extr
ns = ns + 4
end if
if (jdla==1) then
! call dlauny(xs, ys, ns)
call DLAUN(XS,YS,NS,1,ierr)
end if
jgetw = 0 ! niets met gewichten, doe interpolatie
if ( present(indxn) .and. jdla .eq. 1) jgetw = 1 ! haal gewichten doe interpolatie , gebruik gewichten
if ( present(indxn) .and. jdla .eq. 0) jgetw = 2 ! doe interpolatie , gebruik gewichten
do n = 1,mnx
if (kcs(n) .eq. 1) then
if (jgetw .le. 1) then
call findtri_indices_weights (x(n),y( n), xs, ys, ns, zp, indxp) ! zoeken bij 0 en 1
end if
if (jgetw .eq. 1) then ! zetten bij 1
do k = 1,3
indxn(k,n) = indxp(k)
wfn(k,n) = zp(k)
enddo
else if (jgetw .eq. 2) then ! halen bij 2, je hoeft niet te zoeken
do k = 1,3
indxp(k) = indxn(k,n)
zp(k) = wfn(k,n)
enddo
end if
! en altijd interpoleren
do k = 1,kx ! over vectormax loop
if (indxp(1)==0 .or. indxp(2)==0 .or. indxp(3)==0 ) then
! z(mnx*(k-1) + n) = -999
else
z(mnx*(k-1) + n) = zp(1)*zs(kx*(indxp(1)-1)+k) + zp(2)*zs(kx*(indxp(2)-1)+k) + zp(3)*zs(kx*(indxp(3)-1)+k)
end if
enddo
end if
enddo
deallocate(xs)
deallocate(ys)
deallocate(zs)
deallocate(kcss)
end subroutine triint_z1D
!
!
! ==========================================================================
!>
subroutine findtri_indices_weights(xp, yp, xs, ys, ns, zp, indxp)
implicit none
! Global variables
double precision, intent(in) :: xp ! for this point
double precision, intent(in) :: yp
integer , intent(in) :: ns
double precision, dimension(ns), intent(in) :: xs ! on this set
double precision, dimension(ns), intent(in) :: ys
integer , dimension(3) , intent(out) :: indxp ! find indices to set
double precision, dimension(3) , intent(out) :: zp ! and corresponding weightfactors
! Local variables
integer :: k
integer :: k1
integer :: k2, n3
integer :: intri
integer :: nroldfind, nrfind
double precision :: xtmax
double precision :: xtmin
double precision :: ytmax
double precision :: ytmin
double precision, dimension(3) :: xt
double precision, dimension(3) :: yt
!
!
data nroldfind/0/
!
!! executable statements -------------------------------------------------------
!
!
indxp = 0
n3 = 3
5 continue
if (nroldfind/=0) then
k1 = max(1, nroldfind - 200)
k2 = min(numtri, nroldfind + 200)
else
k1 = 1
k2 = numtri
end if
!
do k = k1, k2
xt(1) = xs(indx(1, k))
xt(2) = xs(indx(2, k))
xt(3) = xs(indx(3, k))
yt(1) = ys(indx(1, k))
yt(2) = ys(indx(2, k))
yt(3) = ys(indx(3, k))
xtmax = max(xt(1), max(xt(2), xt(3)))
ytmax = max(yt(1), max(yt(2), yt(3)))
xtmin = min(xt(1), min(xt(2), xt(3)))
ytmin = min(yt(1), min(yt(2), yt(3)))
if (xp>=xtmin .and. xp<=xtmax .and. yp>=ytmin .and. yp<=ytmax) then
call pinpok(xp ,yp, n3, xt, yt, intri)
if (intri==1) then
nrfind = k
nroldfind = nrfind
indxp(1) = indx(1, k)
indxp(2) = indx(2, k)
indxp(3) = indx(3, k)
call linweight(xt ,yt ,xp ,yp, zp)
! write(*,*) xp, yp, k, indxp(1), indxp(2), indxp(3)
return
end if
end if
enddo
if (nroldfind/=0) then
nroldfind = 0
goto 5
end if
end subroutine findtri_indices_weights
!
!
! ==========================================================================
!>
subroutine linweight(xt ,yt ,xp ,yp, zp)
double precision, intent(in) :: xp ! for this point
double precision, intent(in) :: yp
double precision, dimension(3) :: xt ! in this triangle
double precision, dimension(3) :: yt
double precision, dimension(3) , intent(out) :: zp ! the weightfactors are...
double precision :: a11, a12, a21, a22, b1, b2, det
zp = 0
a11 = xt(2) - xt(1)
a21 = yt(2) - yt(1)
a12 = xt(3) - xt(1)
a22 = yt(3) - yt(1)
b1 = xp - xt(1)
b2 = yp - yt(1)
det = a11*a22 - a12*a21
if (abs(det)<1E-9) then
return
end if
!
zp(2) = ( a22*b1 - a12*b2)/det
zp(3) = ( -a21*b1 + a11*b2)/det
zp(1) = 1d0 - zp(2) - zp(3)
end subroutine linweight
!
!
! ==========================================================================
!>
subroutine linear(x ,y ,z ,xp ,yp , &
& zp ,jslo ,slo )
use precision
implicit none
!
!
! COMMON variables
!
double precision :: dmiss
data dmiss /-999d0/
!
! Global variables
!
integer, intent(in) :: jslo
double precision, intent(out) :: slo
double precision :: xp
double precision :: yp
double precision :: zp
double precision, dimension(3) :: x
double precision, dimension(3) :: y
double precision, dimension(3), intent(in) :: z
!
!
! Local variables
!
double precision :: a11
double precision :: a12
double precision :: a21
double precision :: a22
double precision :: a31
double precision :: a32
double precision :: b1
double precision :: b2
double precision :: det
double precision :: r3
double precision :: rlam
double precision :: rmhu
double precision :: x3
double precision :: xn
double precision :: xy
double precision :: y3
double precision :: yn
double precision :: z3
double precision :: zn
!
!
!! executable statements -------------------------------------------------------
!
!
!
!
!
zp = dmiss
a11 = x(2) - x(1)
a21 = y(2) - y(1)
a12 = x(3) - x(1)
a22 = y(3) - y(1)
b1 = xp - x(1)
b2 = yp - y(1)
!
det = a11*a22 - a12*a21
if (abs(det)<1E-12) then ! Jan Mooiman 07-01-2015
return
end if
!
rlam = (a22*b1 - a12*b2)/det
rmhu = ( - a21*b1 + a11*b2)/det
!
zp = z(1) + rlam*(z(2) - z(1)) + rmhu*(z(3) - z(1))
if (jslo==1) then
a31 = z(2) - z(1)
a32 = z(3) - z(1)
x3 = (a21*a32 - a22*a31)
y3 = -(a11*a32 - a12*a31)
z3 = (a11*a22 - a12*a21)
r3 = sqrt(x3*x3 + y3*y3 + z3*z3)
if (r3/=0) then
xn = x3/r3
yn = y3/r3
zn = z3/r3
xy = sqrt(xn*xn + yn*yn)
if (zn/=0) then
slo = abs(xy/zn)
else
slo = dmiss
end if
else
slo = dmiss
end if
end if
end subroutine linear
!
!
! ==========================================================================
!>
subroutine minmax_h(x, n, xmin, xmax ) ! BEPAAL MINIMUM EN MAXIMUM VAN EEN EENDIMENSIONALE ARRAY
use precision
implicit none
! Global variables
integer, intent(in) :: n
double precision, dimension(n), intent(in) :: x
double precision :: xmax
double precision :: xmin
integer :: i
xmin = 1E30
xmax = -1E30
do i = 1, n
xmin = min(xmin, x(i))
xmax = max(xmax, x(i))
enddo
end subroutine minmax_h
!
!
! ==========================================================================
!>
subroutine get_extend2D(n, m, x, y, kcs, x_ext, y_ext)
double precision, dimension(:,:) :: x
double precision, dimension(:,:) :: y
integer , dimension(:,:) :: kcs
integer :: n
integer :: m
double precision, dimension(:) :: x_ext
double precision, dimension(:) :: y_ext
call get_extend1D(n*m, x, y, kcs, x_ext, y_ext)
end subroutine get_extend2D
!
!
! ==========================================================================
!>
subroutine get_extend1D(n, x, y, kcs, x_ext, y_ext)
integer :: n
double precision, dimension(n) :: x
double precision, dimension(n) :: y
integer , dimension(n) :: kcs
double precision, dimension(4) :: x_ext
double precision, dimension(4) :: y_ext
double precision :: x_min
double precision :: x_max
double precision :: x_dist
double precision :: y_min
double precision :: y_max
double precision :: y_dist
integer :: index
x_min = 1E30
x_max = -1E30
y_min = 1E30
y_max = -1E30
do index = 1, n
if(kcs(index) == 1) then
if(x_min > x(index)) then
x_min = x(index)
end if
if(x_max < x(index)) then
x_max = x(index)
end if
if(y_min > y(index)) then
y_min = y(index)
end if
if(y_max < y(index)) then
y_max = y(index)
end if
end if
enddo
x_dist = x_max - x_min
y_dist = y_max - y_min
x_min = x_min - 0.01d0*x_dist
x_max = x_max + 0.01d0*x_dist
y_min = y_min - 0.01d0*y_dist
y_max = y_max + 0.01d0*y_dist
x_ext(1) = x_min
y_ext(1) = y_min
x_ext(2) = x_min
y_ext(2) = y_max
x_ext(3) = x_max
y_ext(3) = y_max
x_ext(4) = x_max
y_ext(4) = y_min
end subroutine get_extend1D
!
!
! ==========================================================================
!>
subroutine extrapolate(n, x, y, z, kcs, n_extr, x_extr, y_extr, z_extr)
integer :: n
double precision, dimension(n) :: x
double precision, dimension(n) :: y
double precision, dimension(n) :: z
integer , dimension(n) :: kcs
integer :: n_extr
double precision, dimension(n_extr), target :: x_extr
double precision, dimension(n_extr), target :: y_extr
double precision, dimension(n_extr), target :: z_extr
integer :: i_extr
integer :: i_min
double precision, pointer :: x_a
double precision, pointer :: y_a
double precision, pointer :: z_a
double precision :: dist_min
dist_min = 1E30
i_min = 0
do i_extr = 1, n_extr
x_a => x_extr(i_extr)
y_a => y_extr(i_extr)
z_a => z_extr(i_extr)
call find_nearest(n, x, y, z, kcs, x_a, y_a, i_min, dist_min)
z_a = z(i_min)
enddo
end subroutine extrapolate
!
!
! ==========================================================================
!>
subroutine find_nearest2D(n, m, x, y, kcs, x_a, y_a, n_min, m_min, dist_min)
use precision
integer :: n
integer :: m
double precision, dimension(:,:) :: x
double precision, dimension(:,:) :: y
integer , dimension(:,:) :: kcs
integer :: n_min
integer :: m_min
integer :: i_min
double precision :: x_a
double precision :: y_a
double precision :: dist_min
call find_nearest1D(n*m, x, y, kcs, x_a, y_a, i_min, dist_min)
m_min = i_min/n
n_min = i_min - (m_min * n)
m_min = m_min + 1
end subroutine find_nearest2D
!
!
! ==========================================================================
!>
subroutine find_nearest2D_missing_value(n, m, x, y, z, kcs, x_a, y_a, n_min, m_min, dist_min)
use precision
integer :: n
integer :: m
double precision, dimension(:,:) :: x
double precision, dimension(:,:) :: y
double precision, dimension(:,:) :: z
integer , dimension(:,:) :: kcs
integer :: n_min
integer :: m_min
integer :: i_min
double precision :: x_a
double precision :: y_a
double precision :: dist_min
call find_nearest1D_missing_value(n*m, x, y, z, kcs, x_a, y_a, i_min, dist_min)
m_min = i_min/n
n_min = i_min - (m_min * n)
m_min = m_min + 1
end subroutine find_nearest2D_missing_value
!
!
! ==========================================================================
!>
subroutine find_nearest1D(n, x, y, kcs, x_a, y_a, i_min, dist_min)
use precision
integer :: n
double precision, dimension(n) :: x
double precision, dimension(n) :: y
integer , dimension(n) :: kcs
integer :: i
integer :: i_min
double precision :: x_a
double precision :: y_a
double precision :: dist
double precision :: dist_min
dist_min = 1E30
i_min = 0
do i = 1, n
if(kcs(i) == 1) then
dist = (x(i)-x_a)**2 + (y(i)-y_a)**2
if(dist < dist_min) then
dist_min = dist
i_min = i
end if
end if
enddo
dist_min = sqrt(dist_min)
end subroutine find_nearest1D
!
!
! ==========================================================================
!>
subroutine find_nearest1D_missing_value(n, x, y, z, kcs, x_a, y_a, i_min, dist_min)
use precision
integer :: n
double precision, dimension(n) :: x
double precision, dimension(n) :: y
double precision, dimension(n) :: z
integer , dimension(n) :: kcs
integer :: i
integer :: i_min
double precision :: x_a
double precision :: y_a
double precision :: dist
double precision :: dist_min
dist_min = 1E30
i_min = 0
do i = 1, n
if(kcs(i) == 1) then
dist = (x(i)-x_a)**2 + (y(i)-y_a)**2
if((dist < dist_min).and.(z(i)/=-999d0)) then
dist_min = dist
i_min = i
end if
end if
enddo
dist_min = sqrt(dist_min)
end subroutine find_nearest1D_missing_value
!
!
! ==========================================================================
!>
subroutine xxpolyint( xs, ys, zs ,kcs, ns, & ! interpolate in a polyline like way
x , y ,z ,kc , kx , mnx, jintp, xyen, indxn, wfn)
implicit none
! Global variables
integer, intent(in) :: ns !< Dimension of polygon OR LINE BOUNDARY
double precision, dimension(:), intent(in) :: xs !< polyline point coordinates
double precision, dimension(:), intent(in) :: ys
double precision, dimension(:), intent(in) :: zs !< Values at all points. Dimension: ns*kx
integer, dimension(:), intent(in) :: kcs !< polyline mask
integer, intent(in) :: mnx !< Dimension of target points
integer, intent(in) :: kx !< #values at each point (vectormax)
double precision, dimension(:), intent(in) :: x !< Grid points (where to interpolate to)
double precision, dimension(:), intent(in) :: y
double precision, dimension(kx*mnx), intent(out) :: z !< Output array for interpolated values. Dimension: mnx*kx
integer , dimension(:), intent(in) :: kc !< Target (grid) points mask
integer, intent(in) :: jintp !< (Re-)interpolate if 1 (otherwise use index weights)
double precision, dimension(:,:), intent(in) :: xyen !< cellsize / tol
integer, dimension(:,:), intent(inout), optional :: indxn !< pli segment is identified by its first node nr.
double precision, dimension(:,:), intent(inout), optional :: wfn !< If present, get weight index and factor
! locals
double precision:: wL, wR
integer :: m, k, kL, kR, jgetw
jgetw = 0 ! niets met gewichten, doe interpolatie
if ( present(indxn) .and. jintp .eq. 1) jgetw = 1 ! haal gewichten doe interpolatie , gebruik gewichten
if ( present(indxn) .and. jintp .eq. 0) jgetw = 2 ! doe interpolatie , gebruik gewichten
do m = 1, mnx
if (jgetw .le. 1) then
!call polyindexweight( x(m), y(m), xs, ys, kcs, ns, xyen(:,m), k1, rl) ! interpolate in a polyline like way
call polyindexweight( x(m), y(m), xyen(1,m), xyen(2,m), xs, ys, kcs, ns, kL, wL, kR, wR) ! interpolate in a polyline like way
!call findtri_indices_weights (x(n),y( n), xs, ys, ns, zp, indxp) ! zoeken bij 0 en 1
if (jgetw .eq. 1) then ! zetten bij 1
indxn(1,m) = kL
wfn(1,m) = wL
indxn(2,m) = kR
wfn(2,m) = wR
end if
elseif (jgetw .eq. 2) then ! halen bij 2, je hoeft niet te zoeken
kL = indxn(1,m)
wL = wfn(1,m)
kR = indxn(2,m)
wR = wfn(2,m)
end if
! Now do the actual interpolation of data zs -> z
if (kL > 0) then
if (kR > 0) then
do k = 1,kx
z(kx*(m-1)+k) = wL*zs(kx*(kL-1)+k) + wR*zs(kx*(kR-1)+k)
end do
else ! Just left point
do k = 1,kx
z(kx*(m-1)+k) = wL*zs(kx*(kL-1)+k)
end do
end if
else if (kR > 0) then
do k = 1,kx
z(kx*(m-1)+k) = wR*zs(kx*(kR-1)+k)
end do
end if
enddo
end subroutine xxpolyint
!
! ==========================================================================
!>
!subroutine polyindexweight( xe, ye, xs, ys, kcs, ns, xyen, k1, rl) ! interpolate in a polyline like way
!
! ! Global variables
! integer , intent(in) :: ns ! Dimension of polygon OR LINE BOUNDARY
! double precision, dimension(:), intent(in) :: xs ! polygon
! double precision, dimension(:), intent(in) :: ys
! integer, dimension(:), intent(in) :: kcs ! polygon mask
! double precision :: xyen(:)
! double precision :: xe, ye, rl
!
!
! integer :: ja1, ja2, k, km, k1, k2
! double precision:: x1,x2,y1,y2,dis,xn,yn,dx,dy
! double precision:: dism, dis1, dis2, rl1, rl2, dbdistance
!
!
! dism = 1e30
! do k = 1, ns
! dis = DbdISTANCE( Xe,Ye,XS(K),YS(K) )
! if (dis < dism) then
! dism = dis
! km = k
! end if
! enddo
!
! k1 = 0
!
! if (km == 1) then
! x1 = xs(km ); y1 = ys(km )
! x2 = xs(km+1); y2 = ys(km+1)
! call LINEDISQ(Xe,Ye,X1,Y1,X2,Y2,JA1,DIS1,XN,YN,RL)
! if (ja1 == 1) then
! if (dis1 < rdis) k1 = km
! end if
! else if (km == ns) then
! x1 = xs(km-1); y1 = ys(km-1)
! x2 = xs(km ); y2 = ys(km )
! call LINEDISQ(Xe,Ye,X1,Y1,X2,Y2,JA1,DIS1,XN,YN,RL)
! if (ja1 == 1) then
! if (dis1 < rdis) k1 = km-1
! end if
! else
! x1 = xs(km-1); y1 = ys(km-1)
! x2 = xs(km) ; y2 = ys(km)
! call LINEDISQ(Xe,Ye,X1,Y1,X2,Y2,JA1,DIS1,XN,YN,RL1)
! x1 = xs(km) ; y1 = ys(km)
! x2 = xs(km+1); y2 = ys(km+1)
! call LINEDISQ(Xe,Ye,X1,Y1,X2,Y2,JA2,DIS2,XN,YN,RL2)
! if (ja1 == 1) then ! if on line 1
! if (dis1 < rdis) then
! k1 = km-1 ; rl = rl1
! end if
! else if (ja2 == 1) then
! if (dis2 < rdis) then
! k1 = km ; rl = rl2
! end if
! else ! niet op een van beiden, maar wel in de buurt, uitwerken. Nu dus alleen convexe randen
! end if
! end if
!
!end subroutine polyindexweight
!
!
! ==========================================================================
!>
!> Selects the index of the polyline segment that intersects with line e--en
!! with the intersection closest to point e.
!! The search range is thus from e to en, and not a distance rdis as before.
!! The normal direction is now
!! defined by e--en and not normal to the polyline. Also, *all* polyline
!! segments are checked, not the closest based on dbdistance of pli points.
subroutine polyindexweight( xe, ye, xen, yen, xs, ys, kcs, ns, kL, wL, kR, wR)
use m_sferic
use geometry_module, only: dbdistance, cross
use m_missing, only: dmiss
! Global variables
integer , intent(in) :: ns !< Dimension of polygon OR LINE BOUNDARY
double precision, intent(in) :: xs(:) !< polygon
double precision, intent(in) :: ys(:)
integer , intent(in) :: kcs(:) !< polygon mask
double precision, intent(in) :: xe, ye !
double precision, intent(in) :: xen, yen !< in input uitstekers, on output SL and CRP
integer , intent(out) :: kL !< Index of left nearest polyline point (with kcs==1!)
double precision, intent(out) :: wL !< Relative weight of left nearest polyline point.
integer , intent(out) :: kR !< Index of right nearest polyline point (with kcs==1!)
double precision, intent(out) :: wR !< Relative weight of right nearest polyline point.
integer :: k, km, JACROS
double precision :: dis, disM, disL, disR !, rl1, rl2,
double precision :: SL,SM,SMM,SLM,XCR,YCR,CRP,CRPM,DEPS
DISM = huge(DISM)
kL = 0 ! Default: No valid point found
kR = 0 ! idem
wL = 0d0
wR = 0d0
km = 0
crpm = 0
disL = 0d0
disR = 0d0
DEPS = 1d-3
do k = 1, ns-1
call cross(xe, ye, xen, yen, xs(k), ys(k), xs(k+1), ys(k+1), JACROS,SL,SM,XCR,YCR,CRP,jsferic, dmiss)
if (SL >= 0d0 .AND. SL <= 1D0 .AND. SM > -DEPS .AND. SM < 1.0D0+DEPS) then ! instead of jacros==1, solves firmijn's problem
DIS = DBDISTANCE(XE,YE, XCR, YCR, jsferic, jasfer3D, dmiss)
if (DIS < DISM) then ! Found a better intersection point
DISM = DIS
km = k
SMM = SM
SLM = SL
CRPM = CRP
end if
end if
enddo
if (km > 0) then
dis = dbdistance(xs(km), ys(km), xs(km+1), ys(km+1), jsferic, jasfer3D, dmiss) ! Length of this segment.
! Find nearest valid polyline point left of the intersection (i.e.: kcs(kL) == 1)
disL = SMM*dis
do k = km,1,-1
if (kcs(k) == 1) then
kL = k
exit ! Valid point on the left (distance was already included in disL)
else if (k > 1) then
disL = disL + dbdistance(xs(k-1), ys(k-1), xs(k), ys(k), jsferic, jasfer3D, dmiss) ! Add entire length of this segment.
end if
end do
! Find nearest valid polyline point right of the intersection (i.e.: kcs(kR) == 1)
disR = (1d0-SMM)*dis
do k = km+1,ns
if (kcs(k) == 1) then
kR = k
exit ! Valid point on the left (distance was already included in disL)
else if (k < ns) then
disR = disR + dbdistance(xs(k), ys(k), xs(k+1), ys(k+1), jsferic, jasfer3D, dmiss) ! Add entire length of this segment.
end if
end do
end if
if (kL /= 0 .and. kR /= 0) then
wL = disR/(disL+disR)
wR = 1d0-wL
else if (kL /= 0) then
wL = 1d0
else if (kR /= 0) then
wR = 1d0
end if
end subroutine polyindexweight
!
!
! ==========================================================================
!>
!LC: TODO remove
! SUBROUTINE LINEDISq(X3,Y3,X1,Y1,X2,Y2,JA,DIS,XN,YN,rl) ! = dlinesdis2
!
!
! integer :: ja
! DOUBLE PRECISION :: X1,Y1,X2,Y2,X3,Y3,DIS,XN,YN
! DOUBLE PRECISION :: R2,RL,X21,Y21,X31,Y31,dbdistance
!
! ! korste afstand tot lijnelement tussen eindpunten
! JA = 0
! !X21 = getdx(x1,y1,x2,y2)
! !Y21 = getdy(x1,y1,x2,y2)
! call getdxdy(x1,y1,x2,y2,x21,y21)
! !X31 = getdx(x1,y1,x3,y3)
! !Y31 = getdy(x1,y1,x3,y3)
! call getdxdy(x1,y1,x3,y3,x31,y31)
! R2 = dbdistance(x2,y2,x1,y1)
! R2 = R2*R2
! IF (R2 .NE. 0) THEN
! RL = (X31*X21 + Y31*Y21) / R2
! IF (0d0 .LE. RL .AND. RL .LE. 1d0) then
! JA = 1
! end if
! XN = X1 + RL*(x2-x1)
! YN = Y1 + RL*(y2-y1)
! DIS = dbdistance(x3,y3,xn,yn)
! end if
! RETURN
! END subroutine LINEDISq
end module timespace_triangle ! met leading dimensions 3 of 4
!
!
!
! ==========================================================================
! ==========================================================================
! ==========================================================================
!>
module timespace
!!--description-----------------------------------------------------------------
!
! Read time series in five possible formats:
! uniform : Delft3D-FLOW format: time, uniform windspeed, direction and pressure
! space varying : Delft3D-FLOW format: time and fields of patm, windx, windy
! on Delft3D-FLOW m,n grid
! arcinfo : time and fields on own equidistant grid
! spiderweb : time and fields of patm, windspeed, direction op spiderweb grid
! curvi : time and fields on own curvilinear grid
!
! Main calls from Delft3D-FLOW:
! readmd -> rdmeteo:
! initmeteo : allocate meteo structure for this domain
! adddataprovider : allocate and initialized an input quantity
! with specified format
! checkmeteo : check whether input is available for the complete
! time interval
! trisol -> incmeteo:
! meteoupdate : prepare meteo data for the current time
! getmeteoval : return meteo data for the current time and position
! use optional m and n parameters to speed up in case of curvi
! getspiderval : same as getmeteoval for spiderweb data
!
! gdp_dealloc:
! deallocmeteo
!
! Additional calls:
! getmeteoerror : returns a string containing an error message
! to be used in case success = false for a main call
! meteogetpaver : returns the average atmospheric pressure read
! meteogetpcorr : returns whether pressure correction is switched on on
! the boundaries
!
!!--pseudo code and references--------------------------------------------------
!
! Stef.Hummel@WlDelft.nl
! Herman.Kernkamp@WlDelft.nl
! Adri.Mourits@WlDelft.nl
!
!!--declarations----------------------------------------------------------------
use precision
use timespace_data
use timespace_triangle
implicit none
contains
!
!
! ==========================================================================
!>
!> this function selects points (kc = 1) that can receive data from the provider in file =filename
!! All points have an allowable 'search range', defined by a line from x,y
!! to xyen(1,) to xyen(2,). Generally, the points in xyen are endpoints of
!! rrtol times a perpendicular vector to edge links.
subroutine selectelset( filename, filetype, x, y, xyen, kc, mnx, ki, num, usemask, rrtolrel)
use MessageHandling
use geometry_module, only: cross
use m_missing, only: dmiss
use m_sferic, only: jsferic
implicit none
! arguments
integer , intent(in) :: mnx !< dimension of quantity
double precision, intent(in) :: x(:) !< x of elset of all possible points in model
double precision, intent(in) :: y(:) !< y of elset
double precision, intent(in) :: xyen(:,:) !< Points on opposite edges of elementset
integer , intent(inout) :: kc(:) !< kcs of elset, allowable kandidates have 1, eg. points with less links than edges
integer , intent(out) :: ki(:) !< Returned indices of allowable points (in x/y) that fall near provided data
integer :: num !< nr of points served bij this provider
character(*), intent(in) :: filename ! file name for meteo data file
integer , intent(in) :: filetype ! spw, arcinfo, uniuvp etc
logical, intent(in) :: usemask !< Whether to use the mask array kc, or not (allows you to keep kc, but disable it for certain quantities, for example salinitybnd).
double precision, intent(in), optional :: rrtolrel !< Optional, a more strict rrtolerance value than the global rrtol. selectelset will succeed if cross SL value <= rrtolrel
! locals
double precision, allocatable :: xs (:) ! temporary array to hold polygon
double precision, allocatable :: ys (:) !
integer , allocatable :: kcs(:) !
double precision :: wL, wR
integer :: kL, kR, minp, ns, m
integer :: JACROS
double precision :: SL,SM,XCR,YCR,CRP
num = 0
ki = 0
if (filetype == poly_tim) then
call oldfil(minp, filename)
call read1polylin(minp,xs,ys,ns)
if (.not. allocated(kcs)) then
allocate(kcs(ns))
else if (ns > size(kcs)) then
call realloc(kcs, ns, keepExisting=.false.)
end if
kcs = 1 ! todo make this safe
do m = 1,mnx
if (iabs(kc(m)) == 1) then ! point is a possible candidate for a line boundary
call polyindexweight( x(m), y(m), xyen(1,m), xyen(2,m), xs, ys, kcs, ns, kL, wL, kR, wR)
if (kL > 0 .or. kR > 0) then
if (present(rrtolrel)) then
! x,y -> xyen =approx D + 2*rrtol * D
! This bnd requests a more strict tolerance than the global rrtol, namely: D + 2*rrtolb * D, so:
call CROSS(x(m), y(m), xyen(1,m), xyen(2,m), xs(kL), ys(kL), xs(kR), ys(kR), JACROS,SL,SM,XCR,YCR,CRP, jsferic, dmiss)
if (SL > rrtolrel) then
! More strict rrtolrel check failed, so do not accept this node.
cycle
end if
end if
if (usemask .and. kc(m) .eq. -1 ) then
errormessage = 'Boundary location already claimed; Overlap with other bnds?'
return
else
num = num + 1
ki(num) = m
if (usemask) then ! If we don't use the mask, also don't administer this opened bnd location (e.g. for salinitybnd)
kc(m) = -1 ! this tells you this point is already claimed by some bnd
end if
end if
end if
end if
enddo
write(msgbuf,'(a,a,a,i0,a)') 'boundary: ''', trim(filename), ''' opened ', num, ' cells.'
call msg_flush()
deallocate(xs, ys, kcs)
end if
end subroutine selectelset
!
!
! ==========================================================================
!>
subroutine selectelset_internal_links( filename, filetype, xz, yz, ln, lnx, keg, numg, xps, yps, nps, lftopol, sortLinks) ! find links cut by polyline filetype 9
use sorting_algorithms, only: sort
implicit none
!inputs
character(len=*), intent(in) :: filename ! file name for meteo data file
integer , intent(in) :: filetype ! spw, arcinfo, uniuvp etc
double precision, intent(in) :: xz (:)
double precision, intent(in) :: yz (:)
integer , intent(in) :: ln (:,:)
integer , intent(in) :: lnx
integer , intent(out) :: keg(:)
integer , intent(out) :: numg
integer :: isec
!optional inputs/outputs
double precision, allocatable, optional, dimension(:), intent(inout) :: xps(:), yps(:)
integer, optional, intent(inout) :: nps
integer, optional, dimension(:), intent(inout) :: lftopol
integer, optional, intent(in) :: sortLinks
!locals
integer :: minp, L, k1, k2, ja, np
double precision :: xa, ya, xb, yb,xm, ym, CRPM, dist
double precision, allocatable, dimension(:) :: xp, yp, distsStartPoly, sortedDistsStartPoly
integer, allocatable, dimension(:):: sortedIndexses, tempLinkArray !< the sorted indexses
numg = 0
if (filetype == poly_tim) then
call realloc(xp,100000)
call realloc(yp,100000)
call oldfil(minp, filename)
call read1polylin(minp,xp,yp,np)
if (present(sortLinks)) then
allocate(distsStartPoly(lnx))
endif
do L = 1,lnx
k1 = ln(1,L) ; k2 = ln(2,L)
xa = xz(k1) ; ya = yz(k1)
xb = xz(k2) ; yb = yz(k2)
call crosspoly(xa,ya,xb,yb,xp,yp,np,XM,YM,CRPM,JA,isec,dist)
if (ja == 1) then
numg = numg + 1
if(present(lftopol)) lftopol(numg) = isec
if (crpm > 0) then
keg(numg) = -L
else
keg(numg) = L
end if
if (present(sortLinks)) then
distsStartPoly(numg) = dist
endif
end if
enddo
if(present(xps)) then
if(allocated(xps)) deallocate(xps)
if(allocated(yps)) deallocate(yps)
call realloc(xps,100000)
call realloc(yps,100000)
xps = xp
yps = yp
nps = np
endif
deallocate(xp,yp)
!if required, sort the links by distance in the polyline
if (present(sortLinks)) then
if (sortLinks==1) then
allocate(sortedDistsStartPoly(numg))
allocate(sortedIndexses(numg))
allocate(tempLinkArray(numg))
call sort(numg,distsStartPoly(1:numg),sortedDistsStartPoly,sortedIndexses)
tempLinkArray = keg(sortedIndexses(1:numg))
keg(1:numg) = tempLinkArray
endif
endif
endif
end subroutine selectelset_internal_links
subroutine selectelset_internal_nodes( filename, filetype, xz, yz, kc, nx, numprov, kp) ! find nodes contained inside polygon filetype 10
implicit none
character(len=*), intent(in) :: filename ! file name for meteo data file
integer , intent(in) :: filetype ! spw, arcinfo, uniuvp etc
integer , intent(in) :: nx ! dim of nodes
double precision, intent(in) :: xz(nx) ! nodes coord
double precision, intent(in) :: yz(nx)
integer , intent(in) :: kc(nx) ! allow search in this node 1/0
integer , intent(in) :: numprov ! this is provider nr so much
integer , intent(out) :: kp(nx) ! point is found in provider nr so much
integer :: minp, inp, n
if (filetype == 10) then ! inside polygon
call oldfil(minp, filename)
call reapol (minp, 0)
inp = -1
do n = 1,nx
if (kc(n) > 0) then ! search allowed, (not allowed like closed pipes point etc)
call inwhichpolygon(xz(n), yz(n), inp)
if (inp > 0) then
kp(n) = numprov
endif
endif
enddo
endif
end subroutine selectelset_internal_nodes
!
!
! ==========================================================================
!> Combine a newly computed (external forcings-)value with an existing one, based on the operand type.
subroutine operate(a,b,operand)
use precision
implicit none
double precision, intent(inout) :: a !< Current value, will be updated based on b and operand.
double precision, intent(in) :: b !< New value, to be combined with existing value a.
character(len=1), intent(in) :: operand !< Operand type, valid values: 'O', 'A', '+', '*', 'X', 'N'.
! b = factor*b + offset ! todo doorplussen
if (operand == 'O') then ! Override, regardless of what was specified before
a = b
else if (operand == 'A') then ! Add, means: only if nothing was specified before
if (a == dmiss_default ) then
a = b
end if
else if (a .ne. dmiss_default) then ! algebra only if not missing
if (operand == '+') then
a = a + b
else if (operand == '*' ) then
a = a * b
else if (operand == 'X' ) then
a = max(a,b)
else if (operand == 'N' ) then
a = min(a,b)
end if
end if
end subroutine operate
!
!
! ==========================================================================
!>
function timespaceinitialfield(xu, yu, zu, nx, filename, filetype, method, operand, transformcoef, iprimpos, kcc) result(success) !
use kdtree2Factory
use m_samples
use m_netw
use m_flowgeom, only : xz, yz, ln2lne, Ln, Lnx, Wu1Duni
use m_partitioninfo
use unstruc_netcdf
use m_flowexternalforcings, only: qid
use m_ec_interpolationsettings
use m_flowparameters
use m_missing
use m_sferic, only: jsferic, jasfer3D
use m_polygon, only: NPL, xpl, ypl, zpl
use m_ec_basic_interpolation, only: triinterp2, averaging2
use geometry_module, only: dbpinpol
use gridoperations
use unstruc_model, only: getoutputdir
implicit none
logical :: success
integer, intent(in) :: nx
double precision, intent(in) :: xu(nx)
double precision, intent(in) :: yu(nx)
double precision, intent(out) :: zu(nx)
integer , intent(in), optional :: kcc(nx)
character(*), intent(in) :: filename ! file name for meteo data file
integer , intent(in) :: filetype ! spw, arcinfo, uniuvp etc
integer , intent(in) :: method ! time/space interpolation method
! 4 : inside polygon
! 5 : triangulation
! 6 : averaging
! 7 : index triangulation
! 8 : smoothing
! 9 : internal diffusion
character(1), intent(in) :: operand ! override, add
double precision, intent(in) :: transformcoef(:) !< Transformation coefficients
integer , intent(in) :: iprimpos ! only needed for averaging, position of primitive variables in network
! 1 = u point, cellfacemid, 2 = zeta point, cell centre, 3 = netnode
double precision, allocatable :: zh(:)
integer :: ierr
integer :: minp0, inside,k, jdla, mout
double precision, allocatable :: xx(:,:), yy(:,:)
integer , allocatable :: nnn (:)
double precision, allocatable :: xxx(:), yyy(:)
integer, allocatable :: LnnL(:), Lorg(:)
double precision :: zz
integer :: n6 , L, Lk, n, nn, n1, n2, i
integer :: ierror, jakc
integer :: jakdtree=1
double precision :: rcel_store, percentileminmax_store
integer :: iav_store, nummin_store
character(len=1), external :: get_dirsep
character(len=5) :: sd
success = .false.
minp0 = 0
jakc = 0
if (present(kcc)) then
jakc = 1
endif
if (filename == 'empty') then
do k=1,nx
call operate(zu(k), transformcoef(1), operand)
enddo
endif
allocate( zh(nx) , stat=ierr)
zh = dmiss_default
call aerr( 'zh(nx)', ierr, nx)
if (filetype .ne. ncflow .and. filetype .ne. arcinfo) then
call oldfil(minp0, filename)
end if
if (method == 4) then ! polyfil
call savepol()
call reapol(minp0, 0)
inside = -1
do k=1,nx
if (jakc == 1) then
if (kcc(k) == 0) cycle
endif
call dbpinpol(xu(k), yu(k), inside, &
dmiss, JINS, NPL, xpl, ypl, zpl)
if (inside == 1) then
call operate(zu(k), transformcoef(1), operand)
zh(k) = zu(k)
end if
enddo
call restorepol()
else if (method == 5 .or. method == 6) then ! triangulation todo
if (filetype == ncflow) then
call read_flowsamples_from_netcdf(filename, qid, ierr)
elseif (filetype == ncgrid) then
! TODO: support reading initial fields from NetCDF too
write (msgbuf, '(A)') 'timespace::timespaceinitialfield: Error while reading '''//qid//''' from file '''//trim(filename)//'''. File type not supported for initial fields.'
call warn_flush()
success = .false.
else if (filetype == arcinfo) then
call read_samples_from_arcinfo(filename, 0)
else
call reasam(minp0, 0)
end if
if (method == 5) then
jdla = 1
if (jakc == 0) then
call triinterp2(xu,yu,zh,nx,jdla, XS, YS, ZS, NS, dmiss, jsferic, jins, jasfer3D, &
NPL, MXSAM, MYSAM, XPL, YPL, ZPL, transformcoef)
else
call triinterp2(xu,yu,zh,nx,jdla, XS, YS, ZS, NS, dmiss, jsferic, jins, jasfer3D, &
NPL, MXSAM, MYSAM, XPL, YPL, ZPL, transformcoef, kcc)
endif
else if (method == 6) then ! and this only applies to flow-link data
! store settings
iav_store = iav
rcel_store = rcel
percentileminmax_store = percentileminmax
nummin_store = nummin
if ( transformcoef(4).ne.DMISS ) then
iav = int(transformcoef(4))
end if
if ( transformcoef(5).ne.DMISS ) then
rcel = transformcoef(5)
end if
if ( transformcoef(7).ne.DMISS ) then
percentileminmax = transformcoef(7)
end if
if ( transformcoef(8).ne.DMISS ) then
nummin = int(transformcoef(8))
end if
if (iprimpos == 1) then ! primitime position = velocitypoint, cellfacemid
n6 = 4
allocate( xx(n6,lnx), yy(n6,lnx), nnn(lnx) )
do L = 1,lnx
xx(1,L) = xzw(ln(1,L))
yy(1,L) = yzw(ln(1,L))
xx(3,L) = xzw(ln(2,L))
yy(3,L) = yzw(ln(2,L))
Lk = ln2lne(L)
xx(2,L) = xk(kn(1,Lk))
yy(2,L) = yk(kn(1,Lk))
xx(4,L) = xk(kn(2,Lk))
yy(4,L) = yk(kn(2,Lk))
enddo
nnn = 4 ! array nnn
else if (iprimpos == 2) then ! primitime position = waterlevelpoint, cell centre
n6 = maxval(netcell%n)
if ( jsferic.eq.1 ) then
n6 = n6+2 ! safety at poles
end if
allocate( xx(n6,nx), yy(n6,nx), nnn(nx) )
allocate(LnnL(n6), Lorg(n6)) ! not used
do n = 1,nx
! 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
call get_cellpolygon(n,n6,nnn(n),rcel,xx(1,n),yy(1,n),LnnL,Lorg,zz)
enddo
else if (iprimpos == 3) then ! primitime position = netnode, cell corner
n6 = 3*maxval(nmk) ! 2: safe upper bound , 3 : even safer!
allocate( xx(n6,numk), yy(n6,numk), nnn(numk), xxx(n6), yyy(n6) )
do k = 1,numk
if (jakc == 0) then
if (kcc(k) /= 1) then
cycle
end if
end if
! get the celllist
call make_dual_cell(k, n6, rcel, xxx, yyy, nnn(k), Wu1Duni)
do i=1,nnn(k)
xx(i,k) = xxx(i)
yy(i,k) = yyy(i)
enddo
enddo
DEALLOCATE(xxx,yyy)
end if
if ( jakdtree.eq.1 ) then
! initialize kdtree
call build_kdtree(treeglob,Ns,xs,ys,ierror, jsferic, dmiss)
if ( ierror.ne.0 ) then
! disable kdtree
call delete_kdtree2(treeglob)
jakdtree = 0
end if
end if
if (jakc == 0) then
call averaging2(1,ns,xs,ys,zs,ipsam,xu,yu,zh,nx,xx,yy,n6,nnn,jakdtree,&
dmiss, jsferic, jasfer3D, JINS, NPL, xpl, ypl, zpl)
else
call averaging2(1,ns,xs,ys,zs,ipsam,xu,yu,zh,nx,xx,yy,n6,nnn,jakdtree,&
dmiss, jsferic, jasfer3D, JINS, NPL, xpl, ypl, zpl, kcc)
end if
deallocate(xx,yy,nnn)
if ( iprimpos.eq.2 ) then
if ( allocated(LnnL) ) deallocate(LnnL)
if ( allocated(Lorg) ) deallocate(Lorg)
end if
! restore settings
iav = iav_store
rcel = rcel_store
percentileminmax = percentileminmax_store
nummin = nummin_store
if ( jakdtree.eq.1 ) then
call delete_kdtree2(treeglob)
end if
end if
do k=1,nx
if ( zh(k) .ne. dmiss_default) then
call operate(zu(k), zh(k), operand)
zh(k) = zu(k)
end if
end do
! call delsam(0)
! SPvdP: sample set can be large, delete it and do not make a copy
call delsam(-1)
end if
success = .true.
call doclose(minp0)
N1 = index (trim(filename) , get_dirsep() , .true.)
! fix for Linux-prepared input on Windows
if ( N1.eq.0 ) then
N1 = index(trim(filename), char(47), .true.)
end if
sd = ''
if (jampi == 1) then
sd = '_'//trim(sdmn)
end if
N2 = INDEX (trim(filename) , '.' , .true.)
if (n2 == 0) then
n2 = len_trim(filename)
else
n2 = n2 -1
end if
if (jawriteDFMinterpretedvalues > 0) then
call newfil(mout, trim(getoutputdir())//'DFM_interpreted_values_'//trim(filename(n1+1:n2))//trim(sd)//'.xyz')
do k = 1,nx
if (zh(k) .ne. dmiss_default) then
write(mout,*) xu(k), yu(k), zu(k)
end if
enddo
call doclose(mout)
endif
if (allocated (zh) ) deallocate(zh)
end function timespaceinitialfield
!
!
! ==========================================================================
!>
function timespaceinitialfield_int(xz, yz, zz, nx, filename, filetype, method, operand, transformcoef) result(success) ! deze subroutine moet veralgemeniseerd en naar meteo module
implicit none
logical :: success
integer, intent(in) :: nx
double precision, intent(in) :: xz(nx)
double precision, intent(in) :: yz(nx)
integer , intent(out) :: zz(nx)
character(*), intent(in) :: filename ! file name for meteo data file
integer , intent(in) :: filetype ! spw, arcinfo, uniuvp etc
integer , intent(in) :: method ! time/space interpolation method
character(1), intent(in) :: operand ! file name for meteo data file
double precision, intent(in) :: transformcoef(:) !< Transformation coefficients
double precision, allocatable :: xpli(:), ypli(:)
integer :: maxpli = 10000
integer :: minp0, inside, npli,k
success = .false.
call oldfil(minp0, filename)
if (filetype == inside_polygon) then ! polyfil
allocate(xpli(maxpli), ypli(maxpli))
call read1polylin(minp0,xpli,ypli,npli)
do k=1,nx
call pinpok(xz(k), yz(k), npli, xpli, ypli, inside)
if (inside == 1) then
if (operand == '+') then
zz(k) = zz(k) + transformcoef(1)
else
zz(k) = transformcoef(1)
end if
end if
enddo
deallocate(xpli, ypli)
else if (filetype == arcinfo) then ! arcinfo bilinear todo
else if (filetype == triangulation) then ! triangulation todo
end if
success = .true.
end function timespaceinitialfield_int
end module timespace