! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program make_fake_obs

! Generate an observation sequence FINAL file to thoroughly test obs_diag.
!
! Lots of goals for this routine.
! * all observation 'levels' for all 'VERTISxxxx' possibilities
! * exercise all 'regions'
! * exercise U,V wind combinations
!
! I want to test the vertical binning, the geographic binning, etc.
!

use         types_mod, only : r8, MISSING_R8, metadatalength
use     utilities_mod, only : initialize_utilities, get_unit, error_handler, E_ERR, &
                              open_file, close_file, finalize_utilities, &
                              find_namelist_in_file, check_namelist_read, nmlfileunit, &
                              do_nml_file, do_nml_term
use  time_manager_mod, only : time_type, set_calendar_type, set_date, get_time
use      location_mod, only : VERTISUNDEF,    VERTISSURFACE, VERTISLEVEL, &
                              VERTISPRESSURE, VERTISHEIGHT, VERTISSCALEHEIGHT
use obs_utilities_mod, only : add_obs_to_seq, create_3d_obs
use  obs_sequence_mod, only : obs_sequence_type, obs_type, init_obs, get_num_obs, &
                              static_init_obs_sequence, init_obs_sequence, &
                              set_copy_meta_data, set_qc_meta_data, write_obs_seq, &
                              set_obs_values, set_qc
use      obs_kind_mod, only : PRESSURE,                   &
                              ARGO_SALINITY,              &
                              SPECIFIC_HUMIDITY,          &
                              DROPSONDE_SURFACE_PRESSURE, &
                              ACARS_U_WIND_COMPONENT,     &
                              ACARS_V_WIND_COMPONENT,     &
                              EFGWORO

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

character(len=256) :: string1, string2, string3
integer, parameter :: stringlength = 32

integer, parameter :: index_obs              = 1 ! 'observations'
integer, parameter :: index_truth            = 2 ! 'truth'
integer, parameter :: index_prior_ens_mean   = 3 ! 'prior ensemble mean'
integer, parameter :: index_poste_ens_mean   = 4 ! 'posterior ensemble mean'
integer, parameter :: index_prior_ens_spread = 5 ! 'prior ensemble spread'
integer, parameter :: index_poste_ens_spread = 6 ! 'posterior ensemble spread'
integer, parameter :: index_qc_in            = 1
integer, parameter :: index_qc_dart          = 2

integer, parameter :: MaxLevels       = 12
integer, parameter :: MaxRegions      = 4
integer, parameter :: MaxVertCoords   = 7
integer, parameter :: MaxObsPerRegion = 5
integer, parameter :: max_obs    = MaxRegions * MaxObsPerRegion * MaxLevels * MaxVertCoords
integer, parameter :: ens_size   = 10
integer, parameter :: num_copies = 6 + ens_size*2
integer, parameter :: num_qc     = 2

! 1) PRESSURE                     MODEL LEVEL    obs_def_gps_mod.f90
! 2) ARGO_SALINITY                HEIGHT         obs_def_ocean_mod.f90
! 3) SPECIFIC_HUMIDITY            SCALE HEIGHT   obs_def_gps_mod.f90
! 4) DROPSONDE_SURFACE_PRESSURE   SURFACE        obs_def_reanalysis_bufr_mod.f90
! 5) ACARS_U_WIND_COMPONENT       PRESSURE       obs_def_reanalysis_bufr_mod.f90
! 6) ACARS_V_WIND_COMPONENT       PRESSURE       obs_def_reanalysis_bufr_mod.f90
! 7) EFGWORO                      UNDEFINED      obs_def_GWD_mod.f90

integer, parameter, dimension(MaxVertCoords) :: vertlevels = &
      (/ VERTISLEVEL       , &
         VERTISHEIGHT      , &
         VERTISSCALEHEIGHT , &
         VERTISSURFACE     , &
         VERTISPRESSURE    , &
         VERTISPRESSURE    , &
         VERTISUNDEF     /)

integer, parameter, dimension(MaxVertCoords) :: obs_type_list = &
      (/ PRESSURE                   , &
         ARGO_SALINITY              , &
         SPECIFIC_HUMIDITY          , &
         DROPSONDE_SURFACE_PRESSURE , &
         ACARS_U_WIND_COMPONENT     , &
         ACARS_V_WIND_COMPONENT     , &
         EFGWORO /)

integer, dimension(MaxVertCoords) :: numlevels
integer  :: Nplevels=0, Nhlevels=0, Nmlevels=0

!-------------------------------------------------------------------------------
! SOME of the obs_diag namelist is required to determine observation locations.
!-------------------------------------------------------------------------------

real(r8), dimension(MaxLevels)   :: plevel       = MISSING_R8 ! pressure level (hPa)
real(r8), dimension(MaxLevels)   :: hlevel       = MISSING_R8 ! height (meters)
real(r8), dimension(MaxLevels)   :: mlevel       = MISSING_R8 ! model level (integer index)
real(r8), dimension(MaxLevels+1) :: plevel_edges = MISSING_R8 ! pressure level (hPa)
real(r8), dimension(MaxLevels+1) :: hlevel_edges = MISSING_R8 ! height (meters)
real(r8), dimension(MaxLevels+1) :: mlevel_edges = MISSING_R8 ! model levels (nondimensional)

real(r8), dimension(MaxRegions)  :: lonlim1 = (/   0.0,   0.0,   0.0, 235.0 /)
real(r8), dimension(MaxRegions)  :: lonlim2 = (/ 360.0, 360.0, 360.0, 295.0 /)
real(r8), dimension(MaxRegions)  :: latlim1 = (/  20.0, -80.0, -20.0,  25.0 /)
real(r8), dimension(MaxRegions)  :: latlim2 = (/  80.0, -20.0,  20.0,  55.0 /)

integer,  dimension(6)  :: first_bin_center = (/ 2003, 1, 1, 0, 0, 0 /)
integer,  dimension(6)  :: last_bin_center  = (/ 2003, 1, 2, 0, 0, 0 /)
integer,  dimension(6)  :: bin_separation   = (/    0, 0, 0, 6, 0, 0 /)
integer,  dimension(6)  :: bin_width        = (/    0, 0, 0, 6, 0, 0 /)
integer,  dimension(6)  :: time_to_skip     = (/    0, 0, 1, 0, 0, 0 /)

! Intentionally using only a subset of variables and then NOT calling
! the DART namelist error-checking routine  check_namelist_read()

namelist /obs_diag_nml/ plevel, hlevel, mlevel, &
                        plevel_edges, hlevel_edges, mlevel_edges, &
                        first_bin_center, last_bin_center, bin_separation, &
                        bin_width, time_to_skip

!-------------------------------------------------------------------------------
! variables associated with the observation
!-------------------------------------------------------------------------------

type(obs_type)          :: prev_obs, obs, next_obs
type(obs_sequence_type) :: seq
type(time_type)         :: prev_time, time_obs

integer  :: iunit, io
integer  :: iobs, iregion, ilevel, verttype
integer  :: year, month, day, hour, minute, second, obsec, obday
real(r8) :: lat, lon, vert, oberr, obsval, obsqc

logical  :: first_obs = .true.

!===============================================================================
! Get the ball rolling
!===============================================================================

call initialize_utilities('make_fake_obs')
call set_calendar_type('Gregorian')

call find_namelist_in_file("input.nml", "obs_diag_nml", iunit)
read(iunit, nml = obs_diag_nml, iostat = io)
call check_namelist_read(iunit, io, "obs_diag_nml")

! Record the namelist values
if (do_nml_file()) write(nmlfileunit, nml=obs_diag_nml)
if (do_nml_term()) write(    *      , nml=obs_diag_nml)

call SetPressureLevels(plevel, plevel_edges, Nplevels)
call SetHeightLevels(  hlevel, hlevel_edges, Nhlevels)
call SetModelLevels(   mlevel, mlevel_edges, Nmlevels)

write(*,*)'pressure levels     = ',plevel(      1:Nplevels)
write(*,*)'pressure interfaces = ',plevel_edges(1:Nplevels+1)
write(*,*)'height   levels     = ',hlevel(      1:Nhlevels)
write(*,*)'height   interfaces = ',hlevel_edges(1:Nhlevels+1)
write(*,*)'model    levels     = ',mlevel(      1:Nmlevels)
write(*,*)'model    interfaces = ',mlevel_edges(1:Nmlevels+1)

! order:      LEVEL HEIGHT SCALEHEIGHT SURFACE PRESSURE PRESSURE UNDEF
numlevels = (/ Nmlevels, Nhlevels, Nhlevels, 1, Nplevels, Nplevels, 1 /)

! only 1 observation time for now.
year   = first_bin_center(1)
month  = first_bin_center(2)
day    = first_bin_center(3)
hour   = first_bin_center(4)
minute = first_bin_center(5)
second = first_bin_center(6)

time_obs = set_date(year, month, day, hour, minute, second)
call get_time(time_obs, obsec, obday)

call static_init_obs_sequence()
call init_obs(obs,      num_copies, num_qc)
call init_obs(prev_obs, num_copies, num_qc)
call init_obs(next_obs, num_copies, num_qc)
first_obs = .true.
prev_time = time_obs

! create a new, empty obs_seq file.  you must give a max limit
! on number of obs.  increase the size if too small.
call init_obs_sequence(seq, num_copies, num_qc, max_obs)
call generate_copy_meta_data(ens_size, seq)
call generate_qc_meta_data( seq )

! order:      LEVEL HEIGHT SCALEHEIGHT SURFACE PRESSURE PRESSURE UNDEF
coords  : do verttype = 1,MaxVertCoords
levels  : do ilevel   = 1,numlevels(verttype)
!regions : do iregion  = 1,MaxRegions
regions : do iregion  = 1,1
obsloop : do iobs     = 1,MaxObsPerRegion

   call CompleteObservation(vertlevels(verttype), obs_type_list(verttype), ilevel, iregion, iobs)

enddo obsloop
enddo regions
enddo levels
enddo coords

if ( get_num_obs(seq) > 0 ) then
   print *, 'writing obs_seq, obs_count = ', get_num_obs(seq)
   call write_obs_seq(seq, 'make_fake_obs.final')
endif

call finalize_utilities()

!-------------------------------------------------------------------------------
contains
!-------------------------------------------------------------------------------

Subroutine generate_copy_meta_data(ens_size, seq)

! This mimics what is done in filter:filter_generate_copy_meta_data()

integer,                 intent(in)    :: ens_size
type(obs_sequence_type), intent(inout) :: seq

integer :: i, copycount
character(len=metadatalength) :: prior_meta_data, posterior_meta_data

call set_copy_meta_data(seq, 1, 'observations')
call set_copy_meta_data(seq, 2, 'truth')
call set_copy_meta_data(seq, 3, 'prior ensemble mean')
call set_copy_meta_data(seq, 4, 'posterior ensemble mean')
call set_copy_meta_data(seq, 5, 'prior ensemble spread')
call set_copy_meta_data(seq, 6, 'posterior ensemble spread')

copycount = 6

! Set up obs ensemble members as requested
do i = 1, ens_size
   write(    prior_meta_data, '(a, 1x, i6)') 'prior ensemble member', i
   write(posterior_meta_data, '(a, 1x, i6)') 'posterior ensemble member', i
   copycount = copycount + 1
   call set_copy_meta_data(seq, copycount, prior_meta_data)
   copycount = copycount + 1
   call set_copy_meta_data(seq, copycount, posterior_meta_data)
