FV3 Bundle
CRTM_SfcOptics.f90
Go to the documentation of this file.
1 !
2 ! CRTM_SfcOptics
3 !
4 ! Module to compute the surface optical properties required for
5 ! determining the surface contribution to the radiative transfer.
6 !
7 !
8 ! CREATION HISTORY:
9 ! Written by: Yong Han, NOAA/NESDIS; Yong.Han@noaa.gov
10 ! Quanhua Liu, QSS Group, Inc; Quanhua.Liu@noaa.gov
11 ! Paul van Delst, CIMSS/SSEC; paul.vandelst@ssec.wisc.edu
12 ! 02-Apr-2004
13 !
14 
15 MODULE crtm_sfcoptics
16 
17  ! ------------------
18  ! Environment set up
19  ! ------------------
20  ! Module use statements
21  USE type_kinds, ONLY: fp
22  USE message_handler, ONLY: success, failure, display_message
23  USE crtm_parameters, ONLY: zero, point_5, one, degrees_to_radians, max_n_stokes
24  USE crtm_spccoeff, ONLY: sc, &
25  spccoeff_ismicrowavesensor , &
26  spccoeff_isinfraredsensor , &
27  spccoeff_isvisiblesensor , &
28  spccoeff_isultravioletsensor, &
29  unpolarized, &
30  intensity, &
31  first_stokes_component, &
32  second_stokes_component, &
33  third_stokes_component, &
34  fourth_stokes_component, &
35  vl_polarization, &
36  hl_polarization, &
37  plus45l_polarization, &
38  minus45l_polarization, &
39  vl_mixed_polarization, &
40  hl_mixed_polarization, &
41  rc_polarization, &
42  lc_polarization
43  USE crtm_surface_define, ONLY: crtm_surface_type
44  USE crtm_geometryinfo_define, ONLY: crtm_geometryinfo_type
45  USE crtm_sfcoptics_define, ONLY: crtm_sfcoptics_type , &
46  OPERATOR(==) , &
47  crtm_sfcoptics_associated, &
48  crtm_sfcoptics_destroy , &
49  crtm_sfcoptics_create
50  USE crtm_mw_land_sfcoptics, ONLY: mwlsovar_type => ivar_type, &
51  compute_mw_land_sfcoptics, &
52  compute_mw_land_sfcoptics_tl, &
53  compute_mw_land_sfcoptics_ad
54  USE crtm_mw_water_sfcoptics, ONLY: mwwsovar_type => ivar_type , &
55  compute_mw_water_sfcoptics , &
56  compute_mw_water_sfcoptics_tl, &
57  compute_mw_water_sfcoptics_ad
58  USE crtm_mw_snow_sfcoptics, ONLY: mwssovar_type => ivar_type, &
59  compute_mw_snow_sfcoptics, &
60  compute_mw_snow_sfcoptics_tl, &
61  compute_mw_snow_sfcoptics_ad
62  USE crtm_mw_ice_sfcoptics, ONLY: mwisovar_type => ivar_type, &
63  compute_mw_ice_sfcoptics, &
64  compute_mw_ice_sfcoptics_tl, &
65  compute_mw_ice_sfcoptics_ad
66  USE crtm_ir_land_sfcoptics, ONLY: irlsovar_type => ivar_type, &
67  compute_ir_land_sfcoptics, &
68  compute_ir_land_sfcoptics_tl, &
69  compute_ir_land_sfcoptics_ad
70  USE crtm_ir_water_sfcoptics, ONLY: irwsovar_type => ivar_type, &
71  compute_ir_water_sfcoptics, &
72  compute_ir_water_sfcoptics_tl, &
73  compute_ir_water_sfcoptics_ad
74  USE crtm_ir_snow_sfcoptics, ONLY: irssovar_type => ivar_type, &
75  compute_ir_snow_sfcoptics, &
76  compute_ir_snow_sfcoptics_tl, &
77  compute_ir_snow_sfcoptics_ad
78  USE crtm_ir_ice_sfcoptics, ONLY: irisovar_type => ivar_type, &
79  compute_ir_ice_sfcoptics, &
80  compute_ir_ice_sfcoptics_tl, &
81  compute_ir_ice_sfcoptics_ad
82  USE crtm_vis_land_sfcoptics, ONLY: vislsovar_type => ivar_type, &
83  compute_vis_land_sfcoptics, &
84  compute_vis_land_sfcoptics_tl, &
85  compute_vis_land_sfcoptics_ad
86  USE crtm_vis_water_sfcoptics, ONLY: viswsovar_type => ivar_type, &
87  compute_vis_water_sfcoptics, &
88  compute_vis_water_sfcoptics_tl, &
89  compute_vis_water_sfcoptics_ad
90  USE crtm_vis_snow_sfcoptics, ONLY: visssovar_type => ivar_type, &
91  compute_vis_snow_sfcoptics, &
92  compute_vis_snow_sfcoptics_tl, &
93  compute_vis_snow_sfcoptics_ad
94  USE crtm_vis_ice_sfcoptics, ONLY: visisovar_type => ivar_type, &
95  compute_vis_ice_sfcoptics, &
96  compute_vis_ice_sfcoptics_tl, &
97  compute_vis_ice_sfcoptics_ad
98  ! Disable implicit typing
99  IMPLICIT NONE
100 
101 
102  ! ------------
103  ! Visibilities
104  ! ------------
105  ! Everything private by default
106  PRIVATE
107  ! Data types
108  PUBLIC :: ivar_type
109  ! Procedures
110  PUBLIC :: crtm_compute_surfacet
111  PUBLIC :: crtm_compute_surfacet_tl
112  PUBLIC :: crtm_compute_surfacet_ad
113  PUBLIC :: crtm_compute_sfcoptics
114  PUBLIC :: crtm_compute_sfcoptics_tl
115  PUBLIC :: crtm_compute_sfcoptics_ad
116 
117 
118  ! -----------------
119  ! Module parameters
120  ! -----------------
121  CHARACTER(*), PARAMETER :: module_version_id = &
122  '$Id: CRTM_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
123  ! Message length
124  INTEGER, PARAMETER :: ml = 256
125 
126 
127  ! --------------------------------------
128  ! Structure definition to hold forward
129  ! variables across FWD, TL, and AD calls
130  ! --------------------------------------
131  TYPE :: ivar_type
132  PRIVATE
133  ! Microwave
134  TYPE(mwlsovar_type) :: mwlsov ! Land
135  TYPE(mwwsovar_type) :: mwwsov ! Water
136  TYPE(mwssovar_type) :: mwssov ! Snow
137  TYPE(mwisovar_type) :: mwisov ! Ice
138  ! Infrared
139  TYPE(irlsovar_type) :: irlsov ! Land
140  TYPE(irwsovar_type) :: irwsov ! Water
141  TYPE(irssovar_type) :: irssov ! Snow
142  TYPE(irisovar_type) :: irisov ! Ice
143  ! Visible
144  TYPE(vislsovar_type) :: vislsov ! Land
145  TYPE(viswsovar_type) :: viswsov ! Water
146  TYPE(visssovar_type) :: visssov ! Snow
147  TYPE(visisovar_type) :: visisov ! Ice
148  END TYPE ivar_type
149 
150 
151 CONTAINS
152 
153 
154 !--------------------------------------------------------------------------------
155 !
156 ! NAME:
157 ! CRTM_Compute_SurfaceT
158 !
159 ! PURPOSE:
160 ! Subroutine to compute the average of the various surface type
161 ! temperatures weighted by their coverage fraction.
162 !
163 ! CALLING SEQUENCE:
164 ! CALL CRTM_Compute_SurfaceT( Surface, & ! Input
165 ! SfcOptics ) ! Output
166 !
167 ! INPUTS:
168 ! Surface: CRTM_Surface structure containing the surface state
169 ! data.
170 ! UNITS: N/A
171 ! TYPE: CRTM_Surface_type
172 ! DIMENSION: Scalar
173 ! ATTRIBUTES: INTENT(IN)
174 !
175 ! OUTPUTS:
176 ! SfcOptics: CRTM_SfcOptics structure containing the surface
177 ! temperature required for the radiative
178 ! transfer calculation.
179 ! UNITS: N/A
180 ! TYPE: CRTM_SfcOptics_type
181 ! DIMENSION: Scalar
182 ! ATTRIBUTES: INTENT(IN OUT)
183 !
184 ! COMMENTS:
185 ! Note the INTENT on the output SfcOptics argument is IN OUT rather
186 ! than just OUT. This is necessary because the argument may be defined
187 ! upon input. To prevent memory leaks, the IN OUT INTENT is a must.
188 !
189 !
190 !--------------------------------------------------------------------------------
191 
192  SUBROUTINE crtm_compute_surfacet( Surface, & ! Input
193  SfcOptics ) ! Output
194  ! Arguments
195  TYPE(crtm_surface_type), INTENT(IN) :: surface
196  TYPE(crtm_sfcoptics_type), INTENT(IN OUT) :: sfcoptics
197 
198  ! The weighted average surface temperature
199  sfcoptics%Surface_Temperature = &
200  ( surface%Land_Coverage * surface%Land_Temperature ) + &
201  ( surface%Water_Coverage * surface%Water_Temperature ) + &
202  ( surface%Snow_Coverage * surface%Snow_Temperature ) + &
203  ( surface%Ice_Coverage * surface%Ice_Temperature )
204 
205  END SUBROUTINE crtm_compute_surfacet
206 
207 
208 !----------------------------------------------------------------------------------
209 !
210 ! NAME:
211 ! CRTM_Compute_SurfaceT_TL
212 !
213 ! PURPOSE:
214 ! Subroutine to compute the tangent-linear average of the various
215 ! surface type temperatures weighted by their coverage fraction.
216 !
217 ! CALLING SEQUENCE:
218 ! CALL CRTM_Compute_SurfaceT_TL( Surface, & ! Input
219 ! Surface_TL, & ! Input
220 ! SfcOptics_TL ) ! In/Output
221 !
222 ! INPUTS:
223 ! Surface: CRTM_Surface structure containing the surface state
224 ! data.
225 ! UNITS: N/A
226 ! TYPE: CRTM_Surface_type
227 ! DIMENSION: Scalar
228 ! ATTRIBUTES: INTENT(IN)
229 !
230 ! Surface_TL: CRTM_Surface structure containing the tangent-linerar
231 ! surface state data.
232 ! UNITS: N/A
233 ! TYPE: CRTM_Surface_type
234 ! DIMENSION: Scalar
235 ! ATTRIBUTES: INTENT(IN)
236 !
237 ! OUTPUTS:
238 ! SfcOptics_TL: CRTM_SfcOptics structure containing the tangent-linear
239 ! surface temperature required for the radiative
240 ! transfer calculation.
241 ! UNITS: N/A
242 ! TYPE: CRTM_SfcOptics_type
243 ! DIMENSION: Scalar
244 ! ATTRIBUTES: INTENT(IN OUT)
245 !
246 !
247 ! COMMENTS:
248 ! Note the INTENT on the output SfcOptics argument is IN OUT rather
249 ! than just OUT. This is necessary because the argument may be defined
250 ! upon input. To prevent memory leaks, the IN OUT INTENT is a must.
251 !
252 !----------------------------------------------------------------------------------
253 
254  SUBROUTINE crtm_compute_surfacet_tl( Surface, & ! Input
255  Surface_TL, & ! Input
256  SfcOptics_TL ) ! Output
257  ! Arguments
258  TYPE(crtm_surface_type), INTENT(IN) :: surface
259  TYPE(crtm_surface_type), INTENT(IN) :: surface_tl
260  TYPE(crtm_sfcoptics_type), INTENT(IN OUT) :: sfcoptics_tl
261 
262  ! The weighted average tangent-linear surface temperature
263  sfcoptics_tl%Surface_Temperature = &
264  ( surface%Land_Coverage * surface_tl%Land_Temperature ) + &
265  ( surface%Water_Coverage * surface_tl%Water_Temperature ) + &
266  ( surface%Snow_Coverage * surface_tl%Snow_Temperature ) + &
267  ( surface%Ice_Coverage * surface_tl%Ice_Temperature )
268 
269  END SUBROUTINE crtm_compute_surfacet_tl
270 
271 
272 !----------------------------------------------------------------------------------
273 !
274 ! NAME:
275 ! CRTM_Compute_SurfaceT_AD
276 !
277 ! PURPOSE:
278 ! Subroutine to compute the adjoint of the average of the various
279 ! surface type temperatures weighted by their coverage fraction.
280 !
281 ! CALLING SEQUENCE:
282 ! CALL CRTM_Compute_SurfaceT_AD( Surface, & ! Input
283 ! SfcOptics_AD, & ! Input
284 ! Surface_AD ) ! Output
285 !
286 ! INPUTS:
287 ! Surface: CRTM_Surface structure containing the surface state
288 ! data.
289 ! UNITS: N/A
290 ! TYPE: CRTM_Surface_type
291 ! DIMENSION: Scalar
292 ! ATTRIBUTES: INTENT(IN)
293 !
294 ! SfcOptics_AD: CRTM_SfcOptics structure containing the adjoint
295 ! surface temperature required for the radiative
296 ! transfer calculation.
297 ! UNITS: N/A
298 ! TYPE: CRTM_SfcOptics_type
299 ! DIMENSION: Scalar
300 ! ATTRIBUTES: INTENT(IN OUT)
301 !
302 ! OUTPUTS:
303 ! Surface_AD: CRTM_Surface structure containing the adjoint surface state
304 ! data.
305 ! UNITS: N/A
306 ! TYPE: CRTM_Surface_type
307 ! DIMENSION: Scalar
308 ! ATTRIBUTES: INTENT(IN OUT)
309 !
310 ! SIDE EFFECTS:
311 ! Even though the SfcOptics_AD argument is listed as an INPUT, its
312 ! INTENT is ( IN OUT ) as it is modified on output since the
313 ! Surface_Temperature component is set to zero after the adjoint
314 ! calculation.
315 !
316 ! Even though the Surface_AD argument is listed as an OUTPUT, its
317 ! INTENT is ( IN OUT ) as the components of the adjoint calculation
318 ! in this routine may already have a value from a previous adjoint
319 ! calculation performed on the structure.
320 !
321 ! COMMENTS:
322 ! In addition to the input/output requirements described in the SIDE
323 ! EFFECTS section, the SfcOptics_AD and Surface_AD arguments require
324 ! an INTENT of IN OUT to prevent memory leaks.
325 !
326 !----------------------------------------------------------------------------------
327 
328  SUBROUTINE crtm_compute_surfacet_ad( Surface, & ! Input
329  SfcOptics_AD, & ! Input
330  Surface_AD ) ! Output
331  ! Arguments
332  TYPE(crtm_surface_type), INTENT(IN) :: surface
333  TYPE(crtm_sfcoptics_type), INTENT(IN OUT) :: sfcoptics_ad
334  TYPE(crtm_surface_type), INTENT(IN OUT) :: surface_ad
335 
336  ! The adjoint of the weighted average surface temperature
337  surface_ad%Land_Temperature = surface_ad%Land_Temperature + &
338  (surface%Land_Coverage *sfcoptics_ad%Surface_Temperature)
339  surface_ad%Water_Temperature = surface_ad%Water_Temperature + &
340  (surface%Water_Coverage*sfcoptics_ad%Surface_Temperature)
341  surface_ad%Snow_Temperature = surface_ad%Snow_Temperature + &
342  (surface%Snow_Coverage *sfcoptics_ad%Surface_Temperature)
343  surface_ad%Ice_Temperature = surface_ad%Ice_Temperature + &
344  (surface%Ice_Coverage *sfcoptics_ad%Surface_Temperature)
345  sfcoptics_ad%Surface_Temperature = zero
346 
347  END SUBROUTINE crtm_compute_surfacet_ad
348 
349 
350 !----------------------------------------------------------------------------------
351 !:sdoc+:
352 !
353 ! NAME:
354 ! CRTM_Compute_SfcOptics
355 !
356 ! PURPOSE:
357 ! Function to compute the surface optical properties and populate
358 ! the output SfcOptics structure for a single channel.
359 !
360 ! CALLING SEQUENCE:
361 ! Error_Status = CRTM_Compute_SfcOptics( &
362 ! Surface , & ! Input
363 ! GeometryInfo, & ! Input
364 ! SensorIndex , & ! Input
365 ! ChannelIndex, & ! Input
366 ! SfcOptics , & ! Output
367 ! iVar ) ! Internal variable output
368 !
369 ! INPUTS:
370 ! Surface: CRTM_Surface structure containing the surface state
371 ! data.
372 ! UNITS: N/A
373 ! TYPE: CRTM_Surface_type
374 ! DIMENSION: Scalar
375 ! ATTRIBUTES: INTENT(IN)
376 !
377 ! GeometryInfo: CRTM_GeometryInfo structure containing the
378 ! view geometry information.
379 ! UNITS: N/A
380 ! TYPE: CRTM_GeometryInfo_type
381 ! DIMENSION: Scalar
382 ! ATTRIBUTES: INTENT(IN)
383 !
384 ! SensorIndex: Sensor index id. This is a unique index associated
385 ! with a (supported) sensor used to access the
386 ! shared coefficient data for a particular sensor.
387 ! See the ChannelIndex argument.
388 ! UNITS: N/A
389 ! TYPE: INTEGER
390 ! DIMENSION: Scalar
391 ! ATTRIBUTES: INTENT(IN)
392 !
393 ! ChannelIndex: Channel index id. This is a unique index associated
394 ! with a (supported) sensor channel used to access the
395 ! shared coefficient data for a particular sensor's
396 ! channel.
397 ! See the SensorIndex argument.
398 ! UNITS: N/A
399 ! TYPE: INTEGER
400 ! DIMENSION: Scalar
401 ! ATTRIBUTES: INTENT(IN)
402 !
403 ! OUTPUTS:
404 ! SfcOptics: CRTM_SfcOptics structure containing the surface
405 ! optical properties required for the radiative
406 ! transfer calculation.
407 ! On Input: The Secant_Angle component is assumed to
408 ! contain data.
409 ! On Output: The Emissivity and Reflectivity components
410 ! will contain the required data.
411 ! UNITS: N/A
412 ! TYPE: CRTM_SfcOptics_type
413 ! DIMENSION: Scalar
414 ! ATTRIBUTES: INTENT(IN OUT)
415 !
416 ! iVar: Structure containing internal variables required for
417 ! subsequent tangent-linear or adjoint model calls.
418 ! The contents of this structure are NOT accessible
419 ! outside of the CRTM_SfcOptics module.
420 ! UNITS: N/A
421 ! TYPE: iVar_type
422 ! DIMENSION: Scalar
423 ! ATTRIBUTES: INTENT(IN OUT)
424 !
425 ! FUNCTION RESULT:
426 ! Error_Status: The return value is an integer defining the error status.
427 ! The error codes are defined in the ERROR_HANDLER module.
428 ! If == SUCCESS the computation was sucessful
429 ! == FAILURE an unrecoverable error occurred
430 ! UNITS: N/A
431 ! TYPE: INTEGER
432 ! DIMENSION: Scalar
433 !
434 ! COMMENTS:
435 ! Note the INTENT on the output SfcOptics argument is IN OUT rather
436 ! than just OUT. This is necessary because the argument should be defined
437 ! upon input. To prevent memory leaks, the IN OUT INTENT is a must.
438 !
439 !:sdoc-:
440 !----------------------------------------------------------------------------------
441 
442  FUNCTION crtm_compute_sfcoptics( &
443  Surface , & ! Input
444  GeometryInfo, & ! Input
445  SensorIndex , & ! Input
446  ChannelIndex, & ! Input
447  SfcOptics , & ! Output
448  iVar ) & ! Internal variable output
449  result( error_status )
450  ! Arguments
451  TYPE(crtm_surface_type) , INTENT(IN) :: surface
452  TYPE(crtm_geometryinfo_type), INTENT(IN) :: geometryinfo
453  INTEGER , INTENT(IN) :: sensorindex
454  INTEGER , INTENT(IN) :: channelindex
455  TYPE(crtm_sfcoptics_type) , INTENT(IN OUT) :: sfcoptics
456  TYPE(ivar_type) , INTENT(OUT) :: ivar
457  ! Function result
458  INTEGER :: error_status
459  ! Local parameters
460  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_SfcOptics'
461  ! Local variables
462  CHARACTER(ML) :: message
463  INTEGER :: i
464  INTEGER :: nl, nz
465  REAL(fp) :: sin2_angle
466  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: emissivity
467  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES, & SfcOptics%n_Angles,MAX_N_STOKES) :: reflectivity
468  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: direct_reflectivity
469  INTEGER :: polarization
470 
471 
472  ! ------
473  ! Set up
474  ! ------
475  error_status = success
476  nl = sfcoptics%n_Stokes
477  nz = sfcoptics%n_Angles
478  polarization = sc(sensorindex)%Polarization(channelindex)
479  ! Initialise the local emissivity and reflectivities
480  emissivity = zero
481  reflectivity = zero
482  direct_reflectivity = zero
483 
484 
485  !##########################################################################
486  !##########################################################################
487  !## ##
488  !## ## MICROWAVE CALCULATIONS ## ##
489  !## ##
490  !##########################################################################
491  !##########################################################################
492 
493  sensor_select: IF ( spccoeff_ismicrowavesensor( sc(sensorindex) ) ) THEN
494 
495  ! --------------------------------------
496  ! Microwave LAND emissivity/reflectivity
497  ! --------------------------------------
498  microwave_land: IF( surface%Land_Coverage > zero) THEN
499 
500  ! Compute the surface optics
501  error_status = compute_mw_land_sfcoptics( &
502  surface , & ! Input
503  sensorindex , & ! Input
504  channelindex, & ! Input
505  sfcoptics ) ! In/Output
506  IF ( error_status /= success ) THEN
507  WRITE( message,'("Error computing MW land SfcOptics at ",&
508  &"channel index ",i0)' ) channelindex
509  CALL display_message( routine_name, message, error_status )
510  RETURN
511  END IF
512 
513  ! Accumulate the surface optics properties
514  ! based on land coverage fraction
515  emissivity(1:nz,1:2) = sfcoptics%Emissivity(1:nz,1:2) * surface%Land_Coverage
516  reflectivity(1:nz,1:2,1:nz,1:2) = sfcoptics%Reflectivity(1:nz,1:2,1:nz,1:2) * surface%Land_Coverage
517 
518  END IF microwave_land
519 
520 
521  ! ---------------------------------------
522  ! Microwave WATER emissivity/reflectivity
523  ! ---------------------------------------
524  microwave_water: IF( surface%Water_Coverage > zero ) THEN
525 
526  ! Compute the surface optics
527  error_status = compute_mw_water_sfcoptics( &
528  surface , & ! Input
529  geometryinfo, & ! Input
530  sensorindex , & ! Input
531  channelindex, & ! Input
532  sfcoptics , & ! In/Output
533  ivar%MWWSOV ) ! Internal variable output
534  IF ( error_status /= success ) THEN
535  WRITE( message,'("Error computing MW water SfcOptics at ",&
536  &"channel index ",i0)' ) channelindex
537  CALL display_message( routine_name, message, error_status )
538  RETURN
539  END IF
540 
541 
542  ! Accumulate the surface optics properties
543  ! based on water coverage fraction
544  emissivity(1:nz,1:2) = emissivity(1:nz,1:2) + &
545  (sfcoptics%Emissivity(1:nz,1:2)*surface%Water_Coverage)
546  reflectivity(1:nz,1:2,1:nz,1:2) = reflectivity(1:nz,1:2,1:nz,1:2) + &
547  (sfcoptics%Reflectivity(1:nz,1:2,1:nz,1:2)*surface%Water_Coverage)
548 
549  END IF microwave_water
550 
551 
552  ! --------------------------------------
553  ! Microwave SNOW emissivity/reflectivity
554  ! --------------------------------------
555  microwave_snow: IF( surface%Snow_Coverage > zero ) THEN
556 
557  ! Compute the surface optics
558  error_status = compute_mw_snow_sfcoptics( &
559  surface , & ! Input
560  geometryinfo, & ! Input
561  sensorindex , & ! Input
562  channelindex, & ! Input
563  sfcoptics ) ! In/Output
564  IF ( error_status /= success ) THEN
565  WRITE( message,'("Error computing MW snow SfcOptics at ",&
566  &"channel index ",i0)' ) channelindex
567  CALL display_message( routine_name, message, error_status )
568  RETURN
569  END IF
570 
571  ! Accumulate the surface optics properties
572  ! based on snow coverage fraction
573  emissivity(1:nz,1:2) = emissivity(1:nz,1:2) + &
574  (sfcoptics%Emissivity(1:nz,1:2)*surface%Snow_Coverage)
575  reflectivity(1:nz,1:2,1:nz,1:2) = reflectivity(1:nz,1:2,1:nz,1:2) + &
576  (sfcoptics%Reflectivity(1:nz,1:2,1:nz,1:2)*surface%Snow_Coverage)
577 
578  END IF microwave_snow
579 
580 
581  ! -------------------------------------
582  ! Microwave ICE emissivity/reflectivity
583  ! -------------------------------------
584  microwave_ice: IF( surface%Ice_Coverage > zero ) THEN
585 
586  ! Compute the surface optics
587  error_status = compute_mw_ice_sfcoptics( &
588  surface , & ! Input
589  geometryinfo, & ! Input
590  sensorindex , & ! Input
591  channelindex, & ! Input
592  sfcoptics ) ! In/Output
593  IF ( error_status /= success ) THEN
594  WRITE( message,'("Error computing MW ice SfcOptics at ",&
595  &"channel index ",i0)' ) channelindex
596  CALL display_message( routine_name, message, error_status )
597  RETURN
598  END IF
599 
600  ! Accumulate the surface optics properties
601  ! based on snow coverage fraction
602  emissivity(1:nz,1:2) = emissivity(1:nz,1:2) + &
603  (sfcoptics%Emissivity(1:nz,1:2)*surface%Ice_Coverage)
604  reflectivity(1:nz,1:2,1:nz,1:2) = reflectivity(1:nz,1:2,1:nz,1:2) + &
605  (sfcoptics%Reflectivity(1:nz,1:2,1:nz,1:2)*surface%Ice_Coverage)
606 
607  END IF microwave_ice
608 
609 
610 
611  !#----------------------------------------------------------------------#
612  !# -- HANDLE THE DECOUPLED POLARISATION -- #
613  !# #
614  !# The SfcOptics n_Stokes dimension determines whether the surface #
615  !# optics takes into account the second order effect of cross #
616  !# polarisation, e.g. if the surface optics for a purely vertically #
617  !# polarised channel has a horizontal (or other) component due to #
618  !# scattering at the surface. #
619  !# #
620  !# If the SfcOptics n_Stokes dimension == 1, the polarisations are #
621  !# decoupled. #
622  !#----------------------------------------------------------------------#
623 
624  decoupled_polarization: IF( sfcoptics%n_Stokes == 1 ) THEN
625 
626 
627  ! ------------------------------------------------------
628  ! Decoupled polarisation. Branch on channel polarisation
629  ! ------------------------------------------------------
630  polarization_type: SELECT CASE( polarization )
631 
632  ! The unpolarised case, I
633  ! e = (eV + eH)/2
634  ! r = (rV + rH)/2
635  ! Note: INTENSITY == UNPOLARIZED == FIRST_STOKES_COMPONENT
636  CASE( intensity )
637  sfcoptics%Emissivity(1:nz,1) = &
638  point_5 * ( emissivity(1:nz,1) + emissivity(1:nz,2) )
639  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = &
640  point_5 * ( reflectivity(1:nz,1,1:nz,1) + reflectivity(1:nz,2,1:nz,2) )
641 
642  ! The second Stokes component, Q, the polarisation difference.
643  ! e = (eV - eH)/2
644  ! r = (rV - rH)/2
645  CASE( second_stokes_component )
646  sfcoptics%Emissivity(1:nz,1) = &
647  point_5 * ( emissivity(1:nz,1) - emissivity(1:nz,2) )
648  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = &
649  point_5 * ( reflectivity(1:nz,1,1:nz,1) - reflectivity(1:nz,2,1:nz,2) )
650 
651  ! The third Stokes component, U.
652  CASE ( third_stokes_component )
653  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,3)
654  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,3,1:nz,3)
655 
656  ! The fourth Stokes component, V.
657  CASE ( fourth_stokes_component )
658  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,4)
659  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,4,1:nz,4)
660 
661  ! Vertical linear polarisation
662  CASE ( vl_polarization )
663  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
664  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
665 
666  ! Horizontal linear polarisation
667  CASE ( hl_polarization )
668  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,2)
669  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,2,1:nz,2)
670 
671  ! +45deg. linear polarisation
672  CASE ( plus45l_polarization )
673 
674  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
675  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
676 
677  ! -45deg. linear polarisation
678  CASE ( minus45l_polarization )
679  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
680  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
681 
682  ! Vertical, mixed polarisation. This category of polarisation is
683  ! for those microwave channels where the nadir polarisation is
684  ! vertical, but the instrument scans cross-track.
685  ! e = eV * (1-SIN^2(z)) + eH * SIN^2(z)
686  ! r = rV * (1-SIN^2(z)) + rH * SIN^2(z)
687  CASE ( vl_mixed_polarization )
688  DO i = 1, nz
689  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
690  sfcoptics%Emissivity(i,1) = (emissivity(i,1)*(one-sin2_angle)) + &
691  (emissivity(i,2)*sin2_angle)
692  sfcoptics%Reflectivity(i,1,i,1) = (reflectivity(i,1,i,1)*(one-sin2_angle)) + &
693  (reflectivity(i,2,i,2)*sin2_angle)
694  END DO
695 
696  ! Horizontal, mixed polarisation. This category of polarisation is
697  ! for those microwave channels where the nadir polarisation is
698  ! horizontal, but the instrument scans cross-track.
699  ! e = eV * SIN^2(z) + eH * (1-SIN^2(z))
700  ! r = rV * SIN^2(z) + rH * (1-SIN^2(z))
701  CASE ( hl_mixed_polarization )
702  DO i = 1, nz
703  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
704  sfcoptics%Emissivity(i,1) = (emissivity(i,1)*sin2_angle) + &
705  (emissivity(i,2)*(one-sin2_angle))
706  sfcoptics%Reflectivity(i,1,i,1) = (reflectivity(i,1,i,1)*sin2_angle) + &
707  (reflectivity(i,2,i,2)*(one-sin2_angle))
708  END DO
709 
710  ! Right circular polarisation
711  CASE ( rc_polarization )
712  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
713  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
714 
715  ! Left circular polarisation
716  CASE ( lc_polarization )
717  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
718  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
719 
720  ! Serious problem if we got to this points
721  CASE DEFAULT
722  error_status = failure
723  WRITE( message,'("Unrecognised polarization flag for microwave ",&
724  &"channel index ",i0)' ) channelindex
725  CALL display_message( routine_name, message, error_status )
726  RETURN
727 
728  END SELECT polarization_type
729 
730  ELSE
731 
732 
733  ! ------------------------------------
734  ! Coupled polarization from atmosphere
735  ! considered. Simply copy the data
736  ! ------------------------------------
737  sfcoptics%Emissivity(1:nz,1:nl) = emissivity(1:nz,1:nl)
738  sfcoptics%Reflectivity(1:nz,1:nl,1:nz,1:nl) = reflectivity(1:nz,1:nl,1:nz,1:nl)
739 
740  END IF decoupled_polarization
741 
742 
743 
744  !##########################################################################
745  !##########################################################################
746  !## ##
747  !## ## INFRARED CALCULATIONS ## ##
748  !## ##
749  !##########################################################################
750  !##########################################################################
751 
752  ELSE IF ( spccoeff_isinfraredsensor( sc(sensorindex) ) ) THEN
753 
754  ! -------------------------------------
755  ! Infrared LAND emissivity/reflectivity
756  ! -------------------------------------
757  infrared_land: IF( surface%Land_Coverage > zero ) THEN
758 
759  ! Compute the surface optics
760  error_status = compute_ir_land_sfcoptics( &
761  surface , & ! Input
762  sensorindex , & ! Input
763  channelindex, & ! Input
764  sfcoptics , & ! In/Output
765  ivar%IRLSOV ) ! Internal variable output
766  IF ( error_status /= success ) THEN
767  WRITE( message,'("Error computing IR land SfcOptics at ",&
768  &"channel index ",i0)' ) channelindex
769  CALL display_message( routine_name, message, error_status )
770  RETURN
771  END IF
772 
773  ! Accumulate the surface optics properties
774  ! based on land coverage fraction
775  emissivity(1:nz,1) = sfcoptics%Emissivity(1:nz,1) * surface%Land_Coverage
776  reflectivity(1:nz,1,1:nz,1) = sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Land_Coverage
777  direct_reflectivity(1:nz,1) = sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Land_Coverage
778  END IF infrared_land
779 
780 
781  ! --------------------------------------
782  ! Infrared WATER emissivity/reflectivity
783  ! --------------------------------------
784  infrared_water: IF( surface%Water_Coverage > zero ) THEN
785 
786  ! Compute the surface optics
787  error_status = compute_ir_water_sfcoptics( &
788  surface , & ! Input
789  geometryinfo, & ! Input
790  sensorindex , & ! Input
791  channelindex, & ! Input
792  sfcoptics , & ! In/Output
793  ivar%IRWSOV ) ! Internal variable output
794  IF ( error_status /= success ) THEN
795  WRITE( message,'("Error computing IR water SfcOptics at ",&
796  &"channel index ",i0)' ) channelindex
797  CALL display_message( routine_name, message, error_status )
798  RETURN
799  END IF
800 
801  ! Accumulate the surface optics properties
802  ! based on water coverage fraction
803  emissivity(1:nz,1) = emissivity(1:nz,1) + &
804  ( sfcoptics%Emissivity(1:nz,1) * surface%Water_Coverage )
805  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
806  ( sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Water_Coverage )
807  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
808  ( sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Water_Coverage )
809 
810  END IF infrared_water
811 
812 
813  ! -------------------------------------
814  ! Infrared SNOW emissivity/reflectivity
815  ! -------------------------------------
816  infrared_snow: IF( surface%Snow_Coverage > zero ) THEN
817 
818  ! Compute the surface optics
819  error_status = compute_ir_snow_sfcoptics( &
820  surface , & ! Input
821  sensorindex , & ! Input
822  channelindex, & ! Input
823  sfcoptics , & ! In/Output
824  ivar%IRSSOV ) ! Internal variable output
825  IF ( error_status /= success ) THEN
826  WRITE( message,'("Error computing IR snow SfcOptics at ",&
827  &"channel index ",i0)' ) channelindex
828  CALL display_message( routine_name, message, error_status )
829  RETURN
830  END IF
831 
832  ! Accumulate the surface optics properties
833  ! based on snow coverage fraction
834  emissivity(1:nz,1) = emissivity(1:nz,1) + &
835  (sfcoptics%Emissivity(1:nz,1)*surface%Snow_Coverage)
836  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
837  (sfcoptics%Reflectivity(1:nz,1,1:nz,1)*surface%Snow_Coverage)
838  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
839  ( sfcoptics%Direct_Reflectivity(1:nz,1)*surface%Snow_Coverage)
840 
841  ENDIF infrared_snow
842 
843 
844  ! ------------------------------------
845  ! Infrared ICE emissivity/reflectivity
846  ! ------------------------------------
847  infrared_ice: IF( surface%Ice_Coverage > zero ) THEN
848 
849  ! Compute the surface optics
850  error_status = compute_ir_ice_sfcoptics( &
851  surface , & ! Input
852  sensorindex , & ! Input
853  channelindex, & ! Input
854  sfcoptics , & ! In/Output
855  ivar%IRISOV ) ! Internal variable output
856  IF ( error_status /= success ) THEN
857  WRITE( message,'("Error computing IR ice SfcOptics at ",&
858  &"channel index ",i0)' ) channelindex
859  CALL display_message( routine_name, message, error_status )
860  RETURN
861  END IF
862 
863  ! Accumulate the surface optics properties
864  ! based on Ice coverage fraction
865  emissivity(1:nz,1) = emissivity(1:nz,1) + &
866  (sfcoptics%Emissivity(1:nz,1) * surface%Ice_Coverage)
867  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
868  (sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Ice_Coverage)
869  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
870  ( sfcoptics%Direct_Reflectivity(1:nz,1)*surface%Ice_Coverage)
871 
872  END IF infrared_ice
873 
874 
875  ! -----------------------
876  ! Assign the final result
877  ! -----------------------
878  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
879  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
880  sfcoptics%Direct_Reflectivity(1:nz,1) = direct_reflectivity(1:nz,1)
881 
882 
883  !##########################################################################
884  !##########################################################################
885  !## ##
886  !## ## VISIBLE CALCULATIONS ## ##
887  !## Visible part shares using the IR code, in which visible ##
888  !## lambertian emissivity/reflectivity can be computed for visible ##
889  !## wavenumber. ##
890  !##########################################################################
891  !##########################################################################
892 
893  ELSE IF ( spccoeff_isvisiblesensor( sc(sensorindex) ) ) THEN
894 
895  mth_azi_test: IF( sfcoptics%mth_Azi == 0 ) THEN
896 
897  ! ==================
898  ! Lambertian surface
899  ! ==================
900 
901  ! -------------------------------------
902  ! Visible LAND emissivity/reflectivity
903  ! -------------------------------------
904  visible_land: IF( surface%Land_Coverage > zero ) THEN
905 
906  ! Compute the surface optics
907  error_status = compute_vis_land_sfcoptics( &
908  surface , & ! Input
909  sensorindex , & ! Input
910  channelindex, & ! Input
911  sfcoptics , & ! In/Output
912  ivar%VISLSOV ) ! Internal variable output
913  IF ( error_status /= success ) THEN
914  WRITE( message,'("Error computing VIS land SfcOptics at ", &
915  &"channel index ",i0)' ) channelindex
916  CALL display_message( routine_name, message, error_status )
917  RETURN
918  END IF
919 
920  ! Accumulate the surface optics properties
921  ! based on land coverage fraction
922  emissivity(1:nz,1) = sfcoptics%Emissivity(1:nz,1) * surface%Land_Coverage
923  reflectivity(1:nz,1,1:nz,1) = sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Land_Coverage
924  direct_reflectivity(1:nz,1) = sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Land_Coverage
925 
926  END IF visible_land
927 
928 
929  ! -------------------------------------
930  ! Visible WATER emissivity/reflectivity
931  ! -------------------------------------
932  visible_water: IF( surface%Water_Coverage > zero ) THEN
933 
934  ! Compute the surface optics
935  error_status = compute_vis_water_sfcoptics( &
936  surface , & ! Input
937  sensorindex , & ! Input
938  channelindex, & ! Input
939  sfcoptics , & ! In/Output
940  ivar%VISWSOV ) ! Internal variable output
941  IF ( error_status /= success ) THEN
942  WRITE( message,'("Error computing VIS water SfcOptics at ",&
943  &"channel index ",i0)' ) channelindex
944  CALL display_message( routine_name, message, error_status )
945  RETURN
946  END IF
947 
948  ! Accumulate the surface optics properties
949  ! based on water coverage fraction
950  emissivity(1:nz,1) = emissivity(1:nz,1) + &
951  ( sfcoptics%Emissivity(1:nz,1) * surface%Water_Coverage )
952  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
953  ( sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Water_Coverage )
954  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
955  ( sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Water_Coverage )
956 
957  END IF visible_water
958 
959 
960  ! ------------------------------------
961  ! Visible SNOW emissivity/reflectivity
962  ! ------------------------------------
963  visible_snow: IF( surface%Snow_Coverage > zero ) THEN
964 
965  ! Compute the surface optics
966  error_status = compute_vis_snow_sfcoptics( &
967  surface , & ! Input
968  sensorindex , & ! Input
969  channelindex, & ! Input
970  sfcoptics , & ! In/Output
971  ivar%VISSSOV ) ! Internal variable output
972  IF ( error_status /= success ) THEN
973  WRITE( message,'("Error computing VIS snow SfcOptics at ",&
974  &"channel index ",i0)' ) channelindex
975  CALL display_message( routine_name, message, error_status )
976  RETURN
977  END IF
978 
979  ! Accumulate the surface optics properties
980  ! based on snow coverage fraction
981  emissivity(1:nz,1) = emissivity(1:nz,1) + &
982  (sfcoptics%Emissivity(1:nz,1)*surface%Snow_Coverage)
983  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
984  (sfcoptics%Reflectivity(1:nz,1,1:nz,1)*surface%Snow_Coverage)
985  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
986  ( sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Snow_Coverage )
987 
988  ENDIF visible_snow
989 
990 
991  ! -----------------------------------
992  ! Visible ICE emissivity/reflectivity
993  ! -----------------------------------
994  visible_ice: IF( surface%Ice_Coverage > zero ) THEN
995 
996  ! Compute the surface optics
997  error_status = compute_vis_ice_sfcoptics( &
998  surface , & ! Input
999  sensorindex , & ! Input
1000  channelindex, & ! Input
1001  sfcoptics , & ! In/Output
1002  ivar%VISISOV ) ! Internal variable output
1003  IF ( error_status /= success ) THEN
1004  WRITE( message,'("Error computing VIS ice SfcOptics at ",&
1005  &"channel index ",i0)' ) channelindex
1006  CALL display_message( routine_name, message, error_status )
1007  RETURN
1008  END IF
1009 
1010  ! Accumulate the surface optics properties
1011  ! based on Ice coverage fraction
1012  emissivity(1:nz,1) = emissivity(1:nz,1) + &
1013  (sfcoptics%Emissivity(1:nz,1) * surface%Ice_Coverage)
1014  reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1) + &
1015  (sfcoptics%Reflectivity(1:nz,1,1:nz,1) * surface%Ice_Coverage)
1016  direct_reflectivity(1:nz,1) = direct_reflectivity(1:nz,1) + &
1017  ( sfcoptics%Direct_Reflectivity(1:nz,1) * surface%Ice_Coverage )
1018 
1019  END IF visible_ice
1020 
1021 
1022  ! -----------------------
1023  ! Assign the final result
1024  ! -----------------------
1025  sfcoptics%Emissivity(1:nz,1) = emissivity(1:nz,1)
1026  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = reflectivity(1:nz,1,1:nz,1)
1027  sfcoptics%Direct_Reflectivity(1:nz,1) = direct_reflectivity(1:nz,1)
1028 
1029  ELSE
1030 
1031  sfcoptics%Emissivity(1:nz,1) = zero
1032  sfcoptics%Reflectivity(1:nz,1,1:nz,1) = zero
1033  sfcoptics%Direct_Reflectivity = zero
1034 
1035  END IF mth_azi_test
1036 
1037 
1038 
1039  !##########################################################################
1040  !##########################################################################
1041  !## ##
1042  !## ## INVALID SENSOR TYPE ## ##
1043  !## ##
1044  !##########################################################################
1045  !##########################################################################
1046 
1047  ELSE sensor_select
1048 
1049  error_status = failure
1050  WRITE( message,'("Unrecognised sensor type for channel index ",i0)' ) &
1051  channelindex
1052  CALL display_message( routine_name, message, error_status )
1053  RETURN
1054 
1055  END IF sensor_select
1056 
1057  END FUNCTION crtm_compute_sfcoptics
1058 
1059 
1060 !----------------------------------------------------------------------------------
1061 !:sdoc+:
1062 !
1063 ! NAME:
1064 ! CRTM_Compute_SfcOptics_TL
1065 !
1066 ! PURPOSE:
1067 ! Function to compute the tangent-linear surface optical properties
1068 ! and populate the output SfcOptics_TL structure for a single channel.
1069 !
1070 ! CALLING SEQUENCE:
1071 ! Error_Status = CRTM_Compute_SfcOptics_TL( &
1072 ! Surface , & ! Input
1073 ! SfcOptics , & ! Input
1074 ! Surface_TL , & ! Input
1075 ! GeometryInfo, & ! Input
1076 ! SensorIndex , & ! Input
1077 ! ChannelIndex, & ! Input
1078 ! SfcOptics_TL, & ! In/Output
1079 ! iVar ) ! Internal variable input
1080 !
1081 ! INPUTS:
1082 ! Surface: CRTM_Surface structure containing the surface state
1083 ! data.
1084 ! UNITS: N/A
1085 ! TYPE: CRTM_Surface_type
1086 ! DIMENSION: Scalar
1087 ! ATTRIBUTES: INTENT(IN)
1088 !
1089 ! SfcOptics: CRTM_SfcOptics structure containing the surface
1090 ! optical properties required for the radiative
1091 ! transfer calculation.
1092 ! UNITS: N/A
1093 ! TYPE: CRTM_SfcOptics_type
1094 ! DIMENSION: Scalar
1095 ! ATTRIBUTES: INTENT(IN)
1096 !
1097 ! Surface_TL: CRTM_Surface structure containing the tangent-linear
1098 ! surface state data.
1099 ! UNITS: N/A
1100 ! TYPE: CRTM_Surface_type
1101 ! DIMENSION: Scalar
1102 ! ATTRIBUTES: INTENT(IN)
1103 !
1104 ! GeometryInfo: CRTM_GeometryInfo structure containing the
1105 ! view geometry information.
1106 ! UNITS: N/A
1107 ! TYPE: CRTM_GeometryInfo_type
1108 ! DIMENSION: Scalar
1109 ! ATTRIBUTES: INTENT(IN)
1110 !
1111 ! SensorIndex: Sensor index id. This is a unique index associated
1112 ! with a (supported) sensor used to access the
1113 ! shared coefficient data for a particular sensor.
1114 ! See the ChannelIndex argument.
1115 ! UNITS: N/A
1116 ! TYPE: INTEGER
1117 ! DIMENSION: Scalar
1118 ! ATTRIBUTES: INTENT(IN)
1119 !
1120 ! ChannelIndex: Channel index id. This is a unique index associated
1121 ! with a (supported) sensor channel used to access the
1122 ! shared coefficient data for a particular sensor's
1123 ! channel.
1124 ! See the SensorIndex argument.
1125 ! UNITS: N/A
1126 ! TYPE: INTEGER
1127 ! DIMENSION: Scalar
1128 ! ATTRIBUTES: INTENT(IN)
1129 !
1130 ! iVar: Structure containing internal variables required for
1131 ! subsequent tangent-linear or adjoint model calls.
1132 ! The contents of this structure are NOT accessible
1133 ! outside of the CRTM_SfcOptics module.
1134 ! UNITS: N/A
1135 ! TYPE: iVar_type
1136 ! DIMENSION: Scalar
1137 ! ATTRIBUTES: INTENT(IN)
1138 !
1139 ! OUTPUTS:
1140 ! SfcOptics_TL: CRTM_SfcOptics structure containing the tangent-linear
1141 ! surface optical properties required for the radiative
1142 ! transfer calculation.
1143 ! On Input: The Secant_Angle component is assumed to
1144 ! contain data.
1145 ! On Output: The Emissivity and Reflectivity components
1146 ! will contain the required data.
1147 ! UNITS: N/A
1148 ! TYPE: CRTM_SfcOptics_type
1149 ! DIMENSION: Scalar
1150 ! ATTRIBUTES: INTENT(IN OUT)
1151 !
1152 ! FUNCTION RESULT:
1153 ! Error_Status: The return value is an integer defining the error status.
1154 ! The error codes are defined in the ERROR_HANDLER module.
1155 ! If == SUCCESS the computation was sucessful
1156 ! == FAILURE an unrecoverable error occurred
1157 ! UNITS: N/A
1158 ! TYPE: INTEGER
1159 ! DIMENSION: Scalar
1160 !
1161 ! COMMENTS:
1162 ! Note the INTENT on the output SfcOptics_TL argument is IN OUT rather
1163 ! than just OUT. This is necessary because the argument should be defined
1164 ! upon input. To prevent memory leaks, the IN OUT INTENT is a must.
1165 !:sdoc-:
1166 !----------------------------------------------------------------------------------
1167 
1168  FUNCTION crtm_compute_sfcoptics_tl( &
1169  Surface , & ! Input
1170  SfcOptics , & ! Input
1171  Surface_TL , & ! Input
1172  GeometryInfo, & ! Input
1173  SensorIndex , & ! Input
1174  ChannelIndex, & ! Input
1175  SfcOptics_TL, & ! Output
1176  iVar ) & ! Internal variable input
1177  result( error_status )
1178  ! Arguments
1179  TYPE(crtm_surface_type) , INTENT(IN) :: surface
1180  TYPE(crtm_sfcoptics_type) , INTENT(IN) :: sfcoptics
1181  TYPE(crtm_surface_type) , INTENT(IN) :: surface_tl
1182  TYPE(crtm_geometryinfo_type), INTENT(IN) :: geometryinfo
1183  INTEGER , INTENT(IN) :: sensorindex
1184  INTEGER , INTENT(IN) :: channelindex
1185  TYPE(crtm_sfcoptics_type) , INTENT(IN OUT) :: sfcoptics_tl
1186  TYPE(ivar_type) , INTENT(IN) :: ivar
1187  ! Function result
1188  INTEGER :: error_status
1189  ! Local parameters
1190  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_SfcOptics_TL'
1191  ! Local variables
1192  CHARACTER(ML) :: message
1193  INTEGER :: i
1194  INTEGER :: nl, nz
1195  INTEGER :: polarization
1196  REAL(fp) :: sin2_angle
1197  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: emissivity_tl
1198  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES, & SfcOptics%n_Angles,MAX_N_STOKES) :: reflectivity_tl
1199  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: direct_reflectivity_tl
1200 
1201  ! ------
1202  ! Set up
1203  ! ------
1204  error_status = success
1205  nl = sfcoptics%n_Stokes
1206  nz = sfcoptics%n_Angles
1207  polarization = sc(sensorindex)%Polarization( channelindex )
1208  ! Initialise the local emissivity and reflectivities
1209  emissivity_tl = zero
1210  reflectivity_tl = zero
1211  direct_reflectivity_tl = zero
1212 
1213 
1214  !##########################################################################
1215  !##########################################################################
1216  !## ##
1217  !## ## MICROWAVE CALCULATIONS ## ##
1218  !## ##
1219  !##########################################################################
1220  !##########################################################################
1221 
1222  sensor_select: IF ( spccoeff_ismicrowavesensor( sc(sensorindex) ) ) THEN
1223 
1224  ! --------------------------------------
1225  ! Microwave LAND emissivity/reflectivity
1226  ! --------------------------------------
1227  microwave_land: IF( surface%Land_Coverage > zero) THEN
1228 
1229  ! Compute the surface optics
1230  error_status = compute_mw_land_sfcoptics_tl( sfcoptics_tl )
1231  IF ( error_status /= success ) THEN
1232  WRITE( message,'("Error computing MW land SfcOptics_TL at ",&
1233  &"channel index ",i0)' ) channelindex
1234  CALL display_message( routine_name, message, error_status )
1235  RETURN
1236  END IF
1237 
1238  ! Accumulate the surface optics properties
1239  ! based on land coverage fraction
1240  emissivity_tl(1:nz,1:2) = &
1241  sfcoptics_tl%Emissivity(1:nz,1:2)*surface%Land_Coverage
1242  reflectivity_tl(1:nz,1:2,1:nz,1:2) = &
1243  sfcoptics_tl%Reflectivity(1:nz,1:2,1:nz,1:2)*surface%Land_Coverage
1244 
1245  END IF microwave_land
1246 
1247 
1248  ! ---------------------------------------
1249  ! Microwave WATER emissivity/reflectivity
1250  ! ---------------------------------------
1251  microwave_water: IF( surface%Water_Coverage > zero ) THEN
1252 
1253  ! Compute the surface optics
1254  error_status = compute_mw_water_sfcoptics_tl( &
1255  sfcoptics , & ! Input
1256  surface_tl , & ! Input
1257  geometryinfo, & ! Input
1258  sensorindex , & ! Input
1259  channelindex, & ! Input
1260  sfcoptics_tl, & ! In/Output
1261  ivar%MWWSOV ) ! Internal variable input
1262  IF ( error_status /= success ) THEN
1263  WRITE( message,'("Error computing MW water SfcOptics_TL at ",&
1264  &"channel index ",i0)' ) channelindex
1265  CALL display_message( routine_name, message, error_status )
1266  RETURN
1267  END IF
1268 
1269  ! Accumulate the surface optics properties
1270  ! based on water coverage fraction
1271  emissivity_tl(1:nz,1:2) = emissivity_tl(1:nz,1:2) + &
1272  ( sfcoptics_tl%Emissivity(1:nz,1:2) * surface%Water_Coverage )
1273  reflectivity_tl(1:nz,1:2,1:nz,1:2) = reflectivity_tl(1:nz,1:2,1:nz,1:2) + &
1274  ( sfcoptics_tl%Reflectivity(1:nz,1:2,1:nz,1:2) * surface%Water_Coverage )
1275 
1276  END IF microwave_water
1277 
1278 
1279  ! --------------------------------------
1280  ! Microwave SNOW emissivity/reflectivity
1281  ! --------------------------------------
1282  microwave_snow: IF( surface%Snow_Coverage > zero ) THEN
1283 
1284  ! Compute the surface optics
1285  error_status = compute_mw_snow_sfcoptics_tl( sfcoptics_tl )
1286  IF ( error_status /= success ) THEN
1287  WRITE( message,'("Error computing MW snow SfcOptics_TL at ",&
1288  &"channel index ",i0)' ) channelindex
1289  CALL display_message( routine_name, message, error_status )
1290  RETURN
1291  END IF
1292 
1293  ! Accumulate the surface optics properties
1294  ! based on snow coverage fraction
1295  emissivity_tl(1:nz,1:2) = emissivity_tl(1:nz,1:2) + &
1296  ( sfcoptics_tl%Emissivity(1:nz,1:2) * surface%Snow_Coverage )
1297  reflectivity_tl(1:nz,1:2,1:nz,1:2) = reflectivity_tl(1:nz,1:2,1:nz,1:2) + &
1298  ( sfcoptics_tl%Reflectivity(1:nz,1:2,1:nz,1:2) * surface%Snow_Coverage )
1299 
1300  ENDIF microwave_snow
1301 
1302 
1303  ! -------------------------------------
1304  ! Microwave ICE emissivity/reflectivity
1305  ! -------------------------------------
1306 
1307  microwave_ice: IF( surface%Ice_Coverage > zero ) THEN
1308 
1309  ! Compute the surface optics
1310  error_status = compute_mw_ice_sfcoptics_tl( sfcoptics_tl )
1311  IF ( error_status /= success ) THEN
1312  WRITE( message,'("Error computing MW ice SfcOptics_TL at ",&
1313  &"channel index ",i0)' ) channelindex
1314  CALL display_message( routine_name, message, error_status )
1315  RETURN
1316  END IF
1317 
1318  ! Accumulate the surface optics properties
1319  ! based on snow coverage fraction
1320  emissivity_tl(1:nz,1:2) = emissivity_tl(1:nz,1:2) + &
1321  ( sfcoptics_tl%Emissivity(1:nz,1:2) * surface%Ice_Coverage )
1322  reflectivity_tl(1:nz,1:2,1:nz,1:2) = reflectivity_tl(1:nz,1:2,1:nz,1:2) + &
1323  ( sfcoptics_tl%Reflectivity(1:nz,1:2,1:nz,1:2) * surface%Ice_Coverage )
1324 
1325  ENDIF microwave_ice
1326 
1327 
1328 
1329  !#----------------------------------------------------------------------#
1330  !# -- HANDLE THE DECOUPLED POLARISATION -- #
1331  !# #
1332  !# The SfcOptics n_Stokes dimension determines whether the surface #
1333  !# optics takes into account the second order effect of cross #
1334  !# polarisation, e.g. if the surface optics for a purely vertically #
1335  !# polarised channel has a horizontal (or other) component due to #
1336  !# scattering at the surface. #
1337  !# #
1338  !# If the SfcOptics n_Stokes dimension == 1, the polarisations are #
1339  !# decoupled. #
1340  !#----------------------------------------------------------------------#
1341 
1342  decoupled_polarization: IF( sfcoptics%n_Stokes == 1 ) THEN
1343 
1344 
1345  ! ------------------------------------------------------
1346  ! Decoupled polarisation. Branch on channel polarisation
1347  ! ------------------------------------------------------
1348  polarization_type: SELECT CASE( polarization )
1349 
1350  ! The unpolarised case, I
1351  ! e = (eV + eH)/2
1352  ! r = (rV + rH)/2
1353  ! Note: INTENSITY == UNPOLARIZED == FIRST_STOKES_COMPONENT
1354  CASE( intensity )
1355  sfcoptics_tl%Emissivity(1:nz,1) = &
1356  point_5 * ( emissivity_tl(1:nz,1) + emissivity_tl(1:nz,2) )
1357  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = &
1358  point_5 * ( reflectivity_tl(1:nz,1,1:nz,1) + reflectivity_tl(1:nz,2,1:nz,2) )
1359 
1360  ! The second Stokes component, Q, the polarisation difference.
1361  ! e = (eV - eH)/2
1362  ! r = (rV - rH)/2
1363  CASE( second_stokes_component )
1364  sfcoptics_tl%Emissivity(1:nz,1) = &
1365  point_5 * ( emissivity_tl(1:nz,1) - emissivity_tl(1:nz,2) )
1366  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = &
1367  point_5 * ( reflectivity_tl(1:nz,1,1:nz,1) - reflectivity_tl(1:nz,2,1:nz,2) )
1368 
1369  ! The third Stokes component, U.
1370  CASE ( third_stokes_component )
1371  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,3)
1372  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,3,1:nz,3)
1373 
1374  ! The fourth Stokes component, V.
1375  CASE ( fourth_stokes_component )
1376  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,4)
1377  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,4,1:nz,4)
1378 
1379  ! Vertical linear polarisation
1380  CASE ( vl_polarization )
1381  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1382  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1383 
1384  ! Horizontal linear polarisation
1385  CASE ( hl_polarization )
1386  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,2)
1387  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(:,2,:,2)
1388 
1389  ! +45deg. linear polarisation
1390  CASE ( plus45l_polarization )
1391  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1392  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1393 
1394  ! -45deg. linear polarisation
1395  CASE ( minus45l_polarization )
1396  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1397  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1398 
1399  ! Vertical, mixed polarisation. This category of polarisation is
1400  ! for those microwave channels where the nadir polarisation is
1401  ! vertical, but the instrument scans cross-track.
1402  ! e = eV * (1-SIN^2(z)) + eH * SIN^2(z)
1403  ! r = rV * (1-SIN^2(z)) + rH * SIN^2(z)
1404  CASE ( vl_mixed_polarization )
1405  DO i = 1, nz
1406  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
1407  sfcoptics_tl%Emissivity(i,1) = (emissivity_tl(i,1)*(one-sin2_angle)) + &
1408  (emissivity_tl(i,2)*sin2_angle)
1409  sfcoptics_tl%Reflectivity(i,1,i,1) = (reflectivity_tl(i,1,i,1)*(one-sin2_angle)) + &
1410  (reflectivity_tl(i,2,i,2)*sin2_angle)
1411  END DO
1412 
1413  ! Horizontal, mixed polarisation. This category of polarisation is
1414  ! for those microwave channels where the nadir polarisation is
1415  ! horizontal, but the instrument scans cross-track.
1416  ! e = eV * SIN^2(z) + eH * (1-SIN^2(z))
1417  ! r = rV * SIN^2(z) + rH * (1-SIN^2(z))
1418  CASE ( hl_mixed_polarization )
1419  DO i = 1, nz
1420  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
1421  sfcoptics_tl%Emissivity(i,1) = (emissivity_tl(i,1)*sin2_angle) + &
1422  (emissivity_tl(i,2)*(one-sin2_angle))
1423  sfcoptics_tl%Reflectivity(i,1,i,1) = (reflectivity_tl(i,1,i,1)*sin2_angle) + &
1424  (reflectivity_tl(i,2,i,2)*(one-sin2_angle))
1425  END DO
1426 
1427  ! Right circular polarisation
1428  CASE ( rc_polarization )
1429  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1430  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1431 
1432  ! Left circular polarisation
1433  CASE ( lc_polarization )
1434  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1435  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1436 
1437  ! Serious problem if we got to this point
1438  CASE DEFAULT
1439  error_status = failure
1440  WRITE( message,'("Unrecognised polarization flag for microwave ",&
1441  &"channel index ",i0)' ) channelindex
1442  CALL display_message( routine_name, message, error_status )
1443  RETURN
1444 
1445  END SELECT polarization_type
1446 
1447 
1448  ELSE
1449 
1450 
1451  ! ------------------------------------
1452  ! Coupled polarization from atmosphere
1453  ! considered. Simply copy the data
1454  ! ------------------------------------
1455  sfcoptics_tl%Emissivity = emissivity_tl(1:nz,1:nl)
1456  sfcoptics_tl%Reflectivity = reflectivity_tl(1:nz,1:nl,1:nz,1:nl)
1457 
1458  END IF decoupled_polarization
1459 
1460 
1461 
1462  !##########################################################################
1463  !##########################################################################
1464  !## ##
1465  !## ## INFRARED CALCULATIONS ## ##
1466  !## ##
1467  !##########################################################################
1468  !##########################################################################
1469 
1470  ELSE IF ( spccoeff_isinfraredsensor( sc(sensorindex) ) ) THEN
1471 
1472 
1473  ! -------------------------------------
1474  ! Infrared LAND emissivity/reflectivity
1475  ! -------------------------------------
1476  infrared_land: IF( surface%Land_Coverage > zero ) THEN
1477 
1478  ! Compute the surface optics
1479  ! **STUB PROCEDURE**
1480  error_status = compute_ir_land_sfcoptics_tl( sfcoptics_tl )
1481  IF ( error_status /= success ) THEN
1482  WRITE( message,'("Error computing IR land SfcOptics_TL at ",&
1483  &"channel index ",i0)' ) channelindex
1484  CALL display_message( routine_name, message, error_status )
1485  RETURN
1486  END IF
1487 
1488  ! Accumulate the surface optics properties
1489  ! based on land coverage fraction
1490  emissivity_tl(1:nz,1) = &
1491  sfcoptics_tl%Emissivity(1:nz,1) * surface%Land_Coverage
1492  reflectivity_tl(1:nz,1,1:nz,1) = &
1493  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) * surface%Land_Coverage
1494 
1495  END IF infrared_land
1496 
1497 
1498  ! --------------------------------------
1499  ! Infrared WATER emissivity/reflectivity
1500  ! --------------------------------------
1501  infrared_water: IF( surface%Water_Coverage > zero ) THEN
1502 
1503  ! Compute the surface optics
1504  error_status = compute_ir_water_sfcoptics_tl( &
1505  surface , & ! Input
1506  sfcoptics , & ! Input
1507  surface_tl , & ! Input
1508  geometryinfo, & ! Input
1509  sensorindex , & ! Input
1510  channelindex, & ! Input
1511  sfcoptics_tl, & ! In/Output
1512  ivar%IRWSOV ) ! Internal variable input
1513  IF ( error_status /= success ) THEN
1514  WRITE( message,'("Error computing IR water SfcOptics_TL at ",&
1515  &"channel index ",i0)' ) channelindex
1516  CALL display_message( routine_name, message, error_status )
1517  RETURN
1518  END IF
1519 
1520  ! Accumulate the surface optics properties
1521  ! based on water coverage fraction
1522  emissivity_tl(1:nz,1) = emissivity_tl(1:nz,1) + &
1523  ( sfcoptics_tl%Emissivity(1:nz,1) * surface%Water_Coverage )
1524  reflectivity_tl(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1) + &
1525  ( sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) * surface%Water_Coverage )
1526  direct_reflectivity_tl(1:nz,1) = direct_reflectivity_tl(1:nz,1) + &
1527  ( sfcoptics_tl%Direct_Reflectivity(1:nz,1) * surface%Water_Coverage )
1528 
1529  END IF infrared_water
1530 
1531 
1532  ! -------------------------------------
1533  ! Infrared SNOW emissivity/reflectivity
1534  ! -------------------------------------
1535  infrared_snow: IF( surface%Snow_Coverage > zero ) THEN
1536 
1537  ! Compute the surface optics
1538  error_status = compute_ir_snow_sfcoptics_tl( sfcoptics_tl )
1539  IF ( error_status /= success ) THEN
1540  WRITE( message,'("Error computing IR snow SfcOptics_TL at ",&
1541  &"channel index ",i0)' ) channelindex
1542  CALL display_message( routine_name, message, error_status )
1543  RETURN
1544  END IF
1545 
1546  ! Accumulate the surface optics properties
1547  ! based on snow coverage fraction
1548  emissivity_tl(1:nz,1) = emissivity_tl(1:nz,1) + &
1549  ( sfcoptics_tl%Emissivity(1:nz,1) * surface%Snow_Coverage )
1550  reflectivity_tl(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1) + &
1551  ( sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) * surface%Snow_Coverage )
1552  direct_reflectivity_tl(1:nz,1) = direct_reflectivity_tl(1:nz,1) + &
1553  ( sfcoptics_tl%Direct_Reflectivity(1:nz,1) * surface%Snow_Coverage )
1554 
1555  END IF infrared_snow
1556 
1557 
1558  ! ------------------------------------
1559  ! Infrared ICE emissivity/reflectivity
1560  ! ------------------------------------
1561  infrared_ice: IF( surface%Ice_Coverage > zero ) THEN
1562 
1563  ! Compute the surface optics
1564  error_status = compute_ir_ice_sfcoptics_tl( sfcoptics_tl )
1565  IF ( error_status /= success ) THEN
1566  WRITE( message,'("Error computing IR ice SfcOptics_TL at ",&
1567  &"channel index ",i0)' ) channelindex
1568  CALL display_message( routine_name, message, error_status )
1569  RETURN
1570  END IF
1571 
1572  ! Accumulate the surface optics properties
1573  ! based on Ice coverage fraction
1574  emissivity_tl(1:nz,1) = emissivity_tl(1:nz,1) + &
1575  ( sfcoptics_tl%Emissivity(1:nz,1) * surface%Ice_Coverage )
1576  reflectivity_tl(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1) + &
1577  ( sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) * surface%Ice_Coverage )
1578  direct_reflectivity_tl(1:nz,1) = direct_reflectivity_tl(1:nz,1) + &
1579  ( sfcoptics_tl%Direct_Reflectivity(1:nz,1) * surface%Ice_Coverage )
1580 
1581  END IF infrared_ice
1582 
1583 
1584  ! -----------------------
1585  ! Assign the final result
1586  ! -----------------------
1587  sfcoptics_tl%Emissivity(1:nz,1) = emissivity_tl(1:nz,1)
1588  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = reflectivity_tl(1:nz,1,1:nz,1)
1589  sfcoptics_tl%Direct_Reflectivity(1:nz,1) = direct_reflectivity_tl(1:nz,1)
1590 
1591 
1592  !##########################################################################
1593  !##########################################################################
1594  !## ##
1595  !## ## VISIBLE CALCULATIONS ## ##
1596  !## ##
1597  !##########################################################################
1598  !##########################################################################
1599 
1600  ELSE IF ( spccoeff_isvisiblesensor( sc(sensorindex) ) ) THEN
1601 
1602 
1603  ! -------------------
1604  ! Default values only
1605  ! -------------------
1606  sfcoptics_tl%Emissivity(1:nz,1) = zero
1607  sfcoptics_tl%Reflectivity(1:nz,1,1:nz,1) = zero
1608  sfcoptics_tl%Direct_Reflectivity = zero
1609 
1610 
1611  !##########################################################################
1612  !##########################################################################
1613  !## ##
1614  !## ## INVALID SENSOR TYPE ## ##
1615  !## ##
1616  !##########################################################################
1617  !##########################################################################
1618 
1619  ELSE sensor_select
1620 
1621  error_status = failure
1622  WRITE( message,'("Unrecognised sensor type for channel index ",i0)' ) &
1623  channelindex
1624  CALL display_message( routine_name, message, error_status )
1625  RETURN
1626 
1627  END IF sensor_select
1628 
1629  END FUNCTION crtm_compute_sfcoptics_tl
1630 
1631 
1632 !----------------------------------------------------------------------------------
1633 !:sdoc+:
1634 !
1635 ! NAME:
1636 ! CRTM_Compute_SfcOptics_AD
1637 !
1638 ! PURPOSE:
1639 ! Function to compute the adjoint surface optical properties
1640 ! for a single channel.
1641 !
1642 ! CALLING SEQUENCE:
1643 ! Error_Status = CRTM_Compute_SfcOptics_AD( &
1644 ! Surface , & ! Input
1645 ! SfcOptics , & ! Input
1646 ! SfcOptics_AD, & ! Input
1647 ! GeometryInfo, & ! Input
1648 ! SensorIndex , & ! Input
1649 ! ChannelIndex, & ! Input
1650 ! Surface_AD , & ! Output
1651 ! iVar ) ! Internal variable input
1652 !
1653 ! INPUTS:
1654 ! Surface: CRTM_Surface structure containing the surface state
1655 ! data.
1656 ! UNITS: N/A
1657 ! TYPE: CRTM_Surface_type
1658 ! DIMENSION: Scalar
1659 ! ATTRIBUTES: INTENT(IN)
1660 !
1661 ! SfcOptics: CRTM_SfcOptics structure containing the surface
1662 ! optical properties required for the radiative
1663 ! transfer calculation.
1664 ! UNITS: N/A
1665 ! TYPE: CRTM_SfcOptics_type
1666 ! DIMENSION: Scalar
1667 ! ATTRIBUTES: INTENT(IN)
1668 !
1669 ! SfcOptics_AD: CRTM_SfcOptics structure containing the adjoint
1670 ! surface optical properties.
1671 ! **NOTE: On EXIT from this function, the contents of
1672 ! this structure may be modified (e.g. set to
1673 ! zero.)
1674 ! UNITS: N/A
1675 ! TYPE: CRTM_SfcOptics_type
1676 ! DIMENSION: Scalar
1677 ! ATTRIBUTES: INTENT(IN OUT)
1678 !
1679 ! GeometryInfo: CRTM_GeometryInfo structure containing the
1680 ! view geometry information.
1681 ! UNITS: N/A
1682 ! TYPE: CRTM_GeometryInfo_type
1683 ! DIMENSION: Scalar
1684 ! ATTRIBUTES: INTENT(IN)
1685 !
1686 ! SensorIndex: Sensor index id. This is a unique index associated
1687 ! with a (supported) sensor used to access the
1688 ! shared coefficient data for a particular sensor.
1689 ! See the ChannelIndex argument.
1690 ! UNITS: N/A
1691 ! TYPE: INTEGER
1692 ! DIMENSION: Scalar
1693 ! ATTRIBUTES: INTENT(IN)
1694 !
1695 ! ChannelIndex: Channel index id. This is a unique index associated
1696 ! with a (supported) sensor channel used to access the
1697 ! shared coefficient data for a particular sensor's
1698 ! channel.
1699 ! See the SensorIndex argument.
1700 ! UNITS: N/A
1701 ! TYPE: INTEGER
1702 ! DIMENSION: Scalar
1703 ! ATTRIBUTES: INTENT(IN)
1704 !
1705 ! iVar: Structure containing internal variables required for
1706 ! subsequent tangent-linear or adjoint model calls.
1707 ! The contents of this structure are NOT accessible
1708 ! outside of the CRTM_SfcOptics module.
1709 ! UNITS: N/A
1710 ! TYPE: iVar_type
1711 ! DIMENSION: Scalar
1712 ! ATTRIBUTES: INTENT(IN)
1713 !
1714 ! OUTPUTS:
1715 ! Surface_AD: CRTM_Surface structure containing the adjoint
1716 ! surface state data.
1717 ! **NOTE: On ENTRY to this function, the contents of
1718 ! this structure should be defined (e.g.
1719 ! initialized to some value based on the
1720 ! position of this function in the call chain.)
1721 ! UNITS: N/A
1722 ! TYPE: CRTM_Surface_type
1723 ! DIMENSION: Scalar
1724 ! ATTRIBUTES: INTENT(IN OUT)
1725 !
1726 ! FUNCTION RESULT:
1727 ! Error_Status: The return value is an integer defining the error status.
1728 ! The error codes are defined in the ERROR_HANDLER module.
1729 ! If == SUCCESS the computation was sucessful
1730 ! == FAILURE an unrecoverable error occurred
1731 ! UNITS: N/A
1732 ! TYPE: INTEGER
1733 ! DIMENSION: Scalar
1734 !
1735 ! COMMENTS:
1736 ! Note the INTENT on all of the adjoint arguments (whether input or output)
1737 ! is IN OUT rather than just OUT. This is necessary because the INPUT
1738 ! adjoint arguments are modified, and the OUTPUT adjoint arguments must
1739 ! be defined prior to entry to this routine. So, anytime a structure is
1740 ! to be output, to prevent memory leaks the IN OUT INTENT is a must.
1741 !:sdoc-:
1742 !----------------------------------------------------------------------------------
1743 
1744  FUNCTION crtm_compute_sfcoptics_ad( &
1745  Surface , & ! Input
1746  SfcOptics , & ! Input
1747  SfcOptics_AD, & ! Input
1748  GeometryInfo, & ! Input
1749  SensorIndex , & ! Input
1750  ChannelIndex, & ! Input
1751  Surface_AD , & ! Output
1752  iVar ) & ! Internal variable input
1753  result( error_status )
1754  ! Arguments
1755  TYPE(crtm_surface_type) , INTENT(IN) :: surface
1756  TYPE(crtm_sfcoptics_type) , INTENT(IN) :: sfcoptics
1757  TYPE(crtm_sfcoptics_type) , INTENT(IN OUT) :: sfcoptics_ad
1758  TYPE(crtm_geometryinfo_type), INTENT(IN) :: geometryinfo
1759  INTEGER , INTENT(IN) :: sensorindex
1760  INTEGER , INTENT(IN) :: channelindex
1761  TYPE(crtm_surface_type) , INTENT(IN OUT) :: surface_ad
1762  TYPE(ivar_type) , INTENT(IN) :: ivar
1763  ! Function result
1764  INTEGER :: error_status
1765  ! Local parameters
1766  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_SfcOptics_AD'
1767  ! Local variables
1768  CHARACTER(256) :: message
1769  INTEGER :: i
1770  INTEGER :: nl, nz
1771  INTEGER :: polarization
1772  REAL(fp) :: sin2_angle
1773  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: emissivity_ad
1774  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES, & SfcOptics%n_Angles,MAX_N_STOKES) :: reflectivity_ad
1775  REAL(fp), DIMENSION(SfcOptics%n_Angles,MAX_N_STOKES) :: direct_reflectivity_ad
1776 
1777  ! ------
1778  ! Set up
1779  ! ------
1780  error_status = success
1781  nl = sfcoptics%n_Stokes
1782  nz = sfcoptics%n_Angles
1783  polarization = sc(sensorindex)%Polarization( channelindex )
1784  ! Initialise the local emissivity and reflectivity adjoints
1785  emissivity_ad = zero
1786  reflectivity_ad = zero
1787  direct_reflectivity_ad = zero
1788 
1789 
1790  !##########################################################################
1791  !##########################################################################
1792  !## ##
1793  !## ## MICROWAVE CALCULATIONS ## ##
1794  !## ##
1795  !##########################################################################
1796  !##########################################################################
1797 
1798  sensor_select: IF ( spccoeff_ismicrowavesensor( sc(sensorindex) ) ) THEN
1799 
1800 
1801  !#----------------------------------------------------------------------#
1802  !# -- HANDLE THE DECOUPLED POLARISATION -- #
1803  !# #
1804  !# The SfcOptics n_Stokes dimension determines whether the surface #
1805  !# optics takes into account the second order effect of cross #
1806  !# polarisation, e.g. if the surface optics for a purely vertically #
1807  !# polarised channel has a horizontal (or other) component due to #
1808  !# scattering at the surface. #
1809  !# #
1810  !# If the SfcOptics n_Stokes dimension == 1, the polarisations are #
1811  !# decoupled. #
1812  !#----------------------------------------------------------------------#
1813  decoupled_polarization: IF( sfcoptics%n_Stokes == 1 ) THEN
1814 
1815 
1816  ! ------------------------------------------------------
1817  ! Decoupled polarisation. Branch on channel polarisation
1818  ! ------------------------------------------------------
1819  polarization_type: SELECT CASE( polarization )
1820 
1821  ! The unpolarised case, I
1822  ! e = (eV + eH)/2
1823  ! r = (rV + rH)/2
1824  ! Note: INTENSITY == UNPOLARIZED == FIRST_STOKES_COMPONENT
1825  CASE( intensity )
1826  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1827  emissivity_ad(1:nz,2) = sfcoptics_ad%Emissivity(1:nz,1)
1828  sfcoptics_ad%Emissivity = zero
1829  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1830  reflectivity_ad(1:nz,2,1:nz,2) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1831  sfcoptics_ad%Reflectivity = zero
1832 
1833  ! The second Stokes component, Q, the polarisation difference.
1834  ! e = (eV - eH)/2
1835  ! r = (rV - rH)/2
1836  CASE( second_stokes_component )
1837  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1838  emissivity_ad(1:nz,2) = -sfcoptics_ad%Emissivity(1:nz,1)
1839  sfcoptics_ad%Emissivity = zero
1840  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1841  reflectivity_ad(1:nz,2,1:nz,2) = -sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1842  sfcoptics_ad%Reflectivity = zero
1843 
1844  ! The third Stokes component, U.
1845  CASE ( third_stokes_component )
1846  emissivity_ad(1:nz,3) = sfcoptics_ad%Emissivity(1:nz,1)
1847  sfcoptics_ad%Emissivity = zero
1848  reflectivity_ad(1:nz,3,1:nz,3) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1849  sfcoptics_ad%Reflectivity = zero
1850 
1851  ! The fourth Stokes component, V.
1852  CASE ( fourth_stokes_component )
1853  emissivity_ad(1:nz,4) = sfcoptics_ad%Emissivity(1:nz,1)
1854  sfcoptics_ad%Emissivity = zero
1855  reflectivity_ad(1:nz,4,1:nz,4) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1856  sfcoptics_ad%Reflectivity = zero
1857 
1858  ! Vertical linear polarisation
1859  CASE ( vl_polarization )
1860  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1861  sfcoptics_ad%Emissivity = zero
1862  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1863  sfcoptics_ad%Reflectivity = zero
1864 
1865  ! Horizontal linear polarisation
1866  CASE ( hl_polarization )
1867  emissivity_ad(1:nz,2) = sfcoptics_ad%Emissivity(1:nz,1)
1868  sfcoptics_ad%Emissivity = zero
1869  reflectivity_ad(1:nz,2,1:nz,2) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1870  sfcoptics_ad%Reflectivity = zero
1871 
1872  ! +45deg. linear polarisation
1873  CASE ( plus45l_polarization )
1874  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1875  sfcoptics_ad%Emissivity = zero
1876  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1877  sfcoptics_ad%Reflectivity = zero
1878 
1879  ! -45deg. linear polarisation
1880  CASE ( minus45l_polarization )
1881  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1882  sfcoptics_ad%Emissivity = zero
1883  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1884  sfcoptics_ad%Reflectivity = zero
1885 
1886  ! Vertical, mixed polarisation. This category of polarisation is
1887  ! for those microwave channels where the nadir polarisation is
1888  ! vertical, but the instrument scans cross-track.
1889  ! e = eV * (1-SIN^2(z)) + eH * SIN^2(z)
1890  ! r = rV * (1-SIN^2(z)) + rH * SIN^2(z)
1891  CASE ( vl_mixed_polarization )
1892  DO i = 1, nz
1893  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
1894  emissivity_ad(i,1) = sfcoptics_ad%Emissivity(i,1)*(one-sin2_angle)
1895  emissivity_ad(i,2) = sfcoptics_ad%Emissivity(i,1)*sin2_angle
1896  reflectivity_ad(i,1,i,1) = sfcoptics_ad%Reflectivity(i,1,i,1)*(one-sin2_angle)
1897  reflectivity_ad(i,2,i,2) = sfcoptics_ad%Reflectivity(i,1,i,1)*sin2_angle
1898  END DO
1899  sfcoptics_ad%Emissivity = zero
1900  sfcoptics_ad%Reflectivity = zero
1901 
1902  ! Horizontal, mixed polarisation. This category of polarisation is
1903  ! for those microwave channels where the nadir polarisation is
1904  ! horizontal, but the instrument scans cross-track.
1905  ! e = eV * SIN^2(z) + eH * (1-SIN^2(z))
1906  ! r = rV * SIN^2(z) + rH * (1-SIN^2(z))
1907  CASE ( hl_mixed_polarization )
1908  DO i = 1, nz
1909  sin2_angle = (geometryinfo%Distance_Ratio*sin(degrees_to_radians*sfcoptics%Angle(i)))**2
1910  emissivity_ad(i,1) = sfcoptics_ad%Emissivity(i,1)*sin2_angle
1911  emissivity_ad(i,2) = sfcoptics_ad%Emissivity(i,1)*(one-sin2_angle)
1912  reflectivity_ad(i,1,i,1) = sfcoptics_ad%Reflectivity(i,1,i,1)*sin2_angle
1913  reflectivity_ad(i,2,i,2) = sfcoptics_ad%Reflectivity(i,1,i,1)*(one-sin2_angle)
1914  END DO
1915  sfcoptics_ad%Emissivity = zero
1916  sfcoptics_ad%Reflectivity = zero
1917 
1918  ! Right circular polarisation
1919  CASE ( rc_polarization )
1920  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1921  sfcoptics_ad%Emissivity = zero
1922  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1923  sfcoptics_ad%Reflectivity = zero
1924 
1925  ! Left circular polarisation
1926  CASE ( lc_polarization )
1927  emissivity_ad(1:nz,1) = sfcoptics_ad%Emissivity(1:nz,1)
1928  sfcoptics_ad%Emissivity = zero
1929  reflectivity_ad(1:nz,1,1:nz,1) = sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1)
1930  sfcoptics_ad%Reflectivity = zero
1931 
1932  ! Serious problem if we got to this point
1933  CASE DEFAULT
1934  error_status = failure
1935  WRITE( message,'("Unrecognised polarization flag for microwave ",&
1936  &"channel index ",i0)' ) channelindex
1937  CALL display_message( routine_name, message, error_status )
1938  RETURN
1939 
1940  END SELECT polarization_type
1941 
1942 
1943  ELSE
1944 
1945 
1946  ! ------------------------------------
1947  ! Coupled polarization from atmosphere
1948  ! considered. Simply copy the data
1949  ! ------------------------------------
1950  emissivity_ad(1:nz,1:nl) = sfcoptics_ad%Emissivity(1:nz,1:nl)
1951  sfcoptics_ad%Emissivity = zero
1952  reflectivity_ad(1:nz,1:nl,1:nz,1:nl) = sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl)
1953  sfcoptics_ad%Reflectivity = zero
1954 
1955  END IF decoupled_polarization
1956 
1957 
1958  ! -------------------------------------
1959  ! Microwave ICE emissivity/reflectivity
1960  ! -------------------------------------
1961  microwave_ice: IF( surface%Ice_Coverage > zero ) THEN
1962 
1963  ! The surface optics properties based on ice coverage fraction
1964  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
1965  ! are NOT zeroed here.
1966  sfcoptics_ad%Emissivity(1:nz,1:2) = &
1967  sfcoptics_ad%Emissivity(1:nz,1:2) + &
1968  (emissivity_ad(1:nz,1:2)*surface%Ice_Coverage)
1969  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) = &
1970  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) + &
1971  (reflectivity_ad(1:nz,1:2,1:nz,1:2)*surface%Ice_Coverage)
1972 
1973  ! Compute the surface optics adjoints
1974  error_status = compute_mw_ice_sfcoptics_ad( sfcoptics_ad )
1975  IF ( error_status /= success ) THEN
1976  WRITE( message,'("Error computing MW ice SfcOptics_AD at ",&
1977  &"channel index ",i0)' ) channelindex
1978  CALL display_message( routine_name, message, error_status )
1979  RETURN
1980  END IF
1981  END IF microwave_ice
1982 
1983 
1984  ! --------------------------------------
1985  ! Microwave SNOW emissivity/reflectivity
1986  ! --------------------------------------
1987 
1988  microwave_snow: IF( surface%Snow_Coverage > zero ) THEN
1989 
1990  ! The surface optics properties based on snow coverage fraction
1991  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
1992  ! are NOT zeroed here.
1993  sfcoptics_ad%Emissivity(1:nz,1:2) = &
1994  sfcoptics_ad%Emissivity(1:nz,1:2) + &
1995  (emissivity_ad(1:nz,1:2)*surface%Snow_Coverage)
1996  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) = &
1997  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) + &
1998  (reflectivity_ad(1:nz,1:2,1:nz,1:2)*surface%Snow_Coverage)
1999 
2000  ! Compute the surface optics adjoints
2001  error_status = compute_mw_snow_sfcoptics_ad( sfcoptics_ad )
2002  IF ( error_status /= success ) THEN
2003  WRITE( message,'("Error computing MW snow SfcOptics_AD at ",&
2004  &"channel index ",i0)' ) channelindex
2005  CALL display_message( routine_name, message, error_status )
2006  RETURN
2007  END IF
2008 
2009  END IF microwave_snow
2010 
2011 
2012  ! ---------------------------------------
2013  ! Microwave WATER emissivity/reflectivity
2014  ! ---------------------------------------
2015  microwave_water: IF( surface%Water_Coverage > zero ) THEN
2016 
2017  ! The surface optics properties based on water coverage fraction
2018  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2019  ! are NOT zeroed here.
2020  sfcoptics_ad%Emissivity(1:nz,1:2) = &
2021  sfcoptics_ad%Emissivity(1:nz,1:2) + &
2022  (emissivity_ad(1:nz,1:2)*surface%Water_Coverage)
2023  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) = &
2024  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) + &
2025  (reflectivity_ad(1:nz,1:2,1:nz,1:2)*surface%Water_Coverage)
2026 
2027  ! Compute the surface optics adjoints
2028  error_status = compute_mw_water_sfcoptics_ad( &
2029  sfcoptics , & ! Input
2030  sfcoptics_ad, & ! Input
2031  geometryinfo, & ! Input
2032  sensorindex , & ! Input
2033  channelindex, & ! Input
2034  surface_ad , & ! Output
2035  ivar%MWWSOV ) ! Internal variable input
2036  IF ( error_status /= success ) THEN
2037  WRITE( message,'("Error computing MW water SfcOptics_AD at ",&
2038  &"channel index ",i0)' ) channelindex
2039  CALL display_message( routine_name, message, error_status )
2040  RETURN
2041  END IF
2042 
2043  END IF microwave_water
2044 
2045 
2046  ! --------------------------------------
2047  ! Microwave LAND emissivity/reflectivity
2048  ! --------------------------------------
2049  microwave_land: IF( surface%Land_Coverage > zero ) THEN
2050 
2051  ! The surface optics properties based on land coverage fraction
2052  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2053  ! are NOT zeroed here.
2054  sfcoptics_ad%Emissivity(1:nz,1:2) = &
2055  sfcoptics_ad%Emissivity(1:nz,1:2) + &
2056  (emissivity_ad(1:nz,1:2)*surface%Land_Coverage)
2057  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) = &
2058  sfcoptics_ad%Reflectivity(1:nz,1:2,1:nz,1:2) + &
2059  (reflectivity_ad(1:nz,1:2,1:nz,1:2)*surface%Land_Coverage)
2060 
2061  ! Compute the surface optics adjoints
2062  error_status = compute_mw_land_sfcoptics_ad( sfcoptics_ad )
2063  IF ( error_status /= success ) THEN
2064  WRITE( message,'("Error computing MW land SfcOptics_AD at ",&
2065  &"channel index ",i0)' ) channelindex
2066  CALL display_message( routine_name, message, error_status )
2067  RETURN
2068  END IF
2069 
2070  END IF microwave_land
2071 
2072 
2073 
2074  !##########################################################################
2075  !##########################################################################
2076  !## ##
2077  !## ## INFRARED CALCULATIONS ## ##
2078  !## ##
2079  !##########################################################################
2080  !##########################################################################
2081 
2082  ELSE IF ( spccoeff_isinfraredsensor( sc(sensorindex) ) ) THEN
2083 
2084 
2085  ! ------------------------------------
2086  ! Infrared ICE emissivity/reflectivity
2087  ! ------------------------------------
2088  infrared_ice: IF( surface%Ice_Coverage > zero ) THEN
2089 
2090  ! The surface optics properties based on ice coverage fraction
2091  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2092  ! are NOT zeroed here.
2093  sfcoptics_ad%Emissivity(1:nz,1:nl) = &
2094  sfcoptics_ad%Emissivity(1:nz,1:nl) + &
2095  (emissivity_ad(1:nz,1:nl)*surface%Ice_Coverage)
2096  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) = &
2097  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) + &
2098  (reflectivity_ad(1:nz,1:nl,1:nz,1:nl)*surface%Ice_Coverage)
2099 
2100  ! Compute the surface optics adjoints
2101  error_status = compute_ir_ice_sfcoptics_ad( sfcoptics_ad )
2102  IF ( error_status /= success ) THEN
2103  WRITE( message,'("Error computing IR ice SfcOptics_AD at ",&
2104  &"channel index ",i0)' ) channelindex
2105  CALL display_message( routine_name, message, error_status )
2106  RETURN
2107  END IF
2108 
2109  END IF infrared_ice
2110 
2111 
2112  ! -------------------------------------
2113  ! Infrared SNOW emissivity/reflectivity
2114  ! -------------------------------------
2115  infrared_snow: IF( surface%Snow_Coverage > zero ) THEN
2116 
2117  ! The surface optics properties based on snow coverage fraction
2118  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2119  ! are NOT zeroed here.
2120  sfcoptics_ad%Emissivity(1:nz,1:nl) = &
2121  sfcoptics_ad%Emissivity(1:nz,1:nl) + &
2122  (emissivity_ad(1:nz,1:nl)*surface%Snow_Coverage)
2123  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) = &
2124  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) + &
2125  (reflectivity_ad(1:nz,1:nl,1:nz,1:nl)*surface%Snow_Coverage)
2126 
2127  ! Compute the surface optics adjoints
2128  error_status = compute_ir_snow_sfcoptics_ad( sfcoptics_ad )
2129  IF ( error_status /= success ) THEN
2130  WRITE( message,'("Error computing IR snow SfcOptics_AD at ",&
2131  &"channel index ",i0)' ) channelindex
2132  CALL display_message( routine_name, message, error_status )
2133  RETURN
2134  END IF
2135 
2136  END IF infrared_snow
2137 
2138 
2139  ! --------------------------------------
2140  ! Infrared WATER emissivity/reflectivity
2141  ! --------------------------------------
2142  infrared_water: IF ( surface%Water_Coverage > zero ) THEN
2143 
2144  ! The surface optics properties based on water coverage fraction
2145  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2146  ! are NOT zeroed here.
2147  sfcoptics_ad%Emissivity(1:nz,1:nl) = &
2148  sfcoptics_ad%Emissivity(1:nz,1:nl) + &
2149  (emissivity_ad(1:nz,1:nl)*surface%Water_Coverage)
2150  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) = &
2151  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) + &
2152  (reflectivity_ad(1:nz,1:nl,1:nz,1:nl)*surface%Water_Coverage)
2153 
2154  ! Compute the surface optics adjoints
2155  error_status = compute_ir_water_sfcoptics_ad( &
2156  surface , & ! Input
2157  sfcoptics , & ! Input
2158  sfcoptics_ad, & ! Input
2159  geometryinfo, & ! Input
2160  sensorindex , & ! Input
2161  channelindex, & ! Input
2162  surface_ad , & ! Output
2163  ivar%IRWSOV ) ! Internal variable input
2164  IF ( error_status /= success ) THEN
2165  WRITE( message,'("Error computing IR water SfcOptics_AD at ",&
2166  &"channel index ",i0)' ) channelindex
2167  CALL display_message( routine_name, message, error_status )
2168  RETURN
2169  END IF
2170 
2171  END IF infrared_water
2172 
2173 
2174  ! --------------------------------------
2175  ! Infrared LAND emissivity/reflectivity
2176  ! --------------------------------------
2177  infrared_land: IF( surface%Land_Coverage > zero ) THEN
2178 
2179  ! The surface optics properties based on land coverage fraction
2180  ! Note that the Emissivity_AD and Reflectivity_AD local adjoints
2181  ! are NOT zeroed here.
2182  sfcoptics_ad%Emissivity(1:nz,1:nl) = &
2183  sfcoptics_ad%Emissivity(1:nz,1:nl) + &
2184  (emissivity_ad(1:nz,1:nl)*surface%Land_Coverage)
2185  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) = &
2186  sfcoptics_ad%Reflectivity(1:nz,1:nl,1:nz,1:nl) + &
2187  (reflectivity_ad(1:nz,1:nl,1:nz,1:nl)*surface%Land_Coverage)
2188 
2189  ! Compute the surface optics adjoints
2190  ! **STUB PROCEDURE**
2191  error_status = compute_ir_land_sfcoptics_ad( sfcoptics_ad )
2192  IF ( error_status /= success ) THEN
2193  WRITE( message,'("Error computing IR land SfcOptics_AD at ",&
2194  &"channel index ",i0)' ) channelindex
2195  CALL display_message( routine_name, message, error_status )
2196  RETURN
2197  END IF
2198 
2199  END IF infrared_land
2200 
2201 
2202 
2203  !##########################################################################
2204  !##########################################################################
2205  !## ##
2206  !## ## VISIBLE CALCULATIONS ## ##
2207  !## ##
2208  !##########################################################################
2209  !##########################################################################
2210 
2211  ELSE IF ( spccoeff_isvisiblesensor( sc(sensorindex) ) ) THEN
2212 
2213 
2214  ! -------------------
2215  ! Default values only
2216  ! -------------------
2217  sfcoptics_ad%Emissivity(1:nz,1) = zero
2218  sfcoptics_ad%Reflectivity(1:nz,1,1:nz,1) = zero
2219  sfcoptics_ad%Direct_Reflectivity = zero
2220 
2221 
2222  !##########################################################################
2223  !##########################################################################
2224  !## ##
2225  !## ## INVALID SENSOR TYPE ## ##
2226  !## ##
2227  !##########################################################################
2228  !##########################################################################
2229 
2230  ELSE sensor_select
2231  error_status = failure
2232  WRITE( message,'("Unrecognised sensor type for channel index ",i0)' ) &
2233  channelindex
2234  CALL display_message( routine_name, message, error_status )
2235  RETURN
2236 
2237  END IF sensor_select
2238 
2239  END FUNCTION crtm_compute_sfcoptics_ad
2240 
2241 END MODULE crtm_sfcoptics
2242 
crtm_sfcoptics::crtm_compute_sfcoptics_tl
integer function, public crtm_compute_sfcoptics_tl(Surface, SfcOptics, Surface_TL, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics_TL, iVar)
Definition: CRTM_SfcOptics.f90:1179
crtm_sfcoptics_define::crtm_sfcoptics_type
Definition: CRTM_SfcOptics_Define.f90:67
crtm_ir_land_sfcoptics
Definition: CRTM_IR_Land_SfcOptics.f90:18
crtm_vis_snow_sfcoptics
Definition: CRTM_VIS_Snow_SfcOptics.f90:14
message_handler::failure
integer, parameter, public failure
Definition: Message_Handler.f90:30
crtm_ir_land_sfcoptics::compute_ir_land_sfcoptics
integer function, public compute_ir_land_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_IR_Land_SfcOptics.f90:161
crtm_vis_ice_sfcoptics::compute_vis_ice_sfcoptics_tl
integer function, public compute_vis_ice_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_VIS_Ice_SfcOptics.f90:246
crtm_mw_snow_sfcoptics
Definition: CRTM_MW_Snow_SfcOptics.f90:23
crtm_parameters::zero
real(fp), parameter, public zero
Definition: CRTM_Parameters.f90:70
crtm_ir_water_sfcoptics::compute_ir_water_sfcoptics_tl
integer function, public compute_ir_water_sfcoptics_tl(Surface, SfcOptics, Surface_TL, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics_TL, iVar)
Definition: CRTM_IR_Water_SfcOptics.f90:373
crtm_mw_land_sfcoptics::compute_mw_land_sfcoptics_ad
integer function, public compute_mw_land_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_MW_Land_SfcOptics.f90:371
crtm_vis_water_sfcoptics::compute_vis_water_sfcoptics_tl
integer function, public compute_vis_water_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_VIS_Water_SfcOptics.f90:246
type_kinds::fp
integer, parameter, public fp
Definition: Type_Kinds.f90:124
crtm_mw_ice_sfcoptics
Definition: CRTM_MW_Ice_SfcOptics.f90:21
crtm_sfcoptics
Definition: CRTM_SfcOptics.f90:15
crtm_ir_land_sfcoptics::compute_ir_land_sfcoptics_tl
integer function, public compute_ir_land_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_IR_Land_SfcOptics.f90:255
crtm_vis_land_sfcoptics::compute_vis_land_sfcoptics_tl
integer function, public compute_vis_land_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_VIS_Land_SfcOptics.f90:246
crtm_sfcoptics::module_version_id
character(*), parameter module_version_id
Definition: CRTM_SfcOptics.f90:121
crtm_mw_snow_sfcoptics::compute_mw_snow_sfcoptics_tl
integer function, public compute_mw_snow_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_MW_Snow_SfcOptics.f90:403
crtm_parameters
Definition: CRTM_Parameters.f90:12
crtm_spccoeff
Definition: CRTM_SpcCoeff.f90:24
crtm_mw_water_sfcoptics::compute_mw_water_sfcoptics_tl
integer function, public compute_mw_water_sfcoptics_tl(SfcOptics, Surface_TL, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics_TL, iVar)
Definition: CRTM_MW_Water_SfcOptics.f90:394
crtm_mw_snow_sfcoptics::compute_mw_snow_sfcoptics
integer function, public compute_mw_snow_sfcoptics(Surface, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics)
Definition: CRTM_MW_Snow_SfcOptics.f90:175
crtm_sfcoptics_define
Definition: CRTM_SfcOptics_Define.f90:15
crtm_mw_water_sfcoptics::compute_mw_water_sfcoptics
integer function, public compute_mw_water_sfcoptics(Surface, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_MW_Water_SfcOptics.f90:190
crtm_vis_snow_sfcoptics::compute_vis_snow_sfcoptics
integer function, public compute_vis_snow_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_VIS_Snow_SfcOptics.f90:154
crtm_surface_define::crtm_surface_type
Definition: CRTM_Surface_Define.f90:202
crtm_geometryinfo_define::crtm_geometryinfo_type
Definition: CRTM_GeometryInfo_Define.f90:104
crtm_vis_snow_sfcoptics::compute_vis_snow_sfcoptics_tl
integer function, public compute_vis_snow_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_VIS_Snow_SfcOptics.f90:246
crtm_ir_ice_sfcoptics::compute_ir_ice_sfcoptics_tl
integer function, public compute_ir_ice_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_IR_Ice_SfcOptics.f90:256
crtm_ir_ice_sfcoptics::compute_ir_ice_sfcoptics_ad
integer function, public compute_ir_ice_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_IR_Ice_SfcOptics.f90:327
crtm_sfcoptics_define::crtm_sfcoptics_create
elemental subroutine, public crtm_sfcoptics_create(SfcOptics, n_Angles, n_Stokes)
Definition: CRTM_SfcOptics_Define.f90:256
crtm_vis_land_sfcoptics::compute_vis_land_sfcoptics_ad
integer function, public compute_vis_land_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_VIS_Land_SfcOptics.f90:317
crtm_ir_snow_sfcoptics::compute_ir_snow_sfcoptics_tl
integer function, public compute_ir_snow_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_IR_Snow_SfcOptics.f90:256
message_handler
Definition: Message_Handler.f90:4
crtm_sfcoptics::crtm_compute_sfcoptics
integer function, public crtm_compute_sfcoptics(Surface, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_SfcOptics.f90:450
crtm_mw_land_sfcoptics::compute_mw_land_sfcoptics_tl
integer function, public compute_mw_land_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_MW_Land_SfcOptics.f90:300
crtm_surface_define
Definition: CRTM_Surface_Define.f90:15
crtm_mw_snow_sfcoptics::compute_mw_snow_sfcoptics_ad
integer function, public compute_mw_snow_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_MW_Snow_SfcOptics.f90:474
crtm_mw_water_sfcoptics::compute_mw_water_sfcoptics_ad
integer function, public compute_mw_water_sfcoptics_ad(SfcOptics, SfcOptics_AD, GeometryInfo, SensorIndex, ChannelIndex, Surface_AD, iVar)
Definition: CRTM_MW_Water_SfcOptics.f90:592
crtm_vis_water_sfcoptics::compute_vis_water_sfcoptics
integer function, public compute_vis_water_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_VIS_Water_SfcOptics.f90:154
crtm_parameters::max_n_stokes
integer, parameter, public max_n_stokes
Definition: CRTM_Parameters.f90:262
crtm_sfcoptics::crtm_compute_surfacet_ad
subroutine, public crtm_compute_surfacet_ad(Surface, SfcOptics_AD, Surface_AD)
Definition: CRTM_SfcOptics.f90:331
crtm_vis_land_sfcoptics::compute_vis_land_sfcoptics
integer function, public compute_vis_land_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_VIS_Land_SfcOptics.f90:154
crtm_ir_water_sfcoptics::compute_ir_water_sfcoptics
integer function, public compute_ir_water_sfcoptics(Surface, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_IR_Water_SfcOptics.f90:186
crtm_ir_land_sfcoptics::compute_ir_land_sfcoptics_ad
integer function, public compute_ir_land_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_IR_Land_SfcOptics.f90:326
crtm_parameters::one
real(fp), parameter, public one
Definition: CRTM_Parameters.f90:71
message_handler::display_message
recursive subroutine, public display_message(Routine_Name, Message, Error_State, Message_Log)
Definition: Message_Handler.f90:118
crtm_sfcoptics::crtm_compute_surfacet
subroutine, public crtm_compute_surfacet(Surface, SfcOptics)
Definition: CRTM_SfcOptics.f90:194
crtm_vis_water_sfcoptics::compute_vis_water_sfcoptics_ad
integer function, public compute_vis_water_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_VIS_Water_SfcOptics.f90:317
crtm_vis_snow_sfcoptics::compute_vis_snow_sfcoptics_ad
integer function, public compute_vis_snow_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_VIS_Snow_SfcOptics.f90:317
crtm_sfcoptics_define::crtm_sfcoptics_associated
elemental logical function, public crtm_sfcoptics_associated(SfcOptics)
Definition: CRTM_SfcOptics_Define.f90:188
crtm_mw_land_sfcoptics::compute_mw_land_sfcoptics
integer function, public compute_mw_land_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics)
Definition: CRTM_MW_Land_SfcOptics.f90:184
crtm_mw_water_sfcoptics
Definition: CRTM_MW_Water_SfcOptics.f90:18
crtm_ir_snow_sfcoptics::compute_ir_snow_sfcoptics_ad
integer function, public compute_ir_snow_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_IR_Snow_SfcOptics.f90:327
crtm_mw_land_sfcoptics
Definition: CRTM_MW_Land_SfcOptics.f90:18
crtm_vis_water_sfcoptics
Definition: CRTM_VIS_Water_SfcOptics.f90:14
crtm_sfcoptics::ivar_type
Definition: CRTM_SfcOptics.f90:131
crtm_mw_ice_sfcoptics::compute_mw_ice_sfcoptics_ad
integer function, public compute_mw_ice_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_MW_Ice_SfcOptics.f90:420
crtm_sfcoptics::crtm_compute_surfacet_tl
subroutine, public crtm_compute_surfacet_tl(Surface, Surface_TL, SfcOptics_TL)
Definition: CRTM_SfcOptics.f90:257
crtm_parameters::degrees_to_radians
real(fp), parameter, public degrees_to_radians
Definition: CRTM_Parameters.f90:88
crtm_ir_ice_sfcoptics
Definition: CRTM_IR_Ice_SfcOptics.f90:18
crtm_vis_ice_sfcoptics::compute_vis_ice_sfcoptics_ad
integer function, public compute_vis_ice_sfcoptics_ad(SfcOptics_AD)
Definition: CRTM_VIS_Ice_SfcOptics.f90:317
crtm_spccoeff::sc
type(spccoeff_type), dimension(:), allocatable, save, public sc
Definition: CRTM_SpcCoeff.f90:114
crtm_ir_water_sfcoptics::compute_ir_water_sfcoptics_ad
integer function, public compute_ir_water_sfcoptics_ad(Surface, SfcOptics, SfcOptics_AD, GeometryInfo, SensorIndex, ChannelIndex, Surface_AD, iVar)
Definition: CRTM_IR_Water_SfcOptics.f90:556
crtm_parameters::point_5
real(fp), parameter, public point_5
Definition: CRTM_Parameters.f90:78
crtm_sfcoptics::ml
integer, parameter ml
Definition: CRTM_SfcOptics.f90:124
type_kinds
Definition: Type_Kinds.f90:12
crtm_sfcoptics::crtm_compute_sfcoptics_ad
integer function, public crtm_compute_sfcoptics_ad(Surface, SfcOptics, SfcOptics_AD, GeometryInfo, SensorIndex, ChannelIndex, Surface_AD, iVar)
Definition: CRTM_SfcOptics.f90:1756
crtm_ir_snow_sfcoptics::compute_ir_snow_sfcoptics
integer function, public compute_ir_snow_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_IR_Snow_SfcOptics.f90:162
crtm_sfcoptics_define::crtm_sfcoptics_destroy
elemental subroutine, public crtm_sfcoptics_destroy(SfcOptics)
Definition: CRTM_SfcOptics_Define.f90:217
crtm_mw_ice_sfcoptics::compute_mw_ice_sfcoptics
integer function, public compute_mw_ice_sfcoptics(Surface, GeometryInfo, SensorIndex, ChannelIndex, SfcOptics)
Definition: CRTM_MW_Ice_SfcOptics.f90:172
crtm_vis_ice_sfcoptics
Definition: CRTM_VIS_Ice_SfcOptics.f90:14
crtm_mw_ice_sfcoptics::compute_mw_ice_sfcoptics_tl
integer function, public compute_mw_ice_sfcoptics_tl(SfcOptics_TL)
Definition: CRTM_MW_Ice_SfcOptics.f90:349
crtm_ir_ice_sfcoptics::compute_ir_ice_sfcoptics
integer function, public compute_ir_ice_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_IR_Ice_SfcOptics.f90:162
crtm_geometryinfo_define
Definition: CRTM_GeometryInfo_Define.f90:13
crtm_vis_ice_sfcoptics::compute_vis_ice_sfcoptics
integer function, public compute_vis_ice_sfcoptics(Surface, SensorIndex, ChannelIndex, SfcOptics, iVar)
Definition: CRTM_VIS_Ice_SfcOptics.f90:154
message_handler::success
integer, parameter, public success
Definition: Message_Handler.f90:27
crtm_ir_water_sfcoptics
Definition: CRTM_IR_Water_SfcOptics.f90:18
crtm_ir_snow_sfcoptics
Definition: CRTM_IR_Snow_SfcOptics.f90:18
crtm_vis_land_sfcoptics
Definition: CRTM_VIS_Land_SfcOptics.f90:14