C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.24051 
C                                                                                  RAD_ALL.24052 
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.24053 
C restrictions as set forth in the contract.                                       RAD_ALL.24054 
C                                                                                  RAD_ALL.24055 
C                Meteorological Office                                             RAD_ALL.24056 
C                London Road                                                       RAD_ALL.24057 
C                BRACKNELL                                                         RAD_ALL.24058 
C                Berkshire UK                                                      RAD_ALL.24059 
C                RG12 2SZ                                                          RAD_ALL.24060 
C                                                                                  RAD_ALL.24061 
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.24062 
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.24063 
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.24064 
C Modelling at the above address.                                                  RAD_ALL.24065 
C ******************************COPYRIGHT******************************            RAD_ALL.24066 
C                                                                                  RAD_ALL.24067 
!+ Subroutine to set the properties of the surface.                                RAD_ALL.24068 
!                                                                                  RAD_ALL.24069 
! Method:                                                                          RAD_ALL.24070 
!       The albedo of the surface and the infra-red source                         RAD_ALL.24071 
!       function are set according to the parametrization in use.                  RAD_ALL.24072 
!                                                                                  RAD_ALL.24073 
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.24074 
!                                                                                  RAD_ALL.24075 
! History:                                                                         RAD_ALL.24076 
!       Version         Date                    Comment                            RAD_ALL.24077 
!       4.0             27-07-95                Original Code                      RAD_ALL.24078 
!                                               (J. M. Edwards)                    RAD_ALL.24079 
!                                                                                  RAD_ALL.24080 
! Description of Code:                                                             RAD_ALL.24081 
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.24082 
!                                                                                  RAD_ALL.24083 
!- ---------------------------------------------------------------------           RAD_ALL.24084 
      SUBROUTINE SET_SURFACE_PROPERTIES(N_POINT_TYPE, INDEX_SURFACE                RAD_ALL.24085 
     &   , I_SPEC_SURFACE                                                          RAD_ALL.24086 
     &   , ISOLIR, IB                                                              RAD_ALL.24087 
     &   , SURFACE_ALBEDO, ALBEDO_FIELD_DIFF, ALBEDO_FIELD_DIR                     RAD_ALL.24088 
     &   , N_DIR_ALBEDO_FIT, DIRECT_ALBEDO_PARM, SEC_0                             RAD_ALL.24089 
     &   , EMISSIVITY_GROUND, EMISSIVITY_FIELD                                     RAD_ALL.24090 
     &   , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR                                 RAD_ALL.24091 
     &   , THERMAL_GROUND_BAND                                                     RAD_ALL.24092 
     &   , NPD_PROFILE, NPD_BAND, NPD_SURFACE, NPD_ALBEDO_PARM                     RAD_ALL.24093 
     &   )                                                                         RAD_ALL.24094 
!                                                                                  RAD_ALL.24095 
!                                                                                  RAD_ALL.24096 
      IMPLICIT NONE                                                                RAD_ALL.24097 
!                                                                                  RAD_ALL.24098 
!                                                                                  RAD_ALL.24099 
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.24100 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.24101 
     &     NPD_PROFILE                                                             RAD_ALL.24102 
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.24103 
     &   , NPD_SURFACE                                                             RAD_ALL.24104 
!             MAXIMUM NUMBER OF SURFACES                                           RAD_ALL.24105 
     &   , NPD_BAND                                                                RAD_ALL.24106 
!             MAXIMUM NUMBER OF BANDS                                              RAD_ALL.24107 
     &   , NPD_ALBEDO_PARM                                                         RAD_ALL.24108 
!             MAXIMUM NUMBER OF ALBEDO PARAMETERS                                  RAD_ALL.24109 
!                                                                                  RAD_ALL.24110 
!     COMDECK CALLS                                                                RAD_ALL.24111 
!     ------------------------------------------------------------------           SRFSP3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SRFSP3A.3     
!                                                                                  SRFSP3A.4     
!     MODULE TO SET PERMITTED METHODS OF SPECIFYING THE                            SRFSP3A.5     
!     SURFACE ALBEDO AND EMISSIVITY.                                               SRFSP3A.6     
!                                                                                  SRFSP3A.7     
      INTEGER                                                                      SRFSP3A.8     
     &     IP_SURFACE_SPECIFIED                                                    SRFSP3A.9     
!             PROPERTIES SPECIFIED BY SURFACE TYPE                                 SRFSP3A.10    
     &   , IP_SURFACE_INTERNAL                                                     SRFSP3A.11    
!             PROPERTIES PASSED INTO CODE                                          SRFSP3A.12    
     &   , IP_SURFACE_POLYNOMIAL                                                   SRFSP3A.13    
