text:
      subroutine updmor ( pmsa   , fl     , ipoint , increm , noseg  , &
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   , &
     &                    noq3   , noq4   )
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'UPDMOR' :: UPDMOR
!>\file
!>       Process: BedUpdate - Update bed levels

!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  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, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!------------------------------------------------------------------------------
      use bedcomposition_module, only:updmorlyr
!      use sediment_basics_module
      use message_module, only:writemessages
      use bed_ensemble
      use precision
!
      IMPLICIT NONE
!
!     Type                      Name          I/O Description
!
      real(4), dimension(*)  :: pmsa        !<I/O Process Manager System Array, window of routine to process library
      real(4), dimension(*)  :: fl          !< O  Array of fluxes made by this process in mass/volume/time
      integer, dimension(*)  :: ipoint      !< I  Array of pointers in pmsa to get and store the data
      integer, dimension(*)  :: 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, dimension(4,*):: iexpnt      !< I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      integer, dimension(*)  :: 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)
!
!------------------------------------------------------------------------------
!
!     Type                                  Name          I/O Description                                        Unit
!
      integer                               :: numISS      !< I  number of ISS fractions                            (-)
      integer                               :: numIBS      !< I  number of IBS fractions                            (-)
      real(4)                               :: SBTnrm      !< I  total normal transport comp for IBS frac           (kg/m)
      real(4)                               :: MorFac      !< I  morphological acceleration factor                  (-)
      real(4)                               :: Surf        !< I  horizontal surface area of a DELWAQ segment        (m2)
      real(4)                               :: XWidth      !< I  exchange width                                     (m)
      real(4)                               :: dVB         !< O  segment integrated bed level change                (m3/d)
      real(4)                               :: dZB         !< F  bed level change                                   (m/d)
!
      integer                               :: iflux       !<    Local index for pointering the fluxes
      integer, dimension(:), allocatable    :: ipnt        !<    Local work array for the pointering
      integer                               :: iseg        !<    Local loop counter for computational element loop
      integer                               :: iq          !<    Local loop counter for exchanges loop
      integer                               :: ifrom       !<    Index of from segment
      integer                               :: ito         !<    Index of to segment
      integer                               :: i           !<    Local loop counter for sediment fraction
!
      integer                               :: iSBTnrm     !<    Offset of SBTnrm data in ipnt/increm arrays
      integer                               :: iMorFac     !<    Offset of MorFac data in ipnt/increm arrays
      integer                               :: nItem       !<    Total number of input and output items
!
      integer                               :: pSurf       !<    Offset of Surf data in pmsa array
      integer                               :: numIS       !<    Total number of fractions
      real(fp), dimension(:,:), allocatable :: dbodsd      !<    Bed composition change
      real(fp), dimension(:), allocatable   :: depchg      !<    Bed level change
      real(fp)                              :: S           !<    Total transport flux at exchange
      type(bed_data)                        :: bed         !<    Bed composition data
!
!------------------------------------------------------------------------------
!
      numISS      = int(pmsa( ipoint(  1) ))
      numIBS      = int(pmsa( ipoint(  2) ))
      numIS       = numISS+numIBS
!
      iSBTnrm      = 2
      iMorFac      = iSBTnrm      + numIS
      nItem        = iMorFac      + 4
!
      call failconst(increm(iMorFac+1),'Morphological factor')
      MorFac         = pmsa( ipoint(iMorFac     +  1) )
      allocate( dbodsd(numIS,noseg) )
      dbodsd = 0.0_fp
      allocate( depchg(noseg) )
      depchg = 0.0_fp
!
!     Initialise pointers
!
      allocate(ipnt(nItem))
      ipnt        = ipoint(1:nItem)
!
!     Loop over all exchanges
!
      do iq = 1, noq1+noq2
!
!        Get from and to segments
!
         ifrom = iexpnt(1,iq)
         ito   = iexpnt(2,iq)
!
!        Get input values from arrays
!
         do i = 1, numIS
            SBTnrm = pmsa( ipnt(iSBTnrm+i) )
            XWidth = pmsa( ipnt(iMorFac+3) )
            S = SBTnrm * XWidth * MorFac
            !
            if (ifrom>0) dbodsd(i,ifrom) = dbodsd(i,ifrom) - S
            if (ito>0)   dbodsd(i,ito)   = dbodsd(i,ito)   + S
         enddo
!
!        Increment pointers
!
         ipnt        = ipnt        + increm(1:nItem)
!
      enddo
!
!     Reset pointers
!
      ipnt        = ipoint(1:nItem)
      iflux       = 0
!
!     Convert sediment total mass into sediment per m2
!
      pSurf = ipnt(iMorFac+2)
      do iseg = 1, noseg
         Surf  = pmsa( pSurf )
         do i = 1, numIS
            dbodsd(i,iseg) = dbodsd(i,iseg) / Surf
         enddo
         pSurf = pSurf + increm(iMorFac+2)
      enddo
!
!     Update bedcomposition
!
      call getbedcomp(bed,1,1)
      if (updmorlyr(bed%comp, dbodsd, depchg, bed%messages) /= 0) then
          call writemessages(bed%messages, 6)
          call throwexception()
      endif
!
!     Reset pointers
!
      ipnt        = ipoint(1:nItem)
      iflux       = 0
!
!     Loop over all segments
!
      do iseg = 1, noseg
         Surf  = pmsa( ipnt(iMorFac+2) )
!
         dZB = depchg(iseg)
         dVB = depchg(iseg)*Surf
!
!        Put output and flux values into arrays
!
         fl  ( iflux+1 ) = dZB
         pmsa( ipnt(iMorFac+4) ) = dVB
!
!        Increment pointers
!
         iflux       = iflux       + noflux
         ipnt        = ipnt        + increm(1:nItem)
!
      enddo
!
      deallocate(ipnt)
      deallocate(dbodsd)
      deallocate(depchg)
!
      end subroutine updmor

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
module meteo_data
!----- LGPL --------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This library is free software; you can redistribute it and/or
!  modify it under the terms of the GNU Lesser General Public
!  License as published by the Free Software Foundation version 2.1.
!
!  This library 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
!  Lesser General Public License for more details.
!
!  You should have received a copy of the GNU Lesser General Public
!  License along with this library; 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, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: meteo_data.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_lgpl/ec_module/packages/ec_module/src/meteo/meteo_data.f90 $
!!--description-----------------------------------------------------------------
!
! see meteo.f90
!
!!--pseudo code and references--------------------------------------------------
!
! Stef.Hummel@deltares.nl
! Herman.Kernkamp@deltares.nl
! Adri.Mourits@deltares.nl
!
!!--declarations----------------------------------------------------------------
   use precision
!
! Module constants
!
   integer,      parameter :: maxnamelen     = 256
   real(fp),     parameter :: nodata_default = -999.0_fp   ! Default missing value in meteo arrays
   !
   ! enumeration for data fields
   !
   integer, parameter :: uniuvp                         =  1    ! 3 values per timestep 1 dim arr
   integer, parameter :: meteo_on_computational_grid    =  2    ! 3 velden per timestep 3 dim array
   integer, parameter :: meteo_on_equidistant_grid      =  3    ! 1 veld per timestep 2 dim array
   integer, parameter :: meteo_on_spiderweb_grid        =  4    ! 3 velden per timestep 3 dim array
   integer, parameter :: meteo_on_curvilinear_grid      =  5    ! 1 veld per timestep 2 dim array
   integer, parameter :: numfiletypes                   =  5
   integer, parameter :: max_nummeteoitems              = 10
   integer, parameter, private :: max_num_meteopointers = 50
   !
   ! enumeration for optional flags
   !
   integer, parameter :: opt_not_defined      = 0
   integer, parameter :: opt_value_specified  = 1
   integer, parameter :: opt_use_from_kernel  = 2
