*IF DEF,A19_1A,OR,DEF,A19_2A SPARM1A.2
C *****************************COPYRIGHT****************************** SPARM1A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SPARM1A.4
C SPARM1A.5
C Use, duplication or disclosure of this code is subject to the SPARM1A.6
C restrictions as set forth in the contract. SPARM1A.7
C SPARM1A.8
C Meteorological Office SPARM1A.9
C London Road SPARM1A.10
C BRACKNELL SPARM1A.11
C Berkshire UK SPARM1A.12
C RG12 2SZ SPARM1A.13
C SPARM1A.14
C If no contract has been raised with this copy of the code, the use, SPARM1A.15
C duplication or disclosure of it is strictly prohibited. Permission SPARM1A.16
C to do so must first be obtained in writing from the Head of Numerical SPARM1A.17
C Modelling at the above address. SPARM1A.18
C ******************************COPYRIGHT****************************** SPARM1A.19
!********************************************************************** SPARM1A.20
! Routine to calculate the gridbox mean land surface parameters from SPARM1A.21
! the areal fractions of the surface types and the structural SPARM1A.22
! properties of the plant functional types. SPARM1A.23
! SPARM1A.24
! Written by Peter Cox (June 1997) SPARM1A.25
!********************************************************************** SPARM1A.26
SUBROUTINE SPARM (LAND_FIELD,LAND1,LAND_PTS,TILE_PTS,TILE_INDEX 3,1SPARM1A.27
&, ALBSOIL,FRAC,HT,LAI SPARM1A.28
&, ALBSNC,ALBSNF,CATCH_T,Z0,Z0_T) SPARM1A.29
SPARM1A.30
IMPLICIT NONE SPARM1A.31
SPARM1A.32
*CALL NSTYPES 
SPARM1A.33
SPARM1A.34
INTEGER SPARM1A.35
& LAND_FIELD ! IN Number of land points in whole grid. SPARM1A.36
&,LAND1 ! IN First land point to be processed. SPARM1A.37
&,LAND_PTS ! IN Number of land points to be processed. SPARM1A.38
&,TILE_PTS(NTYPE) ! IN Number of land points which SPARM1A.39
! ! include the nth surface type. SPARM1A.40
&,TILE_INDEX(LAND_FIELD,NTYPE) ! IN Indices of land points which SPARM1A.41
! ! include the nth surface type. SPARM1A.42
SPARM1A.43
REAL SPARM1A.44
& ALBSOIL(LAND_FIELD) ! IN Soil albedo. SPARM1A.45
&,FRAC(LAND_FIELD,NTYPE) ! IN Fractional cover of each SPARM1A.46
! ! surface type. SPARM1A.47
&,HT(LAND_FIELD,NPFT) ! IN Vegetation height (m). SPARM1A.48
&,LAI(LAND_FIELD,NPFT) ! IN Leaf area index. SPARM1A.49
SPARM1A.50
REAL SPARM1A.51
& ALBSNC(LAND_FIELD) ! OUT Snow-covered albedo. SPARM1A.52
&,ALBSNF(LAND_FIELD) ! OUT Snow-free albedo. SPARM1A.53
&,CATCH_T(LAND_FIELD,NTYPE-1)! OUT Canopy capacity for each type SPARM1A.54
! ! apart from ice (kg/m2). SPARM1A.55
&,Z0(LAND_FIELD) ! OUT Roughness length (m). SPARM1A.56
&,Z0_T(LAND_FIELD,NTYPE) ! OUT Roughness length for each SPARM1A.57
! ! type (m). SPARM1A.58
REAL SPARM1A.59
& ALBSNC_T(LAND_FIELD,NTYPE) ! WORK Snow-covered albedo for each SPARM1A.60
! ! type. SPARM1A.61
&,ALBSNF_T(LAND_FIELD,NTYPE) ! WORK Snow-free albedo for each type. SPARM1A.62
&,CATCH(LAND_FIELD) ! WORK Canopy capacity (kg/m2). SPARM1A.63
&,FZ0(LAND_FIELD) ! WORK Aggregation function of Z0. SPARM1A.64
SPARM1A.65
INTEGER SPARM1A.66
& J,L,N ! WORK Loop counters SPARM1A.67
SPARM1A.68
!----------------------------------------------------------------------- SPARM1A.69
! Local parameters. SPARM1A.70
!----------------------------------------------------------------------- SPARM1A.71
REAL SPARM1A.72
& ALBSNCS ! Snow-covered albedo of bare soil. SPARM1A.73
PARAMETER (ALBSNCS = 0.8) SPARM1A.74
SPARM1A.75
*CALL PFTPARM SPARM1A.76
*CALL NVEGPARM SPARM1A.77
*CALL BLEND_H SPARM1A.78
SPARM1A.79
!---------------------------------------------------------------------- SPARM1A.80
! Set parameters for vegetated surface types SPARM1A.81
!---------------------------------------------------------------------- SPARM1A.82
DO N=1,NPFT SPARM1A.83
CALL PFT_SPARM (LAND_FIELD,N,TILE_INDEX(1,N),TILE_PTS(N) SPARM1A.84
&, ALBSOIL,HT(1,N),LAI(1,N) SPARM1A.85
&, ALBSNC_T(1,N),ALBSNF_T(1,N),CATCH_T(1,N) SPARM1A.86
&, Z0_T(1,N)) SPARM1A.87
ENDDO SPARM1A.88
SPARM1A.89
!---------------------------------------------------------------------- SPARM1A.90
! Set parameters for non-vegetated surface types SPARM1A.91
!---------------------------------------------------------------------- SPARM1A.92
DO N=NPFT+1,NTYPE SPARM1A.93
DO J=1,TILE_PTS(N) SPARM1A.94
L = TILE_INDEX(J,N) SPARM1A.95
ALBSNC_T(L,N) = ALBSNC_NVG(N-NPFT) SPARM1A.96
ALBSNF_T(L,N) = ALBSNF_NVG(N-NPFT) SPARM1A.97
IF ( ALBSNF_NVG(N-NPFT).LT.0. ) ALBSNF_T(L,N) = ALBSOIL(L) SPARM1A.98
Z0_T(L,N) = Z0_NVG(N-NPFT) SPARM1A.99
ENDDO SPARM1A.100
ENDDO SPARM1A.101
SPARM1A.102
DO N=NPFT+1,NTYPE-1 SPARM1A.103
DO J=1,TILE_PTS(N) SPARM1A.104
L = TILE_INDEX(J,N) SPARM1A.105
CATCH_T(L,N) = CATCH_NVG(N-NPFT) SPARM1A.106
ENDDO SPARM1A.107
ENDDO SPARM1A.108
SPARM1A.109
!---------------------------------------------------------------------- SPARM1A.110
! Form area means SPARM1A.111
!---------------------------------------------------------------------- SPARM1A.112
DO L=1,LAND_FIELD SPARM1A.113
ALBSNC(L) = 0.0 SPARM1A.114
ALBSNF(L) = 0.0 SPARM1A.115
CATCH(L) = 0.0 SPARM1A.116
FZ0(L) = 0.0 SPARM1A.117
ENDDO SPARM1A.118
SPARM1A.119
DO N=1,NTYPE SPARM1A.120
DO J=1,TILE_PTS(N) SPARM1A.121
L = TILE_INDEX(J,N) SPARM1A.122
ALBSNC(L) = ALBSNC(L) + FRAC(L,N) * ALBSNC_T(L,N) SPARM1A.123
ALBSNF(L) = ALBSNF(L) + FRAC(L,N) * ALBSNF_T(L,N) SPARM1A.124
FZ0(L) = FZ0(L) + FRAC(L,N) / (LOG(LB / Z0_T(L,N)))**2 SPARM1A.125
ENDDO SPARM1A.126
ENDDO SPARM1A.127
SPARM1A.128
DO N=1,NTYPE-1 SPARM1A.129
DO J=1,TILE_PTS(N) SPARM1A.130
L = TILE_INDEX(J,N) SPARM1A.131
CATCH(L) = CATCH(L) + FRAC(L,N) * CATCH_T(L,N) SPARM1A.132
ENDDO SPARM1A.133
ENDDO SPARM1A.134
SPARM1A.135
!---------------------------------------------------------------------- SPARM1A.136
! Calculate the effective roughness length SPARM1A.137
!---------------------------------------------------------------------- SPARM1A.138
DO L=LAND1,LAND1+LAND_PTS-1 SPARM1A.139
Z0(L) = LB * EXP(-SQRT(1. / FZ0(L))) SPARM1A.140
ENDDO SPARM1A.141
SPARM1A.142
RETURN SPARM1A.143
END SPARM1A.144
*ENDIF SPARM1A.145