!             DIRECT ALBEDO FITTED AS POLYNOMIAL                                   SRFSP3A.14    
     &   , IP_SURFACE_PAYNE                                                        SRFSP3A.15    
!             FIT IN THE FUNCTIONAL FORM USED BY PAYNE                             SRFSP3A.16    
!                                                                                  SRFSP3A.17    
      PARAMETER(                                                                   SRFSP3A.18    
     &     IP_SURFACE_SPECIFIED=1                                                  SRFSP3A.19    
     &   , IP_SURFACE_INTERNAL=2                                                   SRFSP3A.20    
     &   , IP_SURFACE_POLYNOMIAL=3                                                 SRFSP3A.21    
     &   , IP_SURFACE_PAYNE=4                                                      SRFSP3A.22    
     &   )                                                                         SRFSP3A.23    
!                                                                                  SRFSP3A.24    
!     ------------------------------------------------------------------           SRFSP3A.25    
!     ------------------------------------------------------------------           SPCRG3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SPCRG3A.3     
!                                                                                  SPCRG3A.4     
!     MODULE TO SET FLAGS FOR DIFFERENT PORTIONS                                   SPCRG3A.5     
!     OF THE SPECTRUM.                                                             SPCRG3A.6     
!                                                                                  SPCRG3A.7     
      INTEGER                                                                      SPCRG3A.8     
     &     IP_SOLAR                                                                SPCRG3A.9     
!             SOLAR REGION                                                         SPCRG3A.10    
     &   , IP_INFRA_RED                                                            SPCRG3A.11    
!             INFRA-RED REGION                                                     SPCRG3A.12    
!                                                                                  SPCRG3A.13    
      PARAMETER(                                                                   SPCRG3A.14    
     &     IP_SOLAR=1                                                              SPCRG3A.15    
     &   , IP_INFRA_RED=2                                                          SPCRG3A.16    
     &   )                                                                         SPCRG3A.17    
!                                                                                  SPCRG3A.18    
!     ------------------------------------------------------------------           SPCRG3A.19    
!                                                                                  RAD_ALL.24114 
!     DUMMY ARGUMENTS.                                                             RAD_ALL.24115 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.24116 
     &     N_POINT_TYPE(NPD_SURFACE)                                               RAD_ALL.24117 
!             NUMBER OF POINTS OF EEACH TYPE                                       RAD_ALL.24118 
     &   , INDEX_SURFACE(NPD_PROFILE, NPD_SURFACE)                                 RAD_ALL.24119 
!             LIST OF POINTS OF EACH TYPE                                          RAD_ALL.24120 
     &   , I_SPEC_SURFACE(NPD_SURFACE)                                             RAD_ALL.24121 
!             METHOD OF SPECIFYING SURFACES                                        RAD_ALL.24122 
     &   , ISOLIR                                                                  RAD_ALL.24123 
!             SPECTRAL REGION                                                      RAD_ALL.24124 
     &   , IB                                                                      RAD_ALL.24125 
!             NUMBER OF BAND                                                       RAD_ALL.24126 
     &   , N_DIR_ALBEDO_FIT(NPD_SURFACE)                                           RAD_ALL.24127 
!             NUMBER OF PARAMETERS IN FIT TO DIRECT ALBEDO                         RAD_ALL.24128 
      REAL      !, INTENT(IN)                                                      RAD_ALL.24129 
     &     SURFACE_ALBEDO(NPD_BAND, NPD_SURFACE)                                   RAD_ALL.24130 
!             BAND-DEPENDENT SURFACE ALBEDOS                                       RAD_ALL.24131 
     &   , ALBEDO_FIELD_DIFF(NPD_PROFILE)                                          RAD_ALL.24132 
!             SPECIFIED DIFFUSE ALBEDO FIELD                                       RAD_ALL.24133 
     &   , ALBEDO_FIELD_DIR(NPD_PROFILE)                                           RAD_ALL.24134 
!             SPECIFIED DIRECT ALBEDO FIELD                                        RAD_ALL.24135 
     &   , DIRECT_ALBEDO_PARM(0: NPD_ALBEDO_PARM, NPD_BAND, NPD_SURFACE)           RAD_ALL.24136 
!             COEFFICIENTS FOR DIRECT ALBEDOS                                      RAD_ALL.24137 
     &   , SEC_0(NPD_PROFILE)                                                      RAD_ALL.24138 
!             SECANTS OF ZENITH ANGLES                                             RAD_ALL.24139 
     &   , EMISSIVITY_GROUND(NPD_BAND, NPD_SURFACE)                                RAD_ALL.24140 