!
! type definitions
!
   type tfield
      ! contains time and field information
      logical                             :: all_nodata     ! Flag to indicate whether all data values are missing
                                                            ! (Only for meteo_on_spiderweb_grid)
      real(hp)                            :: time
      real(hp)                            :: x_spw_eye      ! X-coordinate of cyclone eye (spiderweb centre) at specified TIME
      real(hp)                            :: y_spw_eye      ! Y-coordinate of cyclone eye (spiderweb centre) at specified TIME
      real(hp)                            :: dx             ! x-gridsize
      real(hp)                            :: dy             ! y-gridsize
      real(hp)                            :: p_drop_spw_eye !
      real(hp), dimension(:,:,:), pointer :: arr3d          ! 3-dim array
      real(hp), dimension(:,:),   pointer :: arr2d          ! 2-dim array
      real(hp), dimension(:),     pointer :: arr1d          ! 1-dim array
   end type tfield

   type tgrid
      integer                            :: mmax       ! Size of meteo grid, related to tmeteoitem%numm
      integer                            :: nmax       ! Size of meteo grid, related to tmeteoitem%numn
      integer                            :: mcur
      integer                            :: ncur
      integer, dimension(:,:,:), pointer :: mnref
      real(fp)                           :: misval
      real(hp), dimension(:,:) , pointer :: x
      real(hp), dimension(:,:) , pointer :: y
      character(20)                      :: type       ! Spheric or cartesian
      character(maxnamelen)              :: filename   ! File containing data
   end type tgrid

   type tmeteoitem
      integer                       :: filetype         ! Type of meteofile, read from MD-file
      integer                       :: it0              ! See it1
      integer                       :: it1              ! Index old or new fields
      integer                       :: lun              ! Handle to file
      integer                       :: mfirst           ! Mfirst, mlast, nfirst and nlast are the grid indices that result from the
                                                        ! possible reversing of grid coordinates determined by first_data_value and data_row.
      integer                       :: mlast            ! See mfirst
      integer                       :: n_cols           ! Number of columns used for meteo datafield
      integer                       :: n_quantity       ! Number of quantities prescribed in the file
      integer                       :: n_rows           ! Number of rows used for meteo datafield
      integer                       :: nfirst           ! See mfirst
      integer                       :: nlast            ! See mfirst
      integer                       :: numk
      integer                       :: numm             ! Size of meteo grid, related to tgrid%mmax
      integer                       :: numn             ! Size of meteo grid, related to tgrid%nmax
      integer                       :: pref_option      ! Reference pressure options: 0: not defined, 1: value specified, 2: use from kernel
      real(hp)                      :: dx               ! x-gridsize
      real(hp)                      :: dy               ! y-gridsize
      real(fp)                      :: nodata_value     ! Value used for undefined or missing data
      real(hp)                      :: p_conv           ! Conversion factor for air_pressure (to Pa)
      real(hp)                      :: pref             ! Reference value for air_pressure, optionally used by spiderweb: patm = pref - p_drop
      real(hp)                      :: spw_radius       ! Radius of spiderweb (in units specified in spw_rad_unit)
      real(hp)                      :: spw_merge_frac   ! Fraction of radius for merging spw data with background wind
      real(hp)                      :: x_llcorner       ! X-coordinate of lower left corner of lower left cell of grid (in units specified in grid_unit)
                                                        ! (Only for meteo_on_equidistant_grid)
      real(hp)                      :: y_llcorner       ! Y-coordinate of lower left corner of lower left cell of grid (in units specified in grid_unit)
                                                        ! (Only for meteo_on_equidistant_grid)
      real(hp)                      :: x_llcenter       ! X-coordinate of centre of lower left cell of grid (in units specified in grid_unit)
                                                        ! (Only for meteo_on_equidistant_grid)
      real(hp)                      :: y_llcenter       ! Y-coordinate of centre of lower left cell of grid (in units specified in grid_unit)
                                                        ! (Only for meteo_on_equidistant_grid)
      logical                       :: firstcopy        ! Copied field0 after first read?
      logical                       :: initialized      ! Initialized or not?
      logical                       :: mrow             ! Flag for swithcing columns and row when reading the data on the curvilinear grid file
      character(20)                 :: data_row         ! Specifies whether a row of data corresponds to a row or a column on the grid (for the curvilinear grid file)
      character(256)                :: grid_file        ! Separate grid on which the wind can be specified
      character(20)                 :: first_data_value ! Location on the grid to which the first value of the dataset corresponds
      character(maxnamelen)         :: filename         ! File containing data
      character(20)                 :: fileversion      ! Version of meteo input file, to check if the newest file format is used
      character(20)                 :: grid_unit        ! Unit of distances on the grid
      character(256)                :: meteotype        ! Type of meteo input file: svwp on the FLOW grid, on a separate curvilinear grid,
                                                        ! on a separate equidistant grid or on a spiderweb grid, read from meteo file
      character(60), dimension(3)   :: quantities       ! Quantities to be served by this meteoitem, normally just one.
                                                        ! Exceptions: meteotypes uniuvp, meteo_on_computational_grid, meteo_on_spiderweb_grid
      character(20)                 :: spw_rad_unit     ! Unit of spiderweb radius, must be meters
      character(100)                :: time_unit        ! Actual unit of time, distilled from time_definition, possibly decorated with spaces and long real by the user
      character(300)                :: time_definition  ! Fixed format: Time unit 'since' reference date and time +- time zone difference, possibly decorated with spaces and long reals by the user
      character(30), dimension(3)   :: units = 'undef'  ! Units of the three quantities
      type(tfield) , dimension(0:1) :: field            ! Old and new fields
      type(tgrid)  , pointer        :: grid
   end type tmeteoitem

   type tmeteoitempointer
      type(tmeteoitem), pointer :: ptr
   end type tmeteoitempointer

   type tflowgrid
      logical                           :: initialized
      integer                           :: mmax
      integer                           :: nmax
      integer , dimension(:,:), pointer :: kcs
      real(fp), dimension(:,:), pointer :: xz
      real(fp), dimension(:,:), pointer :: yz
   end type tflowgrid

   type tspiderweb
      logical                             :: active
      real(fp)                            :: time   ! time for which spiderweb arrays are set
      real(fp), dimension(:,:), pointer   :: spwf   ! merge factor spiderweb
      real(fp), dimension(:,:,:), pointer :: spwarr ! addition of windu(1,n,m), windv(2,n,m) and patm(3,n,m), due to spiderweb
   end type tspiderweb

   type tmeteo
     !
     ! Datastucture for all meteo items (= Meteo structure for one subdomain)
     !
     integer                                                  :: nummeteoitems
     type(tmeteoitempointer), dimension(max_nummeteoitems)    :: item
     type(tflowgrid)                                          :: flowgrid
     type(tspiderweb)                                         :: spiderweb
   end type tmeteo

   type tmeteopointer
       character(maxnamelen) :: subdomname
       type(tmeteo), pointer :: pntr
   end type tmeteopointer
!
! Module parameters
!
   integer                                                     :: num_meteopointers
   integer                                                     :: message_count         ! Flag used to make sure message on the time zone shift is given only once
   logical, save                                               :: meteodata_initialized = .false.
   logical                                                     :: msferic               ! true: meteo grid is sferical, false: cartesian
   logical                                                     :: meteoint              ! true: interpolate in time, false: block
   real(fp)                                                    :: patm_default          ! Default air pressure (Pa)
   character(500)                                              :: meteomessage          ! (error)messages are set in meteomessage.
                                                                                ! function getmeteomessage returns the message

   type(tmeteopointer), dimension(max_num_meteopointers),save  :: meteopointers

contains

subroutine init_meteo_data
   implicit none

   num_meteopointers     = 0
   message_count         = 0
   msferic               = .false.
   meteoint              = .true.
   patm_default          = 101300.0_fp
   meteomessage          = ' '

end subroutine init_meteo_data