end do

end Subroutine generate_copy_meta_data

Subroutine CompleteObservation( vertType, obsType, levelindx, regionindx, obsindx )

integer, intent(in) :: vertType    ! [VERTISUNDEF ... VERTISPRESSURE]
integer, intent(in) :: obsType     ! [PRESSURE ... EFGWORO]
integer, intent(in) :: levelindx   ! [1 .... N]
integer, intent(in) :: regionindx  ! [1 .... 4]
integer, intent(in) :: obsindx     ! [1 .... MaxObsPerRegion]

integer :: i, copycount

real(r8), dimension(1) :: obs_value, true_value, dartqc
real(r8), dimension(1) :: prior, prior_mean, prior_spread
real(r8), dimension(1) :: poste, poste_mean, poste_spread

call FillLocation (regionindx, obsindx, lon, lat )

! just put the ob right in the middle ... or on one edge ... or ...
if (    vertType == VERTISPRESSURE    ) then
!       vert     = plevel(levelindx)
        vert     = plevel_edges(levelindx)
elseif (vertType == VERTISLEVEL       ) then
!       vert     = mlevel(levelindx)
        vert     = mlevel_edges(levelindx)
elseif (vertType == VERTISHEIGHT      ) then
!       vert     = hlevel(levelindx)
        vert     = hlevel_edges(levelindx)
elseif (vertType == VERTISSCALEHEIGHT ) then
!       vert     = hlevel(levelindx)
        vert     = hlevel_edges(levelindx)
else
        vert     = 3.0_r8
endif

obsval = 1.0_r8
oberr  = 2.0_r8
obsqc  = 0.0_r8

call create_3d_obs(lat, lon, vert, vertType, obsval, &
             obsType,  oberr, obday, obsec, obsqc, obs)

obs_value(1)    = 10.0
true_value(1)   =  9.0
prior_mean(1)   =  8.0
poste_mean(1)   =  8.5
prior_spread(1) =  1.0
poste_spread(1) =  0.5

call set_obs_values(obs,    obs_value, 1)
call set_obs_values(obs,   true_value, 2)
call set_obs_values(obs,   prior_mean, 3)
call set_obs_values(obs,   poste_mean, 4)
call set_obs_values(obs, prior_spread, 5)
call set_obs_values(obs, poste_spread, 6)

copycount = 6

! Set up obs ensemble members as requested
do i = 1, ens_size
   prior(1) = real(i,r8)
   poste(1) = real(i,r8)
   copycount = copycount + 1
   call set_obs_values(obs, prior, copycount)
   copycount = copycount + 1
   call set_obs_values(obs, poste, copycount)
end do

! Lets make at least one ob have a bad DART value.
if (obsindx == 5) then
   dartqc(1) =  7.0_r8
else
   dartqc(1) =  0.0_r8
endif
call set_qc(obs, dartqc, index_qc_dart)

call add_obs_to_seq(seq, obs, time_obs, prev_obs, prev_time, first_obs)

end Subroutine CompleteObservation

Subroutine generate_qc_meta_data( seq )

type(obs_sequence_type), intent(inout) :: seq

call set_qc_meta_data(seq, 1, 'Quality Control')
call set_qc_meta_data(seq, 2, 'DART quality control')

end Subroutine generate_qc_meta_data

Subroutine FillLocation (regionindx, obsindx, lon, lat )
integer,  intent(in)  :: regionindx, obsindx
real(r8), intent(out) :: lon, lat

real(r8) :: dlat, dlon

dlat = (latlim2(regionindx) - latlim1(regionindx))/10.0_r8
dlon = (lonlim2(regionindx) - lonlim1(regionindx))/10.0_r8

if (    obsindx == 1)  then ! Upper left corner of region
   lat  = latlim2(regionindx) - dlat
   lon  = lonlim1(regionindx) + dlon
elseif (obsindx == 2)  then ! Upper right corner of region
   lat  = latlim2(regionindx) - dlat
   lon  = lonlim2(regionindx) - dlon
elseif (obsindx == 2)  then ! lower right corner of region
   lat  = latlim1(regionindx) + dlat
   lon  = lonlim2(regionindx) - dlon
elseif (obsindx == 4)  then ! lower left corner of region
   lat  = latlim1(regionindx) + dlat
   lon  = lonlim1(regionindx) + dlon
else                        ! dead center
   lat  = (latlim1(regionindx) + latlim2(regionindx)) / 2.0_r8
   lon  = (lonlim1(regionindx) + lonlim2(regionindx)) / 2.0_r8
endif
end Subroutine FillLocation

Subroutine SetPressureLevels(layerMiddles, layerEdges, nLayers)

! This is a utility routine ... presumes user input is minimalist
! and correct. Decreasing, no duplicate values ... etc.

real(r8), dimension(:), intent(inout) :: layerMiddles
real(r8), dimension(:), intent(inout) :: layerEdges
integer,                intent(  out) :: nLayers

integer :: i, n

! Count number of layer midpoints specified in namelist
n = 0
LevelLoop : do i = 1,MaxLevels
   if (layerMiddles(i) == MISSING_R8 ) exit LevelLoop
   n = n + 1
enddo LevelLoop

if ((n == 0) .or. (n == MaxLevels) ) then
   write(string1,*)n,' is too many plevel values - max is ',MaxLevels,' (MaxLevels)'
   call error_handler(E_ERR,'SetPressureLevels', string1,source,revision,revdate)
endif

! Set the layer edges ...
   layerEdges(  1) = layerMiddles(1)   - (layerMiddles(2) - layerMiddles( 1 ))/2.0_r8
   layerEdges(n+1) = layerMiddles(n)   + (layerMiddles(n) - layerMiddles(n-1))/2.0_r8
do i = 2,n
   layerEdges( i ) = layerMiddles(i-1) - (layerMiddles(i) - layerMiddles(i-1))/2.0_r8
enddo

layerEdges( 1 ) = min(1025.0_r8, layerEdges( 1 ))
layerEdges(n+1) = max(   0.0_r8, layerEdges(n+1))

nLayers = n

end Subroutine SetPressureLevels

Subroutine SetHeightLevels(layerMiddles, layerEdges, nLayers)

! This is a utility routine ... presumes user input is minimalist
! and correct. Ascending, no duplicate values ... etc.

real(r8), dimension(:), intent(inout) :: layerMiddles
real(r8), dimension(:), intent(inout) :: layerEdges
integer,                intent(  out) :: nLayers

integer :: i, n

! Count number of layer midpoints specified in namelist
n = 0
LevelLoop : do i = 1,MaxLevels
   if (layerMiddles(i) == MISSING_R8 ) exit LevelLoop
   n = n + 1
enddo LevelLoop

if ((n == 0) .or. (n == MaxLevels) ) then
   write(string1,*)n,' is too many hlevel values - max is ',MaxLevels,' (MaxLevels)'
   call error_handler(E_ERR,'SetHeightLevels', string1,source,revision,revdate)
endif

! Set the layer edges ...
   layerEdges(  1) = layerMiddles(1)   - (layerMiddles(2) - layerMiddles( 1 ))/2.0_r8
   layerEdges(n+1) = layerMiddles(n)   + (layerMiddles(n) - layerMiddles(n-1))/2.0_r8
do i = 2,n
   layerEdges( i ) = layerMiddles(i-1) + (layerMiddles(i) - layerMiddles(i-1))/2.0_r8
enddo

! FIXME ... what about depths ...
! layerEdges(1) = max(0.0_r8, layerEdges(1))

nLayers = n

end Subroutine SetHeightLevels

Subroutine SetModelLevels(layerMiddles, layerEdges, nLayers)

! This is a utility routine ... presumes user input is minimalist
! and correct. Ascending, no duplicate values ... etc.

real(r8), dimension(:), intent(inout) :: layerMiddles
real(r8), dimension(:), intent(inout) :: layerEdges
integer,                intent(  out) :: nLayers

integer :: i, n

! Count number of layer midpoints specified in namelist
n = 0
LevelLoop : do i = 1,MaxLevels
   if (layerMiddles(i) == MISSING_R8 ) exit LevelLoop
   n = n + 1
enddo LevelLoop

if ((n == 0) .or. (n == MaxLevels) ) then
   write(string1,*)n,' is too many mlevel values - max is ',MaxLevels,' (MaxLevels)'
   call error_handler(E_ERR,'SetModelLevels', string1,source,revision,revdate)
endif

! Set the layer edges ...
   layerEdges(  1) = layerMiddles(1)   - (layerMiddles(2) - layerMiddles( 1 ))/2.0_r8
   layerEdges(n+1) = layerMiddles(n)   + (layerMiddles(n) - layerMiddles(n-1))/2.0_r8
do i = 2,n
   layerEdges( i ) = layerMiddles(i-1) + (layerMiddles(i) - layerMiddles(i-1))/2.0_r8
enddo

! FIXME ... what about depths ...
layerEdges(1) = max(0.0_r8, layerEdges(1))

nLayers = n

end Subroutine SetModelLevels

end program make_fake_obs

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


