*IF DEF,A03_7A                                                             ROOTFR7A.2      
C *****************************COPYRIGHT******************************     ROOTFR7A.3      
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved.    ROOTFR7A.4      
C                                                                          ROOTFR7A.5      
C Use, duplication or disclosure of this code is subject to the            ROOTFR7A.6      
C restrictions as set forth in the contract.                               ROOTFR7A.7      
C                                                                          ROOTFR7A.8      
C                Meteorological Office                                     ROOTFR7A.9      
C                London Road                                               ROOTFR7A.10     
C                BRACKNELL                                                 ROOTFR7A.11     
C                Berkshire UK                                              ROOTFR7A.12     
C                RG12 2SZ                                                  ROOTFR7A.13     
C                                                                          ROOTFR7A.14     
C If no contract has been raised with this copy of the code, the use,      ROOTFR7A.15     
C duplication or disclosure of it is strictly prohibited.  Permission      ROOTFR7A.16     
C to do so must first be obtained in writing from the Head of Numerical    ROOTFR7A.17     
C Modelling at the above address.                                          ROOTFR7A.18     
C ******************************COPYRIGHT******************************    ROOTFR7A.19     
!    SUBROUTINE ROOT_FRAC---------------------------------------------     ROOTFR7A.20     
!                                                                          ROOTFR7A.21     
! Subroutine Interface:                                                    ROOTFR7A.22     

      SUBROUTINE ROOT_FRAC (NSHYD,DZ,ROOTD,F_ROOT)                          2ROOTFR7A.23     
                                                                           ROOTFR7A.24     
      IMPLICIT NONE                                                        ROOTFR7A.25     
!                                                                          ROOTFR7A.26     
! Description:                                                             ROOTFR7A.27     
!     Calculates the fraction of the total plant roots within each         ROOTFR7A.28     
!     soil layer.                                                          ROOTFR7A.29     
!                                                                          ROOTFR7A.30     
!                                                                          ROOTFR7A.31     
! Documentation : UM Documentation Paper 25                                ROOTFR7A.32     
!                                                                          ROOTFR7A.33     
! Current Code Owner : Peter Cox                                           ABX1F405.913    
!                                                                          ROOTFR7A.35     
! History:                                                                 ROOTFR7A.36     
! Version   Date     Comment                                               ROOTFR7A.37     
! -------   ----     -------                                               ROOTFR7A.38     
!  4.4      9/97     New deck    Peter Cox                                 ABX1F405.914    
!  4.5      6/98     Exponential profile Peter Cox                         ABX1F405.915    
!                                                                          ROOTFR7A.40     
! Code Description:                                                        ROOTFR7A.41     
!   Language: FORTRAN 77 + common extensions.                              ROOTFR7A.42     
!                                                                          ROOTFR7A.43     
! System component covered: P25                                            ROOTFR7A.44     
! System Task: P25                                                         ROOTFR7A.45     
!                                                                          ROOTFR7A.46     
                                                                           ROOTFR7A.47     
! Subroutine arguments:                                                    ROOTFR7A.48     
!   Scalar arguments with intent(IN) :                                     ROOTFR7A.49     
      INTEGER                                                              ROOTFR7A.50     
     & NSHYD                ! IN Number of soil moisture layers.           ROOTFR7A.51     
                                                                           ROOTFR7A.52     
      REAL                                                                 ROOTFR7A.53     
     & DZ(NSHYD)            ! IN Soil layer thicknesses (m).               ROOTFR7A.54     
     &,ROOTD                ! IN Rootdepth (m).                            ROOTFR7A.55     
                                                                           ROOTFR7A.56     
!   Array arguments with intent(OUT) :                                     ROOTFR7A.57     
      REAL                                                                 ROOTFR7A.58     
     & F_ROOT(NSHYD)        ! OUT Fraction of roots in each soil           ROOTFR7A.59     
!                           !     layer.                                   ROOTFR7A.60     
! Local scalars:                                                           ROOTFR7A.61     
      INTEGER                                                              ROOTFR7A.62     
     & N                    ! WORK Loop counters                           ROOTFR7A.63     
                                                                           ROOTFR7A.64     
      REAL                                                                 ROOTFR7A.65     
     & FTOT                 ! WORK Normalisation factor.                   ABX1F405.916    
     &,ZTOT                 ! WORK Total depth of soil (m).                ABX1F405.917    
     &,Z1,Z2                ! WORK Depth of the top and bottom of the      ABX1F405.918    
!                           !      soil layers (m).                        ROOTFR7A.67     
                                                                           ABX1F405.919    
! Local parameters:                                                        ROOTFR7A.68     
      REAL                                                                 ROOTFR7A.69     
     & P                    ! WORK Power describing depth dependence       ROOTFR7A.70     
!                                  of the root density profile.            ROOTFR7A.71     
      PARAMETER (P=2.0)                                                    ROOTFR7A.72     
                                                                           ROOTFR7A.73     
      Z2=0.0                                                               ROOTFR7A.74     
      ZTOT=0.0                                                             ABX1F405.920    
                                                                           ROOTFR7A.75     
      DO N=1,NSHYD                                                         ROOTFR7A.76     
        Z1=Z2                                                              ROOTFR7A.78     
        Z2=Z2+DZ(N)                                                        ROOTFR7A.79     
        ZTOT=ZTOT+DZ(N)                                                    ABX1F405.921    
        F_ROOT(N)=EXP(-P*Z1/ROOTD)-EXP(-P*Z2/ROOTD)                        ABX1F405.922    
      ENDDO                                                                ABX1F405.923    
                                                                           ROOTFR7A.80     
      FTOT=1.0-EXP(-P*ZTOT/ROOTD)                                          ABX1F405.924    
      DO N=1,NSHYD                                                         ABX1F405.925    
        F_ROOT(N)=F_ROOT(N)/FTOT                                           ABX1F405.926    
      ENDDO                                                                ROOTFR7A.93     
                                                                           ROOTFR7A.94     
      RETURN                                                               ROOTFR7A.95     
      END                                                                  ROOTFR7A.96     
*ENDIF                                                                     ROOTFR7A.97