!subroutine meteosetsferic()
!   implicit none
!   msferic = .true.
!end subroutine meteosetsferic

subroutine nullifyfield( field )
   implicit none
   type(tfield)     :: field
   field%all_nodata     = .false.
   field%dx             = nodata_default
   field%dy             = nodata_default
   field%x_spw_eye      = nodata_default
   field%y_spw_eye      = nodata_default
   field%p_drop_spw_eye = nodata_default
   nullify( field%arr1d )
   nullify( field%arr2d )
   nullify( field%arr3d )
end subroutine nullifyfield

subroutine nullifygrid( grid )
   implicit none
   type(tgrid) :: grid
   grid%mmax = 0
   grid%nmax = 0
   grid%mcur = 0
   grid%ncur = 0
   nullify( grid%mnref )
   nullify( grid%x )
   nullify( grid%y )
   grid%type     = ' '
   grid%filename = ' '
   grid%misval   = nodata_default
end subroutine nullifygrid

subroutine allocfield( field, m, n, k )
   implicit none
   type(tfield)     :: field
   integer          :: m
   integer          :: n
   integer          :: k
   integer          :: mm
   integer          :: nn
   integer          :: kk
   allocate( field % arr3d(1:m,1:n,1:k) )
   !
   ! Must be filled immediately
   !
   do kk = 1,k
      do nn = 1,n
         do mm = 1,m
            field%arr3d(mm,nn,kk) = 0
         enddo
      enddo
   enddo
   field%arr2d => field%arr3d(:, :, 1)
   field%arr1d => field%arr3d(1, 1, :)
end subroutine allocfield

subroutine allocgrid( grid, m, n, flowmmax, flownmax )
   implicit none
   type(tgrid)     :: grid
   integer         :: m
   integer         :: n
   integer         :: flowmmax
   integer         :: flownmax
   if (m > 0 .and. n>0) then
      allocate( grid%x(1:m,1:n) )
      allocate( grid%y(1:m,1:n) )
      grid%x = nodata_default
      grid%y = nodata_default
      if (flowmmax>0 .and. flownmax>0) then
         allocate( grid%mnref(1:flowmmax,1:flownmax,2) )
         grid%mnref = 0
      endif
   endif
end subroutine allocgrid

subroutine deallocfield( field )
   implicit none
   type(tfield)     :: field
   if(associated(field % arr3d)) deallocate( field % arr3d )
end subroutine deallocfield

subroutine deallocgrid( grid )
   implicit none
   type(tgrid)     :: grid
   if(associated(grid%mnref)) deallocate(grid%mnref)
   if(associated(grid%x))     deallocate(grid%x)
   if(associated(grid%y))     deallocate(grid%y)
end subroutine deallocgrid

subroutine deallocmeteo(runid)
   implicit none
   character(*), intent(in)  :: runid
   type(tmeteo), pointer     :: meteo     ! all meteo for one subdomain
   integer                   :: i
   integer                   :: istat

   meteodata_initialized = .false.
   call getmeteopointer(runid, meteo)
   if (associated(meteo) )then
       do i = 1, meteo%nummeteoitems
           call deallocfield( meteo%item(i)%ptr%field(0) )
           call deallocfield( meteo%item(i)%ptr%field(1) )
           if (associated(meteo%item(i)%ptr%grid)) then
              call deallocgrid ( meteo%item(i)%ptr%grid )
           endif
       enddo
       if (meteo%flowgrid%initialized) then
          if (associated(meteo%flowgrid%kcs))     deallocate (meteo%flowgrid%kcs, stat=istat)
          if (associated(meteo%flowgrid%xz))      deallocate (meteo%flowgrid%xz, stat=istat)
          if (associated(meteo%flowgrid%yz))      deallocate (meteo%flowgrid%yz, stat=istat)
       endif
       if (meteo%spiderweb%active) then
          if (associated(meteo%spiderweb%spwf))   deallocate (meteo%spiderweb%spwf, stat=istat)
          if (associated(meteo%spiderweb%spwarr)) deallocate (meteo%spiderweb%spwarr, stat=istat)
       endif
       ! Do not deallocate(meteo)
       ! meteo is a pointer to an element in a fixed, static, saved module array
   endif
end subroutine deallocmeteo

function createmeteoitem(runid, meteo, meteoitem) result(success)
   implicit none
   !
   ! Globals
   !
   logical                                :: success
   character(*)             , intent(in)  :: runid
   type(tmeteo)    , pointer              :: meteo     ! all meteo for one subdomain
   type(tmeteoitem), pointer              :: meteoitem
   !
   ! Locals
   !
   !
   ! Executable statements
   !
   call getmeteopointer(runid, meteo)
   if ( meteo%nummeteoitems < max_nummeteoitems ) then
      meteo%nummeteoitems = meteo%nummeteoitems + 1
      allocate(meteo%item(meteo%nummeteoitems)%ptr)
      meteoitem => meteo%item(meteo%nummeteoitems)%ptr
   else
      write(meteomessage,'(a,i4,a)') 'Meteo module can only handle ', max_nummeteoitems, &
                                  &  ' items per subdomain.'
      success = .false.
      return
   endif
   meteoitem%it0 = 0
   meteoitem%it1 = 1
   call nullifyfield( meteoitem%field(0) )
   call nullifyfield( meteoitem%field(1) )
   nullify(meteoitem%grid)
   meteoitem%initialized = .false.
   success               = .true.
end function createmeteoitem

subroutine meteoallocateitem(meteoitem, numm, numn, numk)
   implicit none
   !
   ! arguments
   !
   type(tmeteoitem), pointer    :: meteoitem
   integer          , intent(in):: numm       ! M, -sizes of item grid
   integer, optional, intent(in):: numn       ! N, -sizes of item grid
   integer, optional, intent(in):: numk       ! optional K-size (default 1)
   !
   ! locals
   !
   integer                      :: locnumn    ! optional N-size (default 1)
   integer                      :: locnumk    ! optional K-size (default 1)
   !
   ! body
   !
   ! Determine size in N, K-direction.
   !
   locnumn = 1
   if ( present(numn) ) then
       if ( numn > 0 ) then
           locnumn = numn
       endif
   endif
   locnumk = 1
   if ( present(numk) ) then
       if ( numk > 0 ) then
           locnumk = numk
       endif
   endif
   !
   ! Allocate data structure
   !
   call allocfield( meteoitem%field(0), numm, locnumn, locnumk )
   call allocfield( meteoitem%field(1), numm, locnumn, locnumk )
   meteoitem%numm = numm
   meteoitem%numn = locnumn
   meteoitem%numk = locnumk
end subroutine meteoallocateitem