MODULE trasbc
  USE oce
  USE sbc_oce
  USE dom_oce
  USE phycst
  USE eosbn2
  USE sbcmod
  USE sbcrnf
  USE sbcisf
  USE iscplini
  USE traqsr
  USE trd_oce
  USE trdtra
  USE wet_dry, ONLY: ll_wd, rn_wdmin1, r_rn_wdmin1
  USE in_out_manager
  USE prtctl
  USE iom
  USE lbclnk
  USE timing
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_sbc
  CONTAINS
  SUBROUTINE tra_sbc(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk, jn
    INTEGER :: ikt, ikb
    REAL(KIND = wp) :: zfact, z1_e3t, zdep, ztim
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :, :) :: ztrdt, ztrds
    IF (ln_timing) CALL timing_start('tra_sbc')
    IF (kt == nit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_sbc : TRAcer Surface Boundary Condition'
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~ '
    END IF
    IF (l_trdtra) THEN
      ALLOCATE(ztrdt(jpi, jpj, jpk), ztrds(jpi, jpj, jpk))
      !$ACC KERNELS
      ztrdt(:, :, :) = tsa(:, :, :, jp_tem)
      ztrds(:, :, :) = tsa(:, :, :, jp_sal)
      !$ACC END KERNELS
    END IF
    IF (.NOT. ln_traqsr) THEN
      !$ACC KERNELS
      qns(:, :) = qns(:, :) + qsr(:, :)
      qsr(:, :) = 0._wp
      !$ACC END KERNELS
    END IF
    IF (kt == nit000) THEN
      IF (ln_rstart .AND. iom_varid(numror, 'sbc_hc_b', ldstop = .FALSE.) > 0) THEN
        IF (lwp) WRITE(numout, FMT = *) '          nit000-1 sbc tracer content field read in the restart file'
        !$ACC KERNELS
        zfact = 0.5_wp
        sbc_tsc(:, :, :) = 0._wp
        !$ACC END KERNELS
        CALL iom_get(numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:, :, jp_tem), ldxios = lrxios)
        CALL iom_get(numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:, :, jp_sal), ldxios = lrxios)
      ELSE
        !$ACC KERNELS
        zfact = 1._wp
        sbc_tsc(:, :, :) = 0._wp
        sbc_tsc_b(:, :, :) = 0._wp
        !$ACC END KERNELS
      END IF
    ELSE
      !$ACC KERNELS
      zfact = 0.5_wp
      sbc_tsc_b(:, :, :) = sbc_tsc(:, :, :)
      !$ACC END KERNELS
    END IF
    DO jj = 2, jpj
      DO ji = 2, jpim1
        IF (ll_wd) THEN
          IF (sshn(ji, jj) + ht_0(ji, jj) > 2._wp * rn_wdmin1) THEN
            sbc_tsc(ji, jj, jp_tem) = r1_rau0_rcp * qns(ji, jj)
          ELSE IF (sshn(ji, jj) + ht_0(ji, jj) > rn_wdmin1) THEN
            sbc_tsc(ji, jj, jp_tem) = r1_rau0_rcp * qns(ji, jj) * TANH(5._wp * ((sshn(ji, jj) + ht_0(ji, jj) - rn_wdmin1) * r_rn_wdmin1))
          ELSE
            sbc_tsc(ji, jj, jp_tem) = 0._wp
          END IF
        ELSE
          sbc_tsc(ji, jj, jp_tem) = r1_rau0_rcp * qns(ji, jj)
        END IF
        sbc_tsc(ji, jj, jp_sal) = r1_rau0 * sfx(ji, jj)
      END DO
    END DO
    IF (ln_linssh) THEN
      !$ACC KERNELS
      DO jj = 2, jpj
        DO ji = 2, jpim1
          sbc_tsc(ji, jj, jp_tem) = sbc_tsc(ji, jj, jp_tem) + r1_rau0 * emp(ji, jj) * tsn(ji, jj, 1, jp_tem)
          sbc_tsc(ji, jj, jp_sal) = sbc_tsc(ji, jj, jp_sal) + r1_rau0 * emp(ji, jj) * tsn(ji, jj, 1, jp_sal)
        END DO
      END DO
      !$ACC END KERNELS
      IF (iom_use('emp_x_sst')) CALL iom_put("emp_x_sst", emp(:, :) * tsn(:, :, 1, jp_tem))
      IF (iom_use('emp_x_sss')) CALL iom_put("emp_x_sss", emp(:, :) * tsn(:, :, 1, jp_sal))
    END IF
    !$ACC KERNELS
    DO jn = 1, jpts
      DO jj = 2, jpj
        DO ji = 2, jpim1
          tsa(ji, jj, 1, jn) = tsa(ji, jj, 1, jn) + zfact * (sbc_tsc_b(ji, jj, jn) + sbc_tsc(ji, jj, jn)) / e3t_n(ji, jj, 1)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (lrst_oce) THEN
      IF (lwxios) CALL iom_swap(cwxios_context)
      CALL iom_rstput(kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:, :, jp_tem), ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:, :, jp_sal), ldxios = lwxios)
      IF (lwxios) CALL iom_swap(cxios_context)
    END IF
    IF (ln_isf) THEN
      !$ACC KERNELS
      zfact = 0.5_wp
      DO jj = 2, jpj
        DO ji = 2, jpim1
          ikt = misfkt(ji, jj)
          ikb = misfkb(ji, jj)
          DO jk = ikt, ikb - 1
            tsa(ji, jj, jk, jp_tem) = tsa(ji, jj, jk, jp_tem) + zfact * (risf_tsc_b(ji, jj, jp_tem) + risf_tsc(ji, jj, jp_tem)) * r1_hisf_tbl(ji, jj)
          END DO
          tsa(ji, jj, ikb, jp_tem) = tsa(ji, jj, ikb, jp_tem) + zfact * (risf_tsc_b(ji, jj, jp_tem) + risf_tsc(ji, jj, jp_tem)) * r1_hisf_tbl(ji, jj) * ralpha(ji, jj)
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (ln_rnf) THEN
      zfact = 0.5_wp
      DO jj = 2, jpj
        DO ji = 2, jpim1
          IF (rnf(ji, jj) /= 0._wp) THEN
            !$ACC KERNELS
            zdep = zfact / h_rnf(ji, jj)
            DO jk = 1, nk_rnf(ji, jj)
              tsa(ji, jj, jk, jp_tem) = tsa(ji, jj, jk, jp_tem) + (rnf_tsc_b(ji, jj, jp_tem) + rnf_tsc(ji, jj, jp_tem)) * zdep
              IF (ln_rnf_sal) tsa(ji, jj, jk, jp_sal) = tsa(ji, jj, jk, jp_sal) + (rnf_tsc_b(ji, jj, jp_sal) + rnf_tsc(ji, jj, jp_sal)) * zdep
            END DO
            !$ACC END KERNELS
          END IF
        END DO
      END DO
    END IF
    IF (iom_use('rnf_x_sst')) CALL iom_put("rnf_x_sst", rnf * tsn(:, :, 1, jp_tem))
    IF (iom_use('rnf_x_sss')) CALL iom_put("rnf_x_sss", rnf * tsn(:, :, 1, jp_sal))
    IF (ln_iscpl .AND. ln_hsb) THEN
      !$ACC KERNELS
      DO jk = 1, jpk
        DO jj = 2, jpj
          DO ji = 2, jpim1
            zdep = 1._wp / e3t_n(ji, jj, jk)
            tsa(ji, jj, jk, jp_tem) = tsa(ji, jj, jk, jp_tem) - htsc_iscpl(ji, jj, jk, jp_tem) * zdep
            tsa(ji, jj, jk, jp_sal) = tsa(ji, jj, jk, jp_sal) - htsc_iscpl(ji, jj, jk, jp_sal) * zdep
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (l_trdtra) THEN
      !$ACC KERNELS
      ztrdt(:, :, :) = tsa(:, :, :, jp_tem) - ztrdt(:, :, :)
      ztrds(:, :, :) = tsa(:, :, :, jp_sal) - ztrds(:, :, :)
      !$ACC END KERNELS
      CALL trd_tra(kt, 'TRA', jp_tem, jptra_nsr, ztrdt)
      CALL trd_tra(kt, 'TRA', jp_sal, jptra_nsr, ztrds)
      DEALLOCATE(ztrdt, ztrds)
    END IF
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = tsa(:, :, :, jp_tem), clinfo1 = ' sbc  - Ta: ', mask1 = tmask, tab3d_2 = tsa(:, :, :, jp_sal), clinfo2 = ' Sa: ', mask2 = tmask, clinfo3 = 'tra')
    IF (ln_timing) CALL timing_stop('tra_sbc')
  END SUBROUTINE tra_sbc
END MODULE trasbc


*DECK DFULMT
      SUBROUTINE DFULMT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG)
