Interact.f90

Go to the documentation of this file.

!==============================================================================
!
!  Name   :  Interact
!
!  Remarks:  contains the SUBROUTINEs
!
!            SeedsDispersedFromThisCell (<LocalDynOneTimeStep<SpatialDynOneTimeStep<
!                                          TimeLoop<TreeMig)
!            SeedsDispFromThisCellAndSpec (<SeedsDispersedFromThisCell<LocalDynOneTimeStep<
!                                            SpatialDynOneTimeStep<TimeLoop<TreeMig)
!            UpdateNewSeeds (<DistrLocalDynThisTime<TimeLoop<TreeMig)
!            SeedsFromOutsSimRegion (<DistrLocalDynThisTime<TimeLoop<TreeMig)
!            BoundaryConditions (<SeedsDispFromThisCellAndSpec<SeedsDispersedFromThisCell<
!                                  LocalDynOneTimeStep<DistrLocalDynThisTime<TimeLoop<TreeMig)
!
!==============================================================================
 
!=================== For For Dispersal without FFT ======================================================
!===============================================================
SUBROUTINE seedsdispersedfromthiscell(nspc, lat, lon)
    IMPLICIT NONE
    
    INTEGER, INTENT(in) :: nspc, lat, lon   ! number of species
    INTEGER  ::isp
 
    do isp = 1, nspc
        call seedsdispfromthiscellandspec(isp, lat, lon)
    end do
 
    return
end SUBROUTINE seedsdispersedfromthiscell
!****<Here the SUBROUTINE ends>********************************************************************
 
!=================== For Dispersal without FFT ======================================================
!===============================================================
SUBROUTINE seedsdispfromthiscellandspec(isp, lat, lon)
    
    use all_par, only: maxlat, maxlon,stategrid, seedrain,  spec, dostochseeddisp,boundaries,stockability    
    IMPLICIT NONE
    
    INTEGER, INTENT(in) :: isp, lat, lon 
    REAL       :: producedSeeds
    
    INTEGER :: seeds_inAir, seeds_onGround, &  ! number of seeds emitted and fallen to ground
               latwin, &     ! index of relative to source cell  window latitude
               lonwin, &     ! index of relative to source cell  window longitude
               wlat, wlon    ! indices of absolute window latitude and longitude
    REAL    :: contrib                 ! contribution of source cell to sink cell
    REAL    ::   prob                  ! probability of seeds landing in  sink cell
    LOGICAL :: dodisp
      
    
    !----- <See also SUBROUTINE InitAndSetConstHeightClProps for the initialization!>
    if (stockability(lat, lon) == 0.0) return  !  if cell is not stockable then also no seed dispersal from this cell
    
    producedseeds = stategrid(lat, lon)%sp(isp)%producedSeeds   ! all seeds of this species produced in the source cell
    !----- <Loop through species to perform seed dispersal calculations>
!    ncells = 0
    if (producedseeds > 0.0) then ! if there are seeds to distribute
        !----- <Loop for general discrete convolution>
        !----- Go through all possible (i.e. within radius of dispersal kernel, given as latwin, lonwin window) sink cells around source cell 
 
        looplatwin: do latwin = -spec(isp)%rad, +spec(isp)%rad
            looplonwin: do lonwin = -spec(isp)%rad, +spec(isp)%rad
                !----- Determine absolute coordinates from those of source cell
                wlat = lat - latwin
                wlon = lon - lonwin
                !----- what happens if seeds cross  edge of simulation domain? Check whether this sink cell is allowed by the boundary conditions
                call boundaryconditions(wlat, maxlat, wlon, maxlon, dodisp, boundaries)
 
                if_inallowedarea: IF (dodisp) then
                    ifstock: if ((stockability(wlat, wlon) > 0.0)  ) then !---- if sink cell is stockable
                        prob = spec(isp)%kernel(latwin, lonwin)           !---- probability of dispersal between source and sink cell
                        if (dostochseeddisp) then
                            seeds_inair = producedseeds                   !---- only integer numbers of seeds allowed for binomial distribution approach
                            call drawfromdistri(seeds_inair, prob, seeds_onground) !----- Stochastic dispersal (by binomial distribution)
                            contrib = seeds_onground
                        else
                            contrib = prob * producedseeds                         !----- Deterministic dispersal, probability interpreted as fraction
                        end if
                        !---- add the seeds transported from source to  sink cell to all seeds of this species ending in the sink cell
                        seedrain(wlat, wlon)%sp(isp)%verynewSeeds = seedrain(wlat, wlon)%sp(isp)%verynewSeeds + contrib !*cachind
                    end if ifstock
                end if if_inallowedarea
            end do looplonwin
        end do looplatwin
    end if !-----  producedSeeds>0.0
    !       end if IF_Active