!             BAND-DEPENDENT EMISSIVITIES                                          RAD_ALL.24141 
     &   , EMISSIVITY_FIELD(NPD_PROFILE)                                           RAD_ALL.24142 
!             SPECIFIED EMISSIVITIES                                               RAD_ALL.24143 
      REAL      !, INTENT(INOUT)                                                   RAD_ALL.24144 
     &     THERMAL_GROUND_BAND(NPD_PROFILE)                                        RAD_ALL.24145 
!             THERMAL SOURCE FROM GROUND                                           RAD_ALL.24146 
      REAL      !, INTENT(OUT)                                                     RAD_ALL.24147 
     &     ALBEDO_SURFACE_DIFF(NPD_PROFILE)                                        RAD_ALL.24148 
!             DIFFUSE SURFACE ALBEDOS                                              RAD_ALL.24149 
     &   , ALBEDO_SURFACE_DIR(NPD_PROFILE)                                         RAD_ALL.24150 
!             DIRECT SURFACE ALBEDOS                                               RAD_ALL.24151 
                                                                                   RAD_ALL.24152 
!                                                                                  RAD_ALL.24153 
!     LOCAL VARIABLES.                                                             RAD_ALL.24154 
      INTEGER                                                                      RAD_ALL.24155 
     &     J                                                                       RAD_ALL.24156 
!             LOOP VARIABLE                                                        RAD_ALL.24157 
     &   , K                                                                       RAD_ALL.24158 
!             LOOP VARIABLE                                                        RAD_ALL.24159 
     &   , L                                                                       RAD_ALL.24160 
!             LOOP VARIABLE                                                        RAD_ALL.24161 
     &   , IC                                                                      RAD_ALL.24162 
!             LOOP VARIABLE                                                        RAD_ALL.24163 
!                                                                                  RAD_ALL.24164 
!                                                                                  RAD_ALL.24165 
!     SET THE SURFACE ALBEDOS.                                                     RAD_ALL.24166 
      DO K=1, NPD_SURFACE                                                          RAD_ALL.24167 
!                                                                                  RAD_ALL.24168 
         IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_SPECIFIED) THEN                       RAD_ALL.24169 
            DO J=1, N_POINT_TYPE(K)                                                RAD_ALL.24170 
               L=INDEX_SURFACE(J, K)                                               RAD_ALL.24171 
               ALBEDO_SURFACE_DIFF(L)                                              RAD_ALL.24172 
     &            =SURFACE_ALBEDO(IB, K)                                           RAD_ALL.24173 
               ALBEDO_SURFACE_DIR(L)                                               RAD_ALL.24174 
     &            =SURFACE_ALBEDO(IB, K)                                           RAD_ALL.24175 
            ENDDO                                                                  RAD_ALL.24176 
         ENDIF                                                                     RAD_ALL.24177 
!                                                                                  RAD_ALL.24178 
         IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_INTERNAL) THEN                        RAD_ALL.24179 
            DO J=1, N_POINT_TYPE(K)                                                RAD_ALL.24180 
               L=INDEX_SURFACE(J, K)                                               RAD_ALL.24181 
               ALBEDO_SURFACE_DIFF(L)=ALBEDO_FIELD_DIFF(L)                         RAD_ALL.24182 
               ALBEDO_SURFACE_DIR(L)=ALBEDO_FIELD_DIR(L)                           RAD_ALL.24183 
            ENDDO                                                                  RAD_ALL.24184 
         ENDIF                                                                     RAD_ALL.24185 
!                                                                                  RAD_ALL.24186 
         IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_POLYNOMIAL) THEN                      RAD_ALL.24187 
            DO J=1, N_POINT_TYPE(K)                                                RAD_ALL.24188 
               L=INDEX_SURFACE(J, K)                                               RAD_ALL.24189 
               ALBEDO_SURFACE_DIFF(L)                                              RAD_ALL.24190 
     &            =SURFACE_ALBEDO(IB, K)                                           RAD_ALL.24191 
               ALBEDO_SURFACE_DIR(L)                                               RAD_ALL.24192 
     &            =DIRECT_ALBEDO_PARM(N_DIR_ALBEDO_FIT(K), IB, K)                  RAD_ALL.24193 
            ENDDO                                                                  RAD_ALL.24194 
            DO IC=N_DIR_ALBEDO_FIT(K), 1, -1                                       RAD_ALL.24195 
               DO J=1, N_POINT_TYPE(K)                                             RAD_ALL.24196 
                  L=INDEX_SURFACE(J, K)                                            RAD_ALL.24197 
                  ALBEDO_SURFACE_DIR(L)                                            RAD_ALL.24198 
     &               =ALBEDO_SURFACE_DIR(L)/SEC_0(L)                               RAD_ALL.24199 
     &               +DIRECT_ALBEDO_PARM(IC-1, IB, K)                              RAD_ALL.24200 
               ENDDO                                                               RAD_ALL.24201 
            ENDDO                                                                  RAD_ALL.24202 
         ENDIF                                                                     RAD_ALL.24203 
