FV3 Bundle
ODPS_Define.f90
Go to the documentation of this file.
1 !
2 ! ODPS_Define
3 !
4 ! Module defining the ODPS (Optical Depth, Pressure Space) data structure and
5 ! containing routines to manipulate it.
6 !
7 !
8 ! CREATION HISTORY:
9 ! Modified by: Yong Han, JCSDA, NOAA/NESDIS 20-Jun-2008
10 ! Based on Paul van Delst's framework
11 !
12 
13 MODULE odps_define
14 
15  ! ------------------
16  ! Environment set up
17  ! ------------------
18  ! Module use
19  USE type_kinds, ONLY: long, single, fp
20  USE message_handler, ONLY: success, failure, warning, display_message
21  USE compare_float_numbers, ONLY: compare_float
22  USE sort_utility, ONLY: insertionsort
23  USE crtm_parameters, ONLY: odps_algorithm
24  ! Disable implicit typing
25  IMPLICIT NONE
26 
27 
28  ! ------------
29  ! Visibilities
30  ! ------------
31  ! Everything private by default
32  PRIVATE
33 
34  ! Public types
35  ! ------------
36  PUBLIC :: odps_type
37 
38  ! Public procedures
39  ! -----------------
40  PUBLIC :: associated_odps
41  PUBLIC :: destroy_odps
42  PUBLIC :: allocate_odps
43  PUBLIC :: allocate_odps_optran
44  PUBLIC :: assign_odps
45  PUBLIC :: concatenate_channel_odps
46  PUBLIC :: concatenate_absorber_odps
47  PUBLIC :: equal_odps
48  PUBLIC :: checkrelease_odps
49  PUBLIC :: checkalgorithm_odps
50  PUBLIC :: info_odps
51 
52  ! Public parameters
53  ! -----------------
54  ! Sensor Id defaults
55  PUBLIC :: invalid_wmo_satellite_id
56  PUBLIC :: invalid_wmo_sensor_id
57  ! Allowable sensor type values and names
58  PUBLIC :: n_sensor_types
59  PUBLIC :: invalid_sensor
60  PUBLIC :: microwave_sensor
61  PUBLIC :: infrared_sensor
62  PUBLIC :: visible_sensor
63  PUBLIC :: sensor_type_name
64  ! The Global unique algorithm ID
65  PUBLIC :: odps_algorithm
66 
67  ! -----------------
68  ! Module parameters
69  ! -----------------
70  ! RCS Id for the module
71  CHARACTER(*), PARAMETER :: module_rcs_id = &
72  '$Id: $'
73  ! ODPS invalid values
74  INTEGER, PARAMETER :: ip_invalid = -1
75  REAL(fp), PARAMETER :: fp_invalid = -1.0_fp
76  ! Keyword set value
77  INTEGER, PARAMETER :: set = 1
78  ! String lengths
79  INTEGER, PARAMETER :: sl = 20 ! Sensor Id
80  INTEGER, PARAMETER :: ml = 256 ! Messages
81  ! Current valid release and version numbers
82  INTEGER, PARAMETER :: odps_release = 2 ! This determines structure and file formats.
83  INTEGER, PARAMETER :: odps_version = 1 ! This is just the data version.
84  ! The optical depth algorithm name
85  CHARACTER(*), PARAMETER :: odps_algorithm_name = 'ODPS'
86  ! ASCII codes for Version routine
87  INTEGER, PARAMETER :: carriage_return = 13
88  INTEGER, PARAMETER :: linefeed = 10
89  ! Invalid sensor ids
90  INTEGER, PARAMETER :: invalid_wmo_satellite_id = 1023
91  INTEGER, PARAMETER :: invalid_wmo_sensor_id = 2047
92  ! The instrument types
93  INTEGER, PARAMETER :: n_sensor_types = 4
94  INTEGER, PARAMETER :: invalid_sensor = 0
95  INTEGER, PARAMETER :: microwave_sensor = 1
96  INTEGER, PARAMETER :: infrared_sensor = 2
97  INTEGER, PARAMETER :: visible_sensor = 3
98  INTEGER, PARAMETER :: ultraviolet_sensor = 4
99  CHARACTER(*), PARAMETER, DIMENSION( 0:N_SENSOR_TYPES ) :: &
100  sensor_type_name = (/ 'Invalid ', &
101  'Microwave ', &
102  'Infrared ', &
103  'Visible ', &
104  'Ultraviolet' /)
105  ! number of predictors used to compute optran absorption coefficients
106  INTEGER, PARAMETER :: n_predictor_used_optran = 6
107  INTEGER, PUBLIC, PARAMETER :: significance_optran = 1
108 
109  ! -------------------------
110  ! ODPS data type definition
111  ! -------------------------
112  TYPE :: odps_type
113  INTEGER :: n_allocates = 0
114  ! Release and version information
115  INTEGER(Long) :: release = odps_release
116  INTEGER(Long) :: version = odps_version
117  ! Algorithm identifer
118  INTEGER(Long) :: algorithm = odps_algorithm
119  ! Dimensions
120  INTEGER(Long) :: n_layers = 0 ! Iorder
121  INTEGER(Long) :: n_components = 0 ! J - Tau component dimension
122  INTEGER(Long) :: n_absorbers = 0 ! Jm - (Molecular) absorber dimension
123  INTEGER(Long) :: n_channels = 0 ! L
124  INTEGER(Long) :: n_coeffs = 0 ! Iuse
125 
126  ! Dimensions for OPTRAN component
127  INTEGER(Long) :: n_opindex = n_predictor_used_optran ! OI, should not be changed
128  INTEGER(Long) :: n_ocoeffs = 0 ! OC
129 
130  !-------------------
131  ! Scalar components
132  !-------------------
133  ! Group ID. TCs in the same group have the same dimensions:
134  ! n_Components and n_Absorbers.
135  INTEGER(Long) :: group_index = 0
136  ! Sensor/Satellite IDs and type
137  CHARACTER(SL) :: sensor_id = ' '
138  INTEGER(Long) :: wmo_satellite_id = invalid_wmo_satellite_id
139  INTEGER(Long) :: wmo_sensor_id = invalid_wmo_sensor_id
140  INTEGER(Long) :: sensor_type = invalid_sensor
141 
142  ! Reference pressures at the layer boundaries
143  REAL(fp), POINTER :: ref_level_pressure(:) => null() ! 0:K
144  ! Reference layer (mean) pressure and temperature
145  REAL(fp), POINTER :: ref_pressure(:) => null() ! K
146  REAL(fp), POINTER :: ref_temperature(:) => null() ! K
147 
148  ! Reference molecular content profile. The sequence of the molecules in the Jm dimension
149  ! must be consistent with that of the Absorber_ID array
150  REAL(fp), POINTER :: ref_absorber(:,:) => null() ! K x Jm
151  ! Training set molecular content ranges
152  REAL(fp), POINTER :: min_absorber(:,:) => null() ! K x Jm
153  REAL(fp), POINTER :: max_absorber(:,:) => null() ! K x Jm
154 
155  ! The actual sensor channel numbers
156  INTEGER(Long), POINTER :: sensor_channel(:) => null() ! L
157  ! The Tau component ID
158  INTEGER(Long), POINTER :: component_id(:) => null() ! J
159  ! Molecular IDs (variable absorbers):
160  INTEGER(Long), POINTER :: absorber_id(:) => null() ! Jm
161 
162  !---------------------------------------------------------------------------
163  ! The array C contains the Tau coefficient. It is structured
164  ! with Pos_Index and n_Predictors, as the following,
165  ! For channel l and component j,
166  ! Pos_Index(j, l) is the starting position in array C for that
167  ! channel and component, and
168  ! n_Predictors(j, l) is the number of predictors for that channel
169  ! and component.
170  ! The size of the coefficient data at j and l is given by
171  ! Pos_Index(j+1, l) - Pos_Index(j, l)
172  ! and the sub-structure of the data at j and l depends on the algorithm. The
173  ! following is an example of the sub-structure:
174  ! As the number layers is fixed and known for all channels and components,
175  ! the positions of the coeffs for a particular layer are known. Let i be the
176  ! index to the array C for channel l, component j, layer k and coefficient m,
177  ! then
178  ! i = Pos_Index(j, l) + (m-1)*n_Predictors(j, l) + k
179  ! Thus, accessing C(i) is equivalent to that given by C(m, k, j, l) if C is
180  ! a 4-D array.
181  !
182  ! Notice: the value of n_Predictors(j, l) can be zero, which means the
183  ! coeff data for j, l does not exist. Thus, this value should
184  ! be checked before accessing C.
185  !---------------------------------------------------------------------------
186  INTEGER(Long), POINTER :: n_predictors(:,:) => null() ! J x L
187  INTEGER(Long), POINTER :: pos_index(:,:) => null() ! J x L
188  REAL(Single), POINTER :: c(:) => null() ! Iuse
189 
190  !----------------------------------------------------------------
191  ! Compact OPTRAN water vapor line
192  ! OSignificance - an integer number indicating if for this channel
193  ! OPTRAN should be applied.
194  ! Order - order of the polynomial
195  ! OP_Index - Predictor indexes (OP_Index(0) is the number of predictors)
196  ! OPos_Index - starting position for the coefficient data in the OC
197  ! array
198  ! OC - Coefficients
199  !----------------------------------------------------------------
200  INTEGER(Long), POINTER :: osignificance(:) => null() ! L
201  INTEGER(LONG), POINTER :: order(:) => null() ! L
202  INTEGER(Long), POINTER :: op_index(:,:) => null() ! 0:OI x L
203  INTEGER(Long), POINTER :: opos_index(:) => null() ! J x L
204  REAL(fp), POINTER :: oc(:) => null() ! OC
205  REAL(fp) :: alpha = 0.0_fp, alpha_c1 = 0.0_fp, alpha_c2 = 0.0_fp
206  INTEGER(Long) :: ocomponent_index = -1
207 
208  END TYPE odps_type
209 
210 CONTAINS
211 
212 
213 !################################################################################
214 !################################################################################
215 !## ##
216 !## ## PUBLIC MODULE ROUTINES ## ##
217 !## ##
218 !################################################################################
219 !################################################################################
220 
221 !--------------------------------------------------------------------------------
222 !
223 ! NAME:
224 ! Associated_ODPS
225 !
226 ! PURPOSE:
227 ! Function to test the association status of the pointer members of a
228 ! ODPS structure.
229 !
230 ! CALLING SEQUENCE:
231 ! Association_Status = Associated_ODPS( ODPS ,& ! Input
232 ! ANY_Test=Any_Test ) ! Optional input
233 !
234 ! INPUT ARGUMENTS:
235 ! ODPS: ODPS structure which is to have its pointer
236 ! member's association status tested.
237 ! UNITS: N/A
238 ! TYPE: ODPS_type
239 ! DIMENSION: Scalar
240 ! ATTRIBUTES: INTENT(IN)
241 !
242 ! OPTIONAL INPUT ARGUMENTS:
243 ! ANY_Test: Set this argument to test if ANY of the
244 ! ODPS structure pointer members are associated.
245 ! The default is to test if ALL the pointer members
246 ! are associated.
247 ! If ANY_Test = 0, test if ALL the pointer members
248 ! are associated. (DEFAULT)
249 ! ANY_Test = 1, test if ANY of the pointer members
250 ! are associated.
251 !
252 ! FUNCTION RESULT:
253 ! Association_Status: The return value is a logical value indicating the
254 ! association status of the ODPS pointer members.
255 ! .TRUE. - if ALL the ODPS pointer members are
256 ! associated, or if the ANY_Test argument
257 ! is set and ANY of the ODPS pointer
258 ! members are associated.
259 ! .FALSE. - some or all of the ODPS pointer
260 ! members are NOT associated.
261 ! UNITS: N/A
262 ! TYPE: LOGICAL
263 ! DIMENSION: Scalar
264 !
265 !--------------------------------------------------------------------------------
266 
267  FUNCTION associated_odps( ODPS , & ! Input
268  ANY_Test) & ! Optional input
269  result( association_status )
270  ! Arguments
271  TYPE(odps_type) , INTENT(IN) :: odps
272  INTEGER, OPTIONAL, INTENT(IN) :: any_test
273  ! Function result
274  LOGICAL :: association_status
275  ! Local variables
276  LOGICAL :: all_test
277 
278  ! Set up
279  ! ------
280  ! Default is to test ALL the pointer members
281  ! for a true association status....
282  all_test = .true.
283  ! ...unless the ANY_Test argument is set.
284  IF ( PRESENT( any_test ) ) THEN
285  IF ( any_test == set ) all_test = .false.
286  END IF
287 
288  ! Test the members that MUST be associated
289  ! ----------------------------------------
290  association_status = .false.
291  IF ( all_test ) THEN
292  IF ( ASSOCIATED( odps%Sensor_Channel ) .AND. &
293  ASSOCIATED( odps%Component_ID ) .AND. &
294  ASSOCIATED( odps%Absorber_ID ) .AND. &
295  ASSOCIATED( odps%Ref_Level_Pressure) .AND. &
296  ASSOCIATED( odps%Ref_Pressure ) .AND. &
297  ASSOCIATED( odps%Ref_Temperature ) .AND. &
298  ASSOCIATED( odps%Ref_Absorber ) .AND. &
299  ASSOCIATED( odps%Min_Absorber ) .AND. &
300  ASSOCIATED( odps%Max_Absorber ) .AND. &
301  ASSOCIATED( odps%n_Predictors ) .AND. &
302  ASSOCIATED( odps%Pos_Index ) ) THEN
303  association_status = .true.
304  END IF
305  IF( odps%n_Coeffs > 0 )THEN
306  association_status = association_status .AND. ASSOCIATED( odps%C )
307  END IF
308  IF( odps%n_OCoeffs > 0 )THEN
309  association_status = association_status .AND. ASSOCIATED( odps%OC ) &
310  .AND. ASSOCIATED( odps%OSignificance ) &
311  .AND. ASSOCIATED( odps%Order ) &
312  .AND. ASSOCIATED( odps%OP_Index ) &
313  .AND. ASSOCIATED( odps%OPos_Index )
314  END IF
315 
316  ELSE
317  IF ( ASSOCIATED( odps%Sensor_Channel ) .OR. &
318  ASSOCIATED( odps%Component_ID ) .OR. &
319  ASSOCIATED( odps%Absorber_ID ) .OR. &
320  ASSOCIATED( odps%Ref_Level_Pressure) .OR. &
321  ASSOCIATED( odps%Ref_Pressure ) .OR. &
322  ASSOCIATED( odps%Ref_Temperature ) .OR. &
323  ASSOCIATED( odps%Ref_Absorber ) .OR. &
324  ASSOCIATED( odps%Min_Absorber ) .OR. &
325  ASSOCIATED( odps%Max_Absorber ) .OR. &
326  ASSOCIATED( odps%n_Predictors ) .OR. &
327  ASSOCIATED( odps%Pos_Index ) ) THEN
328  association_status = .true.
329  END IF
330  IF( odps%n_Coeffs > 0 )THEN
331  association_status = association_status .OR. ASSOCIATED( odps%C )
332  END IF
333  IF( odps%n_OCoeffs > 0 )THEN
334  association_status = association_status .OR. ASSOCIATED( odps%OC ) &
335  .OR. ASSOCIATED( odps%OSignificance ) &
336  .OR. ASSOCIATED( odps%Order ) &
337  .OR. ASSOCIATED( odps%OP_Index ) &
338  .OR. ASSOCIATED( odps%OPos_Index )
339  END IF
340 
341  END IF
342 
343  END FUNCTION associated_odps
344 
345 
346 !------------------------------------------------------------------------------
347 !
348 ! NAME:
349 ! Destroy_ODPS
350 !
351 ! PURPOSE:
352 ! Function to re-initialize the scalar and pointer members of ODPS
353 ! data structures.
354 !
355 ! CALLING SEQUENCE:
356 ! Error_Status = Destroy_ODPS( ODPS , & ! Output
357 ! RCS_Id =RCS_Id , & ! Revision control
358 ! Message_Log=Message_Log ) ! Error messaging
359 !
360 ! OUTPUT ARGUMENTS:
361 ! ODPS: Re-initialized ODPS structure.
362 ! UNITS: N/A
363 ! TYPE: ODPS_type
364 ! DIMENSION: Scalar
365 ! ATTRIBUTES: INTENT(IN OUT)
366 !
367 ! OPTIONAL INPUT ARGUMENTS:
368 ! Message_Log: Character string specifying a filename in which any
369 ! messages will be logged. If not specified, or if an
370 ! error occurs opening the log file, the default action
371 ! is to output messages to standard output.
372 ! UNITS: N/A
373 ! TYPE: CHARACTER(*)
374 ! DIMENSION: Scalar
375 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
376 !
377 ! OPTIONAL OUTPUT ARGUMENTS:
378 ! RCS_Id: Character string containing the Revision Control
379 ! System Id field for the module.
380 ! UNITS: N/A
381 ! TYPE: CHARACTER(*)
382 ! DIMENSION: Scalar
383 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
384 !
385 ! FUNCTION RESULT:
386 ! Error_Status: The return value is an integer defining the error status.
387 ! The error codes are defined in the Message_Handler module.
388 ! If == SUCCESS the structure re-initialisation was successful
389 ! == FAILURE - an error occurred, or
390 ! - the structure internal allocation counter
391 ! is not equal to zero (0) upon exiting this
392 ! function. This value is incremented and
393 ! decremented for every structure allocation
394 ! and deallocation respectively.
395 ! UNITS: N/A
396 ! TYPE: INTEGER
397 ! DIMENSION: Scalar
398 !
399 ! COMMENTS:
400 ! Note the INTENT on the output ODPS argument is IN OUT rather than
401 ! just OUT. This is necessary because the argument may be defined upon
402 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
403 !
404 !------------------------------------------------------------------------------
405 
406  FUNCTION destroy_odps( ODPS , & ! Output
407  No_Clear , & ! Optional input
408  RCS_Id , & ! Revision control
409  Message_Log) & ! Error messaging
410  result( error_status )
411  ! Arguments
412  TYPE(odps_type) , INTENT(IN OUT) :: odps
413  INTEGER, OPTIONAL, INTENT(IN) :: no_clear
414  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
415  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
416  ! Function result
417  INTEGER :: error_status
418  ! Local parameters
419  CHARACTER(*), PARAMETER :: routine_name = 'Destroy_ODPS'
420  ! Local variables
421  CHARACTER(ML) :: message
422  LOGICAL :: clear
423  INTEGER :: allocate_status
424 
425  ! Set up
426  ! ------
427  error_status = success
428  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
429 
430  ! Reinitialise the dimensions
431  odps%n_Layers = 0
432  odps%n_Components = 0
433  odps%n_Absorbers = 0
434  odps%n_Channels = 0
435 
436  ! Default is to clear scalar members...
437  clear = .true.
438  ! ....unless the No_Clear argument is set
439  IF ( PRESENT( no_clear ) ) THEN
440  IF ( no_clear == set ) clear = .false.
441  END IF
442  IF ( clear ) CALL clear_odps( odps )
443 
444  ! If ALL components are NOT associated, do nothing
445  IF ( .NOT. associated_odps( odps ) ) RETURN
446 
447 
448  ! Deallocate the regular arrays components
449  ! ----------------------------------------
450  DEALLOCATE( odps%Sensor_Channel , &
451  odps%Component_ID , &
452  odps%Absorber_ID , &
453  odps%Ref_Level_Pressure , &
454  odps%Ref_Pressure , &
455  odps%Ref_Temperature , &
456  odps%Ref_Absorber , &
457  odps%Min_Absorber , &
458  odps%Max_Absorber , &
459  odps%n_Predictors , &
460  odps%Pos_Index , &
461  stat=allocate_status )
462  IF ( allocate_status /= 0 ) THEN
463  error_status = failure
464  WRITE( message,'("Error deallocating ODPS components. STAT = ",i0)' ) &
465  allocate_status
466  CALL display_message( routine_name, &
467  trim(message), &
468  error_status, &
469  message_log=message_log )
470  END IF
471 
472  IF( odps%n_Coeffs > 0 )THEN
473  odps%n_Coeffs = 0
474  DEALLOCATE( odps%C , &
475  stat=allocate_status )
476  IF ( allocate_status /= 0 ) THEN
477  error_status = failure
478  WRITE( message,'("Error deallocating ODPS C component. STAT = ",i0)' ) &
479  allocate_status
480  CALL display_message( routine_name, &
481  trim(message), &
482  error_status, &
483  message_log=message_log )
484  END IF
485  END IF
486 
487  IF( odps%n_OCoeffs > 0 )THEN
488  odps%n_OCoeffs = 0
489  DEALLOCATE( odps%OC , &
490  odps%OSignificance , &
491  odps%Order , &
492  odps%OP_Index , &
493  odps%OPos_Index , &
494  stat=allocate_status )
495  IF ( allocate_status /= 0 ) THEN
496  error_status = failure
497  WRITE( message,'("Error deallocating ODPS OPTRAN component. STAT = ",i0)' ) &
498  allocate_status
499  CALL display_message( routine_name, &
500  trim(message), &
501  error_status, &
502  message_log=message_log )
503  END IF
504  END IF
505 
506  ! Decrement and test allocation counter
507  ! -------------------------------------
508  odps%n_Allocates = odps%n_Allocates - 1
509  IF ( odps%n_Allocates /= 0 ) THEN
510  error_status = failure
511  WRITE( message,'("Allocation counter /= 0, Value = ",i0)' ) &
512  odps%n_Allocates
513  CALL display_message( routine_name, &
514  trim(message), &
515  error_status, &
516  message_log=message_log )
517  END IF
518  END FUNCTION destroy_odps
519 
520 
521 !------------------------------------------------------------------------------
522 !
523 ! NAME:
524 ! Allocate_ODPS
525 !
526 ! PURPOSE:
527 ! Function to allocate the pointer members of the ODPS
528 ! data structure.
529 !
530 ! CALLING SEQUENCE:
531 ! Error_Status = Allocate_ODPS( n_Layers , & ! Input
532 ! n_Components , & ! Input
533 ! n_Absorbers , & ! Input
534 ! n_Channels , & ! Input
535 ! n_Coeffs , & ! Input
536 ! ODPS , & ! Output
537 ! RCS_Id =RCS_Id , & ! Revision control
538 ! Message_Log=Message_Log ) ! Error messaging
539 !
540 ! INPUT ARGUMENTS:
541 ! n_Layers: The number of profile layers
542 ! UNITS: N/A
543 ! TYPE: INTEGER
544 ! DIMENSION: Scalar
545 ! ATTRIBUTES: INTENT(IN)
546 !
547 ! n_Components: The number of transmittance components (i.g. dry & wlo)
548 ! UNITS: N/A
549 ! TYPE: INTEGER
550 ! DIMENSION: Scalar
551 ! ATTRIBUTES: INTENT(IN)
552 !
553 ! n_Absorbers: The number of absorbers dimension (i.g H2O & O3).
554 ! UNITS: N/A
555 ! TYPE: INTEGER
556 ! DIMENSION: Scalar
557 ! ATTRIBUTES: INTENT(IN)
558 !
559 ! n_Channels: Number of channels dimension.
560 ! Must be > 0.
561 ! UNITS: N/A
562 ! TYPE: INTEGER
563 ! DIMENSION: Scalar
564 ! ATTRIBUTES: INTENT(IN)
565 !
566 ! n_Coeffs: The total number of tau coefficients.
567 ! Note, the Coeff data are now stored in a one-dimensional
568 ! array
569 ! UNITS: N/A
570 ! TYPE: INTEGER
571 ! DIMENSION: Scalar
572 ! ATTRIBUTES: INTENT(IN)
573 !
574 !!
575 ! OUTPUT ARGUMENTS:
576 ! ODPS: ODPS structure with allocated
577 ! pointer members
578 ! UNITS: N/A
579 ! TYPE: ODPS_type
580 ! DIMENSION: Scalar
581 ! ATTRIBUTES: INTENT(OUT)
582 !
583 ! OPTIONAL INPUT ARGUMENTS:
584 ! Message_Log: Character string specifying a filename in
585 ! which any messages will be logged. If not
586 ! specified, or if an error occurs opening
587 ! the log file, the default action is to
588 ! output messages to standard output.
589 ! UNITS: N/A
590 ! TYPE: CHARACTER(*)
591 ! DIMENSION: Scalar
592 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
593 !
594 ! OPTIONAL OUTPUT ARGUMENTS:
595 ! RCS_Id: Character string containing the Revision Control
596 ! System Id field for the module.
597 ! UNITS: N/A
598 ! TYPE: CHARACTER(*)
599 ! DIMENSION: Scalar
600 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
601 !
602 ! FUNCTION RESULT:
603 ! Error_Status: The return value is an integer defining the error status.
604 ! The error codes are defined in the Message_Handler module.
605 ! If == SUCCESS the structure re-initialisation was successful
606 ! == FAILURE - an error occurred, or
607 ! - the structure internal allocation counter
608 ! is not equal to one (1) upon exiting this
609 ! function. This value is incremented and
610 ! decremented for every structure allocation
611 ! and deallocation respectively.
612 ! UNITS: N/A
613 ! TYPE: INTEGER
614 ! DIMENSION: Scalar
615 !
616 ! COMMENTS:
617 ! Note the INTENT on the output ODPS argument is IN OUT rather than
618 ! just OUT. This is necessary because the argument may be defined upon
619 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
620 !
621 !------------------------------------------------------------------------------
622 
623  FUNCTION allocate_odps( n_Layers , & ! Input
624  n_Components, & ! Input
625  n_Absorbers, & ! Input
626  n_Channels , & ! Input
627  n_Coeffs , & ! Input
628  ODPS , & ! Output
629  RCS_Id , & ! Revision control
630  Message_Log ) & ! Error messaging
631  result( error_status )
632  ! Arguments
633  INTEGER , INTENT(IN) :: n_layers
634  INTEGER , INTENT(IN) :: n_components
635  INTEGER , INTENT(IN) :: n_absorbers
636  INTEGER , INTENT(IN) :: n_channels
637  INTEGER , INTENT(IN) :: n_coeffs
638  TYPE(odps_type) , INTENT(IN OUT) :: odps
639  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
640  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
641  ! Function result
642  INTEGER :: error_status
643  ! Local parameters
644  CHARACTER(*), PARAMETER :: routine_name = 'Allocate_ODPS'
645  ! Local variables
646  CHARACTER(ML) :: message
647  INTEGER :: allocate_status
648 
649  ! Set up
650  ! ------
651  error_status = success
652  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
653 
654  ! Check dimension input
655  IF ( n_layers < 1 .OR. &
656  n_components < 1 .OR. &
657  n_absorbers < 1 .OR. &
658  n_channels < 1 .OR. &
659  n_coeffs < 0 ) THEN
660  error_status = failure
661  CALL display_message( routine_name, &
662  "The input ODPS dimension must be >= 0 "//&
663  "and other dimensions must be > 0", &
664  error_status, &
665  message_log=message_log )
666  RETURN
667  END IF
668 
669  ! Check if ANY pointers are already associated.
670  ! If they are, deallocate them but leave scalars.
671  IF ( associated_odps( odps, any_test=set ) ) THEN
672  error_status = destroy_odps( odps, &
673  no_clear=set, &
674  message_log=message_log )
675  IF ( error_status /= success ) THEN
676  CALL display_message( routine_name, &
677  'Error deallocating ODPS prior to reallocation.', &
678  error_status, &
679  message_log=message_log )
680  RETURN
681  END IF
682  END IF
683 
684  ! Allocate the data arrays
685  ! ------------------------
686  ALLOCATE( odps%Sensor_Channel( n_channels ), &
687  odps%Component_ID( n_components ), &
688  odps%Absorber_ID( n_absorbers ), &
689  odps%Ref_Level_Pressure( 0:n_layers ), &
690  odps%Ref_Pressure( n_layers ), &
691  odps%Ref_Temperature( n_layers ), &
692  odps%Ref_Absorber( n_layers, n_absorbers ), &
693  odps%Min_Absorber( n_layers, n_absorbers ), &
694  odps%Max_Absorber( n_layers, n_absorbers ), &
695  odps%n_Predictors( n_components, n_channels ), &
696  odps%Pos_Index( n_components, n_channels ), &
697  stat=allocate_status )
698  IF ( allocate_status /= 0 ) THEN
699  error_status = failure
700  WRITE( message,'("Error allocating ODPS data arrays. STAT = ",i0)' ) &
701  allocate_status
702  CALL display_message( routine_name, &
703  trim(message), &
704  error_status, &
705  message_log=message_log )
706  RETURN
707  END IF
708 
709  IF( n_coeffs > 0 )THEN
710  ALLOCATE( odps%C( n_coeffs ), &
711  stat=allocate_status )
712  IF ( allocate_status /= 0 ) THEN
713  error_status = failure
714  WRITE( message,'("Error allocating the ODPS C array. STAT = ",i0)' ) &
715  allocate_status
716  CALL display_message( routine_name, &
717  trim(message), &
718  error_status, &
719  message_log=message_log )
720  RETURN
721  END IF
722  END IF
723 
724  ! Assign the dimensions and initialise arrays
725  odps%n_Layers = n_layers
726  odps%n_Components = n_components
727  odps%n_Absorbers = n_absorbers
728  odps%n_Channels = n_channels
729  odps%n_Coeffs = n_coeffs
730 
731  odps%Sensor_Channel = 0
732  odps%Component_ID = ip_invalid
733  odps%n_Predictors = 0
734  odps%Pos_Index = 0
735 
736  ! Increment and test allocation counter
737  ! -------------------------------------
738  odps%n_Allocates = odps%n_Allocates + 1
739  IF ( odps%n_Allocates /= 1 ) THEN
740  error_status = failure
741  WRITE( message,'("Allocation counter /= 1, Value = ",i0)' ) &
742  odps%n_Allocates
743  CALL display_message( routine_name, &
744  trim(message), &
745  error_status, &
746  message_log=message_log )
747  RETURN
748  END IF
749 
750  END FUNCTION allocate_odps
751 
752 !------------------------------------------------------------------------------
753 !
754 ! NAME:
755 ! Allocate_ODPS_OPTRAN
756 !
757 ! PURPOSE:
758 ! Function to allocate the pointer members of the ODPS OPTRAN related members
759 ! *** Note: the Allocate_ODPS rouitne must be called before calling this routine
760 ! to allocate memory for other ODPS members
761 !
762 ! CALLING SEQUENCE:
763 ! Error_Status = Allocate_ODPS( n_OCoeffs , & ! Input
764 ! ODPS , & ! IN/Output
765 ! RCS_Id =RCS_Id , & ! Revision control
766 ! Message_Log=Message_Log ) ! Error messaging
767 !
768 ! INPUT ARGUMENTS:
769 ! n_OCoeffs: The total number of OPTRAN tau coefficients.
770 ! Note, the Coeff data are now stored in a one-dimensional
771 ! array
772 ! UNITS: N/A
773 ! TYPE: INTEGER
774 ! DIMENSION: Scalar
775 ! ATTRIBUTES: INTENT(IN)
776 !!
777 ! IN/OUTPUT ARGUMENTS:
778 ! ODPS: ODPS structure with allocated OPTRAN related
779 ! pointer members
780 ! UNITS: N/A
781 ! TYPE: ODPS_type
782 ! DIMENSION: Scalar
783 ! ATTRIBUTES: INTENT(INOUT)
784 !
785 ! OPTIONAL INPUT ARGUMENTS:
786 ! Message_Log: Character string specifying a filename in
787 ! which any messages will be logged. If not
788 ! specified, or if an error occurs opening
789 ! the log file, the default action is to
790 ! output messages to standard output.
791 ! UNITS: N/A
792 ! TYPE: CHARACTER(*)
793 ! DIMENSION: Scalar
794 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
795 !
796 ! OPTIONAL OUTPUT ARGUMENTS:
797 ! RCS_Id: Character string containing the Revision Control
798 ! System Id field for the module.
799 ! UNITS: N/A
800 ! TYPE: CHARACTER(*)
801 ! DIMENSION: Scalar
802 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
803 !
804 ! FUNCTION RESULT:
805 ! Error_Status: The return value is an integer defining the error status.
806 ! The error codes are defined in the Message_Handler module.
807 ! If == SUCCESS the structure re-initialisation was successful
808 ! == FAILURE - an error occurred, or
809 ! - the structure internal allocation counter
810 ! is not equal to one (1) upon exiting this
811 ! function. This value is incremented and
812 ! decremented for every structure allocation
813 ! and deallocation respectively.
814 ! UNITS: N/A
815 ! TYPE: INTEGER
816 ! DIMENSION: Scalar
817 !
818 ! COMMENTS:
819 ! Note the INTENT on the output ODPS argument is IN OUT rather than
820 ! just OUT. This is necessary because the argument may be defined upon
821 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
822 !
823 !------------------------------------------------------------------------------
824 
825  FUNCTION allocate_odps_optran( n_OCoeffs , & ! Input
826  ODPS , & ! Output
827  RCS_Id , & ! Revision control
828  Message_Log ) & ! Error messaging
829  result( error_status )
830  ! Arguments
831  INTEGER , INTENT(IN) :: n_ocoeffs
832  TYPE(odps_type) , INTENT(IN OUT) :: odps
833  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
834  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
835  ! Function result
836  INTEGER :: error_status
837  ! Local parameters
838  CHARACTER(*), PARAMETER :: routine_name = 'Allocate_ODPS_OPTRAN'
839  ! Local variables
840  CHARACTER(ML) :: message
841  INTEGER :: allocate_status
842 
843  ! Set up
844  ! ------
845  error_status = success
846  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
847 
848  IF ( n_ocoeffs < 1 ) THEN
849  error_status = failure
850  CALL display_message( routine_name, &
851  "The input ODPS n_OCoeffs dimension must be > 0 ",&
852  error_status, &
853  message_log=message_log )
854  RETURN
855  END IF
856 
857  ! Check dimension input
858  IF ( odps%n_Channels < 1 ) THEN
859  error_status = failure
860  CALL display_message( routine_name, &
861  "The input ODPS n_Channels dimension must be > 0 ",&
862  error_status, &
863  message_log=message_log )
864  RETURN
865  END IF
866 
867  ! If OPTRAN data arrays have already been allocated, deallocate them
868  IF ( odps%n_OCoeffs > 0 ) THEN
869  DEALLOCATE( odps%OSignificance,&
870  odps%Order, &
871  odps%OP_Index, &
872  odps%OPos_Index, &
873  odps%OC, &
874  stat=allocate_status )
875  IF ( allocate_status /= 0 ) THEN
876  error_status = failure
877  WRITE( message,'("Error deallocating ODPS OPTRAN component prior to reallocation. STAT = ",i0)' ) &
878  allocate_status
879  CALL display_message( routine_name, &
880  trim(message), &
881  error_status, &
882  message_log=message_log )
883  END IF
884  END IF
885 
886  ! Allocate the data arrays
887  ! ------------------------
888  ALLOCATE( odps%OSignificance( odps%n_Channels ), &
889  odps%Order( odps%n_Channels ) , &
890  odps%OP_Index( 0:n_predictor_used_optran, odps%n_Channels ), &
891  odps%OPos_Index( odps%n_Channels), &
892  odps%OC( n_ocoeffs ), &
893  stat=allocate_status )
894  IF ( allocate_status /= 0 ) THEN
895  error_status = failure
896  WRITE( message,'("Error allocating ODPS OPTRAN data arrays. STAT = ",i0)' ) &
897  allocate_status
898  CALL display_message( routine_name, &
899  trim(message), &
900  error_status, &
901  message_log=message_log )
902  RETURN
903  END IF
904 
905  ! Assign the dimensions and initialise arrays
906  odps%n_OCoeffs = n_ocoeffs
907 
908  END FUNCTION allocate_odps_optran
909 
910 !------------------------------------------------------------------------------
911 !
912 ! NAME:
913 ! Assign_ODPS
914 !
915 ! PURPOSE:
916 ! Function to copy valid ODPS structures.
917 !
918 ! CALLING SEQUENCE:
919 ! Error_Status = Assign_ODPS( ODPS_in , & ! Input
920 ! ODPS_out , & ! Output
921 ! RCS_Id =RCS_Id , & ! Revision control
922 ! Message_Log=Message_Log ) ! Error messaging
923 !
924 ! INPUT ARGUMENTS:
925 ! ODPS_in: ODPS structure which is to be copied.
926 ! UNITS: N/A
927 ! TYPE: ODPS_type
928 ! DIMENSION: Scalar
929 ! ATTRIBUTES: INTENT(IN)
930 !
931 ! OUTPUT ARGUMENTS:
932 ! ODPS_out: Copy of the input structure, ODPS_in.
933 ! UNITS: N/A
934 ! TYPE: ODPS_type
935 ! DIMENSION: Scalar
936 ! ATTRIBUTES: INTENT(IN OUT)
937 !
938 ! OPTIONAL INPUT ARGUMENTS:
939 ! Message_Log: Character string specifying a filename in which any
940 ! messages will be logged. If not specified, or if an
941 ! error occurs opening the log file, the default action
942 ! is to output messages to standard output.
943 ! UNITS: N/A
944 ! TYPE: CHARACTER(*)
945 ! DIMENSION: Scalar
946 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
947 !
948 ! OPTIONAL OUTPUT ARGUMENTS:
949 ! RCS_Id: Character string containing the Revision Control
950 ! System Id field for the module.
951 ! UNITS: N/A
952 ! TYPE: CHARACTER(*)
953 ! DIMENSION: Scalar
954 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
955 !
956 ! FUNCTION RESULT:
957 ! Error_Status: The return value is an integer defining the error status.
958 ! The error codes are defined in the Message_Handler module.
959 ! If == SUCCESS the structure assignment was successful
960 ! == FAILURE an error occurred
961 ! UNITS: N/A
962 ! TYPE: INTEGER
963 ! DIMENSION: Scalar
964 !
965 ! COMMENTS:
966 ! Note the INTENT on the output ODPS argument is IN OUT rather than
967 ! just OUT. This is necessary because the argument may be defined upon
968 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
969 !
970 !------------------------------------------------------------------------------
971 
972  FUNCTION assign_odps( ODPS_in , & ! Input
973  ODPS_out , & ! Output
974  RCS_Id , & ! Revision control
975  Message_Log ) & ! Error messaging
976  result( error_status )
977  ! Arguments
978  TYPE(odps_type) , INTENT(IN) :: odps_in
979  TYPE(odps_type) , INTENT(IN OUT) :: odps_out
980  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
981  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
982  ! Function result
983  INTEGER :: error_status
984  ! Local parameters
985  CHARACTER(*), PARAMETER :: routine_name = 'Assign_ODPS'
986 
987  ! Set up
988  ! ------
989  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
990 
991  ! ALL *input* pointers must be associated
992  IF ( .NOT. associated_odps( odps_in ) ) THEN
993  error_status = failure
994  CALL display_message( routine_name, &
995  'Some or all INPUT ODPS pointer '//&
996  'members are NOT associated.', &
997  error_status, &
998  message_log=message_log )
999  RETURN
1000  END IF
1001 
1002 
1003  ! Allocate the structure
1004  ! ----------------------
1005  error_status = allocate_odps( odps_in%n_Layers , &
1006  odps_in%n_Components, &
1007  odps_in%n_Absorbers , &
1008  odps_in%n_Channels , &
1009  odps_in%n_Coeffs, &
1010  odps_out, &
1011  message_log=message_log )
1012  IF ( error_status /= success ) THEN
1013  CALL display_message( routine_name, &
1014  'Error allocating output ODPS arrays.', &
1015  error_status, &
1016  message_log=message_log )
1017  RETURN
1018  END IF
1019 
1020 
1021  ! Assign intrinsic data types
1022  ! ---------------------------
1023  odps_out%Release = odps_in%Release
1024  odps_out%Version = odps_in%Version
1025 
1026  odps_out%Group_Index = odps_in%Group_Index
1027  odps_out%Sensor_Id = odps_in%Sensor_Id
1028  odps_out%Sensor_Type = odps_in%Sensor_Type
1029  odps_out%WMO_Satellite_ID = odps_in%WMO_Satellite_ID
1030  odps_out%WMO_Sensor_ID = odps_in%WMO_Sensor_ID
1031  odps_out%Sensor_Channel = odps_in%Sensor_Channel
1032  odps_out%Component_ID = odps_in%Component_ID
1033  odps_out%Absorber_ID = odps_in%Absorber_ID
1034  odps_out%Ref_Level_Pressure= odps_in%Ref_Level_Pressure
1035  odps_out%Ref_Pressure = odps_in%Ref_Pressure
1036  odps_out%Ref_Temperature = odps_in%Ref_Temperature
1037  odps_out%Ref_Absorber = odps_in%Ref_Absorber
1038  odps_out%Min_Absorber = odps_in%Min_Absorber
1039  odps_out%Max_Absorber = odps_in%Max_Absorber
1040  odps_out%n_Predictors = odps_in%n_Predictors
1041  odps_out%Pos_Index = odps_in%Pos_Index
1042  IF( odps_in%n_Coeffs > 0 )THEN
1043  odps_out%C = odps_in%C
1044  END IF
1045 
1046  ! the OPTRAN part if it is not empty
1047  IF(odps_in%n_OCoeffs > 0)THEN
1048  error_status = allocate_odps_optran( odps_in%n_OCoeffs, &
1049  odps_out, &
1050  message_log=message_log )
1051  IF ( error_status /= success ) THEN
1052  CALL display_message( routine_name, &
1053  'Error allocating output ODPS OPTRAN data arrays.', &
1054  error_status, &
1055  message_log=message_log )
1056  RETURN
1057  END IF
1058 
1059  odps_out%OC = odps_in%OC
1060  odps_out%OSignificance = odps_in%OSignificance
1061  odps_out%Order = odps_in%Order
1062  odps_out%OP_Index = odps_in%OP_Index
1063  odps_out%OPos_Index = odps_in%OPos_Index
1064  odps_out%OComponent_Index = odps_in%OComponent_Index
1065  odps_out%Alpha = odps_in%Alpha
1066  odps_out%Alpha_C1 = odps_in%Alpha_C1
1067  odps_out%Alpha_C2 = odps_in%Alpha_C2
1068 
1069  END IF
1070 
1071  END FUNCTION assign_odps
1072 
1073 
1074 !------------------------------------------------------------------------------
1075 !
1076 ! NAME:
1077 ! Concatenate_Channel_ODPS
1078 !
1079 ! PURPOSE:
1080 ! Function to concatenate two valid ODPS structures along
1081 ! the channel dimension.
1082 !
1083 ! CALLING SEQUENCE:
1084 ! Error_Status = Concatenate_Channel_ODPS( ODPS1 , & ! Input/Output
1085 ! ODPS2 , & ! Input
1086 ! RCS_Id = RCS_Id , & ! Revision control
1087 ! Message_Log=Message_Log ) ! Error messaging
1088 !
1089 ! INPUT ARGUMENTS:
1090 ! ODPS1: First ODPS structure to concatenate.
1091 ! UNITS: N/A
1092 ! TYPE: ODPS_type
1093 ! DIMENSION: Scalar
1094 ! ATTRIBUTES: INTENT(IN OUT)
1095 !
1096 ! ODPS2: Second ODPS structure to concatenate.
1097 ! UNITS: N/A
1098 ! TYPE: ODPS_type
1099 ! DIMENSION: Scalar
1100 ! ATTRIBUTES: INTENT(IN)
1101 !
1102 ! OUTPUT ARGUMENTS:
1103 ! ODPS1: The concatenated ODPS structure. The order of
1104 ! concatenation is ODPS1,ODPS2 along the
1105 ! channel dimension.
1106 ! UNITS: N/A
1107 ! TYPE: ODPS_type
1108 ! DIMENSION: Scalar
1109 ! ATTRIBUTES: INTENT(IN OUT)
1110 !
1111 ! OPTIONAL INPUT ARGUMENTS:
1112 ! Message_Log: Character string specifying a filename in which any
1113 ! messages will be logged. If not specified, or if an
1114 ! error occurs opening the log file, the default action
1115 ! is to output messages to standard output.
1116 ! UNITS: N/A
1117 ! TYPE: CHARACTER(*)
1118 ! DIMENSION: Scalar
1119 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1120 !
1121 ! OPTIONAL OUTPUT ARGUMENTS:
1122 ! RCS_Id: Character string containing the Revision Control
1123 ! System Id field for the module.
1124 ! UNITS: N/A
1125 ! TYPE: CHARACTER(*)
1126 ! DIMENSION: Scalar
1127 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1128 !
1129 ! FUNCTION RESULT:
1130 ! Error_Status: The return value is an integer defining the error status.
1131 ! The error codes are defined in the Message_Handler module.
1132 ! If == SUCCESS the structure concatenation was successful
1133 ! == FAILURE an error occurred
1134 ! UNITS: N/A
1135 ! TYPE: INTEGER
1136 ! DIMENSION: Scalar
1137 !
1138 ! SIDE EFFECTS:
1139 ! The input ODPS1 argument contains the concatenated structure
1140 ! data (in character-speak: ODPS1//ODPS2) on output. It is
1141 ! reallocated within this routine so if an error occurs during the
1142 ! reallocation, the contents of the input ODPS1 structure will
1143 ! be lost.
1144 !
1145 ! Because of the structure reallocation there is a potential that
1146 ! available memory will become fragmented. Use this routine in a
1147 ! manner that will minimise this effect (e.g. destroying structures or
1148 ! allocatable arrays in the opposite order in which they were created).
1149 !
1150 !------------------------------------------------------------------------------
1151 
1152  FUNCTION concatenate_channel_odps( ODPS1 , & ! Input/Output
1153  ODPS2 , & ! Input
1154  RCS_Id , & ! Revision control
1155  Message_Log) & ! Error messaging
1156  result( error_status )
1157  ! Arguments
1158  TYPE(odps_type) , INTENT(IN OUT) :: odps1
1159  TYPE(odps_type) , INTENT(IN) :: odps2
1160  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1161  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1162  ! Function result
1163  INTEGER :: error_status
1164  ! Local parameters
1165  CHARACTER(*), PARAMETER :: routine_name = 'Concatenate_Channel_ODPS'
1166  ! Local variables
1167  INTEGER :: destroy_status
1168  INTEGER :: n_channels, l1, l2
1169  INTEGER(Long) :: n_coeffs, n_ocoeffs
1170  TYPE(odps_type) :: odps_tmp
1171 
1172  ! Set up
1173  ! ------
1174  error_status = success
1175  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
1176 
1177  ! Check structures
1178  IF ( .NOT. associated_odps( odps1 ) ) THEN
1179  error_status = failure
1180  CALL display_message( routine_name, &
1181  'Some or all INPUT ODPS1 pointer '//&
1182  'members are NOT associated.', &
1183  error_status, &
1184  message_log=message_log )
1185  RETURN
1186  END IF
1187  IF ( .NOT. associated_odps( odps2 ) ) THEN
1188  error_status = failure
1189  CALL display_message( routine_name, &
1190  'Some or all INPUT ODPS2 pointer '//&
1191  'members are NOT associated.', &
1192  error_status, &
1193  message_log=message_log )
1194  RETURN
1195  END IF
1196 
1197  ! Compare structure release/version
1198  IF ( odps1%Release /= odps2%Release ) THEN
1199  error_status = failure
1200  CALL display_message( routine_name, &
1201  'Input ODPS Release values are different.', &
1202  error_status, &
1203  message_log=message_log )
1204  RETURN
1205  END IF
1206  IF ( odps1%Version /= odps2%Version ) THEN
1207  CALL display_message( routine_name, &
1208  'Input ODPS Version values are different.', &
1209  warning, &
1210  message_log=message_log )
1211 
1212  END IF
1213 
1214  ! Check non-channel dimensions
1215  IF ( odps1%n_Layers /= odps2%n_Layers .OR. &
1216  odps1%n_Components /= odps2%n_Components .OR. &
1217  odps1%n_Absorbers /= odps2%n_Absorbers ) THEN
1218  error_status = failure
1219  CALL display_message( routine_name, &
1220  'Non-channel ODPS dimensions are different.', &
1221  error_status, &
1222  message_log=message_log )
1223  RETURN
1224  END IF
1225 
1226  ! Check the group ID
1227  IF ( odps1%Group_Index /= odps2%Group_Index )THEN
1228  error_status = failure
1229  CALL display_message( routine_name, &
1230  'ODPS Group ID values are different.', &
1231  error_status, &
1232  message_log=message_log )
1233  RETURN
1234  END IF
1235 
1236  ! Check the sensor ID values
1237  IF ( odps1%Sensor_ID /= odps2%Sensor_ID .OR. &
1238  odps1%WMO_Satellite_ID /= odps2%WMO_Satellite_ID .OR. &
1239  odps1%WMO_Sensor_ID /= odps2%WMO_Sensor_ID ) THEN
1240  error_status = failure
1241  CALL display_message( routine_name, &
1242  'ODPS sensor ID values are different.', &
1243  error_status, &
1244  message_log=message_log )
1245  RETURN
1246  END IF
1247 
1248  ! Check the component ID and absorber ID
1249  IF ( any(odps1%Component_ID /= odps2%Component_ID) .OR. &
1250  any(odps1%Absorber_ID /= odps2%Absorber_ID) ) THEN
1251  error_status = failure
1252  CALL display_message( routine_name, &
1253  'ODPS component ID or absorber ID values are different.', &
1254  error_status, &
1255  message_log=message_log )
1256  RETURN
1257  END IF
1258 
1259  ! Reallocate the first structure
1260  ! ------------------------------
1261  ! Copy it...
1262  error_status = assign_odps( odps1, odps_tmp, &
1263  message_log=message_log )
1264  IF ( error_status /= success ) THEN
1265  CALL display_message( routine_name, &
1266  'Error copying ODPS1 structure.', &
1267  error_status, &
1268  message_log=message_log )
1269  RETURN
1270  END IF
1271 
1272  ! ... now destroy it ...
1273  error_status = destroy_odps( odps1, &
1274  message_log=message_log )
1275  IF ( error_status /= success ) THEN
1276  CALL display_message( routine_name, &
1277  'Error destroying ODPS1 structure.', &
1278  error_status, &
1279  message_log=message_log )
1280  RETURN
1281  END IF
1282 
1283  ! ... and now re-allocate it for all channels
1284  n_channels = odps_tmp%n_Channels + odps2%n_Channels
1285  n_coeffs = odps_tmp%n_Coeffs + odps2%n_Coeffs
1286  error_status = allocate_odps( odps_tmp%n_Layers, &
1287  odps_tmp%n_Components, &
1288  odps_tmp%n_Absorbers, &
1289  n_channels, &
1290  n_coeffs, &
1291  odps1, &
1292  message_log=message_log )
1293  IF ( error_status /= success ) THEN
1294  CALL display_message( routine_name, &
1295  'Error reallocating ODPS1 structure.', &
1296  error_status, &
1297  message_log=message_log )
1298  RETURN
1299  END IF
1300 
1301  ! Allocate memory for the C-OPTRAN part
1302  n_ocoeffs = odps_tmp%n_OCoeffs + odps2%n_OCoeffs
1303  IF( n_ocoeffs > 0 )THEN
1304  IF( odps_tmp%n_OCoeffs * odps2%n_OCoeffs == 0 )THEN
1305  CALL display_message( routine_name, &
1306  'ODPS OPTRAN data in the two ODPS structures are not consistent.', &
1307  failure, &
1308  message_log=message_log )
1309  RETURN
1310  END IF
1311 
1312  error_status = allocate_odps_optran( n_ocoeffs, &
1313  odps1, &
1314  message_log=message_log )
1315  IF ( error_status /= success ) THEN
1316  CALL display_message( routine_name, &
1317  'Error reallocating ODPS1 OPTRAN data arrays.', &
1318  error_status, &
1319  message_log=message_log )
1320  RETURN
1321  END IF
1322  END IF
1323 
1324  ! Assign the non-channel data
1325  ! ---------------------------------
1326  odps1%Version = max(odps_tmp%Version, odps2%Version)
1327  odps1%Group_Index = odps_tmp%Group_Index
1328  odps1%Sensor_ID = odps_tmp%Sensor_ID
1329  odps1%Sensor_type = odps_tmp%Sensor_type
1330  odps1%WMO_Satellite_ID = odps_tmp%WMO_Satellite_ID
1331  odps1%WMO_Sensor_ID = odps_tmp%WMO_Sensor_ID
1332  odps1%Component_ID = odps_tmp%Component_ID
1333  odps1%Absorber_ID = odps_tmp%Absorber_ID
1334  odps1%Ref_Level_Pressure= odps_tmp%Ref_Level_Pressure
1335  odps1%Ref_Pressure = odps_tmp%Ref_Pressure
1336  odps1%Ref_Temperature = odps_tmp%Ref_Temperature
1337  odps1%Ref_Absorber = odps_tmp%Ref_Absorber
1338  odps1%Min_Absorber = odps_tmp%Min_Absorber
1339  odps1%Max_Absorber = odps_tmp%Max_Absorber
1340  ! OPTRAN
1341  odps1%OComponent_Index = odps_tmp%OComponent_Index
1342  odps1%Alpha = odps_tmp%Alpha
1343  odps1%Alpha_C1 = odps_tmp%Alpha_C1
1344  odps1%Alpha_C2 = odps_tmp%Alpha_C2
1345 
1346  ! Concatenate the channel array data
1347  ! ----------------------------------
1348  ! The first part...
1349  l1 = 1
1350  l2 = odps_tmp%n_Channels
1351  odps1%Sensor_Channel(l1:l2) = odps_tmp%Sensor_Channel
1352  odps1%n_Predictors(:,l1:l2) = odps_tmp%n_Predictors
1353  odps1%Pos_Index(:,l1:l2) = odps_tmp%Pos_Index
1354 
1355  IF( odps_tmp%n_Coeffs > 0 )THEN
1356  odps1%C(l1:odps_tmp%n_Coeffs) = odps_tmp%C
1357  END IF
1358 
1359  ! COPTRAN part
1360  IF( odps_tmp%n_OCoeffs > 0 )THEN
1361  odps1%OC(l1:odps_tmp%n_OCoeffs)= odps_tmp%OC
1362  odps1%OSignificance(l1:l2) = odps_tmp%OSignificance
1363  odps1%Order(l1:l2) = odps_tmp%Order
1364  odps1%OP_Index(:,l1:l2) = odps_tmp%OP_Index
1365  odps1%OPos_Index(l1:l2) = odps_tmp%OPos_Index
1366  END IF
1367 
1368  ! ...and the second part
1369  l1 = l2 + 1
1370  l2 = n_channels
1371  odps1%Sensor_Channel(l1:l2) = odps2%Sensor_Channel
1372  odps1%n_Predictors(:,l1:l2) = odps2%n_Predictors
1373  odps1%Pos_Index(:,l1:l2) = odps2%Pos_Index + odps_tmp%n_Coeffs
1374 
1375  IF( odps2%n_Coeffs > 0 )THEN
1376  odps1%C(odps_tmp%n_Coeffs+1:n_coeffs) = odps2%C
1377  END IF
1378 
1379  ! COPTRAN part
1380  IF( odps2%n_OCoeffs > 0 )THEN
1381  odps1%OC(odps_tmp%n_OCoeffs+1:n_ocoeffs)= odps2%OC
1382  odps1%OSignificance(l1:l2) = odps2%OSignificance
1383  odps1%Order(l1:l2) = odps2%Order
1384  odps1%OP_Index(:,l1:l2) = odps2%OP_Index
1385  odps1%OPos_Index(l1:l2) = odps2%OPos_Index
1386  END IF
1387 
1388  ! Destroy the temporary structure
1389  ! -------------------------------
1390  destroy_status = destroy_odps( odps_tmp, &
1391  message_log=message_log )
1392  IF ( destroy_status /= success ) THEN
1393  CALL display_message( routine_name, &
1394  'Error destroying ODPS_Tmp structure.', &
1395  warning, &
1396  message_log=message_log )
1397  END IF
1398 
1399  END FUNCTION concatenate_channel_odps
1400 
1401 
1402 !------------------------------------------------------------------------------
1403 !
1404 ! NAME:
1405 ! Concatenate_Absorber_ODPS
1406 !
1407 ! PURPOSE:
1408 ! Function to concatenate two valid ODPS structures along
1409 ! the absorber dimension.
1410 !
1411 ! CALLING SEQUENCE:
1412 ! Error_Status = Concatenate_Absorber_ODPS( ODPS1 , & ! Input/Output
1413 ! ODPS2 , & ! Input
1414 ! RCS_Id = RCS_Id , & ! Revision control
1415 ! Message_Log=Message_Log ) ! Error messaging
1416 !
1417 ! INPUT ARGUMENTS:
1418 ! ODPS1: First ODPS structure to concatenate.
1419 ! UNITS: N/A
1420 ! TYPE: ODPS_type
1421 ! DIMENSION: Scalar
1422 ! ATTRIBUTES: INTENT(IN OUT)
1423 !
1424 ! ODPS2: Second ODPS structure to concatenate.
1425 ! UNITS: N/A
1426 ! TYPE: ODPS_type
1427 ! DIMENSION: Scalar
1428 ! ATTRIBUTES: INTENT(IN)
1429 !
1430 ! OUTPUT ARGUMENTS:
1431 ! ODPS1: The concatenated ODPS structure. The order of
1432 ! concatenation is ODPS1,ODPS2 along the
1433 ! absorber dimension.
1434 ! UNITS: N/A
1435 ! TYPE: ODPS_type
1436 ! DIMENSION: Scalar
1437 ! ATTRIBUTES: INTENT(IN OUT)
1438 !
1439 ! OPTIONAL INPUT ARGUMENTS:
1440 ! Message_Log: Character string specifying a filename in which any
1441 ! messages will be logged. If not specified, or if an
1442 ! error occurs opening the log file, the default action
1443 ! is to output messages to standard output.
1444 ! UNITS: N/A
1445 ! TYPE: CHARACTER(*)
1446 ! DIMENSION: Scalar
1447 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1448 !
1449 ! OPTIONAL OUTPUT ARGUMENTS:
1450 ! RCS_Id: Character string containing the Revision Control
1451 ! System Id field for the module.
1452 ! UNITS: N/A
1453 ! TYPE: CHARACTER(*)
1454 ! DIMENSION: Scalar
1455 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1456 !
1457 ! FUNCTION RESULT:
1458 ! Error_Status: The return value is an integer defining the error status.
1459 ! The error codes are defined in the Message_Handler module.
1460 ! If == SUCCESS the structure concatenation was successful
1461 ! == FAILURE an error occurred.
1462 ! UNITS: N/A
1463 ! TYPE: INTEGER
1464 ! DIMENSION: Scalar
1465 !
1466 ! SIDE EFFECTS:
1467 ! The input ODPS1 argument contains the concatenated structure
1468 ! data (in character-speak: ODPS1//ODPS2) on output. It is
1469 ! reallocated within this routine so if an error occurs during the
1470 ! reallocation, the contents of the input ODPS1 structure will
1471 ! be lost.
1472 !
1473 ! Because of the structure reallocation there is a potential that
1474 ! available memory will become fragmented. Use this routine in a
1475 ! manner that will minimise this effect (e.g. destroying structures or
1476 ! allocatable arrays in the opposite order in which they were created).
1477 !
1478 !------------------------------------------------------------------------------
1479 
1480  FUNCTION concatenate_absorber_odps( ODPS1 , & ! Input/Output
1481  ODPS2 , & ! Input
1482  RCS_Id , & ! Revision control
1483  Message_Log) & ! Error messaging
1484  result( error_status )
1485  ! Arguments
1486  TYPE(odps_type) , INTENT(IN OUT) :: odps1
1487  TYPE(odps_type) , INTENT(IN) :: odps2
1488  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1489  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1490  ! Function result
1491  INTEGER :: error_status
1492  ! Local parameters
1493  CHARACTER(*), PARAMETER :: routine_name = 'Concatenate_Absorber_ODPS'
1494  ! Local variables
1495  INTEGER :: destroy_status
1496  INTEGER :: i, j, l, n_components, n_layers, n_absorbers
1497  INTEGER(Long) :: j1, j2, m, n, n_coeffs
1498  INTEGER :: indx(32)
1499  TYPE(odps_type) :: odps_tmp
1500 
1501  ! Set up
1502  ! ------
1503  error_status = success
1504  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
1505 
1506  ! Check structures
1507  IF ( .NOT. associated_odps( odps1 ) ) THEN
1508  error_status = failure
1509  CALL display_message( routine_name, &
1510  'Some or all INPUT ODPS1 pointer '//&
1511  'members are NOT associated.', &
1512  error_status, &
1513  message_log=message_log )
1514  RETURN
1515  END IF
1516  IF ( .NOT. associated_odps( odps2 ) ) THEN
1517  error_status = failure
1518  CALL display_message( routine_name, &
1519  'Some or all INPUT ODPS2 pointer '//&
1520  'members are NOT associated.', &
1521  error_status, &
1522  message_log=message_log )
1523  RETURN
1524  END IF
1525 
1526  ! Compare structure release/version
1527  IF ( odps1%Release /= odps2%Release ) THEN
1528  error_status = failure
1529  CALL display_message( routine_name, &
1530  'Input ODPS Release values are different.', &
1531  error_status, &
1532  message_log=message_log )
1533  RETURN
1534  END IF
1535  IF ( odps1%Version /= odps2%Version ) THEN
1536  CALL display_message( routine_name, &
1537  'Input ODPS Version values are different.', &
1538  warning, &
1539  message_log=message_log )
1540  END IF
1541 
1542  ! Check the Layer dimension
1543  IF ( odps1%n_Layers /= odps2%n_Layers .OR. &
1544  odps1%n_Channels /= odps2%n_Channels ) THEN
1545  error_status = failure
1546  CALL display_message( routine_name, &
1547  'Non-absorber ODPS dimensions are different.', &
1548  error_status, &
1549  message_log=message_log )
1550  RETURN
1551  END IF
1552 
1553  ! Check the group ID values
1554  IF ( odps1%Group_Index /= odps2%Group_Index )THEN
1555  error_status = failure
1556  CALL display_message( routine_name, &
1557  'ODPS group ID values are different.', &
1558  error_status, &
1559  message_log=message_log )
1560  RETURN
1561  END IF
1562 
1563  ! Check the sensor ID values
1564  IF ( odps1%Sensor_ID /= odps2%Sensor_ID .OR. &
1565  odps1%WMO_Satellite_ID /= odps2%WMO_Satellite_ID .OR. &
1566  odps1%WMO_Sensor_ID /= odps2%WMO_Sensor_ID ) THEN
1567  error_status = failure
1568  CALL display_message( routine_name, &
1569  'ODPS sensor ID values are different.', &
1570  error_status, &
1571  message_log=message_log )
1572  RETURN
1573  END IF
1574 
1575  ! Check the channels
1576  IF ( any( ( odps1%Sensor_Channel - odps2%Sensor_Channel ) /= 0 ) ) THEN
1577  error_status = failure
1578  CALL display_message( routine_name, &
1579  'ODPS channel values are different.', &
1580  error_status, &
1581  message_log=message_log )
1582  RETURN
1583  END IF
1584 
1585 
1586  ! Reallocate the first structure
1587  ! ------------------------------
1588  ! Copy it...
1589  error_status = assign_odps( odps1, odps_tmp, &
1590  message_log=message_log )
1591  IF ( error_status /= success ) THEN
1592  CALL display_message( routine_name, &
1593  'Error copying ODPS1 structure.', &
1594  error_status, &
1595  message_log=message_log )
1596  RETURN
1597  END IF
1598 
1599  ! Get indexes for Union of the absorber ID for the reference absorber
1600  ! profile array
1601  n_absorbers = odps1%n_Absorbers
1602  n = 0
1603  DO i = 1, odps2%n_Absorbers
1604  DO j = 1, odps1%n_Absorbers
1605  IF(odps2%Absorber_ID(i) == odps1%Absorber_ID(j)) EXIT
1606  END DO
1607  ! an absorber ID in ODPS2 not found in ODSP1, so, add the ID in the Union
1608  IF( j > odps1%n_Absorbers)THEN
1609  n = n + 1
1610  indx(n) = i
1611  END IF
1612  END DO
1613  n_absorbers = n_absorbers + n
1614 
1615  ! ... now destroy it ...
1616  error_status = destroy_odps( odps1, &
1617  message_log=message_log )
1618  IF ( error_status /= success ) THEN
1619  CALL display_message( routine_name, &
1620  'Error destroying ODPS1 structure.', &
1621  error_status, &
1622  message_log=message_log )
1623  RETURN
1624  END IF
1625 
1626 
1627  ! ... and now re-allocate it for all absorbers
1628  n_components = odps_tmp%n_Components + odps2%n_Components
1629  n_coeffs = odps_tmp%n_Coeffs + odps2%n_Coeffs
1630  error_status = allocate_odps( odps_tmp%n_Layers, &
1631  n_components, &
1632  n_absorbers, &
1633  odps_tmp%n_Channels, &
1634  n_coeffs, &
1635  odps1, &
1636  message_log=message_log )
1637  IF ( error_status /= success ) THEN
1638  CALL display_message( routine_name, &
1639  'Error reallocating ODPS1 structure.', &
1640  error_status, &
1641  message_log=message_log )
1642  RETURN
1643  END IF
1644 
1645  ! Assign the reference pressure and temperature
1646  odps1%Ref_Level_Pressure = odps_tmp%Ref_Level_Pressure
1647  odps1%Ref_Pressure = odps_tmp%Ref_Pressure
1648  odps1%Ref_Temperature = odps_tmp%Ref_Temperature
1649 
1650  ! Assign the absorber profile data
1651  odps1%Ref_Absorber(:, 1:odps_tmp%n_Absorbers) = odps_tmp%Ref_Absorber
1652  odps1%Min_Absorber(:, 1:odps_tmp%n_Absorbers) = odps_tmp%Min_Absorber
1653  odps1%Max_Absorber(:, 1:odps_tmp%n_Absorbers) = odps_tmp%Max_Absorber
1654  odps1%Absorber_ID(1:odps_tmp%n_Absorbers) = odps_tmp%Absorber_ID
1655  DO j = 1, n
1656  odps1%Ref_Absorber(:, odps_tmp%n_Absorbers + j) = &
1657  odps2%Ref_Absorber(:, indx(j))
1658  odps1%Min_Absorber(:, odps_tmp%n_Absorbers + j) = &
1659  odps2%Min_Absorber(:, indx(j))
1660  odps1%Max_Absorber(:, odps_tmp%n_Absorbers + j) = &
1661  odps2%Max_Absorber(:, indx(j))
1662  odps1%Absorber_ID(odps_tmp%n_Absorbers + j) = &
1663  odps2%Absorber_ID(indx(j))
1664  END DO
1665 
1666  ! Assign the non-absorber data
1667  ! ----------------------------------
1668  odps1%Version = max( odps_tmp%Version, odps2%Version )
1669  odps1%Group_Index = odps_tmp%Group_Index
1670  odps1%Sensor_ID = odps_tmp%Sensor_ID
1671  odps1%Sensor_type = odps_tmp%Sensor_type
1672  odps1%WMO_Satellite_ID = odps_tmp%WMO_Satellite_ID
1673  odps1%WMO_Sensor_ID = odps_tmp%WMO_Sensor_ID
1674  odps1%Sensor_Channel = odps_tmp%Sensor_Channel
1675  ! OPTRAN
1676  odps1%OComponent_Index = odps_tmp%OComponent_Index
1677  odps1%Alpha = odps_tmp%Alpha
1678  odps1%Alpha_C1 = odps_tmp%Alpha_C1
1679  odps1%Alpha_C2 = odps_tmp%Alpha_C2
1680 
1681  !--------------------------------
1682  ! Concatenate absorber array data
1683  !--------------------------------
1684 
1685  ! The first part...
1686  j1 = 1
1687  j2 = odps_tmp%n_Components
1688  odps1%Component_ID(j1:j2) = odps_tmp%Component_ID
1689  odps1%n_Predictors(j1:j2,:) = odps_tmp%n_Predictors
1690 
1691  ! ...the second part
1692  j1 = odps_tmp%n_Components + 1
1693  j2 = n_components
1694  odps1%Component_ID(j1:j2) = odps2%Component_ID
1695  odps1%n_Predictors(j1:j2,:) = odps2%n_Predictors
1696 
1697  !--- The C and Pos_Index arrays ---
1698  m = 1
1699  n_layers = odps_tmp%n_Layers
1700  DO l = 1, odps1%n_Channels
1701  ! The first part...
1702  DO j = 1, odps_tmp%n_Components
1703  n = n_layers*odps_tmp%n_Predictors(j, l)
1704  IF( n > 0 )THEN
1705  j1 = odps_tmp%Pos_Index(j, l)
1706  j2 = j1 + n - 1
1707  odps1%Pos_Index(j,l) = m
1708  odps1%C(m:m+n-1)= odps_tmp%C(j1:j2)
1709  m = m + n
1710  END IF
1711  END DO
1712 
1713  ! ...the second part
1714  DO j = 1, odps2%n_Components
1715  n = n_layers*odps2%n_Predictors(j, l)
1716  IF( n > 0 )THEN
1717  j1 = odps2%Pos_Index(j, l)
1718  j2 = j1 + n - 1
1719  odps1%Pos_Index(odps_tmp%n_Components+j,l) = m
1720  odps1%C(m:m+n-1)= odps2%C(j1:j2)
1721  m = m + n
1722  END IF
1723  END DO
1724 
1725  END DO
1726 
1727  ! Destroy the temporary structure
1728  ! -------------------------------
1729  destroy_status = destroy_odps( odps_tmp, &
1730  message_log=message_log )
1731  IF ( destroy_status /= success ) THEN
1732  CALL display_message( routine_name, &
1733  'Error destroying ODPS_Tmp structure.', &
1734  warning, &
1735  message_log=message_log )
1736  END IF
1737 
1738  END FUNCTION concatenate_absorber_odps
1739 
1740 
1741 !------------------------------------------------------------------------------
1742 !
1743 ! NAME:
1744 ! Equal_ODPS
1745 !
1746 ! PURPOSE:
1747 ! Function to test if two ODPS structures are equal.
1748 !
1749 ! CALLING SEQUENCE:
1750 ! Error_Status = Equal_ODPS( ODPS_LHS , & ! Input
1751 ! ODPS_RHS , & ! Input
1752 ! ULP_Scale =ULP_Scale , & ! Optional input
1753 ! Check_All =Check_All , & ! Optional input
1754 ! RCS_Id =RCS_Id , & ! Revision control
1755 ! Message_Log=Message_Log ) ! Error messaging
1756 !
1757 ! INPUT ARGUMENTS:
1758 ! ODPS_LHS: ODPS structure to be compared; equivalent to the
1759 ! left-hand side of a lexical comparison, e.g.
1760 ! IF ( ODPS_LHS == ODPS_RHS ).
1761 ! UNITS: N/A
1762 ! TYPE: ODPS_type
1763 ! DIMENSION: Scalar
1764 ! ATTRIBUTES: INTENT(IN)
1765 !
1766 ! ODPS_RHS: ODPS structure to be compared to; equivalent to
1767 ! right-hand side of a lexical comparison, e.g.
1768 ! IF ( ODPS_LHS == ODPS_RHS ).
1769 ! UNITS: N/A
1770 ! TYPE: ODPS_type
1771 ! DIMENSION: Scalar
1772 ! ATTRIBUTES: INTENT(IN)
1773 !
1774 ! OPTIONAL INPUT ARGUMENTS:
1775 ! ULP_Scale: Unit of data precision used to scale the floating
1776 ! point comparison. ULP stands for "Unit in the Last Place,"
1777 ! the smallest possible increment or decrement that can be
1778 ! made using a machine's floating point arithmetic.
1779 ! Value must be positive - if a negative value is supplied,
1780 ! the absolute value is used. If not specified, the default
1781 ! value is 1.
1782 ! UNITS: N/A
1783 ! TYPE: INTEGER
1784 ! DIMENSION: Scalar
1785 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1786 !
1787 ! Check_All: Set this argument to check ALL the *floating point*
1788 ! channel data of the ODPS structures. The default
1789 ! action is return with a FAILURE status as soon as
1790 ! any difference is found. This optional argument can
1791 ! be used to get a listing of ALL the differences
1792 ! between data in ODPS structures.
1793 ! If == 0, Return with FAILURE status as soon as
1794 ! ANY difference is found *DEFAULT*
1795 ! == 1, Set FAILURE status if ANY difference is
1796 ! found, but continue to check ALL data.
1797 ! Note: Setting this argument has no effect if, for
1798 ! example, the structure dimensions are different,
1799 ! or the sensor ids/channels are different, or the
1800 ! absorber ids are different, etc.
1801 ! UNITS: N/A
1802 ! TYPE: INTEGER
1803 ! DIMENSION: Scalar
1804 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1805 !
1806 ! Message_Log: Character string specifying a filename in which any
1807 ! messages will be logged. If not specified, or if an
1808 ! error occurs opening the log file, the default action
1809 ! is to output messages to standard output.
1810 ! UNITS: N/A
1811 ! TYPE: CHARACTER(*)
1812 ! DIMENSION: Scalar
1813 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1814 !
1815 ! OPTIONAL OUTPUT ARGUMENTS:
1816 ! RCS_Id: Character string containing the Revision Control
1817 ! System Id field for the module.
1818 ! UNITS: N/A
1819 ! TYPE: CHARACTER(*)
1820 ! DIMENSION: Scalar
1821 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1822 !
1823 ! FUNCTION RESULT:
1824 ! Error_Status: The return value is an integer defining the error status.
1825 ! The error codes are defined in the Message_Handler module.
1826 ! If == SUCCESS the structures were equal
1827 ! == FAILURE - an error occurred, or
1828 ! - the structures were different.
1829 ! UNITS: N/A
1830 ! TYPE: INTEGER
1831 ! DIMENSION: Scalar
1832 !
1833 ! COMMENTS:
1834 ! Congruency of the structure data is a prerequisite of equality.
1835 ! That is, the *order* of the data is important. For example, if
1836 ! two structures contain the same absorber information, but in a
1837 ! different order, the structures are not considered equal.
1838 !
1839 !------------------------------------------------------------------------------
1840 
1841  FUNCTION equal_odps( ODPS_LHS , & ! Input
1842  ODPS_RHS , & ! Input
1843  ULP_Scale , & ! Optional input
1844  Check_All , & ! Optional input
1845  RCS_Id , & ! Revision control
1846  Message_Log) & ! Error messaging
1847  result( error_status )
1848  ! Arguments
1849  TYPE(odps_type) , INTENT(IN) :: odps_lhs
1850  TYPE(odps_type) , INTENT(IN) :: odps_rhs
1851  INTEGER, OPTIONAL, INTENT(IN) :: ulp_scale
1852  INTEGER, OPTIONAL, INTENT(IN) :: check_all
1853  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1854  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1855  ! Function result
1856  INTEGER :: error_status
1857  ! Local parameters
1858  CHARACTER(*), PARAMETER :: routine_name = 'Equal_ODPS'
1859  ! Local variables
1860  CHARACTER(ML) :: message
1861  INTEGER :: ulp
1862  LOGICAL :: check_once
1863  INTEGER :: j, l
1864  INTEGER(Long) :: i
1865 
1866  ! Set up
1867  ! ------
1868  error_status = success
1869  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
1870 
1871  ! Default precision is a single unit in last place
1872  ulp = 1
1873  ! ... unless the ULP_Scale argument is set and positive
1874  IF ( PRESENT( ulp_scale ) ) THEN
1875  IF ( ulp_scale > 0 ) ulp = ulp_scale
1876  END IF
1877 
1878  ! Default action is to return on ANY difference...
1879  check_once = .true.
1880  ! ...unless the Check_All argument is set
1881  IF ( PRESENT( check_all ) ) THEN
1882  IF ( check_all == 1 ) check_once = .false.
1883  END IF
1884 
1885  ! Check the structure association status
1886  IF ( .NOT. associated_odps( odps_lhs ) ) THEN
1887  error_status = failure
1888  CALL display_message( routine_name, &
1889  'Some or all INPUT ODPS_LHS pointer '//&
1890  'members are NOT associated.', &
1891  error_status, &
1892  message_log=message_log )
1893  RETURN
1894  END IF
1895  IF ( .NOT. associated_odps( odps_rhs ) ) THEN
1896  error_status = failure
1897  CALL display_message( routine_name, &
1898  'Some or all INPUT ODPS_RHS pointer '//&
1899  'members are NOT associated.', &
1900  error_status, &
1901  message_log=message_log )
1902  RETURN
1903  END IF
1904 
1905 
1906  ! Check structure Release/Version
1907  ! -------------------------------
1908  IF ( ( odps_lhs%Release /= odps_rhs%Release ) .OR. &
1909  ( odps_lhs%Version /= odps_rhs%Version ) ) THEN
1910  error_status = failure
1911  WRITE( message, '( "Release/Version numbers are different : ", &
1912  &i2, ".", i2.2, " vs. ", i2, ".", i2.2 )' ) &
1913  odps_lhs%Release, odps_lhs%Version, &
1914  odps_rhs%Release, odps_rhs%Version
1915  CALL display_message( routine_name, &
1916  trim(message), &
1917  error_status, &
1918  message_log=message_log )
1919  IF ( check_once ) RETURN
1920  END IF
1921 
1922 
1923  ! Check dimensions
1924  ! ----------------
1925  IF ( odps_lhs%n_Layers /= odps_rhs%n_Layers .OR. &
1926  odps_lhs%n_Components /= odps_rhs%n_Components .OR. &
1927  odps_lhs%n_Absorbers /= odps_rhs%n_Absorbers .OR. &
1928  odps_lhs%n_Channels /= odps_rhs%n_Channels .OR. &
1929  odps_lhs%n_Coeffs /= odps_rhs%n_Coeffs .OR. &
1930  odps_lhs%n_OCoeffs /= odps_rhs%n_OCoeffs ) THEN
1931  error_status = failure
1932  CALL display_message( routine_name, &
1933  'Structure dimensions are different', &
1934  error_status, &
1935  message_log=message_log )
1936  RETURN
1937  END IF
1938 
1939  ! Compare the values
1940  ! ------------------
1941  ! The Group_Index
1942  IF ( odps_lhs%Group_Index /= odps_rhs%Group_Index ) THEN
1943  error_status = failure
1944  WRITE( message, '( "Group_Index values are different, ", &
1945  &i0, " vs. ", i0 )' ) &
1946  odps_lhs%Group_Index, odps_rhs%Group_Index
1947  CALL display_message( routine_name, &
1948  trim(message), &
1949  error_status, &
1950  message_log=message_log )
1951  IF ( check_once ) RETURN
1952  END IF
1953 
1954  ! The Sensor_ID
1955  IF ( odps_lhs%Sensor_Id /= odps_rhs%Sensor_Id ) THEN
1956  error_status = failure
1957  WRITE( message, '( "Sensor_ID values are different, ", &
1958  &a, " vs. ", a )' ) &
1959  trim( odps_lhs%Sensor_Id), &
1960  trim( odps_rhs%Sensor_Id)
1961  CALL display_message( routine_name, &
1962  trim(message), &
1963  error_status, &
1964  message_log=message_log )
1965  IF ( check_once ) RETURN
1966  END IF
1967 
1968  ! The Sensor_Type
1969  IF ( odps_lhs%Sensor_Type /= odps_rhs%Sensor_Type ) THEN
1970  WRITE( message,'("Sensor types are different, ", &
1971  &i0,"(",a,") vs. ", i0,"(",a,")")' ) &
1972  odps_lhs%Sensor_Type, &
1973  trim(sensor_type_name(odps_lhs%Sensor_Type)), &
1974  odps_rhs%Sensor_Type, &
1975  trim(sensor_type_name(odps_rhs%Sensor_Type))
1976  CALL display_message( routine_name, &
1977  trim(message), &
1978  error_status, &
1979  message_log=message_log )
1980  IF ( check_once ) RETURN
1981  END IF
1982 
1983  ! The WMO Satellite ID
1984  IF ( odps_lhs%WMO_Satellite_ID /= odps_rhs%WMO_Satellite_ID ) THEN
1985  error_status = failure
1986  WRITE( message,'("WMO_Satellite_ID values are different, ",i0,&
1987  &" vs. ",i0 )' ) &
1988  odps_lhs%WMO_Satellite_ID, &
1989  odps_rhs%WMO_Satellite_ID
1990  CALL display_message( routine_name, &
1991  trim(message), &
1992  error_status, &
1993  message_log=message_log )
1994  IF ( check_once ) RETURN
1995  END IF
1996 
1997  ! The WMO Sensor ID
1998  IF ( odps_lhs%WMO_Sensor_ID /= odps_rhs%WMO_Sensor_ID ) THEN
1999  error_status = failure
2000  WRITE( message,'("WMO_Sensor_ID values are different, ",i0,&
2001  &" vs. ",i0)' ) &
2002  odps_lhs%WMO_Sensor_ID, &
2003  odps_rhs%WMO_Sensor_ID
2004  CALL display_message( routine_name, &
2005  trim(message), &
2006  error_status, &
2007  message_log=message_log )
2008  IF ( check_once ) RETURN
2009  END IF
2010 
2011  ! The Sensor_Channel
2012  DO l = 1, odps_rhs%n_Channels
2013  IF ( odps_lhs%Sensor_Channel(l) /= odps_rhs%Sensor_Channel(l) ) THEN
2014  error_status = failure
2015  WRITE( message,'("Sensor_Channel values are different, ",i0,&
2016  &" vs. ",i0,", for channel index # ",i0)' ) &
2017  odps_lhs%Sensor_Channel(l), &
2018  odps_rhs%Sensor_Channel(l), &
2019  l
2020  CALL display_message( routine_name, &
2021  trim(message), &
2022  error_status, &
2023  message_log=message_log )
2024  IF ( check_once ) RETURN
2025  END IF
2026  END DO
2027 
2028  ! The Component_ID
2029  DO j = 1, odps_rhs%n_Components
2030  IF ( odps_lhs%Component_ID(j) /= odps_rhs%Component_ID(j) ) THEN
2031  error_status = failure
2032  WRITE( message,'("Component_ID values are different, ",i0,&
2033  &" vs. ",i0,", for absorber index # ",i0)' ) &
2034  odps_lhs%Component_ID(j), &
2035  odps_rhs%Component_ID(j), &
2036  j
2037  CALL display_message( routine_name, &
2038  trim(message), &
2039  error_status, &
2040  message_log=message_log )
2041  IF ( check_once ) RETURN
2042  END IF
2043  END DO
2044 
2045 
2046  ! The n_Predictors
2047  DO l = 1, odps_rhs%n_Channels
2048  DO j = 1, odps_rhs%n_Components
2049  IF ( odps_lhs%n_Predictors(j,l) /= odps_rhs%n_Predictors(j,l) ) THEN
2050  error_status = failure
2051  WRITE( message,'("n_Predictors values are different, ",i0,&
2052  &" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
2053  odps_lhs%n_Predictors(j,l), &
2054  odps_rhs%n_Predictors(j,l), &
2055  j,l
2056  CALL display_message( routine_name, &
2057  trim(message), &
2058  error_status, &
2059  message_log=message_log )
2060  IF ( check_once ) RETURN
2061  END IF
2062  END DO
2063  END DO
2064 
2065  ! The Pos_Index
2066  DO l = 1, odps_rhs%n_Channels
2067  DO j = 1, odps_rhs%n_Components
2068  IF ( odps_lhs%Pos_Index(j,l) /= odps_rhs%Pos_Index(j,l) ) THEN
2069  error_status = failure
2070  WRITE( message,'("Pos_Index values are different, ",i0,&
2071  &" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
2072  odps_lhs%Pos_Index(j,l), &
2073  odps_rhs%Pos_Index(j,l), &
2074  j,l
2075  CALL display_message( routine_name, &
2076  trim(message), &
2077  error_status, &
2078  message_log=message_log )
2079  IF ( check_once ) RETURN
2080  END IF
2081  END DO
2082  END DO
2083 
2084  ! The Coefficients
2085  DO i = 1, odps_rhs%n_Coeffs
2086  IF ( odps_lhs%C(i) /= odps_rhs%C(i) ) THEN
2087  error_status = failure
2088  WRITE( message,'("C values are different, ",i0,&
2089  &" vs. ",i0,", for index (",i0,")")' ) &
2090  odps_lhs%C(i), &
2091  odps_rhs%C(i), &
2092  i
2093  CALL display_message( routine_name, &
2094  trim(message), &
2095  error_status, &
2096  message_log=message_log )
2097  IF ( check_once ) RETURN
2098  END IF
2099  END DO
2100 
2101  ! C-OPTRAN data
2102  ! ----------------
2103  IF(odps_rhs%n_OCoeffs > 0)THEN
2104  IF(any(odps_lhs%OC /= odps_rhs%OC) .OR. &
2105  any(odps_lhs%OSignificance /= odps_rhs%OSignificance) .OR. &
2106  any(odps_lhs%Order /= odps_rhs%Order) .OR. &
2107  any(odps_lhs%OP_Index /= odps_rhs%OP_Index) .OR. &
2108  any(odps_lhs%OPos_Index /= odps_rhs%OPos_Index) .OR. &
2109  odps_lhs%OComponent_Index /= odps_rhs%OComponent_Index .OR. &
2110  odps_lhs%Alpha /= odps_rhs%Alpha .OR. &
2111  odps_lhs%Alpha_C1 /= odps_rhs%Alpha_C1 .OR. &
2112  odps_lhs%Alpha_C2 /= odps_rhs%Alpha_C2 )THEN
2113  error_status = failure
2114  CALL display_message( routine_name, &
2115  "ODPS OPTRAN data are different", &
2116  error_status, &
2117  message_log=message_log )
2118  IF ( check_once ) RETURN
2119  END IF
2120  END IF
2121 
2122  END FUNCTION equal_odps
2123 
2124 
2125 !----------------------------------------------------------------------------------
2126 !
2127 ! NAME:
2128 ! CheckRelease_ODPS
2129 !
2130 ! PURPOSE:
2131 ! Function to check the ODPS Release value.
2132 !
2133 ! CALLING SEQUENCE:
2134 ! Error_Status = CheckRelease_ODPS( ODPS , & ! Input
2135 ! RCS_Id = RCS_Id , & ! Revision control
2136 ! Message_Log=Message_Log ) ! Error messaging
2137 !
2138 ! INPUT ARGUMENTS:
2139 ! ODPS: ODPS structure for which the Release member
2140 ! is to be checked.
2141 ! UNITS: N/A
2142 ! TYPE: ODPS_type
2143 ! DIMENSION: Scalar
2144 ! ATTRIBUTES: INTENT(OUT)
2145 !
2146 ! OPTIONAL INPUT ARGUMENTS:
2147 ! Message_Log: Character string specifying a filename in which any
2148 ! messages will be logged. If not specified, or if an
2149 ! error occurs opening the log file, the default action
2150 ! is to output messages to standard output.
2151 ! UNITS: N/A
2152 ! TYPE: CHARACTER(*)
2153 ! DIMENSION: Scalar
2154 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
2155 ! OPTIONAL OUTPUT ARGUMENTS:
2156 ! RCS_Id: Character string containing the Revision Control
2157 ! System Id field for the module.
2158 ! UNITS: N/A
2159 ! TYPE: CHARACTER(*)
2160 ! DIMENSION: Scalar
2161 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
2162 !
2163 ! FUNCTION RESULT:
2164 ! Error_Status: The return value is an integer defining the error status.
2165 ! The error codes are defined in the Message_Handler module.
2166 ! If == SUCCESS the structure Release value is valid.
2167 ! == FAILURE the structure Release value is NOT valid
2168 ! and either a data file file or software
2169 ! update is required.
2170 ! UNITS: N/A
2171 ! TYPE: INTEGER
2172 ! DIMENSION: Scalar
2173 !
2174 !----------------------------------------------------------------------------------
2175 
2176  FUNCTION checkrelease_odps( ODPS , & ! Input
2177  RCS_Id , & ! Revision control
2178  Message_Log) & ! Error messaging
2179  result( error_status )
2180  ! Arguments
2181  TYPE(odps_type) , INTENT(IN) :: odps
2182  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
2183  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
2184  ! Function result
2185  INTEGER :: error_status
2186  ! Local parameters
2187  CHARACTER(*), PARAMETER :: routine_name = 'CheckRelease_ODPS'
2188  ! Local variables
2189  CHARACTER(ML) :: message
2190 
2191  ! Set up
2192  ! ------
2193  error_status = success
2194  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
2195 
2196 
2197  ! Check the release
2198  ! -----------------
2199  ! Check that release is not too old
2200  IF ( odps%Release < odps_release ) THEN
2201  error_status = failure
2202  WRITE( message, '( "An ODPS data update is needed. ", &
2203  &"ODPS release is ", i2, &
2204  &". Valid release is ",i2,"." )' ) &
2205  odps%Release, odps_release
2206  CALL display_message( routine_name, &
2207  trim(message), &
2208  error_status, &
2209  message_log=message_log )
2210  RETURN
2211  END IF
2212 
2213  ! Check that release is not too new
2214  IF ( odps%Release > odps_release ) THEN
2215  error_status = failure
2216  WRITE( message, '( "An ODPS software update is needed. ", &
2217  &"ODPS release is ", i2, &
2218  &". Valid release is ",i2,"." )' ) &
2219  odps%Release, odps_release
2220  CALL display_message( routine_name, &
2221  trim(message), &
2222  error_status, &
2223  message_log=message_log )
2224  RETURN
2225  END IF
2226 
2227  END FUNCTION checkrelease_odps
2228 
2229 
2230 !----------------------------------------------------------------------------------
2231 !
2232 ! NAME:
2233 ! CheckAlgorithm_ODPS
2234 !
2235 ! PURPOSE:
2236 ! Function to check the ODPS Algorithm value.
2237 !
2238 ! CALLING SEQUENCE:
2239 ! Error_Status = CheckAlgorithm_ODPS( ODPS , & ! Input
2240 ! RCS_Id = RCS_Id , & ! Revision control
2241 ! Message_Log=Message_Log ) ! Error messaging
2242 !
2243 ! INPUT ARGUMENTS:
2244 ! ODPS: ODPS structure for which the Algorithm member
2245 ! is to be checked.
2246 ! UNITS: N/A
2247 ! TYPE: ODPS_type
2248 ! DIMENSION: Scalar
2249 ! ATTRIBUTES: INTENT(OUT)
2250 !
2251 ! OPTIONAL INPUT ARGUMENTS:
2252 ! Message_Log: Character string specifying a filename in which any
2253 ! messages will be logged. If not specified, or if an
2254 ! error occurs opening the log file, the default action
2255 ! is to output messages to standard output.
2256 ! UNITS: N/A
2257 ! TYPE: CHARACTER(*)
2258 ! DIMENSION: Scalar
2259 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
2260 ! OPTIONAL OUTPUT ARGUMENTS:
2261 ! RCS_Id: Character string containing the Revision Control
2262 ! System Id field for the module.
2263 ! UNITS: N/A
2264 ! TYPE: CHARACTER(*)
2265 ! DIMENSION: Scalar
2266 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
2267 !
2268 ! FUNCTION RESULT:
2269 ! Error_Status: The return value is an integer defining the error status.
2270 ! The error codes are defined in the Message_Handler module.
2271 ! If == SUCCESS the structure Algorithm value is valid.
2272 ! == FAILURE the structure Algorithm value is NOT valid.
2273 ! UNITS: N/A
2274 ! TYPE: INTEGER
2275 ! DIMENSION: Scalar
2276 !
2277 !----------------------------------------------------------------------------------
2278 
2279  FUNCTION checkalgorithm_odps( ODPS , & ! Input
2280  RCS_Id , & ! Revision control
2281  Message_Log) & ! Error messaging
2282  result( error_status )
2283  ! Arguments
2284  TYPE(odps_type) , INTENT(IN) :: odps
2285  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
2286  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
2287  ! Function result
2288  INTEGER :: error_status
2289  ! Local parameters
2290  CHARACTER(*), PARAMETER :: routine_name = 'CheckAlgorithm_ODPS'
2291 
2292  ! Set up
2293  ! ------
2294  error_status = success
2295  IF ( PRESENT(rcs_id) ) rcs_id = module_rcs_id
2296 
2297 
2298  ! Check the algorithm ID
2299  ! ----------------------
2300  IF ( odps%Algorithm /= odps_algorithm ) THEN
2301  error_status = failure
2302  CALL display_message( routine_name, &
2303  'The ODPS Algorithm ID check failed. '//&
2304  'The data structure is not an ODPS structure', &
2305  error_status, &
2306  message_log=message_log )
2307  RETURN
2308  END IF
2309 
2310  END FUNCTION checkalgorithm_odps
2311 
2312 
2313 !------------------------------------------------------------------------------
2314 !
2315 ! NAME:
2316 ! Info_ODPS
2317 !
2318 ! PURPOSE:
2319 ! Subroutine to return a string containing version and dimension
2320 ! information about the ODPS data structure.
2321 !
2322 ! CALLING SEQUENCE:
2323 ! CALL Info_ODPS( ODPS , & ! Input
2324 ! Info , & ! Output
2325 ! RCS_Id=RCS_Id ) ! Revision control
2326 !
2327 ! INPUT ARGUMENTS:
2328 ! ODPS: Filled ODPS structure.
2329 ! UNITS: N/A
2330 ! TYPE: ODPS_type
2331 ! DIMENSION: Scalar
2332 ! ATTRIBUTES: INTENT(IN)
2333 !
2334 ! OUTPUT ARGUMENTS:
2335 ! Info: String containing version and dimension information
2336 ! about the passed ODPS data structure.
2337 ! UNITS: N/A
2338 ! TYPE: CHARACTER(*)
2339 ! DIMENSION: Scalar
2340 ! ATTRIBUTES: INTENT(OUT)
2341 !
2342 ! OPTIONAL OUTPUT ARGUMENTS:
2343 ! RCS_Id: Character string containing the Revision Control
2344 ! System Id field for the module.
2345 ! UNITS: N/A
2346 ! TYPE: CHARACTER(*)
2347 ! DIMENSION: Scalar
2348 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
2349 !
2350 !------------------------------------------------------------------------------
2351 
2352  SUBROUTINE info_odps( ODPS , & ! Input
2353  Info , & ! Output
2354  RCS_Id ) ! Revision control
2355  ! Arguments
2356  TYPE(odps_type) , INTENT(IN) :: odps
2357  CHARACTER(*), INTENT(OUT) :: info
2358  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
2359  ! Local variables
2360  CHARACTER(2000) :: longstring
2361 
2362  ! Set up
2363  ! ------
2364  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
2365 
2366  ! Write the required data to the local string
2367  ! -------------------------------------------
2368  WRITE( longstring,'( a,3x,"ODPS RELEASE.VERSION: ",i2,".",i2.2,2x,&
2369  &"N_LAYERS=",i0,2x,&
2370  &"N_COMPONENTS=",i0,2x,&
2371  &"N_ABSORBERS=",i0,2x,&
2372  &"N_CHANNELS=",i0,2x, &
2373  &"N_COEFFS=",i0)' ) &
2374  achar(carriage_return)//achar(linefeed), &
2375  odps%Release, odps%Version, &
2376  odps%n_Layers, &
2377  odps%n_Components, &
2378  odps%n_Absorbers, &
2379  odps%n_Channels, &
2380  odps%n_Coeffs
2381 
2382  ! Trim the output based on the
2383  ! dummy argument string length
2384  ! ----------------------------
2385  info = longstring(1:min( len(info), len_trim(longstring) ))
2386 
2387  END SUBROUTINE info_odps
2388 
2389 
2390 !##################################################################################
2391 !##################################################################################
2392 !## ##
2393 !## ## PRIVATE MODULE ROUTINES ## ##
2394 !## ##
2395 !##################################################################################
2396 !##################################################################################
2397 
2398 
2399 !----------------------------------------------------------------------------------
2400 !
2401 ! NAME:
2402 ! Clear_ODPS
2403 !
2404 ! PURPOSE:
2405 ! Subroutine to clear the scalar members of a ODPS structure.
2406 !
2407 ! CALLING SEQUENCE:
2408 ! CALL Clear_ODPS( ODPS ) ! Output
2409 !
2410 ! OUTPUT ARGUMENTS:
2411 ! ODPS: ODPS structure for which the scalar members have
2412 ! been cleared.
2413 ! UNITS: N/A
2414 ! TYPE: ODPS_type
2415 ! DIMENSION: Scalar
2416 ! ATTRIBUTES: INTENT(IN OUT)
2417 !
2418 ! COMMENTS:
2419 ! Note the INTENT on the output ODPS argument is IN OUT rather than
2420 ! just OUT. This is necessary because the argument may be defined upon
2421 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
2422 !
2423 !----------------------------------------------------------------------------------
2424 
2425  SUBROUTINE clear_odps( ODPS )
2426  TYPE(ODPS_type), INTENT(IN OUT) :: ODPS
2427  odps%Release = odps_release
2428  odps%Version = odps_version
2429  odps%Algorithm = odps_algorithm
2430  odps%Group_Index = ip_invalid
2431  odps%Sensor_Id = ' '
2432  odps%Sensor_Type = invalid_sensor
2433  odps%WMO_Satellite_ID = invalid_wmo_satellite_id
2434  odps%WMO_Sensor_ID = invalid_wmo_sensor_id
2435  END SUBROUTINE clear_odps
2436 
2437 END MODULE odps_define
odps_define::microwave_sensor
integer, parameter, public microwave_sensor
Definition: ODPS_Define.f90:95
odps_define::linefeed
integer, parameter linefeed
Definition: ODPS_Define.f90:88
compare_float_numbers::compare_float
Definition: Compare_Float_Numbers.f90:45
message_handler::failure
integer, parameter, public failure
Definition: Message_Handler.f90:30
odps_define::checkalgorithm_odps
integer function, public checkalgorithm_odps(ODPS, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:2283
odps_define::equal_odps
integer function, public equal_odps(ODPS_LHS, ODPS_RHS, ULP_Scale, Check_All, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:1848
message_handler::warning
integer, parameter, public warning
Definition: Message_Handler.f90:29
odps_define::invalid_wmo_satellite_id
integer, parameter, public invalid_wmo_satellite_id
Definition: ODPS_Define.f90:90
odps_define::allocate_odps
integer function, public allocate_odps(n_Layers, n_Components, n_Absorbers, n_Channels, n_Coeffs, ODPS, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:632
type_kinds::long
integer, parameter, public long
Definition: Type_Kinds.f90:76
odps_define::info_odps
subroutine, public info_odps(ODPS, Info, RCS_Id)
Definition: ODPS_Define.f90:2355
odps_define::carriage_return
integer, parameter carriage_return
Definition: ODPS_Define.f90:87
type_kinds::fp
integer, parameter, public fp
Definition: Type_Kinds.f90:124
odps_define::destroy_odps
integer function, public destroy_odps(ODPS, No_Clear, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:411
odps_define::n_predictor_used_optran
integer, parameter n_predictor_used_optran
Definition: ODPS_Define.f90:106
crtm_parameters
Definition: CRTM_Parameters.f90:12
odps_define::ip_invalid
integer, parameter ip_invalid
Definition: ODPS_Define.f90:74
odps_define::invalid_wmo_sensor_id
integer, parameter, public invalid_wmo_sensor_id
Definition: ODPS_Define.f90:91
odps_define::assign_odps
integer function, public assign_odps(ODPS_in, ODPS_out, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:977
type_kinds::single
integer, parameter, public single
Definition: Type_Kinds.f90:105
odps_define::ultraviolet_sensor
integer, parameter ultraviolet_sensor
Definition: ODPS_Define.f90:98
sort_utility::insertionsort
Definition: Sort_Utility.f90:37
odps_define::visible_sensor
integer, parameter, public visible_sensor
Definition: ODPS_Define.f90:97
odps_define::concatenate_channel_odps
integer function, public concatenate_channel_odps(ODPS1, ODPS2, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:1157
message_handler
Definition: Message_Handler.f90:4
odps_define::significance_optran
integer, parameter, public significance_optran
Definition: ODPS_Define.f90:107
odps_define::clear_odps
subroutine clear_odps(ODPS)
Definition: ODPS_Define.f90:2426
odps_define::odps_version
integer, parameter odps_version
Definition: ODPS_Define.f90:83
odps_define::infrared_sensor
integer, parameter, public infrared_sensor
Definition: ODPS_Define.f90:96
compare_float_numbers
Definition: Compare_Float_Numbers.f90:13
message_handler::display_message
recursive subroutine, public display_message(Routine_Name, Message, Error_State, Message_Log)
Definition: Message_Handler.f90:118
sort_utility
Definition: Sort_Utility.f90:12
odps_define::associated_odps
logical function, public associated_odps(ODPS, ANY_Test)
Definition: ODPS_Define.f90:270
odps_define::checkrelease_odps
integer function, public checkrelease_odps(ODPS, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:2180
odps_define::ml
integer, parameter ml
Definition: ODPS_Define.f90:80
odps_define::n_sensor_types
integer, parameter, public n_sensor_types
Definition: ODPS_Define.f90:93
odps_define::odps_type
Definition: ODPS_Define.f90:112
crtm_parameters::odps_algorithm
integer, parameter, public odps_algorithm
Definition: CRTM_Parameters.f90:125
odps_define::invalid_sensor
integer, parameter, public invalid_sensor
Definition: ODPS_Define.f90:94
max
#define max(a, b)
Definition: mosaic_util.h:33
type_kinds
Definition: Type_Kinds.f90:12
odps_define::module_rcs_id
character(*), parameter module_rcs_id
Definition: ODPS_Define.f90:71
odps_define::sensor_type_name
character(*), dimension(0:n_sensor_types), parameter, public sensor_type_name
Definition: ODPS_Define.f90:99
odps_define::concatenate_absorber_odps
integer function, public concatenate_absorber_odps(ODPS1, ODPS2, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:1485
odps_define::odps_algorithm_name
character(*), parameter odps_algorithm_name
Definition: ODPS_Define.f90:85
odps_define::sl
integer, parameter sl
Definition: ODPS_Define.f90:79
min
#define min(a, b)
Definition: mosaic_util.h:32
message_handler::success
integer, parameter, public success
Definition: Message_Handler.f90:27
odps_define::odps_release
integer, parameter odps_release
Definition: ODPS_Define.f90:82
odps_define::set
integer, parameter set
Definition: ODPS_Define.f90:77
odps_define
Definition: ODPS_Define.f90:13
odps_define::fp_invalid
real(fp), parameter fp_invalid
Definition: ODPS_Define.f90:75
odps_define::allocate_odps_optran
integer function, public allocate_odps_optran(n_OCoeffs, ODPS, RCS_Id, Message_Log)
Definition: ODPS_Define.f90:830