C***BEGIN PROLOGUE  DFULMT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (FULMAT-S, DFULMT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     DECODES A STANDARD TWO-DIMENSIONAL FORTRAN ARRAY PASSED
C     IN THE ARRAY DATTRV(IA,*).  THE ROW DIMENSION IA AND THE
C     MATRIX DIMENSIONS MRELAS AND NVARS MUST SIMULTANEOUSLY BE
C     PASSED USING THE OPTION ARRAY, PRGOPT(*).  IT IS AN ERROR
C     IF THIS DATA IS NOT PASSED TO DFULMT( ).
C     EXAMPLE-- (FOR USE TOGETHER WITH DSPLP().)
C      EXTERNAL DUSRMT
C      DIMENSION DATTRV(IA,*)
C      PRGOPT(01)=7
C      PRGOPT(02)=68
C      PRGOPT(03)=1
C      PRGOPT(04)=IA
C      PRGOPT(05)=MRELAS
C      PRGOPT(06)=NVARS
C      PRGOPT(07)=1
C     CALL DSPLP(  ... DFULMT INSTEAD OF DUSRMT...)
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DFULMT
      DOUBLE PRECISION AIJ,ZERO,DATTRV(*),PRGOPT(*)
      INTEGER IFLAG(10)
      SAVE ZERO
C***FIRST EXECUTABLE STATEMENT  DFULMT
      IF (.NOT.(IFLAG(1).EQ.1)) GO TO 50
C     INITIALIZE POINTERS TO PROCESS FULL TWO-DIMENSIONAL FORTRAN
C     ARRAYS.
      ZERO = 0.D0
      LP = 1
   10 NEXT = PRGOPT(LP)
      IF (.NOT.(NEXT.LE.1)) GO TO 20
      NERR = 29
      LEVEL = 1
      CALL XERMSG ('SLATEC', 'DFULMT',
     +   'IN DSPLP, ROW DIM., MRELAS, NVARS ARE MISSING FROM PRGOPT.',
     +   NERR, LEVEL)
      IFLAG(1) = 3
      GO TO 110
   20 KEY = PRGOPT(LP+1)
      IF (.NOT.(KEY.NE.68)) GO TO 30
      LP = NEXT
      GO TO 10
   30 IF (.NOT.(PRGOPT(LP+2).EQ.ZERO)) GO TO 40
      LP = NEXT
      GO TO 10
   40 IFLAG(2) = 1
      IFLAG(3) = 1
      IFLAG(4) = PRGOPT(LP+3)
      IFLAG(5) = PRGOPT(LP+4)
      IFLAG(6) = PRGOPT(LP+5)
      GO TO 110
   50 IF (.NOT.(IFLAG(1).EQ.2)) GO TO 100
   60 I = IFLAG(2)
      J = IFLAG(3)
      IF (.NOT.(J.GT.IFLAG(6))) GO TO 70
      IFLAG(1) = 3
      GO TO 110
   70 IF (.NOT.(I.GT.IFLAG(5))) GO TO 80
      IFLAG(2) = 1
      IFLAG(3) = J + 1
      GO TO 60
   80 AIJ = DATTRV(IFLAG(4)*(J-1)+I)
      IFLAG(2) = I + 1
      IF (.NOT.(AIJ.EQ.ZERO)) GO TO 90
      GO TO 60
   90 INDCAT = 0
      GO TO 110
  100 CONTINUE
  110 RETURN
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program 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 General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine ulfix  ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Fixation of BLOOM algae at the water bed (e.g. for Ulvae)

      implicit none

!     arguments

      real               :: pmsa(*)            !I/O Process Manager System Array, window of routine to process library
      real               :: fl(*)              ! O  Array of fluxes made by this process in mass/volume/time
      integer            :: ipoint( * )        ! I  Array of pointers in pmsa to get and store the data
      integer            :: increm( * )        ! I  Increments in ipoint for segment loop, 0=constant, 1=spatially varying
      integer            :: noseg              ! I  Number of computational elements in the whole model schematisation
      integer            :: noflux             ! I  Number of fluxes, increment in the fl array
      integer            :: iexpnt(4,*)        ! I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      integer            :: iknmrk(*)          ! I  Active-Inactive, Surface-water-bottom, see manual for use
      integer            :: noq1               ! I  Nr of exchanges in 1st direction (the horizontal dir if irregular mesh)
      integer            :: noq2               ! I  Nr of exchanges in 2nd direction, noq1+noq2 gives hor. dir. reg. grid
      integer            :: noq3               ! I  Nr of exchanges in 3rd direction, vertical direction, pos. downward
      integer            :: noq4               ! I  Nr of exchanges in the bottom (bottom layers, specialist use only)

!     pmsa array

      real               :: tau                ! I  total bottom shear stress                          (N/m2)
      real               :: taucrulva          ! I  critical shear stress for resuspension ULVA        (N/m2)
      real               :: fixgrad            ! I  gradient of fixation versus shear stress           (-)
      real               :: delt               ! I  timestep for processes                             (d)
      real               :: depth              ! I  depth of segment                                   (m)
      real               :: bloomdepth         ! I  average depth over Bloom time step                 (m)
      real               :: volume             ! I  volume of computational cell                       (m3)
      real               :: bloomalg           ! I  algae concentration                                (gC/m3)
      real               :: fixalg             ! I  benthic:<0, resuspended:>0, plankton:=0            (-)
      real               :: frfixedalg         ! O  fraction of algae fixed                            (-)
      real               :: m2_alg             ! O  concentration of algae square metre                (gC/m2)

!     fluxes

      real    dsedresalg  ! F  sedimentation flux algae (gC) in fl array:         (gC/m3/d)

!     local variables

      integer, parameter :: ntyp_m = 30        ! number of algae types expected in pmsa
      integer, parameter :: nipfix =  7        ! first number of entries in pmsa independent of number of algae
      integer, parameter :: nipvar =  2        ! number of input entries in pmsa dependent of number of algae
      integer            :: ifix(ntyp_m)       ! fix flag >0 suspended <0 corresponding fixed, copied from pmsa
      integer            :: jfix               ! fix flag >0 suspended <0 corresponding fixed other algae
      integer            :: ialg_fixed(ntyp_m) ! if present number of corresponding fixed type
      integer            :: nosegw             ! number of segments in the water
      integer            :: nosegl             ! number of segments per layer
      integer            :: iseg               ! segment number
      integer            :: isegl              ! segment number top layer (=column number)
      integer            :: isegb              ! segment number of bottom segment of the column
      integer            :: nolay              ! number of layers
      integer            :: ilay               ! layer number
      integer            :: ilayb              ! layer number of bottom segment of the column
      integer            :: ialg               ! algae type (suspended)
      integer            :: ialg2              ! algae type
      integer            :: jalg               ! algae type (fixed)
      real               :: msusp              ! mass suspended over the column (gC)
      real               :: mfix               ! mass fixed over the column (gC)
      real               :: mtot               ! total mass over the column (gC)
      real               :: frac               ! fraction of suspended mass in a layer (-)
      integer            :: ikmrk2             ! second segment attribute
      integer            :: ip                 ! index pointer in pmsa
      integer            :: ipp                ! index pointer in pmsa
      integer            :: ip1,ip2,ip3,ip4,ip5! index pointers in pmsa
      integer            :: ip6,ip7            ! index pointers in pmsa
      integer            :: in1,in2,in3,in4,in5! increments in pmsa
      integer            :: in6,in7            ! increments in pmsa
      integer            :: io1                ! index pointers in pmsa first output parameter
      integer            :: ino1               ! increment first output parameter

      ! some init

      ip1  = ipoint(1)
      ip2  = ipoint(2)
      ip3  = ipoint(3)
      ip4  = ipoint(4)
      ip5  = ipoint(5)
      ip6  = ipoint(6)
      ip7  = ipoint(7)
      in1  = increm(1)
      in2  = increm(2)
      in3  = increm(3)
      in4  = increm(4)
      in5  = increm(5)
      in6  = increm(6)
      in7  = increm(7)
      io1  = ipoint(nipfix+nipvar*ntyp_m+1)
      ino1 = increm(nipfix+2*ntyp_m+1)

      call dhnoseg(nosegw)
      call dhnolay(nolay)
      nosegl = nosegw/nolay
      delt   = pmsa(ipoint(4))

      ! set the ifix and ialg_fixed array (should be independent of the segment number)

      ifix       = 0
      ialg_fixed = 0
      do ialg = 1 , ntyp_m
         ip = nipfix + ialg + ntyp_m
         ifix(ialg) = nint(pmsa(ipoint(ip)))
         if (ifix(ialg) .gt. 0) then

            !find corresponding type in rest of the algae

            do ialg2 = 1 , ntyp_m
               ip = nipfix + ialg2 + ntyp_m
               jfix = nint(pmsa(ipoint(ip)))
               if ( jfix. eq. -1*ifix(ialg) ) then
                  ialg_fixed(ialg) = ialg2
                  exit
               endif
            enddo

         endif
      enddo

      ! loop over the columns to determine the fixing/defixing

      do isegl = 1 , nosegl

         do ialg = 1 , ntyp_m
            jalg = ialg_fixed(ialg)
            if (ifix(ialg) .gt. 0 .and. jalg .gt. 0) then

               ! calculate total suspended up till the bottom

               msusp = 0.0
               do ilay = 1 , nolay
                  iseg = isegl + (ilay-1)*nosegl
                  volume = pmsa(ip7+(iseg-1)*in7)
                  depth  = pmsa(ip5+(iseg-1)*in5)
                  ip = ipoint(nipfix+ialg)+ (iseg-1)*increm(nipfix+ialg)
                  bloomalg = max(pmsa(ip),0.0)
                  msusp = msusp + bloomalg*volume  ! total mass suspended type in g
                  call dhkmrk(2,iknmrk(iseg),ikmrk2)
                  if ((ikmrk2.eq.0).or.(ikmrk2.eq.3)) then

                     ip = ipoint(nipfix+jalg)+ (iseg-1)*increm(nipfix+jalg)
                     bloomalg = max(pmsa(ip),0.0)
                     mfix     = bloomalg*volume/depth     ! biomass of attached (fixed) type (convert from g/m2 to g)
                     isegb    = iseg
                     ilayb    = ilay
                     exit
                  endif
               enddo

               ! if the bottom segment is inactive exit algae loop

               if (.not. btest(iknmrk(isegb),0)) exit

               ! caluclate distribution according to tau at the bottom segment

               tau       = pmsa(ip1+(isegb-1)*in1)
               taucrulva = pmsa(ip2+(isegb-1)*in2)
               fixgrad   = pmsa(ip3+(isegb-1)*in3)
               if (taucrulva .gt. 0.) then
                  frfixedalg = min(1. , max(0. , fixgrad - tau / taucrulva))
               else
                  frfixedalg = 0.
               endif
               pmsa(io1+(isegb-1)*ino1) = frfixedalg

               mtot  = msusp + mfix
               dsedresalg = frfixedalg*mtot-mfix
               if ( dsedresalg .gt. 0 ) then

                  ! rooting event decrease suspended material proportionally

                  do ilay = 1 , ilayb
                     iseg = isegl + (ilay-1)*nosegl
                     volume = pmsa(ip7+(iseg-1)*in7)
                     ip = ipoint(nipfix+ialg)+ (iseg-1)*increm(nipfix+ialg)
                     bloomalg = max(pmsa(ip),0.0)
                     frac = bloomalg*volume/msusp
                     fl(ialg+(iseg-1)*noflux) = -frac*dsedresalg/volume/delt
                  enddo
                  fl(jalg+(isegb-1)*noflux) = dsedresalg/volume/delt

               else

                  ! de-rooting event, all material towards suspension in lowest layer

                  volume = pmsa(ip7+(isegb-1)*in7)
                  fl(ialg+(isegb-1)*noflux) = -dsedresalg/volume/delt
                  fl(jalg+(isegb-1)*noflux) = dsedresalg/volume/delt

               endif

            endif

         enddo ! algea type

      enddo ! columns

      ! loop to calculate concentration per m2

      ip5  = ipoint( 5)
      ip7  = ipoint( 7)
      do iseg = 1 , noseg

         if (btest(iknmrk(iseg),0)) then

            depth  = pmsa( ip5 )
            volume = pmsa( ip7 )

            do ialg = 1 , ntyp_m
               ip = nipfix+ialg
               ipp = ipoint(ip)+ (iseg-1)*increm(ip)
               if ( ifix(ialg) .lt. 0 ) then
                  bloomalg = pmsa(ipp)/volume
               else
                  bloomalg = pmsa(ipp)
               endif
               ip = nipfix+ialg+2*ntyp_m+1
               ipp = ipoint(ip)+ (iseg-1)*increm(ip)
               pmsa(ipp) = bloomalg*depth
            enddo

         endif

         ip5   = ip5   + increm (  5 )
         ip7   = ip7   + increm (  7 )

      enddo

      return
      end


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!X
!X IPModel_vdW module
!X
!% Module for Gaussian Approximation Potential.
!%
!% The IPModel_vdW object contains all the parameters read from a
!% 'vdW_params' XML stanza.
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
#include "error.inc"

module IPModel_vdW_module

use error_module
use system_module, only : dp, inoutput, string_to_int, reallocate, system_timer , print, PRINT_NERD
use units_module
use dictionary_module
use periodictable_module, only: total_elements
use extendable_str_module
use paramreader_module
use linearalgebra_module
use atoms_types_module
use atoms_module

use mpi_context_module
use QUIP_Common_module

#ifdef HAVE_GAP
use descriptors_module
use gp_predict_module
#endif

implicit none

private

include 'IPModel_interface.h'

#ifdef GAP_VERSION
   integer, parameter :: gap_version = GAP_VERSION
#else
   integer, parameter :: gap_version = 0
#endif

! this stuff is here for now, but it should live somewhere else eventually
! lower down in the GP

public :: IPModel_vdW

type IPModel_vdW

  real(dp) :: cutoff = 0.0_dp                                  !% Cutoff for computing connection.

  real(dp) :: E_scale = 0.0_dp                                 !% scale factor for the potential
  real(dp) :: sr = 0.0_dp
  real(dp) :: d = 0.0_dp
  real(dp) :: vdW_cutoff = 0.0_dp
  real(dp) :: vdW_cutoff_buffer = 0.0_dp

  character(len=STRING_LENGTH) :: label

#ifdef HAVE_GAP
  type(gpSparse) :: my_gp
  type(descriptor), dimension(:), allocatable :: my_descriptor
#endif
  real(dp), dimension(total_elements) :: e0 = 0.0_dp
  integer(dp), dimension(total_elements) :: map = -1
  integer :: n_types = 0
  integer, dimension(:), allocatable :: Z
  real(dp), dimension(:), allocatable :: r0
  real(dp), dimension(:), allocatable :: alpha0
  real(dp), dimension(:), allocatable :: c6
  real(dp), dimension(:,:), allocatable :: c6_pair

  logical :: initialised = .false.
  type(extendable_str) :: command_line
  integer :: xml_version

end type IPModel_vdW

logical, private :: parse_in_ip, parse_in_vdW_data, parse_matched_label, parse_in_ip_done

type(IPModel_vdW), private, pointer :: parse_ip
type(extendable_str), save :: parse_cur_data

interface Initialise
  module procedure IPModel_vdW_Initialise_str
end interface Initialise

interface Finalise
  module procedure IPModel_vdW_Finalise
end interface Finalise

interface Print
  module procedure IPModel_vdW_Print
end interface Print

interface Calc
  module procedure IPModel_vdW_Calc
end interface Calc

contains

subroutine IPModel_vdW_Initialise_str(this, args_str, param_str)
  type(IPModel_vdW), intent(inout) :: this
  character(len=*), intent(in) :: args_str, param_str
  type(Dictionary) :: params

  integer :: n, m, i_coordinate

  call Finalise(this)

  ! now initialise the potential
#ifndef HAVE_GAP
  call system_abort('IPModel_vdW_Initialise_str: must be compiled with HAVE_GAP')
#else

  call initialise(params)
  this%label=''

  call param_register(params, 'label', '', this%label, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="rescaling factor for the potential")

  if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) &
  call system_abort("IPModel_vdW_Initialise_str failed to parse label from args_str="//trim(args_str))
  call finalise(params)

  call IPModel_vdW_read_params_xml(this, param_str)
  call gp_readXML(this%my_gp, param_str,label=trim(this%label))

  do n = 1, this%n_types
     this%map(this%Z(n)) = n
  enddo

  allocate(this%c6_pair(this%n_types,this%n_types))
  do n = 1, this%n_types
     do m = 1, this%n_types
        this%c6_pair(m,n) = 2.0_dp * ( this%alpha0(n)*this%alpha0(m)*this%c6(n)*this%c6(m) ) / &
           ( this%alpha0(n)**2 * this%c6(m) + this%alpha0(m)**2 * this%c6(n) )
     enddo
  enddo

  allocate(this%my_descriptor(this%my_gp%n_coordinate))

  this%cutoff = 0.0_dp
  do i_coordinate = 1, this%my_gp%n_coordinate
     call concat(this%my_gp%coordinate(i_coordinate)%descriptor_str," xml_version="//this%xml_version)
     call initialise(this%my_descriptor(i_coordinate),string(this%my_gp%coordinate(i_coordinate)%descriptor_str))
     this%cutoff = max(this%cutoff,cutoff(this%my_descriptor(i_coordinate)))
  enddo
  this%cutoff = max(this%cutoff,this%vdW_cutoff)

#endif

end subroutine IPModel_vdW_Initialise_str

subroutine IPModel_vdW_Finalise(this)
  type(IPModel_vdW), intent(inout) :: this
#ifdef HAVE_GAP

  if (this%my_gp%initialised) call finalise(this%my_gp)
  if(allocated(this%Z)) deallocate(this%Z)
  if(allocated(this%r0)) deallocate(this%r0)
  if(allocated(this%alpha0)) deallocate(this%alpha0)
  if(allocated(this%c6)) deallocate(this%c6)
  if(allocated(this%c6_pair)) deallocate(this%c6_pair)
  this%n_types = 0
  this%map = -1

  this%cutoff = 0.0_dp
  this%vdW_cutoff = 0.0_dp
  this%sr = 0.0_dp
  this%d = 0.0_dp

  this%label = ''
  this%initialised = .false.
#endif

  call finalise(this%command_line)

end subroutine IPModel_vdW_Finalise

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!% The potential calculator: this routine computes energy, forces and the virial.
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

subroutine IPModel_vdW_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error)
  type(IPModel_vdW), intent(inout) :: this
  type(Atoms), intent(inout) :: at
  real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}.
  real(dp), intent(out), optional :: f(:,:), local_virial(:,:)   !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)}
  real(dp), intent(out), optional :: virial(3,3)   !% Virial
  character(len=*), intent(in), optional :: args_str
  type(MPI_Context), intent(in), optional :: mpi
  integer, intent(out), optional :: error

