      PROGRAM Surfvmd
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 2002 Oliver Smart & Birmingham University                    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date  Author          Modification
C 05/02 O.S.S. 		Original version
C
C reads in the

C routine FREDA used here to decode lines include common vbles
C vbles used by freda
C col: 	c*80		the command?
C kl: 	int 		no of words inputed 0 then default
C fn:	r*4(40) 	no.'s as they occur
C kn:     int     	no. of no's
C fl:     c*1(40,6)	words?
      INCLUDE 'FREDAINC'

C
C screen, keyboard
C sph_process now command line driven - comment out all
C interactive question lines with !(inter)
!(cinter)      INTEGER                   NIN
!(cinter)      PARAMETER(                NIN = 5)
!(cinter)C input/output file stream
!(cinter)      INTEGER                   SIN, SOUT
      INTEGER                   NOUT
      PARAMETER(                NOUT= 6)

      CHARACTER*200		FINPUT      ! inputfilename (penultimate argument)
      INTEGER			SIN         ! its stream number
      INTEGER			END_FINPUT  ! last character in filename
      CHARACTER*200		FOUTPUT     ! inputfilename (penultimate argument)
      INTEGER			SOUT        ! its stream number
      INTEGER			END_FOUTPUT ! last character in filename
      CHARACTER*200 		FSPHINPUT
      INTEGER			SIN2         ! its stream number
      INTEGER			END_FSPHINPUT

!(cinter)C filename
!(cinter)      CHARACTER*200             FNAME

C string for text records in hydra file
      CHARACTER*80              STRING

C abort indicator
      LOGICAL                   LABORT

C draw centre lines?
      LOGICAL                   LCEN

C override radius?
      DOUBLE PRECISION		ROVER

C lower limit radius - any smaller than this and ignore on read
      DOUBLE PRECISION		RLOWER
C number of ignored records
      INTEGER			NIGN

C sphere centre storage arrays
C maximum number, actual number, co-ords and radius
C logical indicates whether the record is the last centre
      INTEGER                   SPMAX, SPNO
      PARAMETER(                SPMAX = 500000)
      DOUBLE PRECISION          SPXYZ( 3, SPMAX), SPRAD( SPMAX)
      LOGICAL                   SPLAST( SPMAX)