function meteoallocateitemgrid(runid, meteoitem, m, n, gridfilnam, flowmmax, flownmax) result(success)
   implicit none
   !
   ! arguments
   !
   integer          , intent(out):: m          ! M, -sizes of item grid
   integer          , intent(out):: n          ! M, -sizes of item grid
   character(*)     , intent(in) :: runid
   character(*)     , intent(in) :: gridfilnam
   integer          , intent(in) :: flowmmax
   integer          , intent(in) :: flownmax
   logical                       :: success
   type(tmeteoitem)              :: meteoitem
   !
   ! locals
   !
   type(tgrid), pointer  :: grid
   integer               :: i
   integer               :: j
   integer               :: gridfil
   integer               :: pos
   character(256)        :: rec
   character(10)         :: dum
   logical               :: sferic
   logical               :: kw_found
   logical, external     :: openexistingfile_meteo
   real(fp)              :: xymiss
   type(tmeteo), pointer :: meteo
   !
   ! body
   !
   call getmeteopointer(runid, meteo)
   !
   ! Check if there is another meteoItem with the same gridfile
   !
   do i=1,meteo%nummeteoitems
      !
      ! Skip the same meteoItem
      !
      if (  meteo%item(i)%ptr%quantities(1) == meteoitem%quantities(1) .and. &
          & meteo%item(i)%ptr%filetype == meteoitem%filetype                  ) cycle
      if (  associated(meteo%item(i)%ptr%grid) ) then
         if (meteo%item(i)%ptr%grid%filename == gridfilnam) then
            !
            ! Found another meteoItem with the same gridfile; pointering to that one
            !
            meteoitem%grid => meteo%item(i)%ptr%grid
            m       = meteoitem%grid%mmax
            n       = meteoitem%grid%nmax
            success = .true.
            return
         endif
      endif
   enddo
   !
   ! Creating a new (Tgrid type) grid inside meteo%item(meteoItem)
   !
   allocate(meteoitem%grid)
   call nullifygrid( meteoitem%grid )
   sferic   = .false.
   kw_found = .false.
   xymiss   = nodata_default
   grid     =>  meteoitem%grid
   success  = openexistingfile_meteo(gridfil,trim(gridfilnam))
   if (.not. success) return
    !
    ! The following part is copied (and adapted) from file:
    ! Delft3D-FLOW/libsrc/flow/inichk/rdrgf.f90
    !
    ! Read file, check for end of file or error in file:
    ! - The first line always contains comments
    !   sferic is true when the first line contains the keyword Spherical
    ! - Skip comment lines (starting with a '*'), while trying to read the
    !   following keywords: 'Coordinate System'
    !                       'Missing Value'
    !   If 'Coordinate System' is present, it overrules the sferic-specification
    !   in the first line!
    ! - The next line contains the dimensions mc and nc
    !   Parameter npart may also be on this line, but it is neglected
    ! - Read the next line containing three zero's
    !   xori, yori and alfori are not used anymore
    ! - Read x coordinates
    ! - Read y coordinates
    !
    read (gridfil, '(a)', end = 7777, err = 8888) rec
    if (index(rec, 'Spherical')>=1 .or. index(rec, 'SPHERICAL')>=1) then
       sferic = .true.
    endif
10  continue
       kw_found = .false.
       read(gridfil,'(a)',end = 7777,err=8888) rec
       if (rec(1:1) == '*') goto 10
       !
       pos = index(rec,'Coordinate System')
       if (pos >= 1) then
          kw_found = .true.
          if (index(rec(pos+1:),'spherical') >= 1 .or. &
            & index(rec(pos+1:),'Spherical') >= 1 .or. &
            & index(rec(pos+1:),'SPHERICAL') >= 1       ) then
             sferic = .true.
          else
             sferic = .false.
          endif
       endif
       !
       pos = index(rec,'Missing Value')
       if (pos >= 1) then
          kw_found = .true.
          pos      = index(rec,'=') + 1
          read(rec(pos:),*,err=8888) xymiss
       endif
    if (kw_found) goto 10
    !
    read(rec,*,err=8888)  m,n
    !
    ! read three zero's
    !
    read(gridfil,'(a)',end = 7777,err=8888) rec
    !
    ! Put parameters read in grid-structure
    !
    if (sferic) then
       !call meteosetsferic()
       grid%type = 'sferic'
    else
       grid%type = 'cartesian'
    endif
    grid%misval = xymiss
    call allocgrid( grid, m, n, flowmmax, flownmax )
    grid%mmax = m
    grid%nmax = n
    grid%filename = gridfilnam
    !
    ! read XD
    ! read unformatted: The number of digits of xcor may vary
    !
    do j = 1, n
       read (gridfil, *, end = 7777, err = 8888) dum,dum,(grid%x(i, j),i=1, m)
    enddo
    !
    ! read YD
    ! read unformatted: The number of digits of ycor may vary
    !
    do j = 1, n
       read (gridfil, *, end = 7777, err = 8888) dum,dum,(grid%y(i, j),i=1, m)
    enddo
    close (gridfil)
    success = .true.
    return
    !
    ! error handling
    !
  7777 continue
    write(meteomessage,'(2a)') 'Unexpected end of file in ',trim(gridfilnam)
    success = .false.
    return
  8888 continue
    write(meteomessage,'(2a)') 'Error while reading in file ',trim(gridfilnam)
    success = .false.
    return
end function meteoallocateitemgrid

function addnewsubdomainmeteopointer(subdomname, subdommeteo) result(success)
   implicit none
   !
   ! arguments
   !
   logical                :: success
   character(*)           :: subdomname
   type(tmeteo),target    :: subdommeteo
!
!! executable statements -------------------------------------------------------
!
    if ( num_meteopointers < max_num_meteopointers ) then
        num_meteopointers = num_meteopointers + 1
        meteopointers(num_meteopointers) % subdomname = subdomname
        meteopointers(num_meteopointers) % pntr => subdommeteo
    else
        write(meteomessage,'(a,i4,a)') 'Meteo module can only handle ',max_num_meteopointers, &
                                    &  ' subdomains.'
        success = .false.
        return
    endif
    success = .true.
end function addnewsubdomainmeteopointer

subroutine getmeteopointer(subdomname, meteopointer)
   implicit none
   type(tmeteo), pointer               :: meteopointer
   character(*)         , intent(in)   ::  subdomname
   !
   ! locals
   !
   integer :: isubdom ! subdomain counter
!
!! executable statements -------------------------------------------------------
!
   nullify(meteopointer)
   do isubdom = 1, num_meteopointers
      if ( subdomname == meteopointers(isubdom) % subdomname ) then
         meteopointer => meteopointers(isubdom) % pntr
         return
      endif
   enddo
end subroutine getmeteopointer

subroutine getmeteoitempointer(runid, id, filetype, meteoitempointer)
   implicit none
   integer                  , intent(in)  ::  filetype
   character(*)             , intent(in)  ::  id
   character(*)             , intent(in)  ::  runid
   type(tmeteoitem), pointer              ::  meteoitempointer
   !
   ! locals
   !
   integer               :: i
   type(tmeteo), pointer :: meteo
!
!! executable statements -------------------------------------------------------
!
   nullify(meteoitempointer)
   call getmeteopointer(runid, meteo)
   if ( .not. associated(meteo) ) then
      return
   endif
   do i = 1, meteo%nummeteoitems
      if (  meteo%item(i)%ptr%quantities(1) == id      .and. &
          & meteo%item(i)%ptr%filetype      == filetype       ) then
         meteoitempointer => meteo%item(i)%ptr
         return
      endif
   enddo
end subroutine getmeteoitempointer

function getmeteomessage( ) result(retval)
   character(500) :: retval
   retval = meteomessage
   meteomessage = ' '
end function getmeteomessage

subroutine meteoblockint()
   implicit none
   meteoint = .false.
end subroutine meteoblockint

end module meteo_data


text:
program Hydrogen
use dftatom, only: mesh_exp, mesh_exp_deriv, dp, &
    solve_radial_eigenproblem, stop_error
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 1e6_dp
integer, parameter :: NN = 3000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-9_dp
integer :: n, l, relat, converged
real(dp) :: R(NN+1), u(size(r)), Ein, E, E_exact, error
real(dp) :: P(size(R)), Q(size(R)), Rp(NN+1)
logical, parameter :: perturb = .true.

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u(:) = -Z/r

print *, "Hydrogen like energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        E_exact = - Z**2 / (2.0_dp * n**2)
        Ein = -1000
        relat = 0
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, R, Rp, u, Z, c, &
            relat, perturb, -5000._dp, 0._dp, converged, E, P, Q)
        error = abs(E -E_exact)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F15.6, F15.6, ES10.2)", n, l, E, E_exact, error
    end do
end do
end program

max_stars_repo_name: rc/dftatom

max_issues_repo_name: rc/dftatom

max_forks_repo_name: rc/dftatom


subroutine mg_residual(phi, ap, aw, ae, as, an, b, f, nx, ny, xi, xf, res)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: phi, ap, b, aw, ae, as, an, f
real(kind=dp), intent(out), dimension(nx,xi-1:xf+1):: res
!real(kind=dp), dimension(nx), intent(in):: dx
!real(kind=dp), dimension(ny), intent(in):: dy
integer:: i, j

