source: tags/ORCHIDEE/src_stomate/lpj_kill.f90 @ 6

! kills pfts that obviously fare badly
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_kill.f90,v 1.8 2009/01/06 15:01:25 ssipsl Exp $
! IPSL (2006)
!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_kill

  ! modules used:

  USE ioipsl
  USE stomate_constants
  USE constantes_veg

  IMPLICIT NONE

  ! private & public routines

  PRIVATE
  PUBLIC kill

CONTAINS

  SUBROUTINE kill (npts, whichroutine, lm_lastyearmax, &
       ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
       lai, age, leaf_age, leaf_frac, &
       when_growthinit, everywhere, veget, veget_max, bm_to_litter)

    !
    ! 0 declarations
    !

    ! 0.1 input

    ! Domain size
    INTEGER(i_std), INTENT(in)                                       :: npts
    ! message
    CHARACTER*10, INTENT(in)                                  :: whichroutine
    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax

    ! 0.2 modified fields

    ! Number of individuals / m**2
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind
    ! Is pft there
    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: PFTpresent
    ! crown area of individuals (m**2)
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: cn_ind
    ! biomass (gC/(m**2 of ground))
    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: biomass
    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: senescence
    ! How much time ago was the PFT eliminated for the last time (y)
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: RIP_time
    ! leaf area index OF AN INDIVIDUAL PLANT
    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: lai
    ! mean age (years)
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age
    ! leaf age (days)
    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_age
    ! fraction of leaves in leaf age class
    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac
    ! how many days ago was the beginning of the growing season
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit
    ! is the PFT everywhere in the grid box or very localized (after its introduction)
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere
    ! fractional coverage on ground, taking into
    !   account LAI (=grid-scale fpc)
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget
    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max
    ! conversion of biomass to litter (gC/(m**2 of ground)) / day
    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: bm_to_litter

    ! 0.3 local

    ! indices
    INTEGER(i_std)                                             :: j,m
    ! bookkeeping
    LOGICAL, DIMENSION(npts)                                  :: was_killed

    ! =========================================================================

    IF (bavard.GE.3) WRITE(numout,*) 'Entering kill'

    DO j = 2,nvm

       was_killed(:) = .FALSE.

       ! only kill natural PFTs

       IF ( natural(j) ) THEN

          ! kill present plants if number of individuals or last year's leaf
          ! mass is close to zero.
          ! the "was_killed" business is necessary for a more efficient code on the VPP

          WHERE ( PFTpresent(:,j) .AND. &
               ( ( ind(:,j) .LT. min_stomate ) .OR. &
               ( lm_lastyearmax(:,j) .LT. min_stomate ) ) )

             was_killed(:) = .TRUE.

          ENDWHERE

          IF ( ANY( was_killed(:) ) ) THEN

             WHERE ( was_killed(:) )

                ind(:,j) = 0.0

                bm_to_litter(:,j,ileaf) = bm_to_litter(:,j,ileaf) + biomass(:,j,ileaf)
                bm_to_litter(:,j,isapabove) = bm_to_litter(:,j,isapabove) + biomass(:,j,isapabove)
                bm_to_litter(:,j,isapbelow) = bm_to_litter(:,j,isapbelow) + biomass(:,j,isapbelow)
                bm_to_litter(:,j,iheartabove) = bm_to_litter(:,j,iheartabove) + &
                     biomass(:,j,iheartabove)
                bm_to_litter(:,j,iheartbelow) = bm_to_litter(:,j,iheartbelow) + &
                     biomass(:,j,iheartbelow)
                bm_to_litter(:,j,iroot) = bm_to_litter(:,j,iroot) + biomass(:,j,iroot)
                bm_to_litter(:,j,ifruit) = bm_to_litter(:,j,ifruit) + biomass(:,j,ifruit)
                bm_to_litter(:,j,icarbres) = bm_to_litter(:,j,icarbres) + biomass(:,j,icarbres)

                biomass(:,j,ileaf) = 0.0
                biomass(:,j,isapabove) = 0.0
                biomass(:,j,isapbelow) = 0.0
                biomass(:,j,iheartabove) = 0.0
                biomass(:,j,iheartbelow) = 0.0
                biomass(:,j,iroot) = 0.0
                biomass(:,j,ifruit) = 0.0
                biomass(:,j,icarbres) = 0.0

                PFTpresent(:,j) = .FALSE.

                cn_ind(:,j) = 0.0

                senescence(:,j) = .FALSE.


                age(:,j) = 0.0

                when_growthinit(:,j) = undef

                everywhere(:,j) = 0.0

                veget(:,j) = 0.0

                veget_max(:,j) = 0.0

                RIP_time(:,j) = 0.0

             ENDWHERE   ! number of individuals very low

             DO m = 1, nleafages

                WHERE ( was_killed(:) )

                   leaf_age(:,j,m) = 0.0 
                   leaf_frac(:,j,m) = 0.0 

                ENDWHERE

             ENDDO

             IF ( bavard .GE. 2 ) THEN

                WRITE(numout,*) 'kill: eliminated ',PFT_name(j)
                WRITE(numout,*) '  at ',COUNT( was_killed(:) ),' points after '//whichroutine

             ENDIF

          ENDIF     ! PFT must be killed at at least one place

       ENDIF       ! PFT is natural

    ENDDO         ! loop over PFTs

    IF (bavard.GE.4) WRITE(numout,*) 'Leaving kill'

  END SUBROUTINE kill

END MODULE lpj_kill