FV3 Bundle
CRTM_CloudScatter.f90
Go to the documentation of this file.
1 !
2 ! CRTM_CloudScatter
3 !
4 ! Module to compute the cloud particle absorption and scattering properties
5 ! required for radiative transfer in a cloudy atmosphere.
6 !
7 !
8 ! CREATION HISTORY
9 ! Written by: Quanhua Liu, quanhua.liu@noaa.gov
10 ! Yong Han, yong.han@noaa.gov
11 ! Paul van Delst, paul.vandelst@noaa.gov
12 ! 02-July-2005
13 !
14 
15 MODULE crtm_cloudscatter
16 
17  ! -----------------
18  ! Environment setup
19  ! -----------------
20  ! Module use
21  USE type_kinds, ONLY: fp
22  USE message_handler, ONLY: success, failure, display_message
23  USE crtm_parameters, ONLY: zero, one, point_5, onepointfive, &
24  max_n_layers, &
25  max_n_clouds, &
26  water_content_threshold, &
27  bs_threshold, &
28  max_n_legendre_terms, &
29  max_n_phase_elements, &
30  hgphase ! <<< NEED TO REMOVE THIS IN FUTURE
31  USE crtm_spccoeff, ONLY: sc, &
32  spccoeff_ismicrowavesensor , &
33  spccoeff_isinfraredsensor , &
34  spccoeff_isvisiblesensor , &
35  spccoeff_isultravioletsensor
36  USE crtm_cloudcoeff, ONLY: cloudc
37  USE crtm_atmosphere_define, ONLY: crtm_atmosphere_type, &
38  water_cloud, &
39  ice_cloud, &
40  rain_cloud, &
41  snow_cloud, &
42  graupel_cloud, &
43  hail_cloud
44  USE crtm_geometryinfo_define, ONLY: crtm_geometryinfo_type
45  USE crtm_interpolation, ONLY: npts , &
46  lpoly_type , &
47  find_index , &
48  interp_1d , &
49  interp_2d , &
50  interp_3d , &
51  interp_2d_tl, &
52  interp_3d_tl, &
53  interp_2d_ad, &
54  interp_3d_ad, &
55  clear_lpoly , &
56  lpoly , &
57  lpoly_tl , &
58  lpoly_ad
59  USE crtm_atmoptics_define, ONLY: crtm_atmoptics_type
60 
61  ! Internal variable definition module
62  USE csvar_define, ONLY: csvar_type, &
63  csinterp_type, &
64  csvar_associated, &
65  csvar_destroy , &
66  csvar_create
67 
68 
69  ! Disable implicit typing
70  IMPLICIT NONE
71 
72 
73  ! ------------
74  ! Visibilities
75  ! ------------
76  ! Everything private by default
77  PRIVATE
78  ! Procedures
79  PUBLIC :: crtm_compute_cloudscatter
80  PUBLIC :: crtm_compute_cloudscatter_tl
81  PUBLIC :: crtm_compute_cloudscatter_ad
82 
83 
84  ! -----------------
85  ! Module parameters
86  ! -----------------
87  ! Version Id for the module
88  CHARACTER(*), PARAMETER :: module_version_id = &
89  '$Id: CRTM_CloudScatter.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
90  ! Message string length
91  INTEGER, PARAMETER :: ml = 256
92  ! Number of stream angle definitions
93  INTEGER, PARAMETER :: two_streams = 2
94  INTEGER, PARAMETER :: four_streams = 4
95  INTEGER, PARAMETER :: six_streams = 6
96  INTEGER, PARAMETER :: eight_streams = 8
97  INTEGER, PARAMETER :: sixteen_streams = 16
98  INTEGER, PARAMETER :: thirtytwo_streams = 32
99 
100 
101 CONTAINS
102 
103 
104 !------------------------------------------------------------------------------
105 !:sdoc+:
106 !
107 ! NAME:
108 ! CRTM_Compute_CloudScatter
109 !
110 ! PURPOSE:
111 ! Function to compute the cloud particle absorption and scattering
112 ! properties and populate the output CloudScatter structure for a
113 ! single channel.
114 !
115 ! CALLING SEQUENCE:
116 ! Error_Status = CRTM_Compute_CloudScatter( Atmosphere , &
117 ! SensorIndex , &
118 ! ChannelIndex, &
119 ! CloudScatter, &
120 ! CSvar )
121 !
122 ! INPUT ARGUMENTS:
123 ! Atmosphere: CRTM_Atmosphere structure containing the atmospheric
124 ! profile data.
125 ! UNITS: N/A
126 ! TYPE: CRTM_Atmosphere_type
127 ! DIMENSION: Scalar
128 ! ATTRIBUTES: INTENT(IN)
129 !
130 ! SensorIndex: Sensor index id. This is a unique index associated
131 ! with a (supported) sensor used to access the
132 ! shared coefficient data for a particular sensor.
133 ! See the ChannelIndex argument.
134 ! UNITS: N/A
135 ! TYPE: INTEGER
136 ! DIMENSION: Scalar
137 ! ATTRIBUTES: INTENT(IN)
138 !
139 ! ChannelIndex: Channel index id. This is a unique index associated
140 ! with a (supported) sensor channel used to access the
141 ! shared coefficient data for a particular sensor's
142 ! channel.
143 ! See the SensorIndex argument.
144 ! UNITS: N/A
145 ! TYPE: INTEGER
146 ! DIMENSION: Scalar
147 ! ATTRIBUTES: INTENT(IN)
148 !
149 ! OUTPUT ARGUMENTS:
150 ! CloudScatter: CRTM_AtmOptics structure containing the cloud particle
151 ! absorption and scattering properties required for
152 ! radiative transfer.
153 ! UNITS: N/A
154 ! TYPE: CRTM_AtmOptics_type
155 ! DIMENSION: Scalar
156 ! ATTRIBUTES: INTENT(IN OUT)
157 !
158 ! CSvar: Structure containing internal variables required for
159 ! subsequent tangent-linear or adjoint model calls.
160 ! UNITS: N/A
161 ! TYPE: CSvar_type
162 ! DIMENSION: Scalar
163 ! ATTRIBUTES: INTENT(OUT)
164 !
165 ! FUNCTION RESULT:
166 ! Error_Status: The return value is an integer defining the error status.
167 ! The error codes are defined in the Message_Handler module.
168 ! If == SUCCESS the computation was sucessful
169 ! == FAILURE an unrecoverable error occurred
170 ! UNITS: N/A
171 ! TYPE: INTEGER
172 ! DIMENSION: Scalar
173 !
174 !:sdoc-:
175 !------------------------------------------------------------------------------
176 
177  FUNCTION crtm_compute_cloudscatter( &
178  Atm , & ! Input
179  SensorIndex , & ! Input
180  ChannelIndex, & ! Input
181  CScat , & ! Output
182  CSV ) & ! Internal variable output
183  result( error_status )
184  ! Arguments
185  TYPE(crtm_atmosphere_type), INTENT(IN) :: atm
186  INTEGER , INTENT(IN) :: sensorindex
187  INTEGER , INTENT(IN) :: channelindex
188  TYPE(crtm_atmoptics_type) , INTENT(IN OUT) :: cscat
189  TYPE(csvar_type) , INTENT(IN OUT) :: csv
190  ! Function result
191  INTEGER :: error_status
192  ! Function parameters
193  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_CloudScatter'
194  ! Local variables
195  CHARACTER(ML) :: message
196  INTEGER :: k, kc, l, m, n
197  REAL(fp) :: frequency_mw, frequency_ir
198  LOGICAL :: layer_mask(atm%n_layers)
199  INTEGER :: layer_index(atm%n_layers)
200  INTEGER :: ncloud_layers
201  REAL(fp) :: bs
202 
203  ! ------
204  ! Set up
205  ! ------
206  error_status = success
207 
208  IF (atm%n_Clouds == 0) RETURN
209  csv%Total_bs = zero
210  ! Spectral variables
211  frequency_mw = sc(sensorindex)%Frequency(channelindex)
212  frequency_ir = sc(sensorindex)%Wavenumber(channelindex)
213  ! Determine offset for Legendre coefficients in
214  ! the CloudC lookup table corresponding to the
215  ! number of streams
216  SELECT CASE(cscat%n_Legendre_Terms)
217  CASE (two_streams) ; cscat%lOffset = 0
218  CASE (four_streams) ; cscat%lOffset = 0
219  CASE (six_streams) ; cscat%lOffset = 5
220  CASE (eight_streams) ; cscat%lOffset = 12
221  CASE (sixteen_streams); cscat%lOffset = 21
222  CASE DEFAULT
223  cscat%lOffset = 0 ! Is this correct?
224  ! Use two-stream model or HG and RAYLEIGH Phase function
225  IF( hgphase ) THEN
226  cscat%n_Legendre_Terms = 0
227  ELSE
228  error_status = failure
229  WRITE(message,'("The n_Legendre_Terms in CloudScatter, ",i0,", do not fit model")') &
230  cscat%n_Legendre_Terms
231  CALL display_message( routine_name,message,error_status )
232  RETURN
233  END IF
234  END SELECT
235 
236 
237  ! ---------------------------------------------
238  ! Loop over the different clouds in the profile
239  ! ---------------------------------------------
240  cloud_loop: DO n = 1, atm%n_Clouds
241 
242  ! Only process clouds with more
243  ! than the threshold water amount
244  layer_mask = atm%Cloud(n)%Water_Content > water_content_threshold
245  ncloud_layers = count(layer_mask)
246  IF ( ncloud_layers == 0 ) cycle cloud_loop
247 
248  ! ------------------------------------
249  ! Loop over the current cloud's layers
250  ! ------------------------------------
251  layer_index(1:ncloud_layers) = pack((/(k, k=1,atm%Cloud(n)%n_Layers)/), layer_mask)
252  cloud_layer_loop: DO k = 1, ncloud_layers
253  kc = layer_index(k)
254 
255 
256  ! Call sensor specific routines
257  IF ( spccoeff_ismicrowavesensor(sc(sensorindex)) ) THEN
258  CALL get_cloud_opt_mw(cscat , & ! Input
259  frequency_mw , & ! Input
260  atm%Cloud(n)%Type , & ! Input
261  atm%Cloud(n)%Effective_Radius(kc), & ! Input
262  atm%Temperature(kc) , & ! Input
263  csv%ke(kc,n) , & ! Output
264  csv%w(kc,n) , & ! Output
265  csv%pcoeff(:,:,kc,n) , & ! Output
266  csv%csi(kc,n) ) ! Interpolation
267  ELSE IF ( spccoeff_isinfraredsensor(sc(sensorindex)) .OR. &
268  spccoeff_isvisiblesensor( sc(sensorindex)) ) THEN
269  ! IR and visible use the same cloud optical data file, but distingished with Frequency
270  CALL get_cloud_opt_ir(cscat , & ! Input
271  frequency_ir , & ! Input
272  atm%Cloud(n)%Type , & ! Input
273  atm%Cloud(n)%Effective_Radius(kc), & ! Input
274  csv%ke(kc,n) , & ! Output
275  csv%w(kc,n) , & ! Output
276  csv%pcoeff(:,:,kc,n) , & ! Output
277  csv%csi(kc,n) ) ! Interpolation
278  ELSE
279  csv%ke(kc,n) = zero
280  csv%w(kc,n) = zero
281  csv%pcoeff(:,:,kc,n) = zero
282  END IF
283 
284  ! interpolation quality control
285  IF( csv%ke(kc,n) <= zero ) THEN
286  csv%ke(kc,n) = zero
287  csv%w(kc,n) = zero
288  END IF
289  IF( csv%w(kc,n) <= zero ) THEN
290  csv%w(kc,n) = zero
291  csv%pcoeff(:,:,kc,n) = zero
292  END IF
293 
294  IF( csv%w(kc,n) >= one ) THEN
295  csv%w(kc,n) = one
296  END IF
297 
298 
299  ! Compute the optical depth (absorption + scattering)
300  ! tau = rho.ke
301  ! where
302  ! rho = integrated cloud water density for a layer (kg/m^2) [M.L^-2]
303  ! ke = mass extintion coefficient (m^2/kg) [L^2.M^-1]
304  ! Note that since all these computations are done for a given
305  ! layer, the optical depth is the same as the volume extinction
306  ! coefficient, be. Usually,
307  ! tau = be.d(z)
308  ! but we are working with height/thickness independent quantities
309  ! so that
310  ! tau = be
311  ! This is why the optical depth is used in the denominator to
312  ! compute the single scatter albedo in the Layer_loop below.
313  cscat%Optical_Depth(kc) = cscat%Optical_Depth(kc) + &
314  (csv%ke(kc,n)*atm%Cloud(n)%Water_Content(kc))
315 
316  ! Compute the phase matrix coefficients
317  ! p = p + p(LUT)*bs
318  ! where
319  ! p(LUT) = the phase coefficient from the LUT
320  IF( cscat%n_Phase_Elements > 0 .and. cscat%Include_Scattering ) THEN
321  ! Compute the volume scattering coefficient for the current
322  ! cloud layer and accumulate it for the layer total for the
323  ! profile (i.e. all clouds)
324  ! bs = rho.w.ke
325  ! where
326  ! bs = volume scattering coefficient for a layer [dimensionless]
327  ! rho = integrated cloud water density for a layer (kg/m^2) [M.L^-2]
328  ! w = single scatter albedo [dimensionless]
329  ! ke = mass extintion coefficient (m^2/kg) [L^2.M^-1]
330  bs = atm%Cloud(n)%Water_Content(kc) * csv%ke(kc,n) * csv%w(kc,n)
331  csv%Total_bs(kc) = csv%Total_bs(kc) + bs
332  cscat%Single_Scatter_Albedo(kc) = cscat%Single_Scatter_Albedo(kc) + bs
333 
334  DO m = 1, cscat%n_Phase_Elements
335  DO l = 1, cscat%n_Legendre_Terms
336  cscat%Phase_Coefficient(l,m,kc) = cscat%Phase_Coefficient(l,m,kc) + &
337  (csv%pcoeff(l,m,kc,n) * bs)
338  END DO
339  END DO
340  END IF
341 
342  END DO cloud_layer_loop
343  END DO cloud_loop
344 
345  END FUNCTION crtm_compute_cloudscatter
346 
347 
348 !------------------------------------------------------------------------------
349 !:sdoc+:
350 !
351 ! NAME:
352 ! CRTM_Compute_CloudScatter_TL
353 !
354 ! PURPOSE:
355 ! Function to compute the tangent-linear cloud particle absorption and
356 ! scattering properties and populate the output CloudScatter_TL structure
357 ! for a single channel.
358 !
359 ! CALLING SEQUENCE:
360 ! Error_Status = CRTM_Compute_CloudScatter_TL( Atmosphere , &
361 ! CloudScatter , &
362 ! Atmosphere_TL , &
363 ! SensorIndex , &
364 ! ChannelIndex , &
365 ! CloudScatter_TL, &
366 ! CSvar )
367 !
368 ! INPUT ARGUMENTS:
369 ! Atmosphere: CRTM_Atmosphere structure containing the atmospheric
370 ! profile data.
371 ! UNITS: N/A
372 ! TYPE: CRTM_Atmosphere_type
373 ! DIMENSION: Scalar
374 ! ATTRIBUTES: INTENT(IN)
375 !
376 ! CloudScatter: CRTM_AtmOptics structure containing the forward model
377 ! cloud particle absorption and scattering properties
378 ! required for radiative transfer.
379 ! UNITS: N/A
380 ! TYPE: CRTM_AtmOptics_type
381 ! DIMENSION: Scalar
382 ! ATTRIBUTES: INTENT(IN)
383 !
384 ! Atmosphere_TL: CRTM Atmosphere structure containing the tangent-linear
385 ! atmospheric state data.
386 ! UNITS: N/A
387 ! TYPE: CRTM_Atmosphere_type
388 ! DIMENSION: Scalar
389 ! ATTRIBUTES: INTENT(IN)
390 !
391 ! SensorIndex: Sensor index id. This is a unique index associated
392 ! with a (supported) sensor used to access the
393 ! shared coefficient data for a particular sensor.
394 ! See the ChannelIndex argument.
395 ! UNITS: N/A
396 ! TYPE: INTEGER
397 ! DIMENSION: Scalar
398 ! ATTRIBUTES: INTENT(IN)
399 !
400 ! ChannelIndex: Channel index id. This is a unique index associated
401 ! with a (supported) sensor channel used to access the
402 ! shared coefficient data for a particular sensor's
403 ! channel.
404 ! See the SensorIndex argument.
405 ! UNITS: N/A
406 ! TYPE: INTEGER
407 ! DIMENSION: Scalar
408 ! ATTRIBUTES: INTENT(IN)
409 !
410 ! CSvar: Structure containing internal variables required for
411 ! subsequent tangent-linear or adjoint model calls.
412 ! UNITS: N/A
413 ! TYPE: CSvar_type
414 ! DIMENSION: Scalar
415 ! ATTRIBUTES: INTENT(IN)
416 ! OUTPUT ARGUMENTS:
417 ! CloudScatter_TL: CRTM_AtmOptics structure containing the tangent-linear
418 ! cloud particle absorption and scattering properties
419 ! required for radiative transfer.
420 ! UNITS: N/A
421 ! TYPE: CRTM_AtmOptics_type
422 ! DIMENSION: Scalar
423 ! ATTRIBUTES: INTENT(IN OUT)
424 !
425 !
426 ! FUNCTION RESULT:
427 ! Error_Status: The return value is an integer defining the error status.
428 ! The error codes are defined in the Message_Handler module.
429 ! If == SUCCESS the computation was sucessful
430 ! == FAILURE an unrecoverable error occurred
431 ! UNITS: N/A
432 ! TYPE: INTEGER
433 ! DIMENSION: Scalar
434 !
435 !:sdoc-:
436 !------------------------------------------------------------------------------
437 
438  FUNCTION crtm_compute_cloudscatter_tl( &
439  Atm , & ! FWD Input
440  CScat , & ! FWD Input
441  Atm_TL , & ! TL Input
442  SensorIndex , & ! Input
443  ChannelIndex, & ! Input
444  CScat_TL , & ! TL Output
445  CSV ) & ! Internal variable input
446  result( error_status )
447  ! Arguments
448  TYPE(crtm_atmosphere_type), INTENT(IN) :: atm
449  TYPE(crtm_atmoptics_type) , INTENT(IN) :: cscat
450  TYPE(crtm_atmosphere_type), INTENT(IN) :: atm_tl
451  INTEGER , INTENT(IN) :: sensorindex
452  INTEGER , INTENT(IN) :: channelindex
453  TYPE(crtm_atmoptics_type) , INTENT(IN OUT) :: cscat_tl
454  TYPE(csvar_type) , INTENT(IN) :: csv
455  ! Function result
456  INTEGER :: error_status
457  ! Local parameters
458  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_CloudScatter'
459  ! Local variables
460  INTEGER :: k, kc, l, m, n
461  INTEGER :: n_legendre_terms, n_phase_elements
462  REAL(fp) :: frequency_mw, frequency_ir
463  LOGICAL :: layer_mask(atm%n_layers)
464  INTEGER :: layer_index(atm%n_layers)
465  INTEGER :: ncloud_layers
466  REAL(fp) :: ke_tl, w_tl
467  REAL(fp) :: pcoeff_tl(0:cscat%n_legendre_terms, cscat%n_phase_elements)
468  REAL(fp) :: bs, bs_tl
469 
470  ! ------
471  ! Set up
472  ! ------
473  error_status = success
474  IF (atm%n_Clouds == 0) RETURN
475  ! Spectral variables
476  frequency_mw = sc(sensorindex)%Frequency(channelindex)
477  frequency_ir = sc(sensorindex)%Wavenumber(channelindex)
478  ! Phase matrix dimensions
479  n_legendre_terms = cscat_tl%n_Legendre_Terms
480  n_phase_elements = cscat_tl%n_Phase_Elements
481  cscat_tl%lOffset = cscat%lOffset
482 
483 
484  ! ---------------------------------------------
485  ! Loop over the different clouds in the profile
486  ! ---------------------------------------------
487  cloud_loop: DO n = 1, atm%n_Clouds
488 
489  ! Only process clouds with more
490  ! than the threshold water amount
491  layer_mask = atm%Cloud(n)%Water_Content > water_content_threshold
492  ncloud_layers = count(layer_mask)
493  IF ( ncloud_layers == 0 ) cycle cloud_loop
494 
495  ! ------------------------------------
496  ! Loop over the current cloud's layers
497  ! ------------------------------------
498  layer_index(1:ncloud_layers) = pack((/(k, k=1,atm%Cloud(n)%n_Layers)/), layer_mask)
499  cloud_layer_loop: DO k = 1, ncloud_layers
500  kc = layer_index(k)
501 
502  ! Call sensor specific routines
503  IF ( spccoeff_ismicrowavesensor(sc(sensorindex)) ) THEN
504  CALL get_cloud_opt_mw_tl(cscat_tl , & ! Input
505  atm%Cloud(n)%Type , & ! Input
506  csv%ke(kc,n) , & ! Input
507  csv%w(kc,n) , & ! Input
508  atm_tl%Cloud(n)%Effective_Radius(kc), & ! TL Input
509  atm_tl%Temperature(kc) , & ! TL Input
510  ke_tl , & ! TL Output
511  w_tl , & ! TL Output
512  pcoeff_tl , & ! TL Output
513  csv%csi(kc,n) ) ! Interpolation
514  ELSE IF ( spccoeff_isinfraredsensor(sc(sensorindex)) .OR. &
515  spccoeff_isvisiblesensor( sc(sensorindex)) ) THEN
516  CALL get_cloud_opt_ir_tl(cscat_tl , & ! Input
517  atm%Cloud(n)%Type , & ! Input
518  csv%ke(kc,n) , & ! Input
519  csv%w(kc,n) , & ! Input
520  atm_tl%Cloud(n)%Effective_Radius(kc), & ! TL Input
521  ke_tl , & ! TL Output
522  w_tl , & ! TL Output
523  pcoeff_tl , & ! TL Output
524  csv%csi(kc,n) ) ! Interpolation
525  ELSE
526  ke_tl = zero
527  w_tl = zero
528  pcoeff_tl = zero
529  END IF
530 
531  ! interpolation quality control
532  IF( csv%ke(kc,n) <= zero ) THEN
533  ke_tl = zero
534  w_tl = zero
535  END IF
536  IF( csv%w(kc,n) <= zero ) THEN
537  w_tl = zero
538  pcoeff_tl = zero
539  END IF
540  IF( csv%w(kc,n) >= one ) THEN
541  w_tl = zero
542  END IF
543 
544  ! Compute the optical depth (absorption + scattering)
545  cscat_tl%Optical_Depth(kc) = cscat_tl%Optical_Depth(kc) + &
546  (ke_tl * atm%Cloud(n)%Water_Content(kc)) + &
547  (csv%ke(kc,n) * atm_tl%Cloud(n)%Water_Content(kc))
548  ! Compute the phase matrix coefficients
549  IF( n_phase_elements > 0 .and. cscat%Include_Scattering ) THEN
550  ! Compute the volume scattering coefficient
551  bs = atm%Cloud(n)%Water_Content(kc) * csv%ke(kc,n) * csv%w(kc,n)
552  bs_tl = (atm_tl%Cloud(n)%Water_Content(kc) * csv%ke(kc,n) * csv%w(kc,n) ) + &
553  (atm%Cloud(n)%Water_Content(kc) * ke_tl * csv%w(kc,n) ) + &
554  (atm%Cloud(n)%Water_Content(kc) * csv%ke(kc,n) * w_tl )
555 
556  cscat_tl%Single_Scatter_Albedo(kc) = cscat_tl%Single_Scatter_Albedo(kc) + bs_tl
557  DO m = 1, n_phase_elements
558  DO l = 0, n_legendre_terms
559  cscat_tl%Phase_Coefficient(l,m,kc) = cscat_tl%Phase_Coefficient(l,m,kc) + &
560  (pcoeff_tl(l,m) * bs ) + &
561  (csv%pcoeff(l,m,kc,n) * bs_tl)
562  END DO
563  END DO
564  END IF
565  END DO cloud_layer_loop
566  END DO cloud_loop
567 
568 
569  END FUNCTION crtm_compute_cloudscatter_tl
570 
571 
572 !------------------------------------------------------------------------------
573 !:sdoc+:
574 !
575 ! NAME:
576 ! CRTM_Compute_CloudScatter_AD
577 !
578 ! PURPOSE:
579 ! Function to compute the adjoint of the cloud particle absorption and
580 ! scattering properties for a single channel.
581 !
582 ! CALLING SEQUENCE:
583 ! Error_Status = CRTM_Compute_CloudScatter_AD( Atmosphere , &
584 ! CloudScatter , &
585 ! CloudScatter_AD, &
586 ! SensorIndex , &
587 ! ChannelIndex , &
588 ! Atmosphere_AD , &
589 ! CSvar )
590 !
591 ! INPUT ARGUMENTS:
592 ! Atmosphere: CRTM_Atmosphere structure containing the atmospheric
593 ! profile data.
594 ! UNITS: N/A
595 ! TYPE: CRTM_Atmosphere_type
596 ! DIMENSION: Scalar
597 ! ATTRIBUTES: INTENT(IN)
598 !
599 ! CloudScatter: CRTM_AtmOptics structure containing the forward model
600 ! cloud particle absorption and scattering properties
601 ! required for radiative transfer.
602 ! UNITS: N/A
603 ! TYPE: CRTM_AtmOptics_type
604 ! DIMENSION: Scalar
605 ! ATTRIBUTES: INTENT(IN)
606 !
607 ! CloudScatter_AD: CRTM_AtmOptics structure containing the adjoint
608 ! of the cloud particle absorption and scattering
609 ! properties required for radiative transfer.
610 ! **NOTE: On EXIT from this function, the contents of
611 ! this structure may be modified (e.g. set to
612 ! zero.)
613 ! UNITS: N/A
614 ! TYPE: CRTM_AtmOptics_type
615 ! DIMENSION: Scalar
616 ! ATTRIBUTES: INTENT(IN OUT)
617 !
618 ! SensorIndex: Sensor index id. This is a unique index associated
619 ! with a (supported) sensor used to access the
620 ! shared coefficient data for a particular sensor.
621 ! See the ChannelIndex argument.
622 ! UNITS: N/A
623 ! TYPE: INTEGER
624 ! DIMENSION: Scalar
625 ! ATTRIBUTES: INTENT(IN)
626 !
627 ! ChannelIndex: Channel index id. This is a unique index associated
628 ! with a (supported) sensor channel used to access the
629 ! shared coefficient data for a particular sensor's
630 ! channel.
631 ! See the SensorIndex argument.
632 ! UNITS: N/A
633 ! TYPE: INTEGER
634 ! DIMENSION: Scalar
635 ! ATTRIBUTES: INTENT(IN)
636 !
637 ! CSvar: Structure containing internal variables required for
638 ! subsequent tangent-linear or adjoint model calls.
639 ! UNITS: N/A
640 ! TYPE: CSvar_type
641 ! DIMENSION: Scalar
642 ! ATTRIBUTES: INTENT(IN)
643 !
644 ! OUTPUT ARGUMENTS:
645 ! Atmosphere_AD: CRTM Atmosphere structure containing the adjoint
646 ! atmospheric state data.
647 ! UNITS: N/A
648 ! TYPE: CRTM_Atmosphere_type
649 ! DIMENSION: Scalar
650 ! ATTRIBUTES: INTENT(IN OUT)
651 !
652 !
653 ! FUNCTION RESULT:
654 ! Error_Status: The return value is an integer defining the error status.
655 ! The error codes are defined in the Message_Handler module.
656 ! If == SUCCESS the computation was sucessful
657 ! == FAILURE an unrecoverable error occurred
658 ! UNITS: N/A
659 ! TYPE: INTEGER
660 ! DIMENSION: Scalar
661 !
662 !:sdoc-:
663 !------------------------------------------------------------------------------
664 
665  FUNCTION crtm_compute_cloudscatter_ad( &
666  Atm , & ! FWD Input
667  CScat , & ! FWD Input
668  CScat_AD , & ! AD Input
669  SensorIndex , & ! Input
670  ChannelIndex, & ! Input
671  Atm_AD , & ! AD Output
672  CSV ) & ! Internal variable input
673  result( error_status )
674  ! Arguments
675  TYPE(crtm_atmosphere_type), INTENT(IN) :: atm
676  TYPE(crtm_atmoptics_type) , INTENT(IN) :: cscat
677  TYPE(crtm_atmoptics_type) , INTENT(IN OUT) :: cscat_ad
678  INTEGER , INTENT(IN) :: sensorindex
679  INTEGER , INTENT(IN) :: channelindex
680  TYPE(crtm_atmosphere_type), INTENT(IN OUT) :: atm_ad
681  TYPE(csvar_type) , INTENT(IN) :: csv
682  ! Function result
683  INTEGER :: error_status
684  ! Local parameters
685  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Compute_CloudScatter_AD'
686  ! Local variables
687  INTEGER :: k, kc, l, m, n
688  INTEGER :: n_legendre_terms, n_phase_elements
689  REAL(fp) :: frequency_mw, frequency_ir
690  LOGICAL :: layer_mask(atm%n_layers)
691  INTEGER :: layer_index(atm%n_layers)
692  INTEGER :: ncloud_layers
693  REAL(fp) :: ke_ad, w_ad
694  REAL(fp) :: pcoeff_ad(0:cscat%n_legendre_terms, cscat%n_phase_elements)
695  REAL(fp) :: bs, bs_ad
696 
697  ! ------
698  ! Set up
699  ! ------
700  error_status = success
701  IF ( atm%n_Clouds == 0 ) RETURN
702  ! Spectral variables
703  frequency_mw = sc(sensorindex)%Frequency(channelindex)
704  frequency_ir = sc(sensorindex)%Wavenumber(channelindex)
705  ! Phase matrix dimensions
706  n_legendre_terms = cscat_ad%n_Legendre_Terms
707  n_phase_elements = cscat_ad%n_Phase_Elements
708  cscat_ad%lOffset = cscat%lOffset
709 
710  ! ---------------------------------------------
711  ! Loop over the different clouds in the profile
712  ! ---------------------------------------------
713  cloud_loop: DO n = 1, atm%n_Clouds
714 
715  ! Only process clouds with more
716  ! than the threshold water amount
717  layer_mask = atm%Cloud(n)%Water_Content > water_content_threshold
718  ncloud_layers = count(layer_mask)
719  IF ( ncloud_layers == 0 ) cycle cloud_loop
720 
721 
722  ! ------------------------------------
723  ! Loop over the current cloud's layers
724  ! ------------------------------------
725  layer_index(1:ncloud_layers) = pack((/(k, k=1,atm%Cloud(n)%n_Layers)/), layer_mask)
726  cloud_layer_loop: DO k = ncloud_layers, 1, -1 !1, nCloud_Layers
727  kc = layer_index(k)
728 
729  ! Initialise the individual
730  ! cloud adjoint variables
731  bs_ad = zero
732  pcoeff_ad = zero
733  ke_ad = zero
734  w_ad = zero
735 
736  ! Compute the adjoint of the
737  ! phase matrix coefficients
738  IF( n_phase_elements > 0 .and. cscat%Include_Scattering ) THEN
739  ! Recompute the forward model volume scattering
740  ! coefficient for the current cloud ONLY
741  bs = atm%Cloud(n)%Water_Content(kc) * csv%ke(kc,n) * csv%w(kc,n)
742 
743  DO m = 1, n_phase_elements
744  DO l = 0, n_legendre_terms
745  bs_ad = bs_ad + (csv%pcoeff(l,m,kc,n) * cscat_ad%Phase_Coefficient(l,m,kc))
746  pcoeff_ad(l,m) = pcoeff_ad(l,m) + (bs * cscat_ad%Phase_Coefficient(l,m,kc))
747  END DO
748  END DO
749  ! NOTE: bs_AD is not reinitialised after this
750  ! point since it is reinitialised at the
751  ! start of the Cloud_Layer_loop.
752  bs_ad = bs_ad + cscat_ad%Single_Scatter_Albedo(kc)
753  w_ad = w_ad + (atm%Cloud(n)%Water_Content(kc) * csv%ke(kc,n)* bs_ad )
754  END IF
755 
756  ! Compute the adjoint of the optical
757  ! depth (absorption + scattering)
758  atm_ad%Cloud(n)%Water_Content(kc) = atm_ad%Cloud(n)%Water_Content(kc) + &
759  (csv%ke(kc,n) * cscat_ad%Optical_Depth(kc))
760  ke_ad = ke_ad + (atm%Cloud(n)%Water_Content(kc) * cscat_ad%Optical_Depth(kc))
761 
762  ! Compute the adjoint of the volume
763  ! scattering coefficient.
764 
765  ke_ad = ke_ad + (atm%Cloud(n)%Water_Content(kc) * bs_ad * csv%w(kc,n) )
766  atm_ad%Cloud(n)%Water_Content(kc) = atm_ad%Cloud(n)%Water_Content(kc) + &
767  ( bs_ad * csv%ke(kc,n) * csv%w(kc,n) )
768 
769  ! interpolation quality control
770  IF( csv%w(kc,n) >= one ) THEN
771  w_ad = zero
772  END IF
773  IF( csv%ke(kc,n) <= zero ) THEN
774  ke_ad = zero
775  w_ad = zero
776  END IF
777  IF( csv%w(kc,n) <= zero ) THEN
778  w_ad = zero
779  pcoeff_ad = zero
780  END IF
781 
782  ! Call sensor specific routines
783  IF ( spccoeff_ismicrowavesensor(sc(sensorindex)) ) THEN
784  CALL get_cloud_opt_mw_ad(cscat_ad , & ! Input
785  atm%Cloud(n)%Type , & ! Input
786  csv%ke(kc,n) , & ! Input
787  csv%w(kc,n) , & ! Input
788  ke_ad , & ! AD Input
789  w_ad , & ! AD Input
790  pcoeff_ad , & ! AD Input
791  atm_ad%Cloud(n)%Effective_Radius(kc), & ! AD Output
792  atm_ad%Temperature(kc) , & ! AD Output
793  csv%csi(kc,n) ) ! Interpolation
794  ELSE IF ( spccoeff_isinfraredsensor(sc(sensorindex)) .OR. &
795  spccoeff_isvisiblesensor( sc(sensorindex)) ) THEN
796  CALL get_cloud_opt_ir_ad(cscat_ad , & ! Input
797  atm%Cloud(n)%Type , & ! Input
798  csv%ke(kc,n) , & ! Input
799  csv%w(kc,n) , & ! Input
800  ke_ad , & ! AD Input
801  w_ad , & ! AD Input
802  pcoeff_ad , & ! AD Input
803  atm_ad%Cloud(n)%Effective_Radius(kc), & ! AD Output
804  csv%csi(kc,n) ) ! Interpolation
805  ELSE
806  ke_ad = zero
807  w_ad = zero
808  pcoeff_ad = zero
809  END IF
810  END DO cloud_layer_loop
811  END DO cloud_loop
812 
813  END FUNCTION crtm_compute_cloudscatter_ad
814 
815 
816 
817 !################################################################################
818 !################################################################################
819 !## ##
820 !## ## PRIVATE MODULE ROUTINES ## ##
821 !## ##
822 !################################################################################
823 !################################################################################
824 
825  ! ------------------------------------------
826  ! Subroutine to obtain the IR bulk
827  ! optical properties of a cloud:
828  ! extinction coefficient (ke),
829  ! scattering coefficient (w)
830  ! asymmetry factor (g), and
831  ! spherical Legendre coefficients (pcoeff)
832  ! ------------------------------------------
833  SUBROUTINE get_cloud_opt_ir( CloudScatter, & ! Input CloudScatter structure
834  Frequency , & ! Input Frequency (cm^-1)
835  cloud_type , & ! Input see CRTM_Cloud_Define.f90
836  reff , & ! Input effective radius (mm)
837  ke , & ! Output optical depth for 1 mm water content
838  w , & ! Output single scattering albedo
839  pcoeff , & ! Output spherical Legendre coefficients
840  csi ) ! Output interpolation data
841  ! Arguments
842  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter
843  REAL(fp) , INTENT(IN) :: Frequency
844  INTEGER , INTENT(IN) :: Cloud_Type
845  REAL(fp) , INTENT(IN) :: Reff
846  REAL(fp) , INTENT(OUT) :: ke
847  REAL(fp) , INTENT(OUT) :: w
848  REAL(fp) , INTENT(IN OUT) :: pcoeff(0:,:)
849  TYPE(CSinterp_type) , INTENT(IN OUT) :: csi
850  ! Local variables
851  INTEGER :: k, l
852 
853 
854  ! Find the frequency and effective
855  ! radius indices for interpolation
856  ! --------------------------------
857  csi%f_int = max(min(cloudc%Frequency_IR(cloudc%n_IR_Frequencies),frequency),cloudc%Frequency_IR(1))
858  CALL find_index(cloudc%Frequency_IR, csi%f_int, csi%i1,csi%i2, csi%f_outbound)
859  csi%f = cloudc%Frequency_IR(csi%i1:csi%i2)
860 
861  csi%r_int = max(min(cloudc%Reff_IR(cloudc%n_IR_Radii),reff),cloudc%Reff_IR(1))
862  CALL find_index(cloudc%Reff_IR, csi%r_int, csi%j1,csi%j2, csi%r_outbound)
863  csi%r = cloudc%Reff_IR(csi%j1:csi%j2)
864 
865  ! Calculate the interpolating polynomials
866  ! ---------------------------------------
867  ! Frequency term
868  CALL lpoly( csi%f, csi%f_int, & ! Input
869  csi%wlp ) ! Output
870  ! Effective radius term
871  CALL lpoly( csi%r, csi%r_int, & ! Input
872  csi%xlp ) ! Output
873 
874  ! Determine the density index, k, for the clouds
875  ! based on CloudC LUT organisation
876  ! ----------------------------------------------
877  SELECT CASE (cloud_type)
878  CASE(water_cloud) ; k=0 ! Liquid
879  CASE(ice_cloud) ; k=3 ! Solid
880  CASE(rain_cloud) ; k=0 ! Liquid
881  CASE(snow_cloud) ; k=1 ! Solid
882  CASE(graupel_cloud); k=2 ! Solid
883  CASE(hail_cloud) ; k=3 ! Solid
884  END SELECT
885 
886  ! Perform interpolation
887  ! ---------------------
888  CALL interp_2d( cloudc%ke_IR(csi%i1:csi%i2,csi%j1:csi%j2,k), csi%wlp, csi%xlp, ke )
889  CALL interp_2d( cloudc%w_IR(csi%i1:csi%i2,csi%j1:csi%j2,k) , csi%wlp, csi%xlp, w )
890  IF (cloudscatter%n_Phase_Elements > 0 .and. cloudscatter%Include_Scattering ) THEN
891  pcoeff(0,1) = point_5
892  DO l = 1, cloudscatter%n_Legendre_Terms
893  CALL interp_2d( cloudc%pcoeff_IR(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter%lOffset), &
894  csi%wlp, csi%xlp, pcoeff(l,1) )
895  END DO
896  ELSE
897  ! Absorption coefficient
898  ke = ke *(one - w)
899  END IF
900 
901  END SUBROUTINE get_cloud_opt_ir
902 
903 
904  ! ---------------------------------------------
905  ! Subroutine to obtain the tangent-linear
906  ! IR bulk optical properties of a cloud:
907  ! extinction coefficient (ke_TL),
908  ! scattereing coefficient (w_TL)
909  ! spherical Legendre coefficients (pcoeff_TL)
910  ! ---------------------------------------------
911  SUBROUTINE get_cloud_opt_ir_tl( CloudScatter_TL, & ! Input CloudScatter TL structure
912  cloud_type , & ! Input see CRTM_Cloud_Define.f90
913  ke , & ! Input
914  w , & ! Input
915  Reff_TL , & ! TL Input effective radius (mm)
916  ke_tl , & ! TL Output extinction coefficient (=~ optical depth for 1 mm water content)
917  w_tl , & ! TL Output single scattering albedo
918  pcoeff_tl , & ! TL Output spherical Legendre coefficients
919  csi ) ! Input interpolation data
920  ! Arguments
921  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter_TL
922  INTEGER , INTENT(IN) :: Cloud_Type
923  REAL(fp), INTENT(IN) :: ke, w, Reff_TL
924  REAL(fp), INTENT(OUT) :: ke_TL
925  REAL(fp), INTENT(OUT) :: w_TL
926  REAL(fp), INTENT(IN OUT) :: pcoeff_TL(0:,:)
927  TYPE(CSinterp_type), INTENT(IN) :: csi
928  ! Local variables
929  INTEGER :: k, l
930  REAL(fp) :: f_int_TL, r_int_TL
931  REAL(fp) :: f_TL(NPTS), r_TL(NPTS)
932  REAL(fp) :: z_TL(NPTS,NPTS)
933  TYPE(LPoly_type) :: wlp_TL, xlp_TL
934  REAL(fp), POINTER :: z(:,:) => null()
935 
936 
937  ! Setup
938  ! -----
939  ! No TL output when all dimensions
940  ! are outside LUT bounds
941  IF ( csi%f_outbound .AND. csi%r_outbound ) THEN
942  ke_tl = zero
943  w_tl = zero
944  pcoeff_tl = zero
945  RETURN
946  END IF
947  ! The TL inputs
948  f_int_tl = zero
949  f_tl = zero
950  r_int_tl = reff_tl
951  r_tl = zero
952  z_tl = zero
953 
954 
955  ! Calculate the TL interpolating polynomials
956  ! ------------------------------------------
957  ! Frequency term (always zero. This is a placeholder for testing)
958  CALL lpoly_tl( csi%f, csi%f_int, & ! FWD Input
959  csi%wlp, & ! FWD Input
960  f_tl, f_int_tl, & ! TL Input
961  wlp_tl ) ! TL Output
962  ! Effective radius term
963  CALL lpoly_tl( csi%r, csi%r_int, & ! FWD Input
964  csi%xlp, & ! FWD Input
965  r_tl, r_int_tl, & ! TL Input
966  xlp_tl ) ! TL Output
967 
968 
969  ! Determine the density index, k, for the clouds
970  ! based on CloudC LUT organisation
971  ! ----------------------------------------------
972  SELECT CASE (cloud_type)
973  CASE(water_cloud) ; k=0 ! Liquid
974  CASE(ice_cloud) ; k=3 ! Solid
975  CASE(rain_cloud) ; k=0 ! Liquid
976  CASE(snow_cloud) ; k=1 ! Solid
977  CASE(graupel_cloud); k=2 ! Solid
978  CASE(hail_cloud) ; k=3 ! Solid
979  END SELECT
980 
981 
982  ! Perform interpolation based on cloud type
983  ! -----------------------------------------
984  ! Extinction coefficient
985  z => cloudc%ke_IR(csi%i1:csi%i2,csi%j1:csi%j2,k)
986  CALL interp_2d_tl( z , csi%wlp, csi%xlp, & ! FWD Input
987  z_tl, wlp_tl , xlp_tl , & ! TL Input
988  ke_tl ) ! TL Output
989  ! Single scatter albedo
990  z => cloudc%w_IR(csi%i1:csi%i2,csi%j1:csi%j2,k)
991  CALL interp_2d_tl( z , csi%wlp, csi%xlp, & ! FWD Input
992  z_tl, wlp_tl , xlp_tl , & ! TL Input
993  w_tl ) ! TL Output
994  ! Phase matrix coefficients
995  IF ( cloudscatter_tl%n_Phase_Elements > 0 .and. cloudscatter_tl%Include_Scattering ) THEN
996  pcoeff_tl(0,1) = zero
997  DO l = 1, cloudscatter_tl%n_Legendre_Terms
998  z => cloudc%pcoeff_IR(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter_tl%lOffset)
999  CALL interp_2d_tl( z , csi%wlp, csi%xlp, & ! FWD Input
1000  z_tl, wlp_tl , xlp_tl , & ! TL Input
1001  pcoeff_tl(l,1) ) ! TL Output
1002  END DO
1003  ELSE
1004  ! Absorption coefficient
1005  IF( w < one ) THEN
1006  ke_tl = ke_tl * (one - w) - ke/(one -w) * w_tl
1007  ELSE
1008  ke_tl = zero
1009  END IF
1010  END IF
1011  NULLIFY(z)
1012 
1013  END SUBROUTINE get_cloud_opt_ir_tl
1014 
1015 
1016  ! ---------------------------------------------
1017  ! Subroutine to obtain the adjoint of the
1018  ! IR bulk optical properties of a cloud:
1019  ! effective radius (Reff_AD)
1020  ! ---------------------------------------------
1021  SUBROUTINE get_cloud_opt_ir_ad( CloudScatter_AD, & ! Input CloudScatter AD structure
1022  cloud_type , & ! Input see CRTM_Cloud_Define.f90
1023  ke , & ! Input
1024  w , & ! Input
1025  ke_AD , & ! AD Input extinction coefficient (=~ optical depth for 1 mm water content)
1026  w_ad , & ! AD Input single scattering albedo
1027  pcoeff_ad , & ! AD Input spherical Legendre coefficients
1028  reff_ad , & ! AD Output effective radius (mm)
1029  csi ) ! Input interpolation data
1030  ! Arguments
1031  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter_AD
1032  INTEGER , INTENT(IN) :: Cloud_Type
1033  REAL(fp), INTENT(IN) :: ke, w
1034  REAL(fp), INTENT(IN OUT) :: ke_AD ! AD Input
1035  REAL(fp), INTENT(IN OUT) :: w_AD ! AD Input
1036  REAL(fp), INTENT(IN OUT) :: pcoeff_AD(0:,:) ! AD Input
1037  REAL(fp), INTENT(IN OUT) :: Reff_AD ! AD Output
1038  TYPE(CSinterp_type), INTENT(IN) :: csi
1039  ! Local variables
1040  INTEGER :: k, l
1041  REAL(fp) :: f_int_AD, r_int_AD
1042  REAL(fp) :: f_AD(NPTS), r_AD(NPTS)
1043  REAL(fp) :: z_AD(NPTS,NPTS)
1044  TYPE(LPoly_type) :: wlp_AD, xlp_AD
1045  REAL(fp), POINTER :: z(:,:) => null()
1046 
1047 
1048  ! Setup
1049  ! -----
1050  ! No AD output when all dimensions
1051  ! are outside LUT bounds
1052  IF ( csi%f_outbound .AND. csi%r_outbound ) THEN
1053  reff_ad = zero
1054  ke_ad = zero
1055  w_ad = zero
1056  pcoeff_ad = zero
1057  RETURN
1058  END IF
1059  ! Initialise local adjoint variables
1060  f_int_ad = zero
1061  r_int_ad = zero
1062  f_ad = zero
1063  r_ad = zero
1064  z_ad = zero
1065  CALL clear_lpoly(wlp_ad)
1066  CALL clear_lpoly(xlp_ad)
1067 
1068 
1069  ! Determine the density index, k, for the clouds
1070  ! based on CloudC LUT organisation
1071  ! ----------------------------------------------
1072  SELECT CASE (cloud_type)
1073  CASE(water_cloud) ; k=0 ! Liquid
1074  CASE(ice_cloud) ; k=3 ! Solid
1075  CASE(rain_cloud) ; k=0 ! Liquid
1076  CASE(snow_cloud) ; k=1 ! Solid
1077  CASE(graupel_cloud); k=2 ! Solid
1078  CASE(hail_cloud) ; k=3 ! Solid
1079  END SELECT
1080 
1081  ! Perform interpolation
1082  ! ---------------------
1083  ! Phase matrix coefficients
1084  IF (cloudscatter_ad%n_Phase_Elements > 0 .and. cloudscatter_ad%Include_Scattering ) THEN
1085  DO l = 1, cloudscatter_ad%n_Legendre_Terms
1086  z => cloudc%pcoeff_IR(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter_ad%lOffset)
1087  CALL interp_2d_ad( z , csi%wlp , csi%xlp , & ! FWD Input
1088  pcoeff_ad(l,1) , & ! AD Input
1089  z_ad, wlp_ad, xlp_ad ) ! AD Output
1090  END DO
1091  pcoeff_ad(0,1) = zero
1092  ELSE
1093  ! Absorption coefficient
1094  IF( w < one ) THEN
1095  w_ad = w_ad - ke/(one -w) * ke_ad
1096  ke_ad = ke_ad * (one - w)
1097  ELSE
1098  ke_ad = zero
1099  END IF
1100  END IF
1101  ! Single scatter albedo
1102  z => cloudc%w_IR(csi%i1:csi%i2,csi%j1:csi%j2,k)
1103  CALL interp_2d_ad( z , csi%wlp, csi%xlp, & ! FWD Input
1104  w_ad , & ! AD Input
1105  z_ad, wlp_ad, xlp_ad ) ! AD Output
1106  ! Extinction coefficient
1107  z => cloudc%ke_IR(csi%i1:csi%i2,csi%j1:csi%j2,k)
1108  CALL interp_2d_ad( z , csi%wlp, csi%xlp, & ! FWD Input
1109  ke_ad , & ! AD Input
1110  z_ad, wlp_ad, xlp_ad ) ! AD Output
1111  NULLIFY(z)
1112 
1113 
1114  ! Compute the AD of the interpolating polynomials
1115  ! -----------------------------------------------
1116  ! Efective radius term
1117  CALL lpoly_ad( csi%r, csi%r_int, & ! FWD Input
1118  csi%xlp, & ! FWD Input
1119  xlp_ad, & ! AD Input
1120  r_ad, r_int_ad ) ! AD Output
1121  ! Frequency term (always zero. This is a placeholder for testing)
1122  CALL lpoly_ad( csi%f, csi%f_int, & ! FWD Input
1123  csi%wlp, & ! FWD Input
1124  wlp_ad, & ! AD Input
1125  f_ad, f_int_ad ) ! AD Output
1126 
1127  ! The AD outputs
1128  ! --------------
1129  reff_ad = reff_ad + r_int_ad
1130 
1131  END SUBROUTINE get_cloud_opt_ir_ad
1132 
1133 
1134  ! ------------------------------------------
1135  ! Subroutine to obtain the MW bulk
1136  ! optical properties of a cloud:
1137  ! extinction coefficient (ke),
1138  ! scattereing coefficient (w)
1139  ! asymmetry factor (g), and
1140  ! spherical Legendre coefficients (pcoeff)
1141  ! ------------------------------------------
1142  SUBROUTINE get_cloud_opt_mw( CloudScatter, & ! Input CloudScatter structure
1143  Frequency , & ! Input Frequency (GHz)
1144  cloud_type , & ! Input see CRTM_Cloud_Define.f90
1145  reff , & ! Input effective radius (mm)
1146  temperature , & ! Input cloudy temperature
1147  ke , & ! Input optical depth for 1 mm water content
1148  w , & ! Input single scattering albedo
1149  pcoeff , & ! Output spherical Legendre coefficients
1150  csi ) ! Output interpolation data
1151  ! Arguments
1152  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter
1153  REAL(fp) , INTENT(IN) :: Frequency
1154  INTEGER , INTENT(IN) :: Cloud_Type
1155  REAL(fp) , INTENT(IN) :: Reff
1156  REAL(fp) , INTENT(IN) :: Temperature
1157  REAL(fp) , INTENT(OUT) :: ke
1158  REAL(fp) , INTENT(OUT) :: w
1159  REAL(fp) , INTENT(IN OUT) :: pcoeff(0:,:)
1160  TYPE(CSinterp_type) , INTENT(IN OUT) :: csi
1161  ! Local variables
1162  INTEGER :: j, k, l, m
1163 
1164  ! Initialise results that may
1165  ! not be interpolated
1166  ! ---------------------------
1167  w = zero
1168  pcoeff = zero
1169 
1170 
1171  ! Find the frequency, effective radius
1172  ! and temperature indices for interpolation
1173  ! -----------------------------------------
1174  csi%f_int = max(min(cloudc%Frequency_MW(cloudc%n_MW_Frequencies),frequency),cloudc%Frequency_MW(1))
1175  CALL find_index(cloudc%Frequency_MW, csi%f_int, csi%i1,csi%i2, csi%f_outbound)
1176  csi%f = cloudc%Frequency_MW(csi%i1:csi%i2)
1177 
1178  csi%r_int = max(min(cloudc%Reff_MW(cloudc%n_MW_Radii),reff),cloudc%Reff_MW(1))
1179  CALL find_index(cloudc%Reff_MW, csi%r_int, csi%j1,csi%j2, csi%r_outbound)
1180  csi%r = cloudc%Reff_MW(csi%j1:csi%j2)
1181 
1182  csi%t_int = max(min(cloudc%Temperature(cloudc%n_Temperatures),temperature),cloudc%Temperature(1))
1183  CALL find_index(cloudc%Temperature, csi%t_int, csi%k1,csi%k2, csi%t_outbound)
1184  csi%t = cloudc%Temperature(csi%k1:csi%k2)
1185 
1186  ! Calculate the interpolating polynomials
1187  ! ---------------------------------------
1188  ! Frequency term
1189  CALL lpoly( csi%f, csi%f_int, & ! Input
1190  csi%wlp ) ! Output
1191  ! Effective radius term
1192  CALL lpoly( csi%r, csi%r_int, & ! Input
1193  csi%xlp ) ! Output
1194  ! Temperature term
1195  CALL lpoly( csi%t, csi%t_int, & ! Input
1196  csi%ylp ) ! Output
1197 
1198  ! Perform interpolation based on cloud type
1199  ! -----------------------------------------
1200  SELECT CASE (cloud_type)
1201 
1202  ! Only 2-D interpolation of extinction coefficient as a
1203  ! fn. of frequency and temperature for water cloud; i.e.
1204  ! we're only considering Rayleigh scattering here.
1205  CASE (water_cloud)
1206  j = 1
1207  CALL interp_2d( cloudc%ke_L_MW(csi%i1:csi%i2,j,csi%k1:csi%k2), csi%wlp, csi%ylp, ke )
1208 
1209  ! All 3-D interpolations for rain cloud!
1210  CASE (rain_cloud)
1211  CALL interp_3d( cloudc%ke_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2), csi%wlp, csi%xlp, csi%ylp, ke )
1212  CALL interp_3d( cloudc%w_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2) , csi%wlp, csi%xlp, csi%ylp, w )
1213  IF ( cloudscatter%n_Phase_Elements > 0 .and. cloudscatter%Include_Scattering ) THEN
1214  pcoeff(0,1) = point_5
1215  DO m = 1, cloudscatter%n_Phase_Elements
1216  DO l = 1, cloudscatter%n_Legendre_Terms
1217  CALL interp_3d( cloudc%pcoeff_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2,l+cloudscatter%lOffset,m), &
1218  csi%wlp, csi%xlp, csi%ylp, pcoeff(l,m) )
1219  END DO
1220  END DO
1221 
1222  ELSE
1223  ! Absorption coefficient
1224  ke = ke * (one - w)
1225  END IF
1226 
1227  ! Only 1-D interpolation of extinction coefficient as a
1228  ! fn. of frequency for ice cloud
1229  CASE (ice_cloud)
1230  j = 1; k = 3
1231  CALL interp_1d( cloudc%ke_S_MW(csi%i1:csi%i2,j,k), csi%wlp, ke )
1232 
1233  ! The remaining cloud types have 2-D interpolation
1234  ! as a fn. of frequency and radius
1235  CASE DEFAULT
1236  ! Select the LUT density
1237  SELECT CASE (cloud_type)
1238  CASE (graupel_cloud); k = 2
1239  CASE (hail_cloud) ; k = 3
1240  CASE DEFAULT ; k = 1
1241  END SELECT
1242  ! Perform interpolation
1243  CALL interp_2d( cloudc%ke_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k), csi%wlp, csi%xlp, ke )
1244  CALL interp_2d( cloudc%w_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k) , csi%wlp, csi%xlp, w )
1245  IF (cloudscatter%n_Phase_Elements > 0 .and. cloudscatter%Include_Scattering ) THEN
1246  pcoeff(0,1) = point_5
1247  DO m = 1, cloudscatter%n_Phase_Elements
1248  DO l = 1, cloudscatter%n_Legendre_Terms
1249  CALL interp_2d( cloudc%pcoeff_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter%lOffset,m), &
1250  csi%wlp, csi%xlp, pcoeff(l,m) )
1251  END DO
1252  END DO
1253 
1254  ELSE
1255  ! Absorption coefficient
1256  ke = ke * (one - w)
1257  END IF
1258 
1259  END SELECT
1260 
1261  END SUBROUTINE get_cloud_opt_mw
1262 
1263 
1264  ! ---------------------------------------------
1265  ! Subroutine to obtain the tangent-linear
1266  ! MW bulk optical properties of a cloud:
1267  ! extinction coefficient (ke_TL),
1268  ! scattereing coefficient (w_TL)
1269  ! spherical Legendre coefficients (pcoeff_TL)
1270  ! ---------------------------------------------
1271  SUBROUTINE get_cloud_opt_mw_tl( CloudScatter_TL, & ! Input CloudScatter TL structure
1272  cloud_type , & ! Input see CRTM_Cloud_Define.f90
1273  ke , & ! Input
1274  w , & ! Input
1275  Reff_TL , & ! TL Input effective radius (mm)
1276  temperature_tl , & ! TL Input cloudy temperature
1277  ke_tl , & ! TL Output extinction coefficient (=~ optical depth for 1 mm water content)
1278  w_tl , & ! TL Output single scattering albedo
1279  pcoeff_tl , & ! TL Output spherical Legendre coefficients
1280  csi ) ! Input interpolation data
1281  ! Arguments
1282  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter_TL
1283  INTEGER , INTENT(IN) :: Cloud_Type
1284  REAL(fp), INTENT(IN) :: ke, w, Reff_TL
1285  REAL(fp), INTENT(IN) :: Temperature_TL
1286  REAL(fp), INTENT(OUT) :: ke_TL
1287  REAL(fp), INTENT(OUT) :: w_TL
1288  REAL(fp), INTENT(IN OUT) :: pcoeff_TL(0:,:)
1289  TYPE(CSinterp_type), INTENT(IN) :: csi
1290  ! Local variables
1291  INTEGER :: j, k, l, m
1292  REAL(fp) :: f_int_TL, r_int_TL, t_int_TL
1293  REAL(fp) :: f_TL(NPTS), r_TL(NPTS), t_TL(NPTS)
1294  REAL(fp) :: z2_TL(NPTS,NPTS)
1295  REAL(fp) :: z3_TL(NPTS,NPTS,NPTS)
1296  TYPE(LPoly_type) :: wlp_TL, xlp_TL, ylp_TL
1297  REAL(fp), POINTER :: z2(:,:) => null()
1298  REAL(fp), POINTER :: z3(:,:,:) => null()
1299 
1300 
1301  ! Setup
1302  ! -----
1303  ! Initialise results that may
1304  ! not be interpolated
1305  w_tl = zero
1306  pcoeff_tl = zero
1307  ! The local TL inputs
1308  f_int_tl = zero
1309  f_tl = zero
1310  r_int_tl = reff_tl
1311  r_tl = zero
1312  t_int_tl = temperature_tl
1313  t_tl = zero
1314  z2_tl = zero
1315  z3_tl = zero
1316 
1317 
1318  ! Calculate the TL interpolating polynomials
1319  ! ------------------------------------------
1320  ! Frequency term (always zero. This is a placeholder for testing)
1321  CALL lpoly_tl( csi%f, csi%f_int, & ! FWD Input
1322  csi%wlp, & ! FWD Input
1323  f_tl, f_int_tl, & ! TL Input
1324  wlp_tl ) ! TL Output
1325  ! Effective radius term
1326  CALL lpoly_tl( csi%r, csi%r_int, & ! FWD Input
1327  csi%xlp, & ! FWD Input
1328  r_tl, r_int_tl, & ! TL Input
1329  xlp_tl ) ! TL Output
1330  ! Temperature term
1331  CALL lpoly_tl( csi%t, csi%t_int, & ! FWD Input
1332  csi%ylp, & ! FWD Input
1333  t_tl, t_int_tl, & ! TL Input
1334  ylp_tl ) ! TL Output
1335 
1336 
1337  ! Perform interpolation based on cloud type
1338  ! -----------------------------------------
1339  SELECT CASE (cloud_type)
1340 
1341  ! Only 2-D interpolation of extinction coefficient as a
1342  ! fn. of frequency and temperature for water cloud; i.e.
1343  ! we're only considering Rayleigh scattering here.
1344  CASE (water_cloud)
1345  ! No TL output when all dimensions
1346  ! are outside LUT bounds
1347  IF ( csi%f_outbound .AND. csi%t_outbound ) THEN
1348  ke_tl = zero
1349  RETURN
1350  END IF
1351  j = 1
1352  z2 => cloudc%ke_L_MW(csi%i1:csi%i2,j,csi%k1:csi%k2)
1353  CALL interp_2d_tl( z2 , csi%wlp, csi%ylp, & ! FWD Input
1354  z2_tl, wlp_tl , ylp_tl , & ! TL Input
1355  ke_tl ) ! TL Output
1356 
1357  ! All 3-D interpolations for rain cloud!
1358  CASE (rain_cloud)
1359  ! No TL output when all dimensions
1360  ! are outside LUT bounds
1361  IF ( csi%f_outbound .AND. csi%r_outbound .AND. csi%t_outbound ) THEN
1362  ke_tl = zero
1363  RETURN
1364  END IF
1365  ! Extinction coefficient
1366  z3 => cloudc%ke_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2)
1367  CALL interp_3d_tl( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1368  z3_tl, wlp_tl , xlp_tl , ylp_tl , & ! TL Input
1369  ke_tl ) ! TL Output
1370  ! Single scatter albedo
1371  z3 => cloudc%w_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2)
1372  CALL interp_3d_tl( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1373  z3_tl, wlp_tl , xlp_tl , ylp_tl , & ! TL Input
1374  w_tl ) ! TL Output
1375  ! Phase matrix coefficients
1376  IF ( cloudscatter_tl%n_Phase_Elements > 0 .and. cloudscatter_tl%Include_Scattering ) THEN
1377  pcoeff_tl(0,1) = zero
1378  DO m = 1, cloudscatter_tl%n_Phase_Elements
1379  DO l = 1, cloudscatter_tl%n_Legendre_Terms
1380  z3 => cloudc%pcoeff_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2,l+cloudscatter_tl%lOffset,m)
1381  CALL interp_3d_tl( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1382  z3_tl, wlp_tl , xlp_tl , ylp_tl , & ! TL Input
1383  pcoeff_tl(l,m) ) ! TL Output
1384  END DO
1385  END DO
1386  ELSE
1387  ! Absorption coefficient
1388  IF( w < one ) THEN
1389  ke_tl = ke_tl * (one - w) - ke/(one -w) * w_tl
1390  ELSE
1391  ke_tl = zero
1392  END IF
1393  END IF
1394 
1395  ! No TL interpolation of extinction coefficient as it
1396  ! is only a fn. of frequency for ice cloud
1397  CASE (ice_cloud)
1398  ke_tl = zero
1399 
1400  ! The remaining cloud types have 2-D interpolation
1401  ! as a fn. of frequency and radius
1402  CASE DEFAULT
1403  ! No TL output when all dimensions
1404  ! are outside LUT bounds
1405  IF ( csi%f_outbound .AND. csi%r_outbound ) THEN
1406  ke_tl = zero
1407  RETURN
1408  END IF
1409  ! Select the LUT temperature
1410  SELECT CASE (cloud_type)
1411  CASE (graupel_cloud); k = 2
1412  CASE (hail_cloud) ; k = 3
1413  CASE DEFAULT ; k = 1
1414  END SELECT
1415  ! Extinction coefficient
1416  z2 => cloudc%ke_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k)
1417  CALL interp_2d_tl( z2 , csi%wlp, csi%xlp, & ! FWD Input
1418  z2_tl, wlp_tl , xlp_tl , & ! TL Input
1419  ke_tl ) ! TL Output
1420  ! Single scatter albedo
1421  z2 => cloudc%w_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k)
1422  CALL interp_2d_tl( z2 , csi%wlp, csi%xlp, & ! FWD Input
1423  z2_tl, wlp_tl , xlp_tl , & ! TL Input
1424  w_tl ) ! TL Output
1425  ! Phase matrix coefficients
1426  IF ( cloudscatter_tl%n_Phase_Elements > 0 .and. cloudscatter_tl%Include_Scattering ) THEN
1427  pcoeff_tl(0,1) = zero
1428  DO m = 1, cloudscatter_tl%n_Phase_Elements
1429  DO l = 1, cloudscatter_tl%n_Legendre_Terms
1430  z2 => cloudc%pcoeff_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter_tl%lOffset,m)
1431  CALL interp_2d_tl( z2 , csi%wlp, csi%xlp, & ! FWD Input
1432  z2_tl, wlp_tl , xlp_tl , & ! TL Input
1433  pcoeff_tl(l,m) ) ! TL Output
1434  END DO
1435  END DO
1436 
1437  ELSE
1438  ! Absorption coefficient
1439  IF( w < one ) THEN
1440  ke_tl = ke_tl * (one - w) - ke/(one -w) * w_tl
1441  ELSE
1442  ke_tl = zero
1443  END IF
1444  END IF
1445  END SELECT
1446  NULLIFY(z2, z3)
1447 
1448  END SUBROUTINE get_cloud_opt_mw_tl
1449 
1450 
1451  ! ---------------------------------------------
1452  ! Subroutine to obtain the adjoint of the
1453  ! MW bulk optical properties of a cloud:
1454  ! effective radius (Reff_AD),
1455  ! temperature (temperature_AD)
1456  ! ---------------------------------------------
1457  SUBROUTINE get_cloud_opt_mw_ad(CloudScatter_AD, & ! Input CloudScatter AD structure
1458  cloud_type , & ! Input see CRTM_Cloud_Define.f90
1459  ke , & ! Input
1460  w , & ! Input
1461  ke_AD , & ! AD Input extinction coefficient (=~ optical depth for 1 mm water content)
1462  w_ad , & ! AD Input single scattering albedo
1463  pcoeff_ad , & ! AD Input spherical Legendre coefficients
1464  reff_ad , & ! AD Output effective radius (mm)
1465  temperature_ad , & ! AD Output temperature
1466  csi ) ! Input interpolation data
1467  ! Arguments
1468  TYPE(CRTM_AtmOptics_type), INTENT(IN) :: CloudScatter_AD
1469  INTEGER , INTENT(IN) :: Cloud_Type
1470  REAL(fp), INTENT(IN) :: ke, w
1471  REAL(fp), INTENT(IN OUT) :: ke_AD ! AD Input
1472  REAL(fp), INTENT(IN OUT) :: w_AD ! AD Input
1473  REAL(fp), INTENT(IN OUT) :: pcoeff_AD(0:,:) ! AD Input
1474  REAL(fp), INTENT(IN OUT) :: Reff_AD ! AD Output
1475  REAL(fp), INTENT(IN OUT) :: Temperature_AD ! AD Output
1476  TYPE(CSinterp_type), INTENT(IN) :: csi
1477  ! Local variables
1478  INTEGER :: j, k, l, m
1479  REAL(fp) :: f_int_AD, r_int_AD, t_int_AD
1480  REAL(fp) :: f_AD(NPTS), r_AD(NPTS), t_AD(NPTS)
1481  REAL(fp) :: z2_AD(NPTS,NPTS)
1482  REAL(fp) :: z3_AD(NPTS,NPTS,NPTS)
1483  TYPE(LPoly_type) :: wlp_AD, xlp_AD, ylp_AD
1484  REAL(fp), POINTER :: z2(:,:) => null()
1485  REAL(fp), POINTER :: z3(:,:,:) => null()
1486 
1487  ! Setup
1488  ! -----
1489  ! Initialise local adjoint variables
1490  f_int_ad = zero
1491  f_ad = zero
1492  r_int_ad = zero
1493  r_ad = zero
1494  t_int_ad = zero
1495  t_ad = zero
1496  z2_ad = zero
1497  z3_ad = zero
1498  CALL clear_lpoly(wlp_ad)
1499  CALL clear_lpoly(xlp_ad)
1500  CALL clear_lpoly(ylp_ad)
1501 
1502 
1503  ! Perform interpolation based on cloud type
1504  ! -----------------------------------------
1505  SELECT CASE (cloud_type)
1506 
1507 
1508  ! Only 2-D interpolation of extinction coefficient as a
1509  ! fn. of frequency and temperature for water cloud; i.e.
1510  ! we're only considering Rayleigh scattering here.
1511  ! ------------------------------------------------------
1512  CASE (water_cloud)
1513  ! No AD output when all dimensions
1514  ! are outside LUT bounds
1515  IF ( csi%f_outbound .AND. csi%t_outbound ) THEN
1516  ke_ad = zero
1517  w_ad = zero
1518  pcoeff_ad = zero
1519  RETURN
1520  END IF
1521  ! Perform the AD interpolations
1522  j = 1
1523  z2 => cloudc%ke_L_MW(csi%i1:csi%i2,j,csi%k1:csi%k2)
1524  CALL interp_2d_ad( z2 , csi%wlp, csi%ylp, & ! FWD Input
1525  ke_ad , & ! AD Input
1526  z2_ad, wlp_ad, ylp_ad ) ! AD Output
1527  ! Compute the AD of the interpolating polynomials
1528  ! Temperature term
1529  CALL lpoly_ad( csi%t, csi%t_int, & ! FWD Input
1530  csi%ylp, & ! FWD Input
1531  ylp_ad, & ! AD Input
1532  t_ad, t_int_ad ) ! AD Output
1533  ! Frequency term (always zero. This is a placeholder for testing)
1534  CALL lpoly_ad( csi%f, csi%f_int, & ! FWD Input
1535  csi%wlp, & ! FWD Input
1536  wlp_ad, & ! AD Input
1537  f_ad, f_int_ad ) ! AD Output
1538  ! The AD outputs
1539  temperature_ad = temperature_ad + t_int_ad
1540 
1541 
1542  ! All 3-D interpolations for rain cloud!
1543  ! --------------------------------------
1544  CASE (rain_cloud)
1545  ! No AD output when all dimensions
1546  ! are outside LUT bounds
1547  IF ( csi%f_outbound .AND. csi%r_outbound .AND. csi%t_outbound ) THEN
1548  ke_ad = zero
1549  w_ad = zero
1550  pcoeff_ad = zero
1551  RETURN
1552  END IF
1553  ! Perform the AD interpolations
1554  ! Phase matrix coefficients
1555  IF (cloudscatter_ad%n_Phase_Elements > 0 .and. cloudscatter_ad%Include_Scattering ) THEN
1556  DO m = 1, cloudscatter_ad%n_Phase_Elements
1557  DO l = 1, cloudscatter_ad%n_Legendre_Terms
1558  z3 => cloudc%pcoeff_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2,l+cloudscatter_ad%lOffset,m)
1559  CALL interp_3d_ad( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1560  pcoeff_ad(l,m) , & ! AD Input
1561  z3_ad, wlp_ad , xlp_ad , ylp_ad ) ! AD Output
1562  END DO
1563  END DO
1564  pcoeff_ad(0,1) = zero
1565 
1566  ELSE
1567  ! Absorption coefficient
1568  IF( w < one ) THEN
1569  w_ad = w_ad - ke/(one -w) * ke_ad
1570  ke_ad = ke_ad * (one - w)
1571  ELSE
1572  ke_ad = zero
1573  END IF
1574  END IF
1575  ! Single scatter albedo
1576  z3 => cloudc%w_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2)
1577  CALL interp_3d_ad( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1578  w_ad , & ! AD Input
1579  z3_ad, wlp_ad , xlp_ad , ylp_ad ) ! AD Output
1580  ! Extinction coefficient
1581  z3 => cloudc%ke_L_MW(csi%i1:csi%i2,csi%j1:csi%j2,csi%k1:csi%k2)
1582  CALL interp_3d_ad( z3 , csi%wlp, csi%xlp, csi%ylp, & ! FWD Input
1583  ke_ad , & ! AD Input
1584  z3_ad, wlp_ad , xlp_ad , ylp_ad ) ! AD Output
1585  ! Compute the AD of the interpolating polynomials
1586  ! Temperature term
1587  CALL lpoly_ad( csi%t, csi%t_int, & ! FWD Input
1588  csi%ylp, & ! FWD Input
1589  ylp_ad, & ! AD Input
1590  t_ad, t_int_ad ) ! AD Output
1591  ! Effective radius term
1592  CALL lpoly_ad( csi%r, csi%r_int, & ! FWD Input
1593  csi%xlp, & ! FWD Input
1594  xlp_ad, & ! AD Input
1595  r_ad, r_int_ad ) ! AD Output
1596  ! Frequency term (always zero. This is a placeholder for testing)
1597  CALL lpoly_ad( csi%f, csi%f_int, & ! FWD Input
1598  csi%wlp, & ! FWD Input
1599  wlp_ad, & ! AD Input
1600  f_ad, f_int_ad ) ! AD Output
1601  ! The AD outputs
1602  temperature_ad = temperature_ad + t_int_ad
1603  reff_ad = reff_ad + r_int_ad
1604 
1605 
1606  ! No AD interpolation as it is only a fn.
1607  ! of frequency for ice cloud
1608  ! ---------------------------------------
1609  CASE (ice_cloud)
1610  ke_ad = zero
1611  w_ad = zero
1612  pcoeff_ad = zero
1613 
1614 
1615  ! The remaining cloud types have 2-D interpolation
1616  ! as a fn. of frequency and radius
1617  ! ------------------------------------------------
1618  CASE DEFAULT
1619  ! No TL output when all dimensions
1620  ! are outside LUT bounds
1621  IF ( csi%f_outbound .AND. csi%r_outbound ) THEN
1622  ke_ad = zero
1623  w_ad = zero
1624  pcoeff_ad = zero
1625  RETURN
1626  END IF
1627  ! Select the LUT temperature
1628  SELECT CASE (cloud_type)
1629  CASE (graupel_cloud); k = 2
1630  CASE (hail_cloud) ; k = 3
1631  CASE DEFAULT ; k = 1
1632  END SELECT
1633  ! Perform the AD interpolations
1634  ! Phase matrix coefficients
1635  IF (cloudscatter_ad%n_Phase_Elements > 0 .and. cloudscatter_ad%Include_Scattering ) THEN
1636  DO m = 1, cloudscatter_ad%n_Phase_Elements
1637  DO l = 1, cloudscatter_ad%n_Legendre_Terms
1638  z2 => cloudc%pcoeff_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k,l+cloudscatter_ad%lOffset,m)
1639  CALL interp_2d_ad( z2 , csi%wlp, csi%xlp, & ! FWD Input
1640  pcoeff_ad(l,m) , & ! AD Input
1641  z2_ad, wlp_ad , xlp_ad ) ! AD Output
1642  END DO
1643  END DO
1644  pcoeff_ad(0,1) = zero
1645  ELSE
1646  ! Absorption coefficient
1647  IF( w < one ) THEN
1648  w_ad = w_ad - ke/(one -w) * ke_ad
1649  ke_ad = ke_ad * (one - w)
1650  ELSE
1651  ke_ad = zero
1652  END IF
1653 
1654  END IF
1655  ! Single scatter albedo
1656  z2 => cloudc%w_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k)
1657  CALL interp_2d_ad( z2 , csi%wlp, csi%xlp, & ! FWD Input
1658  w_ad , & ! AD Input
1659  z2_ad, wlp_ad , xlp_ad ) ! AD Output
1660  ! Extinction coefficient
1661  z2 => cloudc%ke_S_MW(csi%i1:csi%i2,csi%j1:csi%j2,k)
1662  CALL interp_2d_ad( z2 , csi%wlp, csi%xlp, & ! FWD Input
1663  ke_ad , & ! AD Input
1664  z2_ad, wlp_ad , xlp_ad ) ! AD Output
1665  ! Compute the AD of the interpolating polynomials
1666  ! Effective radius term
1667  CALL lpoly_ad( csi%r, csi%r_int, & ! FWD Input
1668  csi%xlp, & ! FWD Input
1669  xlp_ad, & ! AD Input
1670  r_ad, r_int_ad ) ! AD Output
1671  ! Frequency term (always zero. This is a placeholder for testing)
1672  CALL lpoly_ad( csi%f, csi%f_int, & ! FWD Input
1673  csi%wlp, & ! FWD Input
1674  wlp_ad, & ! AD Input
1675  f_ad, f_int_ad ) ! AD Output
1676  ! The AD outputs
1677  reff_ad = reff_ad + r_int_ad
1678  END SELECT
1679  NULLIFY(z2, z3)
1680 
1681  END SUBROUTINE get_cloud_opt_mw_ad
1682 
1683 END MODULE crtm_cloudscatter
crtm_cloudcoeff::cloudc
type(cloudcoeff_type), target, save, public cloudc
Definition: CRTM_CloudCoeff.f90:64
crtm_cloudscatter::ml
integer, parameter ml
Definition: CRTM_CloudScatter.f90:91
crtm_interpolation::interp_3d_ad
subroutine, public interp_3d_ad(z, ulp, vlp, wlp, z_int_AD, z_AD, ulp_AD, vlp_AD, wlp_AD)
Definition: CRTM_Interpolation.f90:614
crtm_interpolation::interp_3d_tl
subroutine, public interp_3d_tl(z, ulp, vlp, wlp, z_TL, ulp_TL, vlp_TL, wlp_TL, z_int_TL)
Definition: CRTM_Interpolation.f90:421
message_handler::failure
integer, parameter, public failure
Definition: Message_Handler.f90:30
csvar_define
Definition: CSvar_Define.f90:13
crtm_parameters::onepointfive
real(fp), parameter, public onepointfive
Definition: CRTM_Parameters.f90:80
crtm_parameters::zero
real(fp), parameter, public zero
Definition: CRTM_Parameters.f90:70
crtm_parameters::max_n_phase_elements
integer, parameter, public max_n_phase_elements
Definition: CRTM_Parameters.f90:259
crtm_parameters::max_n_clouds
integer, parameter, public max_n_clouds
Definition: CRTM_Parameters.f90:247
crtm_cloudscatter::six_streams
integer, parameter six_streams
Definition: CRTM_CloudScatter.f90:95
crtm_atmoptics_define
Definition: CRTM_AtmOptics_Define.f90:12
crtm_cloudscatter::sixteen_streams
integer, parameter sixteen_streams
Definition: CRTM_CloudScatter.f90:97
type_kinds::fp
integer, parameter, public fp
Definition: Type_Kinds.f90:124
crtm_cloudscatter::get_cloud_opt_ir_ad
subroutine get_cloud_opt_ir_ad(CloudScatter_AD, cloud_type, ke, w, ke_AD, w_AD, pcoeff_AD, Reff_AD, csi)
Definition: CRTM_CloudScatter.f90:1030
crtm_parameters
Definition: CRTM_Parameters.f90:12
crtm_spccoeff
Definition: CRTM_SpcCoeff.f90:24
crtm_cloudscatter
Definition: CRTM_CloudScatter.f90:15
crtm_cloudscatter::thirtytwo_streams
integer, parameter thirtytwo_streams
Definition: CRTM_CloudScatter.f90:98
crtm_cloudscatter::get_cloud_opt_ir_tl
subroutine get_cloud_opt_ir_tl(CloudScatter_TL, cloud_type, ke, w, Reff_TL, ke_TL, w_TL, pcoeff_TL, csi)
Definition: CRTM_CloudScatter.f90:920
crtm_geometryinfo_define::crtm_geometryinfo_type
Definition: CRTM_GeometryInfo_Define.f90:104
csvar_define::csvar_create
elemental subroutine, public csvar_create(self, n_Legendre_Terms, n_Phase_Elements, n_Layers, n_Clouds)
Definition: CSvar_Define.f90:168
crtm_parameters::max_n_legendre_terms
integer, parameter, public max_n_legendre_terms
Definition: CRTM_Parameters.f90:258
crtm_parameters::hgphase
logical, parameter, public hgphase
Definition: CRTM_Parameters.f90:266
csvar_define::csvar_type
Definition: CSvar_Define.f90:111
crtm_interpolation
Definition: CRTM_Interpolation.f90:12
message_handler
Definition: Message_Handler.f90:4
crtm_interpolation::clear_lpoly
subroutine, public clear_lpoly(p)
Definition: CRTM_Interpolation.f90:132
crtm_interpolation::lpoly_ad
subroutine, public lpoly_ad(x, x_int, p, p_AD, x_AD, x_int_AD)
Definition: CRTM_Interpolation.f90:1028
crtm_parameters::bs_threshold
real(fp), parameter, public bs_threshold
Definition: CRTM_Parameters.f90:254
crtm_interpolation::lpoly_type
Definition: CRTM_Interpolation.f90:78
crtm_cloudscatter::eight_streams
integer, parameter eight_streams
Definition: CRTM_CloudScatter.f90:96
crtm_cloudscatter::module_version_id
character(*), parameter module_version_id
Definition: CRTM_CloudScatter.f90:88
crtm_cloudscatter::crtm_compute_cloudscatter
integer function, public crtm_compute_cloudscatter(Atm, SensorIndex, ChannelIndex, CScat, CSV)
Definition: CRTM_CloudScatter.f90:184
crtm_parameters::water_content_threshold
real(fp), parameter, public water_content_threshold
Definition: CRTM_Parameters.f90:251
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
csvar_define::csvar_associated
elemental logical function, public csvar_associated(self)
Definition: CSvar_Define.f90:146
csvar_define::csinterp_type
Definition: CSvar_Define.f90:85
crtm_cloudscatter::two_streams
integer, parameter two_streams
Definition: CRTM_CloudScatter.f90:93
crtm_interpolation::find_index
Definition: CRTM_Interpolation.f90:57
csvar_define::csvar_destroy
elemental subroutine, public csvar_destroy(self)
Definition: CSvar_Define.f90:153
crtm_cloudscatter::crtm_compute_cloudscatter_ad
integer function, public crtm_compute_cloudscatter_ad(Atm, CScat, CScat_AD, SensorIndex, ChannelIndex, Atm_AD, CSV)
Definition: CRTM_CloudScatter.f90:674
crtm_cloudscatter::get_cloud_opt_ir
subroutine get_cloud_opt_ir(CloudScatter, Frequency, cloud_type, Reff, ke, w, pcoeff, csi)
Definition: CRTM_CloudScatter.f90:841
crtm_cloudscatter::four_streams
integer, parameter four_streams
Definition: CRTM_CloudScatter.f90:94
crtm_interpolation::interp_2d_ad
subroutine, public interp_2d_ad(z, ulp, vlp, z_int_AD, z_AD, ulp_AD, vlp_AD)
Definition: CRTM_Interpolation.f90:585
crtm_interpolation::lpoly
subroutine, public lpoly(x, x_int, p)
Definition: CRTM_Interpolation.f90:835
crtm_interpolation::npts
integer, parameter, public npts
Definition: CRTM_Interpolation.f90:72
crtm_spccoeff::sc
type(spccoeff_type), dimension(:), allocatable, save, public sc
Definition: CRTM_SpcCoeff.f90:114
crtm_parameters::max_n_layers
integer, parameter, public max_n_layers
Definition: CRTM_Parameters.f90:64
crtm_cloudscatter::get_cloud_opt_mw_tl
subroutine get_cloud_opt_mw_tl(CloudScatter_TL, cloud_type, ke, w, Reff_TL, Temperature_TL, ke_TL, w_TL, pcoeff_TL, csi)
Definition: CRTM_CloudScatter.f90:1281
crtm_parameters::point_5
real(fp), parameter, public point_5
Definition: CRTM_Parameters.f90:78
crtm_interpolation::interp_3d
subroutine, public interp_3d(z, ulp, vlp, wlp, z_int)
Definition: CRTM_Interpolation.f90:264
max
#define max(a, b)
Definition: mosaic_util.h:33
type_kinds
Definition: Type_Kinds.f90:12
crtm_cloudscatter::get_cloud_opt_mw
subroutine get_cloud_opt_mw(CloudScatter, Frequency, cloud_type, Reff, Temperature, ke, w, pcoeff, csi)
Definition: CRTM_CloudScatter.f90:1151
crtm_cloudscatter::get_cloud_opt_mw_ad
subroutine get_cloud_opt_mw_ad(CloudScatter_AD, cloud_type, ke, w, ke_AD, w_AD, pcoeff_AD, Reff_AD, Temperature_AD, csi)
Definition: CRTM_CloudScatter.f90:1467
crtm_cloudscatter::crtm_compute_cloudscatter_tl
integer function, public crtm_compute_cloudscatter_tl(Atm, CScat, Atm_TL, SensorIndex, ChannelIndex, CScat_TL, CSV)
Definition: CRTM_CloudScatter.f90:447
crtm_cloudcoeff
Definition: CRTM_CloudCoeff.f90:24
crtm_atmosphere_define::crtm_atmosphere_type
Definition: CRTM_Atmosphere_Define.f90:361
min
#define min(a, b)
Definition: mosaic_util.h:32
crtm_atmosphere_define
Definition: CRTM_Atmosphere_Define.f90:13
crtm_geometryinfo_define
Definition: CRTM_GeometryInfo_Define.f90:13
crtm_interpolation::lpoly_tl
subroutine, public lpoly_tl(x, x_int, p, x_TL, x_int_TL, p_TL)
Definition: CRTM_Interpolation.f90:931
crtm_atmoptics_define::crtm_atmoptics_type
Definition: CRTM_AtmOptics_Define.f90:93
crtm_interpolation::interp_1d
subroutine, public interp_1d(z, ulp, z_int)
Definition: CRTM_Interpolation.f90:230
message_handler::success
integer, parameter, public success
Definition: Message_Handler.f90:27
crtm_interpolation::interp_2d_tl
subroutine, public interp_2d_tl(z, ulp, vlp, z_TL, ulp_TL, vlp_TL, z_int_TL)
Definition: CRTM_Interpolation.f90:400
crtm_interpolation::interp_2d
subroutine, public interp_2d(z, ulp, vlp, z_int)
Definition: CRTM_Interpolation.f90:246