end SUBROUTINE seedsdispfromthiscellandspec
!****<Here the SUBROUTINE ends>********************************************************************
!==============================================================================
!===============================================================
SUBROUTINE updatenewseeds(nspc, iam, doDispersal, year, lats, late, lons, lone)
    
    use all_par, only: maxlat, maxlon, seedrain, spec      ! Use control and species parameters
    use loggermodule
    IMPLICIT NONE
    
    INTEGER, INTENT(in) :: nspc, iam, lats, late, lons, lone, year    ! number of species
    LOGICAL, INTENT(in) :: doDispersal      ! dispersal on/off flag                                      [=..]
    
    INTEGER ::  latwin, &  ! index of relative window latitude
               lonwin, &  ! index of relative window longitude
               isp                             ! index of species
 ! Check whether subarea is within the simulation area
    if ((lats < 1) .or. (lats > maxlat) .or. (late < 1) .or. (late > maxlat) .or. &
        (lons < 1) .or. (lons > maxlon) .or. (lone < 1) .or. (lone > maxlon)) then
        call logerror("Coordinates out of bounds in updateNewseeds")
        write (logmessage, "(7A15)") "iam", "lats", "lons", "late", "lone", "maxlat", "maxlon"
        call logerror(logmessage)
        write (logmessage, "(7I15)") iam, lats, lons, late, lone, maxlat, maxlon
        call logerror(logmessage)
        error stop
    end if
 !   
    if (dodispersal) then
        loopspc2: do isp = 1, nspc
            if (year >= spec(isp)%immi%dat(1)%year) then  ! is normally fulfilled
                looplatwin2: do latwin = lats, late
                    looplonwin2: do lonwin = lons, lone
                        seedrain(latwin, lonwin)%sp(isp)%newSeeds = seedrain(latwin, lonwin)%sp(isp)%verynewSeeds ! this is the update, 
                        ! if (seedrain(latwin,lonwin)%sp(isp)%verynewSeeds >0.) &
                        seedrain(latwin, lonwin)%sp(isp)%verynewSeeds = 0.0           ! verynewSeeds is refreshed
                    end do looplonwin2
                end do looplatwin2
            end if
        end do loopspc2
    end if ! idisp
end SUBROUTINE updatenewseeds
!****<Here the SUBROUTINE ends>********************************************************************
 
!===============================================================
!===============================================================
SUBROUTINE seedsfromoutssimregion(nspc, doDispersal, year, lats, late, lons, lone)
    ! <CALL modules for TYPE definitions and +- fixed variables>---------------------------------------------------------------
    use all_par, only: outerseeds, seedrain, spec      ! Use control and species parameters
    IMPLICIT NONE
    ! <Passed variables>--------------------------------------------------------------------------------
    INTEGER, INTENT(in) :: nspc, lats, late, lons, lone, year    ! number of species
    LOGICAL, INTENT(in) :: doDispersal      ! dispersal on/off flag                                      [=..]
    ! <Local variables>---------------------------------------------------------------------------------
    INTEGER ::  latwin, &  ! index of relative window latitude
               lonwin, &  ! index of relative window longitude
               isp                             ! index of species
    if (dodispersal) then
        if (outerseeds > 0) then  !----- outerspace boundary conditions
            loopspc2: do isp = 1, nspc
                if (year >= spec(isp)%immi%dat(1)%year) then  !   immi%dat(1)%year is now defined in ReadImmigrationData
                    looplatwin2: do latwin = lats, late
                        looplonwin2: do lonwin = lons, lone
                            seedrain(latwin, lonwin)%sp(isp)%newSeeds = seedrain(latwin, lonwin)%sp(isp)%newSeeds + outerseeds
                        end do looplonwin2
                    end do looplatwin2
                end if
            end do loopspc2
        end if
    end if ! idisp
end SUBROUTINE seedsfromoutssimregion
!****<Here the SUBROUTINE ends>********************************************************************
 
!=================== For Dispersal without FFT ======================================================
!===============================================================
SUBROUTINE boundaryconditions(wlat, maxlat, wlon, maxlon, dodisp, boundaries)
 
    
    IMPLICIT NONE
 
    
    INTEGER, INTENT(in)      :: maxlat, maxlon  ! looping variable for longitude               [=..]
    character(1), INTENT(in) :: boundaries      ! TYPE of boundary conditions
    INTEGER, INTENT(inout)  :: wlat, &         ! variable for latitude                        [=..]
                                wlon            ! variable for longitude                       [=..]
    LOGICAL, INTENT(out)     :: dodisp          ! valid sink cell?                     [=..]
 
    ! LOCAL variables>--------------------------------------------------------------------------------
 
    ! Here the SUBROUTINE starts>**********************************************************************
    dodisp = .true.
    select case (boundaries)
      case('a')                          !----- absorbing boundary conditions
        if ((wlat  <  1) .OR. (wlat .gt. maxlat) .OR. &
            (wlon  <  1) .OR. (wlon .gt. maxlon)) dodisp = .false.
      case('w')                          !----- absorbing boundary conditions in north and south, cyclic in east and west
        if (wlon .ge. 0) then
          wlon = mod(wlon, maxlon)
        else
          wlon = maxlon - mod(abs(wlon), maxlon)
        end if
        if (wlon == 0) wlon=maxlon
        if ((wlat  <  1) .OR. (wlat .gt. maxlat)) dodisp = .false.
      case('s')                             !----- absorbing boundary conditions in west and eats, cyclic in south and north
        if (wlat .ge. 0) then
          wlat = mod(wlat, maxlat)
        else
          wlat = maxlat - mod(abs(wlat), maxlat)
        end if
        if (wlat == 0) wlat = maxlat
        if ((wlon  <  1) .OR. (wlon .gt. maxlon)) dodisp = .false.
      case('c')                          !----- Cyclic boundary conditions
        if (wlat .ge. 0) then
          wlat = mod(wlat, maxlat)
        else
          wlat = maxlat - mod(abs(wlat), maxlat)
        end if
        if (wlat == 0) wlat = maxlat
        if (wlon .ge. 0) then
          wlon = mod(wlon,maxlon)
        else
          wlon = maxlon - mod(abs(wlon), maxlon)
        end if
        if (wlon == 0) wlon = maxlon
      case default
        write(70,*) 'wrong boundary conditions : ', boundaries, ', choose one of a, c, s, w; set to absorbing'       
       if ((wlat  <  1) .OR. (wlat .gt. maxlat) .OR. &
            (wlon  <  1) .OR. (wlon .gt. maxlon)) dodisp = .false.
      end select
    return
end SUBROUTINE boundaryconditions
!done