#ifdef HAVE_GAP
  type v_data
     real(dp) :: v
     integer :: n_lo, n_up
     integer, dimension(:), allocatable :: j
     real(dp), dimension(:,:), allocatable :: deriv
     real(dp), dimension(:,:), allocatable :: diff
  endtype v_data

  character(STRING_LENGTH) :: atom_mask_name

  logical :: has_atom_mask_name, do_rescale_r, do_rescale_E, do_select_descriptor, do_derivative
  logical, dimension(:), pointer :: atom_mask_pointer
  logical, dimension(:), allocatable :: mpi_local_mask

  integer :: only_descriptor, i_coordinate, d, i, j, k, i_desc, n, m

  real(dp) :: r_scale, E_scale, v_i, v_i_cutoff, r_ij, &
     r6_ij, dr6_ij_dr_ij, scaled_buffer, f_cut_ij, df_cut_ij_dr_ij, &
     c6_eff, r0_ij, d_sR_r0_ij, exp_factor, f_damp, e_i, &
     df_damp_dr_ij, df_damp_dr0_ij, df_damp_dvi, df_damp_dvj, dc6_eff_dvi, dc6_eff_dvj, &
     de_i_dr_ij
  real(dp), dimension(3) :: v_deriv, u_ij, f_ij, de_i_drk
  real(dp), dimension(:), allocatable     :: grad_predict, r0_eff, dr0_eff_dv
  real(dp), dimension(:), allocatable     :: local_e_in
  real(dp), dimension(:,:), allocatable   :: f_in
  real(dp), dimension(:,:,:), allocatable :: virial_in

  type(Dictionary) :: params
  type(descriptor_data), target :: my_descriptor_data
  type(extendable_str) :: my_args_str
  type(v_data), dimension(:), allocatable :: local_v

  !real(dp) :: e_i, e_i_cutoff
  !integer :: d, i, j, n, m, i_coordinate, i_pos0

  !real(dp), dimension(3) :: pos, f_gp
  !real(dp), dimension(3,3) :: virial_i
  !type(Dictionary) :: params
  !logical :: has_atom_mask_name
  !character(STRING_LENGTH) :: atom_mask_name, calc_local_gap_variance, calc_energy_per_coordinate
  !real(dp) :: r_scale, E_scale

  !real(dp) :: gap_variance_i_cutoff
  !real(dp), dimension(:), allocatable :: gap_variance, local_gap_variance_in
  !real(dp), dimension(:), pointer :: local_gap_variance_pointer
  !real(dp), dimension(:,:), allocatable :: gap_variance_gradient_in
  !real(dp), dimension(:,:), pointer :: gap_variance_gradient_pointer
  !real(dp) :: gap_variance_regularisation
  !logical :: do_rescale_r, do_rescale_E, do_gap_variance, print_gap_variance, do_local_gap_variance, do_energy_per_coordinate
  !integer :: only_descriptor
  !logical :: do_select_descriptor
  !logical :: mpi_parallel_descriptor

  !type(descriptor_data) :: my_descriptor_data
  !type(extendable_str) :: my_args_str

  INIT_ERROR(error)

  if (present(e)) then
     e = 0.0_dp
  endif

  if (present(local_e)) then
     call check_size('Local_E',local_e,(/at%N/),'IPModel_vdW_Calc', error)
     local_e = 0.0_dp
  endif

  if (present(f)) then
     call check_size('Force',f,(/3,at%N/),'IPModel_vdW_Calc', error)
     f = 0.0_dp
  end if

  if (present(virial)) then
     virial = 0.0_dp
  endif

  if (present(local_virial)) then
     call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_vdW_Calc', error)
     local_virial = 0.0_dp
  endif

  do_derivative = present(f) .or. present(virial) .or. present(local_virial)

  atom_mask_pointer => null()
  has_atom_mask_name = .false.
  atom_mask_name = ""
  only_descriptor = 0

  if( any(this%map(at%Z) == -1) ) then
     RAISE_ERROR("IPModel_vdW_Calc: atoms object contains atom types for which vdW parameters were not specified",error)
  endif

   call initialise(params)

   call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, &
   help_string="Name of a logical property in the atoms object. For atoms where this property is true, energies, forces, virials etc. are " // &
    "calculated")
   call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.")
   call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.")
   call param_register(params, 'only_descriptor', '0', only_descriptor, has_value_target=do_select_descriptor, help_string="Only select a single coordinate")

   if(present(args_str)) then
     if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) &
       call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'")
     call finalise(params)

     if( has_atom_mask_name ) then
        if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) &
            call system_abort("IPModel_vdW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.")
     endif
     if (do_rescale_r .or. do_rescale_E) then
        RAISE_ERROR("IPModel_vdW_Calc: rescaling of potential at the calc() stage with r_scale and E_scale not yet implemented!", error)
     end if

     my_args_str = trim(args_str)
  else
     ! call parser to set defaults
     if (.not. param_read_line(params,"",ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) &
       call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'")
     call finalise(params)
     call initialise(my_args_str)
  endif

  if( present(mpi) ) then
     if(mpi%active) then
        if(has_atom_mask_name) then
           RAISE_ERROR("IPModel_vdW: atom_mask_name "//trim(atom_mask_name)//" present while running MPI version. &
              The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS",error)
        endif

        if( has_property(at,"mpi_local_mask") ) then
           RAISE_ERROR("IPModel_vdW: mpi_local_mask property already present", error)
        endif

        allocate(mpi_local_mask(at%N))
        call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error)
        call concat(my_args_str," atom_mask_name=mpi_local_mask")
     endif
  endif

  call concat(my_args_str," xml_version="//this%xml_version)

  allocate(local_v(at%N))
  do i = 1, at%N
     local_v(i)%v = this%e0(at%Z(i))
  enddo

  do i_coordinate = 1, this%my_gp%n_coordinate

     if (do_select_descriptor .and. (this%my_gp%n_coordinate > 1)) then
        if (i_coordinate /= only_descriptor) then
           call print("vdW label="//trim(this%label)//" skipping coordinate "//i_coordinate, PRINT_NERD)
           cycle
        end if
     end if

     if(mpi%active) call descriptor_MPI_setup(this%my_descriptor(i_coordinate),at,mpi,mpi_local_mask,error)

     d = descriptor_dimensions(this%my_descriptor(i_coordinate))

     if( do_derivative ) then
        if (allocated(grad_predict)) deallocate(grad_predict)
        allocate(grad_predict(d))
     end if
     call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, &
        do_descriptor=.true.,do_grad_descriptor=present(f) .or. present(virial) .or. present(local_virial), args_str=trim(string(my_args_str)), error=error)
     PASS_ERROR(error)
     do i_desc = 1, size(my_descriptor_data%x)
        if( size(my_descriptor_data%x(i_desc)%ci) /= 1 ) then
           RAISE_ERROR("IPModel_vdW_Calc: descriptor is not local and atomic",error)
        endif
        i = my_descriptor_data%x(i_desc)%ci(1)

        if ( do_derivative ) then
           local_v(i)%n_lo = lbound(my_descriptor_data%x(i_desc)%ii,1)
           local_v(i)%n_up = ubound(my_descriptor_data%x(i_desc)%ii,1)
           allocate(local_v(i)%deriv(3,local_v(i)%n_lo:local_v(i)%n_up), &
              local_v(i)%j(local_v(i)%n_lo:local_v(i)%n_up), &
              local_v(i)%diff(3,local_v(i)%n_lo:local_v(i)%n_up))
           do n = local_v(i)%n_lo, local_v(i)%n_up
              local_v(i)%diff(:,n) = my_descriptor_data%x(i_desc)%pos(:,n) - &
                 my_descriptor_data%x(i_desc)%pos(:,local_v(i)%n_lo)
           enddo
           local_v(i)%j = my_descriptor_data%x(i_desc)%ii
           local_v(i)%deriv = 0.0_dp
        endif
     enddo

!$omp parallel default(none) private(i_desc,n,i,grad_predict,v_i,v_i_cutoff,v_deriv) &
!$omp shared(this,d,i_coordinate,my_descriptor_data,f,virial,local_virial,local_v,do_derivative)
!$omp do schedule(dynamic)
     do i_desc = 1, size(my_descriptor_data%x)
        if(present(f) .or. present(virial) .or. present(local_virial)) then
           call reallocate(grad_predict,d,zero=.true.)
           v_i = gp_predict(this%my_gp%coordinate(i_coordinate), &
              xStar=my_descriptor_data%x(i_desc)%data(:), &
              gradPredict = grad_predict )
        else
           v_i =  gp_predict(this%my_gp%coordinate(i_coordinate), xStar=my_descriptor_data%x(i_desc)%data(:))
        endif

        v_i_cutoff = v_i * my_descriptor_data%x(i_desc)%covariance_cutoff
        i = my_descriptor_data%x(i_desc)%ci(1)
        local_v(i)%v = local_v(i)%v + v_i_cutoff

        if( do_derivative ) then
           do n = lbound(my_descriptor_data%x(i_desc)%ii,1), ubound(my_descriptor_data%x(i_desc)%ii,1)
              if( .not. my_descriptor_data%x(i_desc)%has_grad_data(n) ) cycle
              v_deriv = matmul( grad_predict,my_descriptor_data%x(i_desc)%grad_data(:,:,n)) * my_descriptor_data%x(i_desc)%covariance_cutoff + &
                 v_i * my_descriptor_data%x(i_desc)%grad_covariance_cutoff(:,n)
              local_v(i)%deriv(:,n) = local_v(i)%deriv(:,n) + v_deriv
           enddo
        endif
     enddo
!$omp end do
     if(allocated(grad_predict)) deallocate(grad_predict)
!$omp end parallel
     call finalise(my_descriptor_data)
  enddo

  ! Has to be allocated as it's in the reduction clause.
  allocate(local_e_in(at%N))
  local_e_in = 0.0_dp

  allocate(f_in(3,at%N))
  f_in = 0.0_dp

  allocate(virial_in(3,3,at%N))
  virial_in = 0.0_dp

  allocate(r0_eff(at%N))
  if( do_derivative ) then
     allocate(dr0_eff_dv(at%N))
  endif

  do i = 1, at%N
     r0_eff(i) = local_v(i)%v**(1.0_dp/3.0_dp) * this%r0(this%map(at%Z(i)))
     if( do_derivative ) then
        dr0_eff_dv(i) = r0_eff(i) / local_v(i)%v / 3.0_dp
     endif
  enddo

!$omp parallel default(none) private(i,j,k,n,m,r_ij,u_ij,r6_ij,dr6_ij_dr_ij,scaled_buffer,f_cut_ij,df_cut_ij_dr_ij, &
!$omp c6_eff,r0_ij,d_sR_r0_ij,exp_factor,f_damp,e_i,df_damp_dr_ij,df_damp_dr0_ij,df_damp_dvi,df_damp_dvj, &
!$omp dc6_eff_dvi,dc6_eff_dvj,de_i_dr_ij,f_ij,de_i_drk) &
!$omp shared(this,at,e,f,virial,do_derivative,local_v,r0_eff,dr0_eff_dv) &
!$omp reduction(+:local_e_in,f_in,virial_in)
!$omp do schedule(dynamic)
  do i = 1, at%N
     do n = 1, n_neighbours(at,i)
        j = neighbour(at, i, n, distance=r_ij, cosines=u_ij)

        if( r_ij > this%vdW_cutoff ) cycle

        r6_ij = 1.0_dp / r_ij**6
        if( do_derivative ) dr6_ij_dr_ij = -6.0_dp * r6_ij / r_ij

        if( r_ij > this%vdW_cutoff - this%vdW_cutoff_buffer ) then
           scaled_buffer = ( r_ij - this%vdW_cutoff + this%vdW_cutoff_buffer ) / this%vdW_cutoff_buffer
           f_cut_ij = 1.0_dp - 3.0_dp*scaled_buffer**2 + 2.0_dp*scaled_buffer**3

           if( do_derivative ) then
              df_cut_ij_dr_ij = -6.0_dp*(scaled_buffer+scaled_buffer**2) / this%vdW_cutoff_buffer
              dr6_ij_dr_ij = dr6_ij_dr_ij*f_cut_ij + r6_ij*df_cut_ij_dr_ij
           endif
           r6_ij = r6_ij*f_cut_ij
        endif

        c6_eff = local_v(i)%v * local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i)))
        r0_ij = r0_eff(i) + r0_eff(j)

        d_sR_r0_ij = this%d / this%sR / r0_ij
        exp_factor = exp( -d_sR_r0_ij*r_ij + this%d )
        f_damp = 1.0_dp / ( 1.0_dp + exp_factor )

        e_i = -0.5*f_damp*c6_eff*r6_ij
        local_e_in(i) = local_e_in(i) + e_i

        if(do_derivative) then
           df_damp_dr_ij = f_damp**2 * exp_factor * d_sR_r0_ij
           df_damp_dr0_ij = -df_damp_dr_ij * r_ij / r0_ij

           df_damp_dvi = df_damp_dr0_ij * dr0_eff_dv(i)
           df_damp_dvj = df_damp_dr0_ij * dr0_eff_dv(j)

           dc6_eff_dvi = local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i)))
           dc6_eff_dvj = local_v(i)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i)))

           de_i_dr_ij = 0.5_dp*(f_damp*c6_eff*dr6_ij_dr_ij + df_damp_dr_ij*c6_eff*r6_ij)
           f_ij = de_i_dr_ij*u_ij
           if(present(f)) then
              f_in(:,i) = f_in(:,i) - f_ij
              f_in(:,j) = f_in(:,j) + f_ij
           endif
           if(present(virial)) then
              virial_in(:,:,j) = virial_in(:,:,j) + ( f_ij .outer. u_ij ) * r_ij
           endif

           do m = local_v(i)%n_lo, local_v(i)%n_up
              k = local_v(i)%j(m)
              de_i_drk = (df_damp_dvi*c6_eff + f_damp*dc6_eff_dvi)*r6_ij* &
                 local_v(i)%deriv(:,m)
              if(present(f)) f_in(:,k) = f_in(:,k) + de_i_drk
              if(present(virial)) then
                 virial_in(:,:,k) = virial_in(:,:,k) + (de_i_drk .outer. local_v(i)%diff(:,m))
              endif
           enddo
        endif

     enddo
  enddo