! Calculate the residual r = f - Au, where u is the guessed value
! Input
! u      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Modified: Feb 11, 2013

do j = xi,xf

    do i = 2,nx-1

        !res(i,j) = 1.0/(dx(i)*dy(j))*(ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)*dx(i)*dy(j) - f(i,j)*dx(i)*dy(j))
        res(i,j) = ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)- f(i,j)
        !res(i,j) = 1.0/(dx(i)*dy(j))*(ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)*dx(i)*dy(j) - f(i,j)*dx(i)*dy(j))

    end do

end do

call exchange_data(res, nx, xi, xf)

end subroutine


text:
	SUBROUTINE WO_CNTY ( cstrng, lenc, cnties, ncnty, purge, iret )
C************************************************************************
C* WO_CNTY 								*
C*									*
C* This subroutine decodes the county information line for the watch    *
C* outline updates.                					*
C*                                                                      *
C* WO_CNTY ( CSTRNG, LENC, CNTIES, NCNTY, PURGE, IRET )                	*
C*									*
C* Input parameters:	                                                *
C*  	CSTRNG          CHAR*           County string			*
C*	LENC  	  	INTEGER	  	Length of county string		*
C*									*
C* Output parameters:							*
C*  	CNTIES(NCNTY)   CHAR*6   	County names in watch area	*
C*	NCNTY           INTEGER	 	Number of counties in area	*
C*	PURGE           CHAR*   	Purge time (default stop time,  *
C*								UTC)	*
C*	IRET  	  	INTEGER	 Return code			 	*
C*									*
C**									*
C* Log:									*
C* A. Hardy/NCEP	10/02						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'BRIDGE.PRM'
C*
	CHARACTER*(*)	cstrng, cnties(*), purge
C------------------------------------------------------------------------
	iret  = 0
C
C*	Get the county information.
C
	CALL BR_CNTY ( cstrng(:lenc-7), cnties, ncnty, iret )
C
C*	Get purge time.
C
	purge = cstrng ( lenc-6:lenc-1 )
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


! { dg-do compile }
! { dg-compile-aux-modules "binding_label_tests_11.f03" }
module binding_label_tests_11_main
  use iso_c_binding, only: c_int
  implicit none
contains
  function one() bind(c, name="c_one") ! { dg-error "Procedure 'one' with binding label 'c_one' at .1. uses the same global identifier as entity at .2." }
    integer(c_int) one
    one = 1
  end function one
end module binding_label_tests_11_main

program main
  use binding_label_tests_11 ! { dg-error "Procedure 'one' with binding label 'c_one' at .1. uses the same global identifier as entity at .2." }
  use binding_label_tests_11_main
end program main


text:
	SUBROUTINE DCLOSP  ( ncurwn, iret )
C************************************************************************
C* DCLOSP								*
C* 									*
C* This subroutine closes the plot.					*
C*									*
C* DCLOSP  ( NCURWN, IRET )						*
C*									*
C* Output parameters:							*
C* 	NCURWN		INTEGER		Current window number		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log									*
C* G. Chatters/RDS	 5/83						*
C* M. Vilardo/RDS	 6/84	GEMPLT Version 3.0			*
C* M. Goodman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 5/88	Documentation				*
C* S. Jacobs/NCEP	 4/96	Added NCURWN				*
C************************************************************************
	INCLUDE		'FUNCCODE.PRM'
	INCLUDE		'ERROR.PRM'
C
	INTEGER		isend (2)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 2
	isend (2) = CCLOSP
C
	CALL GPUT  ( isend, 2, iret )
	IF  ( iret .ne. NORMAL )  RETURN
	CALL GGET  ( iret, 1, ierr )
	IF  ( ierr .ne. NORMAL )  THEN
	    iret = ierr
	    RETURN
	ENDIF
C
	CALL GGET ( ncurwn, 1, ier )
	IF  ( ier .ne. NORMAL ) iret = ier
C
	RETURN
	END


! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
integer :: g(10)
f(i) = i + 1  ! statement function
g(i) = i + 2  ! mis-parsed array assignment
!ERROR: 'h' has not been declared as an array
h(i) = i + 3
end


text:
	subroutine watpte(n,m,xo,line,x,y)
c
c want to write a pdb file for a set of points. this subroutine
c composes one line.
c
	dimension xo(3)
	character*80 line
	character*5 wnum
	character*4 cnum
	character*8 pnum
	character*12 pnum2
	integer n,m
c
c n=atom number, m=residue number, xo=position
c
	line=" "
	line(1:6)="ATOM  "
	line(18:20)="SC "
cwal	line(14:14)="O"
	write(wnum,310)n
	line(7:11)=wnum
	write(cnum,320)m
	line(23:26)=cnum
	write(pnum,330) xo(1)
	line(31:38)=pnum
	write(pnum,330) xo(2)
	line(39:46)=pnum
	write(pnum,330) xo(3)
	line(47:54)=pnum
	write(pnum2,340) x
	line(56:67)=pnum2
	write(pnum2,340)y
	line(69:80)=pnum2
310	format(i5)
320	format(i4)
330	format(f8.3)
340	format(g12.5)
c
	return
	end

max_stars_repo_name: caixiuhong/Stable-MCCE

max_issues_repo_name: caixiuhong/Stable-MCCE

max_forks_repo_name: caixiuhong/Stable-MCCE


text:
Carl Whithaus teaches writing at UC Davis.  He has Noteworthy Published Authors written two books (Teaching and Evaluating Writing in the Age of Computers and HighStakes Testing and Writing Across Distances and Disciplines).  When not writing about the impact of IT on literacy practices, Carl can be found watching his kids play soccer, taking them to cello or piano lessons, or digging in the garden.

A video of a talk he gave on Peer Response in SmartSite Forums and Word Docs is available at http://fmfp.ucdavis.edu/winter_08_speakers.php

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C$Procedure  VZERO    ( Is a vector the zero vector? )

      LOGICAL FUNCTION VZERO ( V )

C$ Abstract
C
C     Indicate whether a 3-vector is the zero vector.
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     None.
C
C$ Keywords
C
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     V          I   Vector to be tested.
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Detailed_Input
C
C     V              is a vector in 3-space.
C
C$ Detailed_Output
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function has the same truth value as the logical expression
C
C        VNORM ( V )  .EQ.  0.D0
C
C     Replacing the above expression by
C
C        VZERO ( V )
C
C     has several advantages:  the latter expresses the test more
C     clearly, looks better, and doesn't go through the work of scaling,
C     squaring, taking a square root, and re-scaling (all of which
C     VNORM must do) just to find out that a vector is non-zero.
C
C     A related function is VZEROG, which accepts vectors of arbitrary
C     dimension.
C
C$ Examples
C
C     1)  When testing whether a vector is the zero vector, one
C         normally constructs tests like
C
C            IF (  VNORM ( V )  .EQ.  0.D0  ) THEN
C                        .
C                        .
C                        .
C
C
C         These can be replaced with the code
C
C            IF (  VZERO ( V )  ) THEN
C                        .
C                        .
C                        .
C
C
C      2)  Check that a normal vector is non-zero before creating
C         a plane with PNV2PL:
C
C         IF (  VZERO ( NORMAL )  )  THEN
C
C            [ handle error ]
C
C         ELSE
C
C            CALL PNV2PL ( POINT, NORMAL, PLANE )
C                          .
C                          .
C                          .
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 17-JUL-1990  (NJB) (IMU)
C
C-&

C$ Index_Entries
C
C     test whether a 3-dimensional vector is the zero vector
C
C-&