!                                                                                  RAD_ALL.24204 
         IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_PAYNE) THEN                           RAD_ALL.24205 
            DO J=1, N_POINT_TYPE(K)                                                RAD_ALL.24206 
               L=INDEX_SURFACE(J, K)                                               RAD_ALL.24207 
               ALBEDO_SURFACE_DIFF(L)=0.06E+00                                     RAD_ALL.24208 
               ALBEDO_SURFACE_DIR(L)=DIRECT_ALBEDO_PARM(1, IB, K)                  RAD_ALL.24209 
     &           /(DIRECT_ALBEDO_PARM(2, IB, K)                                    RAD_ALL.24210 
     &           +DIRECT_ALBEDO_PARM(3, IB, K)                                     RAD_ALL.24211 
     &           *EXP(-DIRECT_ALBEDO_PARM(4, IB, K)*LOG(SEC_0(L))))                RAD_ALL.24212 
            ENDDO                                                                  RAD_ALL.24213 
         ENDIF                                                                     RAD_ALL.24214 
      ENDDO                                                                        RAD_ALL.24215 
!                                                                                  RAD_ALL.24216 
!     SET THE EMISSIVITY AND MULTIPLY THE SOURCE FUNCTION                          RAD_ALL.24217 
!     IN THE INFRA-RED.                                                            RAD_ALL.24218 
      IF (ISOLIR.EQ.IP_INFRA_RED) THEN                                             RAD_ALL.24219 
         DO K=1, NPD_SURFACE                                                       RAD_ALL.24220 
!                                                                                  RAD_ALL.24221 
            IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_SPECIFIED) THEN                    RAD_ALL.24222 
               DO J=1, N_POINT_TYPE(K)                                             RAD_ALL.24223 
                  L=INDEX_SURFACE(J, K)                                            RAD_ALL.24224 
                  THERMAL_GROUND_BAND(L)=EMISSIVITY_GROUND(IB, K)                  RAD_ALL.24225 
     &               *THERMAL_GROUND_BAND(L)                                       RAD_ALL.24226 
               ENDDO                                                               RAD_ALL.24227 
            ENDIF                                                                  RAD_ALL.24228 
!                                                                                  RAD_ALL.24229 
            IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_INTERNAL) THEN                     RAD_ALL.24230 
               DO J=1, N_POINT_TYPE(K)                                             RAD_ALL.24231 
                  L=INDEX_SURFACE(J, K)                                            RAD_ALL.24232 
                  THERMAL_GROUND_BAND(L)=EMISSIVITY_FIELD(L)                       RAD_ALL.24233 
     &               *THERMAL_GROUND_BAND(L)                                       RAD_ALL.24234 
               ENDDO                                                               RAD_ALL.24235 
            ENDIF                                                                  RAD_ALL.24236 
!                                                                                  RAD_ALL.24237 
            IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_POLYNOMIAL) THEN                   RAD_ALL.24238 
               DO J=1, N_POINT_TYPE(K)                                             RAD_ALL.24239 
                  L=INDEX_SURFACE(J, K)                                            RAD_ALL.24240 
                  THERMAL_GROUND_BAND(L)=EMISSIVITY_GROUND(IB, K)                  RAD_ALL.24241 
     &               *THERMAL_GROUND_BAND(L)                                       RAD_ALL.24242 
               ENDDO                                                               RAD_ALL.24243 
            ENDIF                                                                  RAD_ALL.24244 
!                                                                                  RAD_ALL.24245 
            IF (I_SPEC_SURFACE(K).EQ.IP_SURFACE_PAYNE) THEN                        RAD_ALL.24246 
               DO J=1, N_POINT_TYPE(K)                                             RAD_ALL.24247 
                  L=INDEX_SURFACE(J, K)                                            RAD_ALL.24248 
!                 SINCE THE EMISSIVITY IS 1.0 CONTINUE.                            RAD_ALL.24249 
                  CONTINUE                                                         RAD_ALL.24250 
               ENDDO                                                               RAD_ALL.24251 
            ENDIF                                                                  RAD_ALL.24252 
!                                                                                  RAD_ALL.24253 
         ENDDO                                                                     RAD_ALL.24254 
      ENDIF                                                                        RAD_ALL.24255 
!                                                                                  RAD_ALL.24256 
!                                                                                  RAD_ALL.24257 
      RETURN                                                                       RAD_ALL.24258 
      END      