!$omp end do
!$omp end parallel

  if(present(f)) f = f_in
  if(present(e)) e = sum(local_e_in)
  if(present(local_e)) local_e = local_e_in
  if(present(virial)) virial = sum(virial_in,dim=3)

  if(present(local_virial)) then
     do i = 1, at%N
        local_virial(:,i) = reshape(virial_in(:,:,i),(/9/))
     enddo
  endif

  if(allocated(local_e_in)) deallocate(local_e_in)
  if(allocated(f_in)) deallocate(f_in)
  if(allocated(virial_in)) deallocate(virial_in)

  if (present(mpi)) then
     if( mpi%active ) then
        if(present(f)) call sum_in_place(mpi,f)
        if(present(virial)) call sum_in_place(mpi,virial)
        if(present(local_virial)) call sum_in_place(mpi,local_virial)
        if(present(e)) e = sum(mpi,e)
        if(present(local_e) ) call sum_in_place(mpi,local_e)

        call remove_property(at,'mpi_local_mask', error=error)
        deallocate(mpi_local_mask)
     endif
  endif

!  if(present(e)) then
!     if( associated(atom_mask_pointer) ) then
!        e = e + sum(this%e0(at%Z),mask=atom_mask_pointer)
!     else
!        e = e + sum(this%e0(at%Z))
!     endif
!  endif
!
!  if(present(local_e)) then
!     if( associated(atom_mask_pointer) ) then
!        where (atom_mask_pointer) local_e = local_e + this%e0(at%Z)
!     else
!        local_e = local_e + this%e0(at%Z)
!     endif
!  endif

  if(present(f)) f = this%E_scale * f
  if(present(e)) e = this%E_scale * e
  if(present(local_e)) local_e = this%E_scale * local_e
  if(present(virial)) virial = this%E_scale * virial
  if(present(local_virial)) local_virial = this%E_scale * local_virial

  atom_mask_pointer => null()
  call finalise(my_args_str)

  if(allocated(local_v)) then
     do i = 1, at%N
        local_v(i)%v = 0.0_dp
        if(allocated(local_v(i)%deriv)) deallocate(local_v(i)%deriv)
        if(allocated(local_v(i)%j)) deallocate(local_v(i)%j)
        if(allocated(local_v(i)%diff)) deallocate(local_v(i)%diff)
     enddo
     deallocate(local_v)
  endif
  if( allocated(r0_eff) ) deallocate(r0_eff)
  if( allocated(dr0_eff_dv) ) deallocate(dr0_eff_dv)

!        if(present(e) .or. present(local_e)) then
!
!           e_i_cutoff = e_i * my_descriptor_data%x(i)%covariance_cutoff / size(my_descriptor_data%x(i)%ci)
!           call print("vdWDEBUG ci="//my_descriptor_data%x(i)%ci//" e_i="//e_i//" e_i_cutoff="//e_i_cutoff, PRINT_NERD)
!
!           do n = 1, size(my_descriptor_data%x(i)%ci)
!              local_e_in( my_descriptor_data%x(i)%ci(n) ) = local_e_in( my_descriptor_data%x(i)%ci(n) ) + e_i_cutoff
!           enddo
!        endif
!
!        if(present(f) .or. present(virial) .or. present(local_virial)) then
!           i_pos0 = lbound(my_descriptor_data%x(i)%ii,1)
!
!           do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1)
!              if( .not. my_descriptor_data%x(i)%has_grad_data(n) ) cycle
!              j = my_descriptor_data%x(i)%ii(n)
!              pos = my_descriptor_data%x(i)%pos(:,n)
!              f_gp = matmul( gradPredict,my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff + &
!              e_i * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n)
!              if( present(f) ) then
!                 f_in(:,j) = f_in(:,j) - f_gp
!              endif
!              if( do_local_gap_variance ) then
!                 gap_variance_gradient_in(:,j) = gap_variance_gradient_in(:,j) + &
!                    matmul( grad_variance_estimate, my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff**2 + &
!                    2.0_dp * gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n)
!              endif
!              if( present(virial) .or. present(local_virial) ) then
!                 virial_i = ((pos-my_descriptor_data%x(i)%pos(:,i_pos0)) .outer. f_gp)
!                 virial_in(:,:,j) = virial_in(:,:,j) - virial_i
!
!                 !virial_i = (pos .outer. f_gp) / size(my_descriptor_data%x(i)%ci)
!                 !do m = 1, size(my_descriptor_data%x(i)%ci)
!                 !   virial_in(:,:,my_descriptor_data%x(i)%ci(m)) = virial_in(:,:,my_descriptor_data%x(i)%ci(m)) - virial_i
!                 !enddo
!              endif
!           enddo
!        endif
!     enddo loop_over_descriptor_instances
!     call system_timer('IPModel_vdW_Calc_gp_predict')

#endif

end subroutine IPModel_vdW_Calc

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!% XML param reader functions.
!% An example for XML stanza is given below, please notice that
!% they are simply dummy parameters for testing purposes, with no physical meaning.
!%
!%> <vdW_params datafile="file" label="default">
!%> </vdW_params>
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