C
C     `Just do it'.
C
C
      VZERO   =        (  V(1) .EQ. 0.D0  )
     .          .AND.  (  V(2) .EQ. 0.D0  )
     .          .AND.  (  V(3) .EQ. 0.D0  )

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      subroutine finalbal

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates final water balance for watershed

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aairr(:)    |mm H2O        |average annual amount of irrigation water
!!                               |applied to HRU
!!    hru_dafr(:) |none          |fraction of watershed area in HRU
!!    irrsc(:)    |none          |irrigation source code:
!!                               |1 divert water from reach
!!                               |2 divert water from reservoir
!!                               |3 divert water from shallow aquifer
!!                               |4 divert water from deep aquifer
!!                               |5 divert water from source outside
!!                               |  watershed
!!    nhru        |none          |number of HRUs in watershed
!!    nres        |none          |number of reservoirs in watershed
!!    pnd_sed(:)  |kg/L          |ratio of sediment to water in pond
!!    pnd_vol(:)  |m^3 H2O       |volume of water in pond
!!    res_sed(:)  |kg/L (ton/m^3)|amount of sediment in reservoir
!!    res_vol(:)  |m^3 H2O       |reservoir volume
!!    resouta(3,:)|metric tons   |sediment entering reservoir during simulation
!!    resouta(4,:)|metric tons   |sediment leaving reservoir during simulation
!!    resouta(17,:)|m^3 H2O       |evaporation from reservoir during simulation
!!    resouta(18,:)|m^3 H2O       |seepage from reservoir during simulation
!!    resouta(19,:)|m^3 H2O       |precipitation on reservoir during simulation
!!    resouta(20,:)|m^3 H2O       |water entering reservoir during simulation
!!    resouta(21,:)|m^3 H2O       |water leaving reservoir during simulation
!!    sno_hru(:)  |mm H2O        |amount of water stored as snow
!!    wshd_pndha  |ha            |watershed area in hectares which drains into
!!                               |ponds
!!    wshd_pndsed |metric tons   |total amount of suspended sediment in ponds
!!                               |in the watershed
!!    wshd_pndv   |m^3           |total volume of water in ponds in the
!!                               |watershed
!!    wshd_resha  |ha            |watershed area in hectares which drains into
!!                               |reservoirs
!!    wshd_ressed |metric tons   |total amount of suspended sediment in
!!                               |reservoirs in the watershed
!!    wshd_resv   |m**3          |total volume of water in all reservoirs in
!!                               |the watershed
!!    wshdaao(13) |metric tons   |sediment loading to ponds in watershed
!!    wshdaao(14) |metric tons   |sediment loading from ponds in watershed
!!    wshdaao(15) |metric tons   |net change in sediment level in ponds in
!!                               |watershed
!!    wshdaao(19) |m^3 H2O       |evaporation from ponds in watershed
!!    wshdaao(20) |m^3 H2O       |seepage from ponds in watershed
!!    wshdaao(21) |m^3 H2O       |precipitation on ponds in watershed
!!    wshdaao(22) |m^3 H2O       |volume of water entering ponds in watershed
!!    wshdaao(23) |m^3 H2O       |volume of water leaving ponds in watershed
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    wshd_pndsed |metric tons/ha|mass balance discrepancy for pond
!!                               |sediment expressed as loading per unit
!!                               |hectare of drainage area
!!    wshd_pndv   |mm H2O        |mass balance discrepancy for pond water
!!                               |volume expressed as depth over drainage
!!                               |area
!!    wshd_ressed |metric tons/ha|mass balance discrepancy for reservoir
!!                               |sediment expressed as loading per unit
!!                               |hectare of drainage area
!!    wshd_resv   |mm H2O        |mass balance discrepancy for reservoir water
!!                               |volume expressed as depth over drainage
!!                               |area
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |counter
!!    res3        |metric tons   |sediment entering all reservoirs
!!    res4        |metric tons   |sediment leaving all reservoirs
!!    res17       |m^3 H2O       |evaporation from all reservoirs
!!    res18       |m^3 H2O       |seepage from all reservoirs
!!    res19       |m^3 H2O       |precipitation on all reservoirs
!!    res20       |m^3 H2O       |water entering all reservoirs
!!    res21       |m^3 H2O       |water leaving all reservoirs
!!    sedout      |metric tons   |total sediment in ponds at end of
!!                               |simulation
!!    tir         |mm H2O        |average annual amount of irrigation
!!                               |water applied to watershed
!!    volout      |m^3 H2O       |total volume of water in ponds at end
!!                               |of simulation
!!    wshd_snoe   |mm H2O        |amount of water in snow in watershed
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: swbl, vbl

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: tir, wshd_snoe, volout, sedout, res3, res4, res17
      real :: res18, res19, res20, res21

!! compute amount of irrigation water applied in watershed
      tir = 0.
      do j = 1, nhru
        if (irrsc(j) > 0) then
          tir = tir + aairr(j) * hru_dafr(j)
        end if
      end do

!! compute amount of water stored in snow at end of simulation in watershed
      wshd_snoe = 0.
      do j = 1, nhru
        wshd_snoe = wshd_snoe + sno_hru(j) * hru_dafr(j)
      end do

!! check final soil water balance
      call swbl(wshd_snoe,tir)

!! check pond water and sediment balance
      if (wshd_pndha > 1.e-4) then
        volout = 0.
        sedout = 0.
        do j = 1, nhru
          volout = volout + pnd_vol(j)
          sedout = sedout + pnd_vol(j) * pnd_sed(j)
        end do
        call vbl(wshdaao(19),wshdaao(20),wshdaao(21),wshdaao(22),
     &           wshdaao(23),wshd_pndv,wshd_pndsed,wshdaao(13),
     &           wshdaao(14),wshdaao(15),volout,sedout,wshd_pndha)
      end if

!! check reservoir water and sediment balance
      if (wshd_resha > 1.e-4) then
        res3 = 0.
        res4 = 0.
        res17 = 0.
        res18 = 0.
        res19 = 0.
        res20 = 0.
        res21 = 0.
        volout = 0.
        sedout = 0.
        do j = 1, nres
          res3 = res3 + resouta(3,j)
          res4 = res4 + resouta(4,j)
          res17 = res17 + resouta(17,j)
          res18 = res18 + resouta(18,j)
          res19 = res19 + resouta(19,j)
          res20 = res20 + resouta(20,j)
          res21 = res21 + resouta(21,j)
          volout = volout + res_vol(j)
          sedout = sedout + res_vol(j) * res_sed(j)
        end do
        call vbl(res17,res18,res19,res20,res21,wshd_resv,wshd_ressed,
     &           res3,res4,0.,volout,sedout,wshd_resha)
      end if

      return
      end


text:
Soccer Clinics by Kader Elmo are private or group lessons in learning moderate to advanced fundamentals of soccer. Every session is structured according to a player’s strengths, weaknesses, and developmental needs in the sport. The main focus of each session is “Ball Mastery”, skill perfection, & appropriate positioning  being the foundations of success in soccer.

Kader has coached at a consistently high level since 1994 and has been playing since his childhood. As a retired semiprofessional soccer player in France, Kader began coaching for Davis Youth Soccer League from 19942006. He earned both is USSF License and NCAA Advanced Coaching License and continues to coach privately in North Davis. Kader has an impressive record in his trained athletes, many of which have earned scholarships to DivisionI university soccer teams.


text:
module bgrid_halo_mod

use bgrid_horiz_mod, only: horiz_grid_type, update_np, update_sp, &
                           TGRID, VGRID
use         fms_mod, only: error_mesg, FATAL, mpp_clock_id, &
                           mpp_clock_begin, mpp_clock_end,  &
                           MPP_CLOCK_SYNC, CLOCK_ROUTINE
use mpp_domains_mod, only: mpp_update_domains, SUPDATE, NUPDATE,  &
                                               WUPDATE, EUPDATE

implicit none
private

!------------ public interfaces ------------

public :: update_halo, vel_flux_boundary

interface update_halo
    module procedure  update_halo_2d, update_halo_3d, update_halo_4d
end interface

interface vel_flux_boundary
    module procedure  vel_flux_boundary_2d, vel_flux_boundary_3d
end interface

!-------- public parameters ----------

! possible values for field argument
integer, parameter, public :: TEMP = 21, UWND = 22, VWND = 23, WIND = 24

! possible values for optional halo argument
integer, parameter, public  :: SOUTH = 1, NORTH = 2
integer, parameter, public  ::  WEST = 4,  EAST = 8
integer, parameter, private ::  ALL = SOUTH+NORTH+WEST+EAST ! default

! possible values for optional flags argument
integer, parameter, public :: NOPOLE   = 1
integer, parameter, public :: POLEONLY = 2

!---------------------------------------------------------------
! private timing variables

   integer :: id_update3
   logical :: do_clock_init = .true.

! private module variables (used across module subroutines)

   integer :: domain_flags
   logical :: update_sbnd, update_nbnd, update_wbnd, update_ebnd, &
              no_pole_vel, do_pole_only
   logical :: do_channel

contains

!#######################################################################

 subroutine update_halo_3d (Hgrid, field, data, halos, flags)

!----------------------------------------------------------
!  Halo update for 3-dimensional fields
!----------------------------------------------------------
!  Hgrid = horizontal grid constants
!  field = integer identifier for field
!            possible values: TEMP, UWND, VWND
!  data  = 3-D data
!  halos = identifies which halos should be updated (optional)
!            possible values: NORTH, EAST, WEST, SOUTH
!            default(all): NORTH+EAST+WEST+SOUTH
!  flags = options for handling the pole
!            possible values: NOPOLE, POLEONLY
!----------------------------------------------------------

   type(horiz_grid_type), intent(inout) :: Hgrid
   integer,               intent(in)    :: field
   real,                  intent(inout) :: data(Hgrid%ilb:,Hgrid%jlb:,:)
   integer, optional,     intent(in)    :: halos, flags

   integer :: is, ie, iflags, halosize, xygrid

   if (do_clock_init) call clock_init
   call mpp_clock_begin (id_update3)

!  ----- check dimensions ------

   if (size(data,2) /= Hgrid % jsize)  call error_mesg  &
                    ('update_halo in bgrid_halo_mod',   &
                     'j dimension has wrong size', FATAL)

   if (size(data,1) /= Hgrid % isize)  call error_mesg  &
                    ('update_halo in bgrid_halo_mod',   &
                     'i dimension has wrong size', FATAL)

!  ----- check/set optional flag arguments ----

   call set_domain_flags ( Hgrid, halos, flags )

!  ------ need to determine and check grid -------

   select case (field)
     case (TEMP)
        is = Hgrid % Tmp % is;  ie = Hgrid % Tmp % ie;  xygrid = TGRID
        ! update non-polar boundaries
        if (.not.do_pole_only) call mpp_update_domains (data, Hgrid%Tmp%Domain, domain_flags)
     case (UWND:VWND)
        is = Hgrid % Vel % is;  ie = Hgrid % Vel % ie;  xygrid = VGRID
        ! update non-polar boundaries
        if (.not.do_pole_only) call mpp_update_domains (data, Hgrid%Vel%Domain, domain_flags)
     case default
        call error_mesg ('update_halo in bgrid_halo_mod', &
                         'invalid field', FATAL)
   end select

!  ----- update east-west cyclic boundaries (for 1-d decomp only) ----

   halosize = 1
   if (update_wbnd) data(is-halosize:is-1,:,:) = data(ie-halosize+1:ie,:,:)
   if (update_ebnd) data(ie+1:ie+halosize,:,:) = data(is:is+halosize-1,:,:)

!  ------ update south pole ------

   if ( (update_sbnd.or.do_pole_only) .and. update_sp (Hgrid,xygrid) ) then
      call south_boundary_3d (Hgrid, field, data(:,:,:), no_pole_vel)
   endif

!  ------ update north pole ------

   if ( (update_nbnd.or.do_pole_only) .and. update_np (Hgrid,xygrid) ) then
      call north_boundary_3d (Hgrid, field, data(:,:,:), no_pole_vel)
   endif

   call mpp_clock_end (id_update3)

 end subroutine update_halo_3d

!#######################################################################

 subroutine update_halo_4d (Hgrid, field, data, halos, flags)

!----------------------------------------------------------
!  Halo update for 4-dimensional fields
!----------------------------------------------------------
!  Hgrid = horizontal grid constants
!  field = integer identifier for field
!            possible values: TEMP, UWND, VWND, WIND
!            note: if field=WIND, then 4th dim of data must be 2
!  data  = 4-D data
!  halos = identifies which halos should be updated (optional)
!            possible values: NORTH, EAST, WEST, SOUTH
!            default(all): NORTH+EAST+WEST+SOUTH
!  flags = options for handling the pole
!            possible values: NOPOLE, POLEONLY
!----------------------------------------------------------

   type(horiz_grid_type), intent(inout) :: Hgrid
   integer,               intent(in)    :: field
   real,                  intent(inout) :: data(Hgrid%ilb:,Hgrid%jlb:,:,:)
   integer, optional,     intent(in)    :: halos, flags

   integer :: is, ie, iflags, n, halosize, xygrid

   if (do_clock_init) call clock_init
   call mpp_clock_begin (id_update3)

!  ----- check dimensions ------

   if (size(data,2) /= Hgrid % jsize)  call error_mesg  &
                    ('update_halo in bgrid_halo_mod',   &
                     'j dimension has wrong size', FATAL)

   if (size(data,1) /= Hgrid % isize)  call error_mesg  &
                    ('update_halo in bgrid_halo_mod',   &
                     'i dimension has wrong size', FATAL)

   if (field == WIND .and. size(data,4) /= 2) call error_mesg  &
             ('update_halo in bgrid_halo_mod',   &
      '4th dimension must have size 2 for wind components', FATAL)

!  ----- check/set optional flag arguments ----

   call set_domain_flags ( Hgrid, halos, flags )

!  ------ need to determine and check grid -------

   select case (field)
     case (TEMP)
        is = Hgrid % Tmp % is;  ie = Hgrid % Tmp % ie;  xygrid = TGRID
        ! update non-polar boundaries
        if (.not.do_pole_only) call mpp_update_domains (data, Hgrid%Tmp%Domain, domain_flags)
     case (UWND:WIND)
        is = Hgrid % Vel % is;  ie = Hgrid % Vel % ie;  xygrid = VGRID
        ! update non-polar boundaries
        if (.not.do_pole_only) call mpp_update_domains (data, Hgrid%Vel%Domain, domain_flags)
     case default
        call error_mesg ('update_halo in bgrid_halo_mod', &
                         'invalid field', FATAL)
   end select

!  ----- update east-west cyclic boundaries (for 1-d decomp only) ----

       halosize = 1
       if (update_wbnd) data(is-halosize:is-1,:,:,:) = data(ie-halosize+1:ie,:,:,:)
       if (update_ebnd) data(ie+1:ie+halosize,:,:,:) = data(is:is+halosize-1,:,:,:)

!  ------ update south pole ------

   do_channel = Hgrid%channel

   if ( (update_sbnd.or.do_pole_only) .and. update_sp (Hgrid,xygrid) ) then
      if (field == WIND) then
          call south_boundary_3d (Hgrid, UWND, data(:,:,:,1), no_pole_vel)
          call south_boundary_3d (Hgrid, VWND, data(:,:,:,2), no_pole_vel)
       else
          do n = 1, size(data,4)
            call south_boundary_3d (Hgrid, field, data(:,:,:,n), no_pole_vel)
          enddo
       endif
   endif

!  ------ update north pole ------

   if ( (update_nbnd.or.do_pole_only) .and. update_np (Hgrid,xygrid) ) then
      if (field == WIND) then
          call north_boundary_3d (Hgrid, UWND, data(:,:,:,1), no_pole_vel)
          call north_boundary_3d (Hgrid, VWND, data(:,:,:,2), no_pole_vel)
      else
          do n = 1, size(data,4)
            call north_boundary_3d (Hgrid, field, data(:,:,:,n), no_pole_vel)
          enddo
      endif
   endif

   call mpp_clock_end (id_update3)

 end subroutine update_halo_4d

!#######################################################################
! updates halos at (and beyond) the north pole

 subroutine north_boundary_3d (Hgrid, field, data, nopole)

   type(horiz_grid_type), intent(in)    :: Hgrid
   integer,               intent(in)    :: field
   real,                  intent(inout) :: data(:,Hgrid%jlb:,:)
   logical,               intent(in)    :: nopole

   integer :: js, je, jeg, halo

      halo = 1  ! assumed halo size = 1

! --- update north pole boundary ---

      select case (field)
         case (TEMP)
!        ---- mass ----
            js = Hgrid % Tmp % js;  je = Hgrid % Tmp % je
            data (:, je+1:je+halo, :) = data (:, je:je-halo+1:-1, :)
         case (UWND)
!        ---- u comp ----
            js = Hgrid % Vel % js;  je = Hgrid % Vel % je;  jeg = Hgrid % Vel % jeg
            if (.not. nopole) then
                if (.not.do_channel) then
                    if ( jeg+1 <= je+halo ) data (:, jeg+1,:) = 0.0
                else
                    if ( jeg+1 <= je+halo ) data (:, jeg+1,:) = data (:, jeg,:)
                endif
            endif
            if ( jeg+2 <= je+halo ) &
            data (:, jeg+2:jeg+halo, :) = data (:, je:je-halo+2:-1, :)
         case (VWND)
!        ---- v comp ----
            js = Hgrid % Vel % js;  je = Hgrid % Vel % je;  jeg = Hgrid % Vel % jeg
            if (.not. nopole) then
                if ( jeg+1 <= je+halo ) data (:, jeg+1, :) = 0.0
            endif
            if ( jeg+2 <= je+halo ) &
            data (:, jeg+2:jeg+halo, :) = - data (:, je:je-halo+2:-1, :)
      end select

 end subroutine north_boundary_3d

!#######################################################################
! updates halos at (and beyond) the south pole

 subroutine south_boundary_3d (Hgrid, field, data, nopole)

   type(horiz_grid_type), intent(in)    :: Hgrid
   integer,               intent(in)    ::  field
   real,                  intent(inout) :: data(:,Hgrid%jlb:,:)
   logical,               intent(in)    :: nopole

   integer :: js, je, halo

      halo = 1  ! assumed halo size = 1

! --- update south pole boundary ---

      select case (field)
         case (TEMP)
!        ---- mass ----
            js = Hgrid % Tmp % js;  je = Hgrid % Tmp % je
            data (:, js-1:js-halo:-1, :) = data (:, js:js+halo-1, :)
         case (UWND)
!        ---- u comp ----
            js = Hgrid % Vel % js;  je = Hgrid % Vel % je
            if (.not. nopole) then
                if (.not.do_channel) then
                    data (:, js-1, :) = 0.0
                else
                    data (:, js-1, :) = data (:, js, :)
                endif
            endif
            data (:, js-2:js-halo:-1, :) = data (:, js:js+halo-2, :)
         case (VWND)
!        ---- v comp ----
            js = Hgrid % Vel % js;  je = Hgrid % Vel % je
            if (.not. nopole) data (:, js-1, :) = 0.0
            data (:, js-2:js-halo:-1, :) = - data (:, js:js+halo-2, :)
      end select

 end subroutine south_boundary_3d

!#######################################################################

 subroutine vel_flux_boundary_3d (Hgrid, data)

! zero-out the flux between pole and first velocity row
! do this on both sides of the ppole
! meridional indexing coincides with mass grid
! assumed halo size is one

!  Hgrid = horizontal grid constants
!  data = 3-D data

   type(horiz_grid_type), intent(in)    :: Hgrid
   real,                  intent(inout) :: data(:,Hgrid%jlb:,:)

      if ( update_sp (Hgrid,TGRID) ) then
           data (:, Hgrid%Tmp%js-1, :) = 0.0
           data (:, Hgrid%Tmp%js  , :) = 0.0
      endif

      if ( update_np (Hgrid,TGRID) ) then
           data (:, Hgrid%Tmp%je  , :) = 0.0
           data (:, Hgrid%Tmp%je+1, :) = 0.0
      endif

 end subroutine vel_flux_boundary_3d

!#######################################################################
! overload interfaces
!#######################################################################

 subroutine update_halo_2d (Hgrid, field, data, halos, flags)

   type(horiz_grid_type), intent(inout) :: Hgrid
   integer,               intent(in)    :: field
   real,                  intent(inout) :: data(:,:)
   integer, optional,     intent(in)    :: halos, flags

   real, dimension(size(data,1),size(data,2),1) :: data3

   data3(:,:,1) = data
   call update_halo_3d (Hgrid, field, data3, halos, flags)
   data = data3(:,:,1)

 end subroutine update_halo_2d

!#######################################################################

 subroutine vel_flux_boundary_2d (Hgrid, data)

   type(horiz_grid_type), intent(in)    :: Hgrid
   real,                  intent(inout) :: data(:,Hgrid%jlb:)

   real, dimension(size(data,1),size(data,2),1) :: data3

   data3(:,:,1) = data
   call vel_flux_boundary_3d (Hgrid, data3)
   data = data3(:,:,1)

 end subroutine vel_flux_boundary_2d

!#######################################################################
! private interfaces
!#######################################################################

 subroutine set_domain_flags ( Hgrid, halos, flags )
 type(horiz_grid_type), intent(in) :: Hgrid
 integer, optional,     intent(in) :: halos, flags
 integer :: ihalos, iflags

! sets module variables -- domain_flags,
!                          update_sbnd, update_nbnd,
!                          update_wbnd, update_ebnd,
!                          no_pole_vel, do_pole_only

   ihalos = ALL;  if (present(halos)) ihalos = halos
   iflags = 0;    if (present(flags)) iflags = flags

   domain_flags = 0

   ! south and north boundary
     update_sbnd  = btest(ihalos,0)
     update_nbnd  = btest(ihalos,1)
     if ( update_sbnd ) domain_flags = domain_flags + SUPDATE
     if ( update_nbnd ) domain_flags = domain_flags + NUPDATE
     ! turn off polar update if domain is periodic in y
    !if (Hgrid%Vel%jeg == Hgrid%Tmp%jeg) then
     if (Hgrid%double_periodic) then
        update_sbnd = .false.
        update_nbnd = .false.
     endif
   ! west and east boundary
     update_wbnd  = btest(ihalos,2)
     update_ebnd  = btest(ihalos,3)
     if (Hgrid%decompx) then
        if ( update_wbnd ) domain_flags = domain_flags + WUPDATE
        if ( update_ebnd ) domain_flags = domain_flags + EUPDATE
        update_wbnd = .false. ! turn off ?
        update_ebnd = .false.
     endif

   ! set additional flags related to polar boundary
     no_pole_vel  = btest(iflags,0)    !4)
     do_pole_only = btest(iflags,1)    !5)

   ! might update south or north poles ?
   ! if (do_pole_only) then
   !     update_sbnd = .true.
   !     update_nbnd = .true.
   ! endif

 end subroutine set_domain_flags

!#######################################################################
! initializes mpp performance clock for bgrid halo updates

 subroutine clock_init
   id_update3 = mpp_clock_id ('BGRID: update_halo',   &
                  flags=MPP_CLOCK_SYNC, grain=CLOCK_ROUTINE)
   do_clock_init = .false.
 end subroutine clock_init

!#######################################################################

end module bgrid_halo_mod

max_stars_repo_name: JoyMonteiro/FMSDynamicalCore