C capsule option needs to have the second centre
C n.b. SPRAD is the real capsule radius not the effective rad`
      DOUBLE PRECISION          SPSEC( 3, SPMAX)
C store whether point is product of connolly - pick up by -999 	residue number
      LOGICAL			SPCONN( SPMAX)
      ! need effective radius for colouring connolly
      DOUBLE PRECISION		SPEFFR( SPMAX)

! VBLES FOR s/r SPHPEG
! flag to indicate that the sphere is peg accessible
!  0: not peg accessible
!  1: accessible from +ve end
! -1: accessible from -ve end
!  2: in the shell (within distance shell_add of a peg sphere)
! -2: ditto
      INTEGER			SP_PEG_ACC( SPMAX)

! now with  SHELL_ADD need to modify the radius of some spheres
! normally this would be equal to sprad but if sp_peg_acc = +/-2
! then this radius will be lower
      DOUBLE PRECISION		SP_PEG_RAD( SPMAX)

! SCOTDO -> SP_TDO
! SCOENC -> SP_ENC
! SCOCIRCRAD -> SP_CIRCRAD
! n.b. vble may now be changed in calculation if sphere has no intersection
! with plane under consideration
      LOGICAL			SP_TDO( SPMAX)
C s/r coarea needs a store for the east/north coords of
C each point on grid - these are measured relative to the
C initial point
! SCOCIRCRAD: the radius of the point in the plane under consideration
! in the case of calls from concal this we equal scocrad
      DOUBLE PRECISION		SP_ENC( 2, SPMAX),
     &				SP_CIRCRAD( SPMAX)

! working flag for s/r coarea
      LOGICAL			SP_PEG_FLAG( SPMAX)

C loop counts x,y&z; sphere centre count, dots count,
C 2nd sphere centre count, colour Pass count
      INTEGER                   XCOUNT, SCOUNT

C dot density to be used in output
      INTEGER                   DOTDEN

C program uses a sphere of isotropically distributed points
C on a sphere of unit radius. PTMAX is the array bound,
C PTNO is the number of dots (dependent on dotden)
      INTEGER                   PTMAX, PTNO
      PARAMETER(                PTMAX = 10000)
      DOUBLE PRECISION          PTXYZ( 3, PTMAX)

C error indicator
      LOGICAL                   LERR

C variable to define colours
      DOUBLE PRECISION          RCUT(0:3)
C if we are doing colour NPASS=3
C if we are not doing colour NPASS=1
      INTEGER                   NPASS

C if doing a grid surface then check each new potential vertex
C to see if it lies with distance 0.6*rad*dmult (where rad is
C the pore radius at the point) of any line already output
C- stored in linxyz.
C If the new point is outside this range then it is accepted
C it is joined to any vertex within the range rad*dmult the
C straight line is then corrected so that it curves with the local
C pore surface
C
C within a distance DOTD2 (the square of the minimum distance apart).
C VERMAX is the array bound, VERNO is the number of accepted dots.
C fourth number is the radius of the sphere which produced the dot
      INTEGER                   VERMAX, VERNO
      PARAMETER(                VERMAX = 10000)
      DOUBLE PRECISION          VERXYZ( 4, VERMAX)

C also store points taken from output lines
      INTEGER                   LINMAX, LINNO
      PARAMETER(                LINMAX = 30*VERMAX)
      DOUBLE PRECISION          LINXYZ( 4,LINMAX)

C 21/07/94 program changed so that dot is output if it is
C at least dmult*sphere-radius from any other dot
      DOUBLE PRECISION          DMULT

C control flag - if true do a grid surface
      LOGICAL			LGRID

C logical vble capsules on
      LOGICAL			LCAPS

C string for output
      CHARACTER*90		OUTSTR

C doing sos output
      LOGICAL			SOSOUT

      ! vbles for get_rec_commands
      CHARACTER*3000 		REC_COMMANDS_HELP_MESSAGE
      INTEGER			REC_MAX  ! array bound
      PARAMETER(		REC_MAX = 15)
      INTEGER     		REC_TOT  ! actual number of arguements
      CHARACTER*25		REC_COMMANDS(REC_MAX)
      INTEGER			REC_REQUIRE_NUM(REC_MAX)
      INTEGER			REC_REQUIRE_STRING(REC_MAX)
      INTEGER			RCOUNT
      LOGICAL			REC_FOUND( REC_MAX)
      DOUBLE PRECISION		REC_NUM( 10, REC_MAX)
      INTEGER			REC_NUM_NUM( REC_MAX)
      CHARACTER*200		REC_STRING( 10, REC_MAX)
      INTEGER			REC_STRING_NUM( REC_MAX)

      LOGICAL			LBIN		! binary file indicator
      LOGICAL                   OPENRO	! open files readonly function

! vbles for forpeg option - hole channel vector etc.
      DOUBLE PRECISION		CVECT(3)
! unit vectors in plane normal to cvect
! needed to a number of routines - originally h2dmap but now conn
! and addend
! these are normal - first is east direction (x on plane)
!                    and second is north     (y on plane)
      DOUBLE PRECISION		PERPVE(3), PERPVN(3)
! a sampling distance - the distance between planes
      DOUBLE PRECISION		SAMPLE
! option CONN introduced 1/00 -
! CONNR(1) is the connolly surface probe radius (default 1.15Angs)
!          the option is turned off by setting this radius negative
! CONNR(2) is the grid size to be used in the calculation - default 1/2 probe
      DOUBLE PRECISION		CONNR(2)
! the radius at which an end is reached
      DOUBLE PRECISION		ENDRAD

! PEG is on OR NOT
      LOGICAL 			LPEG

! vbles for working peg effect on conductance -
! first number the ratio of conductance with PEG about to water
! second number is the ratio for non-penetrating PEG
      DOUBLE PRECISION		PEGRAT(2)

! probe radius - +ve direction and -ve
      DOUBLE PRECISION		PROBE_PLUS, PROBE_NEG

! (n037) additional shell around peg spheres where the
! conductivity of the solvent is reduced.
      DOUBLE PRECISION		SHELL_ADD

      INTEGER			REC_SPHERE
      DOUBLE PRECISION		TRIA(3),TRIB(3),TRIC(3),
     &				NORMA(3),NORMB(3),NORMC(3)

      INTEGER			TCOUNT
      DOUBLE PRECISION		DIST

! end of decs ******************

!(cinter)C turn on VT codes  with bold after prompt-
!(cinter)      CALL VTCON( .TRUE.)

C initialise the no.of accepted dots to 0
      VERNO = 0

C capsule option defaults to off
      LCAPS = .FALSE.
C initialize
      LERR = .FALSE.

C write greeting
      WRITE( NOUT, '(A)')
     &' *** Program sph_process (replacing sphqpt) ***',
     &' Reads a .sph file produced by hole',
     &' option SPHPDB which contains sphere centre info,',
     &' and processes it to a either dot surface or a number'//
     &                                     ' of other options',
     &' either as a dot or grid representation',
     &' Copyright 1996,1997 by Oliver Smart and Birkbeck College',
     &' Copyright 1998 by Oliver Smart and Birmingham University',
     &' Program modification number 0001 15-11-00'

C write link time of program to screen
      CALL VERTIM( NOUT)

      ! get the controlling command line arguments

      ! establish values for s/r get
      REC_COMMANDS_HELP_MESSAGE =
     &'                     (help message start)\n'//
     &' Usage: '//
     &' surf2vmd  ((options)) '//
     &        ' -sph input_file.sph input_file.tri output_file\n'//
     &' options: \n'//
     &'  -colour (Rlow Rmid): produce a coloured surface\n'//
     &'                       surface will be \n'//
     &'                       red for pore radii < Rlow \n'//
     &'                       green for Rlow < pore radii < Rmid\n'//
     &'                       blue  for pore radii > Rmid\n'//
     &'                       default Rlow = 1.15 angs\n'//
     &'                       default Rmid = 2.30 angs\n'//
     &'                       (for connolly use effective radius\n'//
     &'                        of slab rather than pore radius\n'//
     &'  -color same as -colour for yanks\n'

!      call chrend( rec_commands_help_message, line_end)
!      write( nout, '(a)') rec_commands_help_message(1:line_end)
      REC_TOT = 3
      DO RCOUNT = 1,REC_TOT          ! initialize require store
        REC_REQUIRE_NUM(RCOUNT) = 0
	REC_REQUIRE_STRING(RCOUNT) = 0
      ENDDO
      REC_COMMANDS(1) = 'colour'
      REC_COMMANDS(2) = 'color'
      REC_COMMANDS(3) = 'sph'
      REC_REQUIRE_STRING(3) = 1

      CALL GET_REC_COMMANDS( NOUT, LERR,
     &			     REC_COMMANDS_HELP_MESSAGE,
     &                       REC_TOT, REC_COMMANDS,
     &                       REC_REQUIRE_NUM, REC_REQUIRE_STRING,
     &                       REC_FOUND, REC_NUM, REC_NUM_NUM,
     &			     REC_STRING, REC_STRING_NUM,
     &			     .TRUE., FINPUT, .TRUE., FOUTPUT)
      IF (LERR) GOTO 55555

      ! REC_COMMANDS(1) = 'colour'
      ! REC_COMMANDS(2) = 'color'
      ! if we are doing colour NPASS=3
      ! if we are not doing colour NPASS=1 accept any radii
      NPASS = 1
      RCUT(0) = -1.0
      RCUT(1) = 9999.0
      IF (REC_FOUND(1).OR.REC_FOUND(2)) THEN
        NPASS = 3
        RCUT(1) = 1.15
	RCUT(2) = 2.30
	RCUT(3) = 9999.0 ! default values for colour
	! pick up the radii if specified
	IF (REC_NUM(1,1).GT.-1E10) RCUT(1) = REC_NUM(1,1)
	IF (REC_NUM(1,2).GT.-1E10) RCUT(1) = REC_NUM(1,2)
	IF (REC_NUM(2,1).GT.-1E10) RCUT(2) = REC_NUM(2,1)
	IF (REC_NUM(2,2).GT.-1E10) RCUT(2) = REC_NUM(2,2)
      ENDIF

      ! REC_COMMANDS(3) = 'sph'
      IF (REC_FOUND(3)) THEN
        FSPHINPUT = REC_STRING(1, 3)
      ELSE
        WRITE( NOUT, '(A)')
     &'Error you must specify the .sph file as an input: ',
     &'surf2vmd -sph input.sph input.tri output.vmd_plot'
        LERR = .TRUE.
	GOTO 55555

      ENDIF

      ! end of unpacking arguments

      ! find last character in each filename
      CALL CHREND( FOUTPUT, END_FOUTPUT)
      CALL CHREND( FINPUT, END_FINPUT)
      CALL CHREND( FSPHINPUT, END_FSPHINPUT)

! open the input sph  file as readonly
      IF (.NOT.OPENRO( SIN, FINPUT, NOUT)) THEN
        WRITE( NOUT, '(A,A,A)')
     &' Error cannot open input file: ''', FINPUT(1:END_FINPUT), ''''
        LERR = .TRUE. ! have failed
        GOTO 55555
      ENDIF
! open the input sph  file as readonly
      IF (.NOT.OPENRO( SIN2, FSPHINPUT, NOUT)) THEN
        WRITE( NOUT, '(A,A,A)')
     &' Error cannot open input file: ''', FSPHINPUT(1:END_FSPHINPUT),
     &                                                            ''''
        LERR = .TRUE. ! have failed
        GOTO 55555
      ENDIF

! open the output file as new
! use s/r newop - this keeps old version removes tilda's spaces etc. etc.
! arguments output stream, error indicator,
! reduce_output_variable (0 for full), filename, filestream, binary indicator
      IF (FOUTPUT(1:4).NE.'none') THEN
        LBIN = .FALSE.
        CALL NEWOP( NOUT, LERR, 0,
     &                  FOUTPUT, SOUT, LBIN)
        IF (LERR) THEN
          WRITE( NOUT, '(A,A,A)')
     &' Error cannot open output file: ''', FOUTPUT(1:END_FOUTPUT), ''''
          LERR = .TRUE. ! have failed
          GOTO 55555
        ENDIF
!	WRITE( SOUT, '(A)')
!     &'draw delete all ',   ! header
!     &'draw color green '
      ELSE
        ! no output file - only to be used for -peg option
        SOUT = -1
	WRITE( NOUT, '(A)')
     &'WARNING ''none'' specified as output file - so have not opened',
     &'        one.  This only makes sense with -peg option'
      ENDIF

      WRITE( NOUT, '(A,A,A)')
     &'Have opened ', FINPUT(1:END_FINPUT),   ' for surf tri input ',
     &'        and ', FSPHINPUT(1:END_FSPHINPUT), ' for sph input',
     &'        and ', FOUTPUT(1:END_FOUTPUT), ' for output'

C have opened input and output files
C and got initial conditions start work
      ROVER  = 0.
      RLOWER = -1D06
      CALL SPH_PROCESS_READ( NOUT, LERR, SIN2, ROVER, RLOWER,
     &				   SPMAX, SPNO, SPXYZ, SPRAD, SPLAST,
     &				   SPSEC, SPCONN, SPEFFR, LCAPS,
     & 				   SAMPLE, CVECT, PERPVE, PERPVN,
     &				   CONNR, ENDRAD )
      write( *, *) sprad(1)
      IF (LERR) GOTO 55555
      DO SCOUNT = 1, SPNO
        DO TCOUNT = 1, SPNO
	  IF(SCOUNT.NE.TCOUNT) THEN ! look at the pair if different
	    ! Q: is the sphere scount inside sphere tcount
	    DIST = (SPXYZ(1,SCOUNT)-SPXYZ(1,TCOUNT))**2 +
     &             (SPXYZ(2,SCOUNT)-SPXYZ(2,TCOUNT))**2 +
     &             (SPXYZ(3,SCOUNT)-SPXYZ(3,TCOUNT))**2
            IF (DIST.LT.SPRAD(TCOUNT)**2) THEN
	      ! could be inside - centre of scount is in tcount
	      DIST = SQRT(DIST)
	      DIST = DIST+ABS(SPRAD(SCOUNT))
	      IF (DIST.LE.ABS(SPRAD(TCOUNT))) THEN
	        ! inside - mark by chaging case of radius
		SPRAD(SCOUNT) = -ABS(SPRAD(SCOUNT))
	      ENDIF
	    ENDIF

	  ENDIF
	ENDDO
      ENDDO
      DO SCOUNT = 1, SPNO
        WRITE( SOUT,'(4F10.4)')
     &   SPXYZ(1,SCOUNT), SPXYZ(2,SCOUNT), SPXYZ(3,SCOUNT),
     &   SPRAD(SCOUNT)
      ENDDO
C! now we have the .sph file in memory go through the tri file
C10    CONTINUE
C
C        READ( SIN, '(A)', END=55) COL
C        CALL FREDA(1,80,FL,6)
C        IF (KN.EQ.1) THEN
C 	 REC_SPHERE = FN(1)
C        ELSE
C 	 stop
C        ENDIF

C        READ( SIN, '(A)', END=55) COL
C        CALL FREDA(1,80,FL,6)
C        IF (KN.EQ.6) THEN
C 	 TRIA(1)  = FN(1)
C 	 TRIA(2)  = FN(2)
C 	 TRIA(3)  = FN(3)
C 	 NORMA(1) = FN(4)
C 	 NORMA(2) = FN(5)
C 	 NORMA(3) = FN(6)
C        ELSE
C	 stop
C        ENDIF

C	READ( SIN, '(A)', END=55) COL
C	CALL FREDA(1,80,FL,6)
C	IF (KN.EQ.6) THEN
C	  TRIB(1)  = FN(1)
C	  TRIB(2)  = FN(2)
C	  TRIB(3)  = FN(3)
C	  NORMB(1) = FN(4)
C	  NORMB(2) = FN(5)
C	  NORMB(3) = FN(6)
C	ELSE
C	  stop
C	ENDIF
C	CALL FREDA(1,80,FL,6)
C	READ( SIN, '(A)', END=55) COL
C	IF (KN.EQ.6) THEN
C	  TRIC(1)  = FN(1)
C	  TRIC(2)  = FN(2)
C	  TRIC(3)  = FN(3)
C	  NORMC(1) = FN(4)
C	  NORMC(2) = FN(5)
C	  NORMC(3) = FN(6)
C	ELSE
C	  stop
C	ENDIF

C!	WRITE( SOUT, '(12(A,3F11.5) )')
C!     &'draw trinorm { ', TRIA,  ' }  {', TRIB, '}  {', TRIC, ' }  {',
C!     & NORMA,  ' }  {', NORMB, ' }  {',   NORMC, ' }'
C	WRITE( SOUT, '(12(A,3F11.5) )')
C     &'draw triange { ', TRIA,  ' }  {', TRIB, '}  {', TRIC, ' }'
C      GOTO 10
C55    CONTINUE

55555 CONTINUE
      STOP 'FORTRAN STOP - sphqpt normal completion.'
      END


! <module_mc_wind_domain.for - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a simplified
!*    EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*
!* ==========================================
!*
!DEC$ FIXEDFORMLINESIZE: 132
!***********************************************************************

      module module_mc_wind_domain

!     This module contains the declaration of the variables defining
!     the model domain.

! Modifications:
!    29 Jan 2019  M. Karl: replaced real*8 by double precision
!
!***********************************************************************

!***  Unique simulation ID:
      character (len=256) :: sim_id

!***  Sideral day frequency:
      real, parameter :: sid_freq = 0.7292E-4

      integer :: im
      integer :: jm
      integer :: km

      real :: clon,clat
      real :: fc
      real :: dx
      real :: dy

      real :: first_layer_depth
      real :: stretch_factor

      double precision :: h0

!     The variable "elev_max" is just used when testing with
!     an idealized topography:

      real    :: elev_max

!     The name of the domain. This name is used to distinguish
!     various domain-specific inputs:
      character (len=256) :: domain_name

!     Applied 1D-arrays (vectors):

!_LHS_Aug2007_Start:
      real, allocatable   :: user_def_deltasigma(:)
!_LHS_Aug2007_End.

      double precision, allocatable :: sigma(:)
      double precision, allocatable :: sigmal(:)
      double precision, allocatable :: delta_sigma(:)
      double precision, allocatable :: delta_sigmal(:)

      double precision, allocatable :: h0msig(:)
      double precision, allocatable :: h0msigl(:)

! *** Applied 2D-arrays:

      real, allocatable :: in_top(:,:)
      real, allocatable :: topo(:,:)
      real, allocatable :: topou(:,:)
      real, allocatable :: topov(:,:)

! *** Double precissions for the following model variables:

      double precision, allocatable :: depth(:,:)
      double precision, allocatable :: depthu(:,:)
      double precision, allocatable :: depthv(:,:)

      double precision, allocatable :: dD_dx(:,:)
      double precision, allocatable :: dD_dy(:,:)

      double precision, allocatable :: dRD_dx(:,:)
      double precision, allocatable :: dRD_dy(:,:)
      double precision, allocatable :: d2RD_dxx(:,:)
      double precision, allocatable :: d2RD_dyy(:,:)

      contains

! *** DOMAIN MODULE INTERFACE ROUTINES

!*******************************************************************************************

      subroutine call_construct_domain
!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'call_construct_domain' :: call_construct_domain
      implicit none

      call construct_domain

      return

      end subroutine call_construct_domain

!*******************************************************************************************

      subroutine call_initialize_static
!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'call_initialize_static' :: call_initialize_static
      implicit none

      call initialize_static

      return

      end subroutine call_initialize_static

! **************************************************************************************

      SUBROUTINE SendSimID(cv_sim_id,iv_sim_id_len)

!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'SendSimID' :: SendSimID
      IMPLICIT NONE

      integer                      :: iv_sim_id_len
      character(len=iv_sim_id_len) :: cv_sim_id

!DEC$ ATTRIBUTES REFERENCE :: cv_sim_id

! *** Local variables:

! *** Initializing the variables declared above in: "module_mc_wind_domian"

      sim_id = cv_sim_id

      END SUBROUTINE SendSimID

! **************************************************************************************

      SUBROUTINE SendDomainDefinitions(rv_clon,rv_clat, &
            iv_im,iv_jm,iv_km,rv_dx,rv_dy,rav1_ds, &
            rav2_in_top)

!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'SendDomainDefinitions' :: SendDomainDefinitions

!----------------------------------------------------------------------------------------

      IMPLICIT NONE

      integer :: iv_im
      integer :: iv_jm
      integer :: iv_km

      real :: rv_clon
      real :: rv_clat

      real :: rv_dx
      real :: rv_dy

      real :: rav1_ds(iv_km)
      real :: rav2_in_top(iv_im,iv_jm)

! *** Initializing the McWIND variables declared above in: "module_mc_wind_domain"

      clon = rv_clon
      clat = rv_clat

      im = iv_im
      jm = iv_jm
      km = iv_km

! *** Convert from km to meters:
      dx = rv_dx * 1000.0
      dy = rv_dy * 1000.0

      if (.not. allocated(user_def_deltasigma))  &
           allocate(user_def_deltasigma(iv_km))

      user_def_deltasigma = rav1_ds

      if (.not. allocated(in_top))  &
           allocate(in_top(iv_im,iv_jm))

      in_top = rav2_in_top

      END SUBROUTINE SendDomainDefinitions

!****************************************************************************************

      SUBROUTINE SendDomainAdvanced(rv_stretch_factor, &
                       rv_first_layer_depth)

!DEC$ ATTRIBUTES DLLEXPORT,STDCALL,ALIAS:'SendDomainAdvanced' :: SendDomainAdvanced

!----------------------------------------------------------------------------------------

      IMPLICIT NONE

      real :: rv_stretch_factor
      real :: rv_first_layer_depth

! *** Variable explanation and Default values:
! ***
! *** rv_stretch_factor    = -1.0  ! If positive it indicate the stretch-factor of the
! ***                              ! thickness of the vertical layers. User defined
! ***                              ! thicknesses applied if negative.
! ***
! *** rv_first_layer_depth =  0.0  ! Vertical thickness of first layer. Not applied if
! ***                              ! the "rv_stretch_factor" is negative.

! *** Initializing the variables declared above in: "module_mc_wind_domain"

      stretch_factor    = rv_stretch_factor
      first_layer_depth = rv_first_layer_depth

      END SUBROUTINE SendDomainAdvanced

!***********************************************************************************

      SUBROUTINE FreeDomain_Memory()

!-----------------------------------------------------------------------------------

      implicit none

      if (allocated(user_def_deltasigma))  &
    deallocate(user_def_deltasigma)
      if (allocated(in_top))  deallocate(in_top)

      END SUBROUTINE FreeDomain_Memory

! *** End of module module_mc_wind_domain.

      end module module_mc_wind_domain


      SUBROUTINE SFCBKGD_SFC(bgmodel,t,q,height,heightsfc
     &,td_sfc,tsfc,sh_sfc, ter,p,IMX,JMX,KX,psfc,nx_pr,ny_pr)

c inputs are from laps analyzed 2- 3d fields
C     INPUT       t        ANALYZED TEMPERATURE     3D
C                 q        Analyzed MIXXING RATIO   3D
C                 height   ANALYZED HEIGHT          3D
c                 heightsfc ANALYZED HEIGHT         2D
C                 ter      TERRAIN                  2D
C                 IMX      DIMENSION E-W
C                 JMX      DIMENSION N-S
C                 KX       NUMBER OF VERTICAL LEVELS
C                 p        LAPS Pressure levels     1D
c                 tsfc     !I/O input model T, output recomputed T
c                 sh_sfc   !I,   model sh
c                 td_sfc   !I/O, model Td recomputed in routine
c                 qsfc     !I/O surface spec hum, Input as q or computed internally
c
c Recompute surface variables on hi-res terrain using 2D model surface data.

c
c J. Smart    09-22-98:	Original Version: This is used to compute
c                       sfc p for lgb when using NOGAPS1.0 deg since
c                       this field currently does not come with the
c                       model grids at AFWA.
c    "        02-01-99: Recompute sh_sfc with new psfc and tsfc for
c                       consistency.
c    "        11-18-99: Put psfc,tsfc, and sh_sfc comps into subroutine
c KML:  CHANGES MADE APRIL 2004
c this subroutine now reads in heightsfc and td_sfc
c heightsfc and td_sfc are passed into subroutine compute_sfc_bgfields
c KML: END
c
      IMPLICIT NONE

      INTEGER    I
      INTEGER    IMX
      INTEGER    J
      INTEGER    JMX
      INTEGER    K
      INTEGER    KX
      INTEGER    it
      INTEGER    bgmodel
      INTEGER    nx_pr,ny_pr,ip,jp
      INTEGER    istatus

      LOGICAL    lfndz

      REAL       HEIGHT      ( IMX , JMX, KX )
      REAL       HEIGHTSFC   ( IMX, JMX )
      REAL       P           ( nx_pr,ny_pr,KX )
      REAL       PSFC        ( IMX , JMX )               ! I    (MB)
      REAL       TSFC        ( IMX , JMX )               ! I/O  (K)
      REAL       Q           ( IMX , JMX , KX )
      REAL       rh3d        ( IMX , JMX , KX )
      REAL       rh2d        ( IMX , JMX )
      REAL       sh_sfc      ( imx,  jmx )               ! I    (kg/kg)
      REAL       td_sfc      ( imx,  jmx )               ! I/O  (K)
      REAL       T           ( IMX , JMX , KX )
      REAL       esat
      REAL       TER         ( IMX , JMX )
      REAL       make_td
      REAL       make_rh
      REAL       make_ssh
      REAL       t_ref,badflag
      REAL       p_mb
      REAL       r_missing_data
c
c if bgmodel = 6 or 8 then sh_sfc is indeed td sfc
c if bgmodel = 4      then sh_sfc is rh (WFO - RUC)
c if bgmodel = 9      then no surface fields input. Compute all from 3d
c                     fields. q3d used. (NOS - ETA)
c otherwise sh_sfc is input with q
c
      write(6,*)' Subroutine sfcbkgd_sfc, bgmodel = ',bgmodel

      call get_r_missing_data(r_missing_data,istatus)

      t_ref=-132.0

      if(minval(td_sfc) .eq. r_missing_data .AND.
     &   maxval(td_sfc) .eq. r_missing_data       )then
         write(6,*)' NOTE: td_sfc has missing data values'
         write(6,*)' Computing td_sfc from sh_sfc'

          do i = 1,imx
          do j = 1,jmx
              td_sfc(i,j)=make_td(psfc(i,j)/100.,tsfc(i,j)-273.15
     1                           ,sh_sfc(i,j)*1000.
     1                           ,t_ref)+273.15
          enddo ! j
          enddo ! i
      endif

      if(bgmodel.eq.3.or.bgmodel.eq.9)then
         write(6,*)' bgmodel is ',bgmodel,' convert 3D q to rh'
         do k=1,kx
            do j=1,jmx
            do i=1,imx
               ip = min(i,nx_pr)
               jp = min(j,ny_pr)
               p_mb = p(ip,jp,k) / 100.
               rh3d(i,j,k)=make_rh(p_mb,t(i,j,k)-273.15,q(i,j,k)*1000.
     +,t_ref)*100.
            enddo
            enddo
         enddo

         badflag=0.
         write(6,*)
     &   ' Interp 3D T and RH to hi-res terrain, set sh_sfc array to RH'
         call interp_to_sfc(ter,rh3d,height,imx,jmx,kx,
     &                      badflag,sh_sfc) ! Here sh_sfc temporarily is RH
         call interp_to_sfc(ter,t,height,imx,jmx,kx,badflag,
     &                      tsfc)
      endif

      write(6,*)' Compute sfc fields using 2D model surface data'

      do j=1,jmx
      do i=1,imx

         ip = min(i,nx_pr)
         jp = min(j,ny_pr)

         k=0
         lfndz=.false.
         do while(.not.lfndz)
            k=k+1
            if(height(i,j,k).gt.ter(i,j))then
               lfndz=.true.
c
c
c recompute psfc with moisture consideration. snook's orig code.
c              it=sh_sfc(i,j)*100.
c              it=min(45000,max(15000,it))
c              xe=esat(it)
c              qsfc=0.622*xe/(p_sfc-xe)
c              qsfc=qsfc/(1.+qsfc)
c --------------------------------------------------

               if(k.gt.0)then
                  call compute_sfc_bgfields_sfc(bgmodel,imx,jmx,kx,i,j,k
     &,ter(i,j),height,heightsfc(i,j),t,p,q,t_ref,psfc(i,j),tsfc(i,j),
     &sh_sfc(i,j),td_sfc(i,j),ip,jp,nx_pr,ny_pr)
c              else
c                 tsfc(i,j)=t(i,j,k)
c                 td_sfc(i,j)=make_td(p(k),t(i,j,k)-273.15,q(i,j,k)*1000.
c    &,t_ref)+273.15

               endif

            endif
            if(k.eq.kx)lfndz=.true.
         enddo
      enddo
      enddo

      if(minval(sh_sfc) .eq. r_missing_data .AND.
     &   maxval(sh_sfc) .eq. r_missing_data       )then
         write(6,*)' NOTE: sh_sfc has missing data values'
      endif

      if(minval(td_sfc) .eq. r_missing_data .AND.
     &   maxval(td_sfc) .eq. r_missing_data       )then
         write(6,*)' WARNING: td_sfc has missing data values'
      endif

      write(6,*)' returning from subroutine sfcbkgd_sfc'

      return
      end
c
c----------------------------------------------------------------------------
c
      subroutine compute_sfc_bgfields_sfc(bgm,nx,ny,nz,i,j,k,ter,height
     &,heightsfc,t,p,q,t_ref,psfc,tsfc,sh_sfc,td_sfc,ip,jp,nx_pr,ny_pr)
c
c J. Smart 11/18/99 put existing code in subroutine for other process use in laps
c
c KML: CHANGES MADE APRIL 2004
c heightsfc (analyzed 2m height) and td_sfc are now read in
c dz is computed as the difference between heightsfc and terrain
c lapse rate adjustment is made to tsfc and td_sfc (2m level)...
c  ...rather than t and td2 (pressure levels)
c KML: END
      implicit none

      integer nx,ny,nz
      integer i,j,k            !I, i,j,k coordinate of point for calculation
      integer bgm              !I, model type {if = 0, then sh_sfc input = qsfc}
      integer nx_pr,ny_pr,ip,jp
      integer istatus

      real   p(nx_pr,ny_pr,nz) !I, pressure of levels (Pa)
      real   ter               !I, Terrain height at i,j
      real   t_ref             !I, reference temp for library moisture conv routines

      real   height(nx,ny,nz)  !I, heights of pressure levels 3d
      real   heightsfc         !I, height of surface at i,j
      real   t(nx,ny,nz)       !I, temperatures 3d
      real   q(nx,ny,nz)       !I, specific humidity 3d
      real   psfc              !I/O, input bkgd model sfc p; output recalculated surface pressure, pa
      real   tsfc              !I/O input model T, output recomputed T
      real   sh_sfc            !I/O input model SH
      real   td_sfc            !I/O input model Td, output recomputed Td
      real   qsfc              !I/O surface spec hum, Input as q or computed internally

      real   tbar
      real   td1,td2
      real   p_mb,p_mb_p1,p_mb_m1
      real   pdry   ! BLS/Iteris - Needed for estimate of sfc pressure before moisture adjustment
      real   G,R
      real   ssh2,make_ssh,make_td
      real   dz,dzp,dtdz
      real   tvsfc,tvk,tbarv
      real   r_missing_data

      parameter (G         = 9.8,
     &           R         = 287.04)
c
c if first guess values are missing data then return missing data
c
       call get_r_missing_data(r_missing_data,istatus)
       if(tsfc.lt.500.0.and.t(i,j,k).lt.500.0.and.
     .    td_sfc.lt.500.0)then
c
c first guess psfc without moisture consideration
c

          p_mb = p(ip,jp,k) / 100.

          tbar=(tsfc+t(i,j,k))*0.5
          dz=heightsfc-ter
c         psfc=p_mb*exp(G/(R*tbar)*dz)
          psfc=psfc/100.                                ! calcs done in mb

          ! BLS/Iteris - Original code modified psfc directly, only to
          ! do it again farther below, which was not correct and leading
          ! to wacky surface pressures in area of big dz
          ! ORIG:  psfc=psfc*exp(G/(R*tbar)*dz)
          pdry=psfc*exp(G/(R*tbar)*dz)

!         Determine qsfc
          ! BLS/Iteris - Where pdry is used below used to be psfc (incorrect)
          if(bgm.eq.0.or.bgm.eq.6.or.bgm.eq.8)then      ! sh_sfc is Td
             qsfc=ssh2(pdry,tsfc-273.15
     &                  ,sh_sfc-273.15,t_ref)*.001      ! sh is kg/kg
          elseif(bgm.eq.3.or.bgm.eq.4.or.bgm.eq.9)then  ! sh_sfc is RH
             qsfc=make_ssh(pdry,tsfc-273.15
     &                      ,sh_sfc/100.,t_ref)*.001    ! sh is kg/kg

          else                                          ! sh_sfc is q (kg/kg)
             qsfc=sh_sfc
          endif

c pressure
          tvsfc=tsfc*(1.+0.608*qsfc)
          tvk=t(i,j,k)*(1.+0.608*q(i,j,k))
          tbarv=(tvsfc+tvk)*.5
c         psfc=(p_mb*exp(G/(R*tbarv)*dz))*100.  !return units = pa
          psfc=(psfc*exp(G/(R*tbarv)*dz))*100.  !return units = pa
          if(k.gt.1)then
             dzp=height(i,j,k)-height(i,j,k-1)
c temp
             dtdz=(t(i,j,k-1)-t(i,j,k))/dzp
             tsfc=tsfc+dtdz*dz
c dew point temp
             td2=make_td(p_mb,t(i,j,k)-273.15,q(i,j,k)*1000.,t_ref)
             p_mb_m1 = p(ip,jp,k-1) / 100.
             td1=make_td(p_mb_m1,t(i,j,k-1)-273.15,q(i,j,k-1)*1000.
     .,t_ref)
             td_sfc=td_sfc+((td1-td2)/dzp)*dz

             td_sfc = min(tsfc,td_sfc)
c
          else
             dzp=height(i,j,k+1)-height(i,j,k)
             p_mb_p1 = p(ip,jp,k+1) / 100.
             td2=make_td(p_mb_p1,t(i,j,k+1)-273.15
     &,q(i,j,k+1)*1000.,t_ref)+273.15
             td1=make_td(p_mb,t(i,j,k)-273.15
     &,q(i,j,k)*1000.,t_ref)+273.15
             dtdz=(t(i,j,k)-t(i,j,k+1))/dzp
             tsfc=tsfc+dtdz*dz
             tbar=(tsfc+t(i,j,k))*0.5
c            psfc=p_mb*exp(G/(R*tbar)*dz)
             psfc=psfc*exp(G/(R*tbar)*dz)
             td_sfc=td_sfc+((td1-td2)/dzp)*dz

             td_sfc = min(tsfc,td_sfc)

          endif
       else
          psfc =r_missing_data
          tsfc =r_missing_data
          td_sfc=r_missing_data
       endif
       return
       end


*-----------------------------------------------------------------------
*     R E A D W T
*-----------------------------------------------------------------------
*
*     If the wavefunction expansion has been obtained from an
*     MCHF calculation, the weights are J independent and are read from
*     the file <name>.c . If the wavefunction expansion has been
*     obtained from a CI calculation, the weights
*     are read from the file <name>.l .NR is the ordernumber of the
*     main cfg component in the CI expansion
*     and determines where in the file the weights are read.
*     The weights are saved in an array WT(K) where K is the number of
*     the configurations in the expansion

      SUBROUTINE  READWT(MAXORB,IMCHF,NCFG,NR)
C      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER CFGNR
      CHARACTER*80 LINE
      COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,
     : IALL,JSC(3),ISCW
      COMMON/RYDBERG/RYDBRG,ZUM,ENERGY

      POINTER(QWT,WT(1))

      COMMON /NAN/ QWT

*     Read from <name>.c

*     allocate memory

      call alloc(qwt,ncfg,8)

      IF (IMCHF.EQ.1) THEN
         REWIND(UNIT=IREAD)
         DO 5 K=1,3+((MAXORB-1)/20)
            READ(IREAD,*)
5        CONTINUE
         DO 10 K=1,NCFG
            READ(IREAD,100) WT(K)
            READ(IREAD,*)
10       CONTINUE
100      FORMAT(T65,F15.12)
Cww100      FORMAT(T65,F10.7)
         RETURN
      ENDIF

*     Weights from CI calc. If IMCHF=2 read from <name>.l
*     else if IMCHF=3 read from <name>.j

      J=0
      READ(63,200) NNCFG
200   FORMAT(T40,I7)
Cww old ci format 200   FORMAT(T38,I4)
      IF (NNCFG.NE.NCFG) THEN
         WRITE(0,*) ' Unequal numer of cfg in <name>.c and <name>.j(l)'
         STOP
      ENDIF

*     Determine how many lines the array of weights occupy
*     and the number of weights on the last line.

      IF (MOD(NNCFG,7).EQ.0) THEN
         NRLINES=NNCFG/7
         NRLL=0
      ELSE
         NRLINES=NNCFG/7+1
         NRLL=MOD(NNCFG,7)
      ENDIF

*     Find the right array of weights in the file.
*     Firstly the right J quantum number should be found.

20    READ(63,*)
      READ(63,*)
      READ(63,300) JJ,NUMBER
300   FORMAT(T8,I6,T23,I4)

      IF (IMCHF.EQ.2) THEN
         JJ=0
         MAX=0
         MIN=0
      ENDIF
      IF (JJ.GT.MAX) THEN
         DO 30 K=1,NUMBER*(NRLINES+2)
            READ(63,*)
30       CONTINUE
         GO TO 20
      ENDIF

      J=J+1
      N=0
      ENERGY=0.0

*     Secondly the right configuration should be found.

      DO 40 I=1,NUMBER
      READ(63,*)
      READ(63,400) CFGNR,ENERG
      IF (CFGNR.EQ.NR) THEN
	 ENERGY=ENERG
         N=N+1
         DO 50 K=1,NNCFG/7
                  READ(63,500) (WT(L),L=7*(K-1)+1,7*K)
                  WRITE(*,*) (WT(L),L=7*(K-1)+1,7*K)
50       CONTINUE
         IF (NRLL.NE.0) THEN
                 READ(63,500) (WT(L),L=NNCFG-NRLL+1,NNCFG)
                 write(*,*) (WT(L),L=NNCFG-NRLL+1,NNCFG)
         ENDIF
      ELSE
         DO 60 K=1,NRLINES
            READ(63,*)
60       CONTINUE
      ENDIF
40    CONTINUE
400   FORMAT(I6,F16.9)
CGG400   FORMAT(I6)
500   FORMAT(7F11.8)
CGG500   FORMAT(7F15.12)
Cww500   FORMAT(7F10.7)
6     FORMAT(A,I4,A)
      IF (N.EQ.0) THEN
         IF (IMCHF.EQ.2) THEN
         WRITE(0,*) 'There is no eigenvector in the file <name>.l that'
         WRITE(0,6) 'has cfg',NR,' as the dominating component.'
         WRITE(0,*) 'Change the number of the dominating component in'
         WRITE(0,*) 'the wanted eigenvector to the right one according'
         WRITE(0,*) 'to your identification and rerun the program.'
         STOP
         ELSE
         WRITE(0,6) 'There is no eigenvector with 2*J=',JJ,' in the'
        WRITE(0,6) 'file <name>.j that has cfg',NR,' as the dominating'
         WRITE(0,*) 'component. Change the number of the dominating'
         WRITE(0,*) 'component in the wanted eigenvector to the right'
         WRITE(0,*) 'one according to your identification and rerun'
         WRITE(0,*) 'the program.'
         STOP
         ENDIF
      ENDIF
      IF (N.GT.1) THEN
         IF (IMCHF.EQ.2) THEN
         WRITE(0,*) 'There is more than one eigenvector in the file'
         WRITE(0,6) '<name>.l that has cfg',NR,' as the dominating'
         WRITE(0,*) 'component. Discard the unwanted eigenvectors'
         WRITE(0,*) 'and change the digit giving the number of eigen-'
         WRITE(0,*) 'vectors to the right one and rerun the program.'
         STOP
         ELSE
         WRITE(0,6) 'There is more than one eigenvector with 2*J=',JJ
         WRITE(0,6) 'in the file <name>.j that has cfg',NR,' as'
         WRITE(0,*) 'the dominating component. Discard the unwanted'
         WRITE(0,*) 'eigenvectors and change the digit giving the'
         WRITE(0,*) 'number of eigenvectors to the right one and'
         WRITE(0,*) 'rerun the program.'
         STOP
         ENDIF
      ENDIF
      IF (JJ.EQ.MIN) THEN
         GO TO 999
      ENDIF
      GO TO 20
999   RETURN
      END


      subroutine smp_filter

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the reduction of pollutants in surface runoff
!!    due to an edge of field filter or buffer strip

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sedminpa(:) |kg P/ha       |amount of active mineral phosphorus sorbed to
!!                               |sediment in surface runoff in HRU for day
!!    sedminps(:) |kg P/ha       |amount of stable mineral phosphorus sorbed to
!!                               |sediment in surface runoff in HRU for day
!!    surfq(:)    |mm H2O        |surface runoff generated on day in HRU
!!    hru_ha(:)   |ha            |area of HRU in hectares
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sedminpa(:) |kg P/ha       |amount of active mineral phosphorus sorbed to
!!                               |sediment in surface runoff in HRU for day
!!    sedminps(:) |kg P/ha       |amount of stable mineral phosphorus sorbed to
!!                               |sediment in surface runoff in HRU for day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

    use basin_module
    use hru_module, only : hru, surfq, ihru, sagyld, silyld, clayld, lagyld, sedorgn, surqno3, sedminpa,  &
      sedminps, sedorgp, surqsolp, sedyld, sanyld
    use soil_module
    use constituent_mass_module
    use time_module
    use output_ls_pesticide_module

    implicit none

    integer :: i              !                |
    integer :: j              !none            |hru number
    integer :: k              !none            |counter
    real :: drain_vfs1        !ha	           |drainage area of vfs section 1
    real :: drain_vfs2        !ha	           |drainage area of vfs section 2
    real :: drain_vfs3        !	           |
    real :: area_vfs1         !ha	           |Area of vfs section 1
    real :: area_vfs2         !ha	           |Area of vfs section 2
    real :: vfs_depth1        !mm	           |Runoff Loading for vfs section 1
    real :: vfs_depth2        !mm	           |Runoff Loading for vfs section 2
    real :: vfs_sed1          !kg/m^2          |sediment loading for vfs section 1
    real :: vfs_sed2          !kg/m^2          |sediment loading for vfs section 2
    real :: surq_remove1      !%               |Surface runoff removal for for vfs section 1
    real :: surq_remove2      !%               |Surface runoff removal for for vfs section 2
    real :: surq_remove       !%               |Average surface runoff removal for for entire vfs
    real :: sed_remove1       !%               |sediment removal for for vfs section 1
    real :: sed_remove2       !%               |sediment removal for for vfs section 2
    real :: sed_remove        !%               |Average sediment removal for for entire vfs
    real :: remove1           !%               |Generic removal for for vfs section 1
                              !                |(recycled for constituants)
    real :: remove2           !%               |Generic removal for for vfs section 2
                              !                |(recycled for constituants)
    real :: sedtrap           !                |
    real :: xrem              !                !
    real :: vfs_ratio1        !                !
    real :: vfs_ratio2        !                !
    real :: orgn_remove       !%	           |Average organic N removal from surface
                              !                |runoff for for entire vfs
    real :: surqno3_remove    !%	           |Average nitrate removal from surface
                              !                |runoff for for entire vfs
    real :: partp_remove      !%	           |Average particulate P removal from surface
                              !                | runoff for for entire vfs
    real :: solP_remove       !%	           |Average soluble P removal from surface
                              !                |runoff for for entire vfs
    real :: remove21          !                |
    integer :: icmd           !                |

    j = ihru

	if (i == 100) then
	remove2=0
	end if

!! Filter only if there is some surface runoff
	if (surfq(j) > .0001) then

!! vfs comnposed of two sections one with more concentrated flow than the other

!! Calculate drainage area of vfs 1 2 3 in ha
	drain_vfs1 = (1-hru(j)%lumv%vfscon)* hru(j)%area_ha
	drain_vfs2 = ((1-hru(j)%lumv%vfsch) * hru(j)%lumv%vfscon)* hru(j)%area_ha
	drain_vfs3 = hru(j)%lumv%vfscon * hru(j)%lumv%vfsch * hru(j)%area_ha

!! Calculate area of vfs 1 and 2 in ha
	area_vfs1 = hru(j)%area_ha * 0.9 / hru(j)%lumv%vfsratio
	area_vfs2 = hru(j)%area_ha * 0.1 / hru(j)%lumv%vfsratio

!!	Calculate drainage area to vfs area ratio (unitless)
	vfs_ratio1 = drain_vfs1/area_vfs1
	vfs_ratio2 = drain_vfs2/area_vfs2

!! calculate runoff depth over buffer area in mm
	vfs_depth1 = vfs_ratio1 * surfq(j)
	vfs_depth2 = vfs_ratio2 * surfq(j)

!! calculate sediment loading over buffer area in kg/m^2
	vfs_sed1 = (sedyld(j) / hru(j)%area_ha * 1000 * drain_vfs1) /          &
       (area_vfs1 * 10000)
	vfs_sed2 = (sedyld(j) / hru(j)%area_ha * 1000 * drain_vfs2) /          &
       (area_vfs2 * 10000)

!! calculate Runoff Removal by vfs (used for nutrient removal estimation only) based on runoff depth and ksat
!! Based on vfsmod simulations

      surq_remove1 = 75.8-10.8 * Log(vfs_depth1) + 25.9 *                &
                Log(soil(j)%phys(1)%k)
	if (surq_remove1 > 100.) surq_remove1 = 100.
	if (surq_remove1 < 0.) surq_remove1 = 0.

      surq_remove2 = 75.8-10.8 * Log(vfs_depth2) + 25.9 *                &
                Log(soil(j)%phys(1)%k)
	if (surq_remove2 > 100.) surq_remove2 = 100.
	if (surq_remove2 < 0.) surq_remove2 = 0.

	surq_remove = (surq_remove1 * drain_vfs1 + surq_remove2            &
                * drain_vfs2)/hru(j)%area_ha

!! calculate sediment Removal
!! Based on measured data from literature

	sed_remove1 = 79.0 - 1.04 * vfs_sed1 + 0.213 * surq_remove1
	if (sed_remove1 > 100.) sed_remove1 = 100.
	if (sed_remove1 < 0.) sed_remove1 = 0.

	sed_remove2 = 79.0 - 1.04 * vfs_sed2 + 0.213 * surq_remove1
	if (sed_remove2 > 100.) sed_remove2 = 100.
	if (sed_remove2 < 0.) sed_remove2 = 0.

	sed_remove = (sed_remove1 * drain_vfs1 + sed_remove2            &
                 * drain_vfs2)/hru(j)%area_ha

	sedyld(j) = sedyld(j) * (1. - sed_remove / 100.)
      sedyld(j) = Max(0., sedyld(j))

	sedtrap = sedyld(j) * sed_remove / 100.
	xrem = 0.

	  if (sedtrap <= lagyld(j)) then
	    lagyld(j) = lagyld(j) - sedtrap
	  else
	    xrem = sedtrap - lagyld(j)
	    lagyld(j) = 0.
	    if (xrem <= sanyld(j)) then
	      sanyld(j) = sanyld(j) - xrem
	    else
	      xrem = xrem - sanyld(j)
	      sanyld(j) = 0.
	      if (xrem <= sagyld(j)) then
	        sagyld(j) = sagyld(j) - xrem
	      else
	        xrem = xrem - sagyld(j)
	        sagyld(j) = 0.
	        if (xrem <= silyld(j)) then
	          silyld(j) = silyld(j) - xrem
	        else
	          xrem = xrem - silyld(j)
	          silyld(j) = 0.
	          if (xrem <= clayld(j)) then
	            clayld(j) = clayld(j) - xrem
	          else
	            xrem = xrem - clayld(j)
	            clayld(j) = 0.
	          end if
	        end if
	      end if
	    end if
	  end if
        sanyld(j) = Max(0., sanyld(j))
        silyld(j) = Max(0., silyld(j))
        clayld(j) = Max(0., clayld(j))
        sagyld(j) = Max(0., sagyld(j))
        lagyld(j) = Max(0., lagyld(j))

!! Calculate Organic Nitrogen Removal
!! Based on measured data from literature

	remove1 = 0.036 * sed_remove1 ** 1.69
	if (remove1 > 100.) remove1 = 100.
	if (remove1 < 0.) remove1 = 0.

	remove2 = 0.036 * sed_remove2 ** 1.69
	if (remove2 > 100.) remove2 = 100.
	if (remove2 < 0.) remove2 = 0.

	orgn_remove = (remove1 * drain_vfs1 + remove2                  &
                  * drain_vfs2)/hru(j)%area_ha
	sedorgn(j) = sedorgn(j) * (1. - orgn_remove / 100.)

!! calculate Nitrate removal from surface runoff
!! Based on measured data from literature

	remove1 = 39.4 + 0.584 * surq_remove1
	if (remove1 > 100.) remove1 = 100.
	if (remove1 < 0.) remove1 = 0.

	remove2 = 39.4 + 0.584 * surq_remove2
	if (remove2 > 100.) remove2 = 100.
	if (remove2 < 0.) remove2 = 0.

	surqno3_remove = (remove1 * drain_vfs1 + remove2                &
                    * drain_vfs2)/hru(j)%area_ha
	surqno3(j) = surqno3(j) * (1. - surqno3_remove / 100.)

!! calculate Particulate P removal from surface runoff
!!Based on measured data from literature

	remove1 = 0.903 * sed_remove1
	if (remove1 > 100.) remove1 = 100.
	if (remove1 < 0.) remove1 = 0.

	remove2 = 0.903 * sed_remove2
	if (remove2 > 100.) remove2 = 100.
	if (remove2 < 0.) remove2 = 0.

	partP_remove = (remove1 * drain_vfs1 + remove2                  &
                * drain_vfs2)/hru(j)%area_ha
	sedminpa(j) = sedminpa(j) * (1. - partP_remove / 100.)
	sedminps(j) = sedminps(j) * (1. - partP_remove / 100.)
	sedorgp(j) = sedorgp(j) * (1. - partP_remove / 100.)

!! Calculate Soluble P removal from surface runoff
!!  DP% = - 6.14 + 1.13 Runoff%
	remove1 = 29.3 + 0.51 * surq_remove1
	if (remove1 > 100.) remove1 = 100.
	if (remove1 < 0.) remove1 = 0.

	remove21 = 29.3 + 0.51 * surq_remove2
	if (remove2 > 100.) remove2 = 100.
	if (remove2 < 0.) remove2 = 0.

	solp_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha
	surqsolp(j) = surqsolp(j) * (1. - solp_remove / 100.)

!! Calculate pesticide removal
!! based on the sediment and runoff removal only
        do k = 1, cs_db%num_pests
          hpestb_d(j)%pest(k)%surq = hpestb_d(j)%pest(k)%surq * (1. - surq_remove / 100.)
          hpestb_d(j)%pest(k)%sed = hpestb_d(j)%pest(k)%sed * (1. - sed_remove / 100.)
        end do

	end if

      return
      end subroutine smp_filter