subroutine IPModel_startElement_handler(URI, localname, name, attributes)
  character(len=*), intent(in)   :: URI
  character(len=*), intent(in)   :: localname
  character(len=*), intent(in)   :: name
  type(dictionary_t), intent(in) :: attributes

  integer :: status
  character(len=1024) :: value

  integer :: ri, Z

  if(name == 'vdW_params') then ! new vdW stanza

     if(parse_in_ip) &
        call system_abort("IPModel_startElement_handler entered vdW_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)")

     if(parse_matched_label) return ! we already found an exact match for this label

     call QUIP_FoX_get_value(attributes, 'label', value, status)
     if(status /= 0) value = ''

     if(len(trim(parse_ip%label)) > 0) then ! we were passed in a label
        if(value == parse_ip%label) then ! exact match
           parse_matched_label = .true.
           parse_in_ip = .true.
        else ! no match
           parse_in_ip = .false.
        endif
     else ! no label passed in
        parse_in_ip = .true.
        parse_ip%label = trim(value) ! if we found a label, AND didn't have one originally, pass it back to the object.
     endif

     if(parse_in_ip) then
        if(parse_ip%initialised) call finalise(parse_ip)
     endif

     call QUIP_FoX_get_value(attributes, 'gap_version', value, status)
     if( (status == 0) ) then
        parse_ip%xml_version = string_to_int(value)
        if( parse_ip%xml_version > gap_version ) &
        call system_abort( &
           'Database was created with a later version of the code.' // &
           'Version of code used to generate the database is '//trim(value)//'.'// &
           'Version of current code is '//gap_version//'. Please update your code.')
     else
        parse_ip%xml_version = 0
     endif

     call QUIP_FoX_get_value(attributes, 'sR', value, status)
     if(status == 0) then
        read (value, *) parse_ip%sR
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find sR')
     endif

     call QUIP_FoX_get_value(attributes, 'd', value, status)
     if(status == 0) then
        read (value, *) parse_ip%d
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find d')
     endif

     call QUIP_FoX_get_value(attributes, 'cutoff', value, status)
     if(status == 0) then
        read (value, *) parse_ip%vdW_cutoff
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find cutoff')
     endif

     call QUIP_FoX_get_value(attributes, 'cutoff_buffer', value, status)
     if(status == 0) then
        read (value, *) parse_ip%vdW_cutoff_buffer
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find cutoff_buffer')
     endif

     ! For good measure
     parse_ip%map = -1

  elseif(parse_in_ip .and. name == 'GAP_data') then

     call QUIP_FoX_get_value(attributes, 'e0', value, status)
     if(status == 0) then
        read (value, *) parse_ip%e0(1)
        parse_ip%e0 = parse_ip%e0(1)
     endif

     parse_in_vdW_data = .true.

  elseif(parse_in_ip .and. parse_in_vdW_data .and. name == 'e0') then
     call QUIP_FoX_get_value(attributes, 'Z', value, status)
     if(status == 0) then
        read (value, *) Z
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find Z')
     endif
     if( Z > size(parse_ip%e0) ) call system_abort('IPModel_vdW_read_params_xml: attribute Z = '//Z//' > '//size(parse_ip%e0))

     call QUIP_FoX_get_value(attributes, 'value', value, status)
     if(status == 0) then
        read (value, *) parse_ip%e0(Z)
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find value in e0')
     endif

  elseif(parse_in_ip .and. name == 'per_type_data') then
     parse_ip%n_types = parse_ip%n_types + 1
     call reallocate(parse_ip%Z,parse_ip%n_types,copy=.true.)
     call reallocate(parse_ip%r0,parse_ip%n_types,copy=.true.)
     call reallocate(parse_ip%alpha0,parse_ip%n_types,copy=.true.)
     call reallocate(parse_ip%c6,parse_ip%n_types,copy=.true.)

     call QUIP_FoX_get_value(attributes, 'Z', value, status)
     if(status == 0) then
        read (value, *) parse_ip%Z(parse_ip%n_types)
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find Z')
     endif

     call QUIP_FoX_get_value(attributes, 'r0', value, status)
     if(status == 0) then
        read (value, *) parse_ip%r0(parse_ip%n_types)
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find r0')
     endif

     call QUIP_FoX_get_value(attributes, 'alpha0', value, status)
     if(status == 0) then
        read (value, *) parse_ip%alpha0(parse_ip%n_types)
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find alpha0')
     endif

     call QUIP_FoX_get_value(attributes, 'c6', value, status)
     if(status == 0) then
        read (value, *) parse_ip%c6(parse_ip%n_types)
     else
        call system_abort('IPModel_vdW_read_params_xml cannot find c6')
     endif
  endif

end subroutine IPModel_startElement_handler

subroutine IPModel_endElement_handler(URI, localname, name)
  character(len=*), intent(in)   :: URI
  character(len=*), intent(in)   :: localname
  character(len=*), intent(in)   :: name

  if (parse_in_ip) then
    if(name == 'vdW_params') then
       parse_in_ip = .false.
       parse_in_ip_done = .true.
    elseif(name == 'vdW_data') then
       parse_in_vdW_data = .false.

    elseif(name == 'per_type_data') then

    elseif(name == 'command_line') then
       parse_ip%command_line = parse_cur_data
    end if
  endif

end subroutine IPModel_endElement_handler

subroutine IPModel_characters_handler(in)
   character(len=*), intent(in) :: in

   if(parse_in_ip) then
     call concat(parse_cur_data, in, keep_lf=.false.)
   endif

end subroutine IPModel_characters_handler

subroutine IPModel_vdW_read_params_xml(this, param_str)
  type(IPModel_vdW), intent(inout), target :: this
  character(len=*), intent(in) :: param_str

  type(xml_t) :: fxml

  if (len(trim(param_str)) <= 0) then
     call system_abort('IPModel_vdW_read_params_xml: invalid param_str length '//len(trim(param_str)) )
  else
     parse_in_ip = .false.
     parse_in_ip_done = .false.
     parse_matched_label = .false.
     parse_ip => this
     call initialise(parse_cur_data)

     call open_xml_string(fxml, param_str)
     call parse(fxml,  &
       startElement_handler = IPModel_startElement_handler, &
       endElement_handler = IPModel_endElement_handler, &
       characters_handler = IPModel_characters_handler)
     call close_xml_t(fxml)

     if(.not. parse_in_ip_done) &
     call  system_abort('IPModel_vdW_read_params_xml: could not initialise vdW potential. No vdW_params present?')
     this%initialised = .true.
  endif

end subroutine IPModel_vdW_read_params_xml

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!% Printing of vdW parameters: number of different types, cutoff radius, atomic numbers, etc.
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

subroutine IPModel_vdW_Print (this, file, dict)
  type(IPModel_vdW), intent(inout) :: this
  type(Inoutput), intent(inout),optional :: file
  type(Dictionary), intent(inout), optional :: dict
  integer :: i

#ifdef HAVE_GAP
  call Print("IPModel_vdW : Gaussian Approximation Potential", file=file)
  call Print("IPModel_vdW : label = "//this%label, file=file)
  call Print("IPModel_vdW : cutoff = "//this%cutoff, file=file)
  call Print("IPModel_vdW : E_scale = "//this%E_scale, file=file)
  call Print("IPModel_vdW : command_line = "//string(this%command_line),file=file)

#else
#endif

end subroutine IPModel_vdW_Print

end module IPModel_vdW_module


C$Procedure      SPKW09 ( Write SPK segment, type 9 )

      SUBROUTINE SPKW09 (  HANDLE,  BODY,    CENTER,  FRAME,
     .                     FIRST,   LAST,    SEGID,   DEGREE,
     .                     N,       STATES,  EPOCHS           )

C$ Abstract
C
C     Write a type 9 segment to an SPK file.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     NAIF_IDS
C     SPC
C     SPK
C     TIME
C
C$ Keywords
C
C     EPHEMERIS
C     FILES
C
C$ Declarations

      IMPLICIT NONE
      INTEGER               HANDLE
      INTEGER               BODY
      INTEGER               CENTER
      CHARACTER*(*)         FRAME
      DOUBLE PRECISION      FIRST
      DOUBLE PRECISION      LAST
      CHARACTER*(*)         SEGID
      INTEGER               DEGREE
      INTEGER               N
      DOUBLE PRECISION      STATES ( 6, * )
      DOUBLE PRECISION      EPOCHS (    * )

      INTEGER               MAXDEG
      PARAMETER           ( MAXDEG = 27 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   Handle of an SPK file open for writing.
C     BODY       I   NAIF code for an ephemeris object.
C     CENTER     I   NAIF code for center of motion of BODY.
C     FRAME      I   Reference frame name.
C     FIRST      I   Start time of interval covered by segment.
C     LAST       I   End time of interval covered by segment.
C     SEGID      I   Segment identifier.
C     DEGREE     I   Degree of interpolating polynomials.
C     N          I   Number of states.
C     STATES     I   Array of states.
C     EPOCHS     I   Array of epochs corresponding to states.
C     MAXDEG     P   Maximum allowed degree of interpolating polynomial.
C
C$ Detailed_Input
C
C     HANDLE         is the file handle of an SPK file that has been
C                    opened for writing.
C
C     BODY           is the NAIF integer code for an ephemeris object
C                    whose state relative to another body is described
C                    by the segment to be created.
C
C     CENTER         is the NAIF integer code for the center of motion
C                    of the object identified by BODY.
C
C     FRAME          is the NAIF name for a reference frame
C                    relative to which the state information for BODY
C                    is specified.
C
C     FIRST,
C     LAST           are, respectively, the start and stop times of
C                    the time interval over which the segment defines
C                    the state of BODY.
C
C     SEGID          is the segment identifier.  An SPK segment
C                    identifier may contain up to 40 characters.
C
C     DEGREE         is the degree of the Lagrange polynomials used to
C                    interpolate the states.  All components of the
C                    state vectors are interpolated by polynomials of
C                    fixed degree.
C
C     N              is the number of states in the input state vector
C                    array.
C
C     STATES         contains a time-ordered array of geometric states
C                    ( x, y, z, dx/dt, dy/dt, dz/dt, in kilometers and
C                    kilometers per second ) of BODY relative to CENTER,
C                    specified relative to FRAME.
C
C     EPOCHS         is an array of epochs corresponding to the members
C                    of the state array.  The epochs are specified as
C                    seconds past J2000, TDB.
C
C$ Detailed_Output
C
C     None.  See $Particulars for a description of the effect of this
C     routine.
C
C$ Parameters
C
C     MAXDEG         is the maximum allowed degree of the interpolating
C                    polynomial.  If the value of MAXDEG is increased,
C                    the SPICELIB routine SPKPV must be changed
C                    accordingly.  In particular, the size of the
C                    record passed to SPKRnn and SPKEnn must be
C                    increased, and comments describing the record size
C                    must be changed.
C
C$ Exceptions
C
C     If any of the following exceptions occur, this routine will return
C     without creating a new segment.
C
C     1) If FRAME is not a recognized name, the error
C        SPICE(INVALIDREFFRAME) is signaled.
C
C     2) If the last non-blank character of SEGID occurs past index 40,
C        the error SPICE(SEGIDTOOLONG) is signaled.
C
C     3) If SEGID contains any nonprintable characters, the error
C        SPICE(NONPRINTABLECHARS) is signaled.
C
C     4) If DEGREE is not at least 1 or is greater than MAXDEG, the
C        error SPICE(INVALIDDEGREE) is signaled.
C
C     5) If the number of states N is not at least DEGREE+1, the error
C        SPICE(TOOFEWSTATES) will be signaled.
C
C     6) If FIRST is greater than or equal to LAST then the error
C        SPICE(BADDESCRTIMES) will be signaled.
C
C     7) If the elements of the array EPOCHS are not in strictly
C        increasing order, the error SPICE(TIMESOUTOFORDER) will be
C        signaled.
C
C     8) If the first epoch EPOCHS(1) is greater than FIRST, the error
C        SPICE(BADDESCRTIMES) will be signaled.
C
C     9) If the last epoch EPOCHS(N) is less than LAST, the error
C        SPICE(BADDESCRTIMES) will be signaled.
C
C
C$ Files
C
C     A new type 9 SPK segment is written to the SPK file attached
C     to HANDLE.
C
C$ Particulars
C
C     This routine writes an SPK type 09 data segment to the open SPK
C     file according to the format described in the type 09 section of
C     the SPK Required Reading. The SPK file must have been opened with
C     write access.
C
C$ Examples
C
C     Suppose that you have states and are prepared to produce
C     a segment of type 09 in an SPK file.
C
C     The following code fragment could be used to add the new segment
C     to a previously opened SPK file attached to HANDLE. The file must
C     have been opened with write access.
C
C        C
C        C     Create a segment identifier.
C        C
C                  SEGID = 'MY_SAMPLE_SPK_TYPE_9_SEGMENT'
C
C        C
C        C     Write the segment.
C        C
C              CALL SPKW09 (  HANDLE,  BODY,    CENTER,  FRAME,
C             .               FIRST,   LAST,    SEGID,   DEGREE,
C             .               N,       STATES,  EPOCHS          )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     K.R. Gehringer (JPL)
C     N.J. Bachman   (JPL)
C     J.M. Lynch     (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.0.0, 24-DEC-2013 (NJB)
C
C        Increased MAXDEG to 27 for compatibility
C        with SPK type 21.
C
C-    SPICELIB Version 2.0.0, 19-SEP-1995 (WLT)
C
C        The routine was upgraded to support non-inertial reference
C        frames.
C
C-    SPICELIB Version 1.0.1, 05-OCT-1993 (KRG)
C
C        Removed all references to a specific method of opening the SPK
C        file in the $ Brief_I/O, $ Detailed_Input, $ Particulars and
C        $ Examples sections of the header. It is assumed that a person
C        using this routine has some knowledge of the DAF system and the
C        methods for obtaining file handles.
C
C-    SPICELIB Version 1.0.0, 05-AUG-1993 (NJB) (JML) (WLT)
C
C-&

C$ Index_Entries
C
C     write spk type_9 ephemeris data segment
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 19-SEP-1995 (WLT)
C
C        The routine was upgraded to support non-inertial reference
C        frames.
C
C-    SPICELIB Version 1.0.1, 05-OCT-1993 (KRG)
C
C        Removed all references to a specific method of opening the SPK
C        file in the $ Brief_I/O, $ Detailed_Input, $ Particulars and
C        $ Examples sections of the header. It is assumed that a person
C        using this routine has some knowledge of the DAF system and the
C        methods for obtaining file handles.
C
C-    SPICELIB Version 1.0.0, 05-AUG-1993 (NJB) (JML) (WLT)
C
C-&

C
C     SPICELIB functions
C
      INTEGER               LASTNB

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     SIDLEN is the maximum number of characters allowed in an
C     SPK segment identifier.
C
C     NS is the size of a packed SPK segment descriptor.
C
C     ND is the number of double precision components in an SPK
C     segment descriptor.
C
C     NI is the number of integer components in an SPK segment
C     descriptor.
C
C     DTYPE is the data type.
C
C     FPRINT is the integer value of the first printable ASCII
C     character.
C
C     LPRINT is the integer value of the last printable ASCII character.
C
C
      INTEGER               SIDLEN
      PARAMETER           ( SIDLEN  =  40 )

      INTEGER               NS
      PARAMETER           ( NS      =   5 )

      INTEGER               ND
      PARAMETER           ( ND      =   2 )

      INTEGER               NI
      PARAMETER           ( NI      =   6 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE   =   9 )

      INTEGER               FPRINT
      PARAMETER           ( FPRINT  =  32 )

      INTEGER               LPRINT
      PARAMETER           ( LPRINT  = 126 )

      INTEGER               STATSZ
      PARAMETER           ( STATSZ  =   6 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ  = 100 )

C
C     Local variables
C
      DOUBLE PRECISION      DCD    ( ND )
      DOUBLE PRECISION      DESCR  ( NS )
      DOUBLE PRECISION      MAXTIM

      INTEGER               CHRCOD
      INTEGER               I
      INTEGER               ICD    ( NI )
      INTEGER               REFCOD

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SPKW09' )
      END IF

C
C     Get the NAIF integer code for the reference frame.
C
      CALL NAMFRM ( FRAME, REFCOD )

      IF ( REFCOD .EQ. 0 ) THEN

         CALL SETMSG ( 'The reference frame # is not supported.'   )
         CALL ERRCH  ( '#', FRAME                                  )
         CALL SIGERR ( 'SPICE(INVALIDREFFRAME)'                    )
         CALL CHKOUT ( 'SPKW09'                                    )
         RETURN

      END IF

C
C     The segment stop time should be greater then the begin time.
C
      IF ( FIRST .GE. LAST ) THEN

         CALL SETMSG ( 'The segment start time: # is greater then ' //
     .                 'the segment end time: #'                   )
         CALL ERRDP  ( '#', FIRST                                  )
         CALL ERRDP  ( '#', LAST                                   )
         CALL SIGERR ( 'SPICE(BADDESCRTIMES)'                      )
         CALL CHKOUT ( 'SPKW09'                                    )
         RETURN

      END IF

C
C     Now check that all the characters in the segment identifier
C     can be printed.
C
      DO I = 1, LASTNB(SEGID)

         CHRCOD = ICHAR( SEGID(I:I) )

         IF ( ( CHRCOD .LT. FPRINT ) .OR. ( CHRCOD .GT. LPRINT ) ) THEN

            CALL SETMSG ( 'The segment identifier contains '  //
     .                    'nonprintable characters'               )
            CALL SIGERR ( 'SPICE(NONPRINTABLECHARS)'              )
            CALL CHKOUT ( 'SPKW09'                                )
            RETURN

         END IF

      END DO

C
C     Also check to see if the segment identifier is too long.
C
      IF ( LASTNB(SEGID) .GT. SIDLEN ) THEN

         CALL SETMSG ( 'Segment identifier contains more than ' //
     .                 '40 characters.'                          )
         CALL SIGERR ( 'SPICE(SEGIDTOOLONG)'                     )
         CALL CHKOUT ( 'SPKW09'                                  )
         RETURN

      END IF

C
C     Make sure that the degree of the interpolating polynomials is
C     in range.
C
      IF (  ( DEGREE .LT. 1 ) .OR. ( DEGREE .GT. MAXDEG )  )  THEN

         CALL SETMSG ( 'The interpolating polynomials have degree #; '//
     .                 'the valid degree range is [1, #]'              )
         CALL ERRINT ( '#', DEGREE                                     )
         CALL ERRINT ( '#', MAXDEG                                     )
         CALL SIGERR ( 'SPICE(INVALIDDEGREE)'                          )
         CALL CHKOUT ( 'SPKW09'                                        )
         RETURN

      END IF

C
C     Make sure that the number of states is sufficient to define a
C     polynomial whose degree is DEGREE.
C
      IF ( N .LE. DEGREE ) THEN

         CALL SETMSG ( 'At least # states are required to define a '  //
     .                 'polynomial of degree #.  Number of states '   //
     .                 'supplied:  #'                                  )
         CALL ERRINT ( '#', DEGREE + 1                                 )
         CALL ERRINT ( '#', DEGREE                                     )
         CALL ERRINT ( '#', N                                          )
         CALL SIGERR ( 'SPICE(TOOFEWSTATES)'                           )
         CALL CHKOUT ( 'SPKW09'                                        )
         RETURN

      END IF

C
C     Make sure the epochs form a strictly increasing sequence.
C
      MAXTIM = EPOCHS(1)

      DO I = 2, N

         IF ( EPOCHS(I) .LE. MAXTIM ) THEN

            CALL SETMSG ( 'EPOCH # having index # is not greater '    //
     .                    'than its predecessor #.'                   )
            CALL ERRDP  ( '#',  EPOCHS(I)                             )
            CALL ERRINT ( '#',  I                                     )
            CALL ERRDP  ( '#',  EPOCHS(I-1)                           )
            CALL SIGERR ( 'SPICE(TIMESOUTOFORDER)'                    )
            CALL CHKOUT ( 'SPKW09'                                    )
            RETURN
         ELSE
            MAXTIM = EPOCHS(I)
         END IF

      END DO

C
C     Make sure that the span of the input epochs includes the interval
C     defined by the segment descriptor.
C
      IF (  EPOCHS(1) .GT. FIRST ) THEN

         CALL SETMSG ( 'Segment start time # precedes first epoch #.' )
         CALL ERRDP  ( '#',  FIRST                                    )
         CALL ERRDP  ( '#',  EPOCHS(1)                                )
         CALL SIGERR ( 'SPICE(BADDESCRTIMES)'                         )
         CALL CHKOUT ( 'SPKW09'                                       )
         RETURN

      ELSE IF (  EPOCHS(N) .LT. LAST ) THEN

         CALL SETMSG ( 'Segment end time # follows last epoch #.'     )
         CALL ERRDP  ( '#',  LAST                                     )
         CALL ERRDP  ( '#',  EPOCHS(N)                                )
         CALL SIGERR ( 'SPICE(BADDESCRTIMES)'                         )
         CALL CHKOUT ( 'SPKW09'                                       )
         RETURN

      END IF

C
C     That concludes the error checks.  Make the segment.
C
C     Store the start and end times to be associated
C     with this segment.
C
      DCD(1) = FIRST
      DCD(2) = LAST

C
C     Create the integer portion of the descriptor.
C
      ICD(1) = BODY
      ICD(2) = CENTER
      ICD(3) = REFCOD
      ICD(4) = DTYPE

C
C     Pack the segment descriptor.
C
      CALL DAFPS ( ND, NI, DCD, ICD, DESCR )

C
C     Begin a new segment.
C
      CALL DAFBNA ( HANDLE, DESCR, SEGID )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'SPKW09' )
         RETURN
      END IF
C
C     The type 9 segment structure is eloquently described by this
C     diagram from the SPK Required Reading:
C
C        +-----------------------+
C        | State 1               |
C        +-----------------------+
C        | State 2               |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | State N               |
C        +-----------------------+
C        | Epoch 1               |
C        +-----------------------+
C        | Epoch 2               |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | Epoch N               |
C        +-----------------------+
C        | Epoch 100             | (First directory)
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | Epoch ((N-1)/100)*100 | (Last directory)
C        +-----------------------+
C        | Polynomial degree     |
C        +-----------------------+
C        | Number of states      |
C        +-----------------------+
C
C

      CALL DAFADA ( STATES,  N*STATSZ )
      CALL DAFADA ( EPOCHS,  N        )

      DO I = 1,   (N-1) / DIRSIZ
         CALL DAFADA (  EPOCHS( DIRSIZ*I ),  1  )
      END DO

      CALL DAFADA ( DBLE(DEGREE),   1 )
      CALL DAFADA ( DBLE(N),        1 )

C
C     As long as nothing went wrong, end the segment.
C
      IF ( .NOT. FAILED() ) THEN
         CALL DAFENA
      END IF

      CALL CHKOUT ( 'SPKW09' )
      RETURN
      END