FV3 Bundle
ODAS_Define.f90
Go to the documentation of this file.
1 !
2 ! ODAS_Define
3 !
4 ! Module defining the ODAS (Optical Depth, Absorber Space) data structure and
5 ! containing routines to manipulate it.
6 !
7 !
8 ! CREATION HISTORY:
9 ! Written by: Paul van Delst, CIMSS/SSEC 18-Mar-2002
10 ! paul.vandelst@ssec.wisc.edu
11 !
12 
13 MODULE odas_define
14 
15  ! ------------------
16  ! Environment set up
17  ! ------------------
18  ! Module use
19  USE type_kinds, ONLY: long, double
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: odas_algorithm
24 
25  ! Disable implicit typing
26  IMPLICIT NONE
27 
28 
29  ! ------------
30  ! Visibilities
31  ! ------------
32  ! Everything private by default
33  PRIVATE
34 
35  ! Public types
36  ! ------------
37  PUBLIC :: odas_type
38 
39  ! Public procedures
40  ! -----------------
41  PUBLIC :: associated_odas
42  PUBLIC :: destroy_odas
43  PUBLIC :: allocate_odas
44  PUBLIC :: assign_odas
45  PUBLIC :: equal_odas
46  PUBLIC :: checkrelease_odas
47  PUBLIC :: checkalgorithm_odas
48  PUBLIC :: info_odas
49 
50  ! Public parameters
51  ! -----------------
52  ! Sensor Id defaults
53  PUBLIC :: invalid_wmo_satellite_id
54  PUBLIC :: invalid_wmo_sensor_id
55  ! Allowable sensor type values and names
56  PUBLIC :: n_sensor_types
57  PUBLIC :: invalid_sensor
58  PUBLIC :: microwave_sensor
59  PUBLIC :: infrared_sensor
60  PUBLIC :: visible_sensor
61  PUBLIC :: sensor_type_name
62  PUBLIC :: odas_release
63  ! The Global unique algorithm ID
64  PUBLIC :: odas_algorithm
65 
66 
67  ! -----------------
68  ! Module parameters
69  ! -----------------
70  ! RCS Id for the module
71  CHARACTER(*), PARAMETER :: module_rcs_id = &
72  '$Id: ODAS_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
73  ! ODAS invalid values
74  INTEGER, PARAMETER :: ip_invalid = -1
75  REAL(Double), PARAMETER :: fp_invalid = -1.0_double
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 :: odas_release = 7 ! This determines structure and file formats.
83  INTEGER, PARAMETER :: odas_version = 1 ! This is just the data version.
84  ! The optical depth algorithm name
85  CHARACTER(*), PARAMETER :: odas_algorithm_name = 'ODAS'
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 
106  ! -------------------------
107  ! ODAS data type definition
108  ! -------------------------
109  TYPE :: odas_type
110  INTEGER :: n_allocates = 0
111  ! Release and version information
112  INTEGER(Long) :: release = odas_release
113  INTEGER(Long) :: version = odas_version
114  ! Algorithm identifer
115  INTEGER(Long) :: algorithm = odas_algorithm
116  ! Dimensions
117  INTEGER(Long) :: n_predictors = 0 ! Iuse
118  INTEGER(Long) :: n_absorbers = 0 ! J
119  INTEGER(Long) :: n_channels = 0 ! L
120  INTEGER(Long) :: n_alphas = 0 ! Ia
121  INTEGER(Long) :: n_coeffs = 0 ! Co dimension of the C array
122  ! Scalar components
123  CHARACTER(SL) :: sensor_id = ' '
124  INTEGER(Long) :: wmo_satellite_id = invalid_wmo_satellite_id
125  INTEGER(Long) :: wmo_sensor_id = invalid_wmo_sensor_id
126  INTEGER(Long) :: sensor_type = invalid_sensor
127  ! The actual sensor channel numbers
128  INTEGER(Long), POINTER :: sensor_channel(:) => null() ! L
129  ! The absorber ID and absorber space values
130  INTEGER(Long), POINTER :: absorber_id(:) => null() ! J
131  ! maximum order of the polynomial function for each absorber, independent channel
132  INTEGER(Long), POINTER :: max_order(:) => null() ! J
133 
134  ! Coefficients for computing absorber level
135  ! Alpha(1, j) - the original alpha
136  ! Alpha(2, j) - the original alpha_C1
137  ! Alpha(3, j) - the original alpha_C2
138  REAL(Double), POINTER :: alpha(:,:) => null() ! Ia x J
139 
140 
141  !-----------------------------------------------------------------------------------
142  ! Order - used maximum order of the polynomial function, given absorber and channel
143  ! Pre_Index - Predict index. Pre_Index(0, j, l) is the numberof used predictors
144  ! for absorber j and channel l
145  ! Pos_Index - starting position of a coefficient subset
146  ! C - tau coefficient
147  !
148  ! The C array is one-dimesional and its internal structure is given by the Order,
149  ! Pre_index and the Pos_index arrays. Let j and l be the array indexes along
150  ! the absorber and channel dimensions:
151  ! ps = Pos_Index(j, l) and n = Pre_Index(0, j l)*Order(j,l) are the starting
152  ! position and size of the coefficient sub-set in array C at absorber j and
153  ! channel l. The coefficient sub-set is equally divided into np+1 segments,
154  ! where np = Pre_Index(0, j, l) is the number of predictors. The np+1 segments
155  ! are used to compute the set of np+1 B coefficiets. The B coefficents are then
156  ! used to compute the absorption coefficients.
157  !------------------------------------------------------------------------------------
158  INTEGER(LONG), POINTER :: order(:,:) => null() ! J x L
159  INTEGER(Long), POINTER :: pre_index(:,:,:) => null() ! 0:Iuse x J x L
160  INTEGER(Long), POINTER :: pos_index(:,:) => null() ! J x L
161  REAL(Double), POINTER :: c(:) => null() ! Co ! tau coefficient array
162 
163 
164  END TYPE odas_type
165 
166 
167 CONTAINS
168 
169 
170 !################################################################################
171 !################################################################################
172 !## ##
173 !## ## PUBLIC MODULE ROUTINES ## ##
174 !## ##
175 !################################################################################
176 !################################################################################
177 
178 !--------------------------------------------------------------------------------
179 !
180 ! NAME:
181 ! Associated_ODAS
182 !
183 ! PURPOSE:
184 ! Function to test the association status of the pointer members of a
185 ! ODAS structure.
186 !
187 ! CALLING SEQUENCE:
188 ! Association_Status = Associated_ODAS( ODAS ,& ! Input
189 ! ANY_Test=Any_Test ) ! Optional input
190 !
191 ! INPUT ARGUMENTS:
192 ! ODAS: ODAS structure which is to have its pointer
193 ! member's association status tested.
194 ! UNITS: N/A
195 ! TYPE: ODAS_type
196 ! DIMENSION: Scalar
197 ! ATTRIBUTES: INTENT(IN)
198 !
199 ! OPTIONAL INPUT ARGUMENTS:
200 ! ANY_Test: Set this argument to test if ANY of the
201 ! ODAS structure pointer members are associated.
202 ! The default is to test if ALL the pointer members
203 ! are associated.
204 ! If ANY_Test = 0, test if ALL the pointer members
205 ! are associated. (DEFAULT)
206 ! ANY_Test = 1, test if ANY of the pointer members
207 ! are associated.
208 !
209 ! FUNCTION RESULT:
210 ! Association_Status: The return value is a logical value indicating the
211 ! association status of the ODAS pointer members.
212 ! .TRUE. - if ALL the ODAS pointer members are
213 ! associated, or if the ANY_Test argument
214 ! is set and ANY of the ODAS pointer
215 ! members are associated.
216 ! .FALSE. - some or all of the ODAS pointer
217 ! members are NOT associated.
218 ! UNITS: N/A
219 ! TYPE: LOGICAL
220 ! DIMENSION: Scalar
221 !
222 !--------------------------------------------------------------------------------
223 
224  FUNCTION associated_odas( ODAS , & ! Input
225  ANY_Test) & ! Optional input
226  result( association_status )
227  ! Arguments
228  TYPE(odas_type) , INTENT(IN) :: odas
229  INTEGER, OPTIONAL, INTENT(IN) :: any_test
230  ! Function result
231  LOGICAL :: association_status
232  ! Local variables
233  LOGICAL :: all_test
234 
235  ! Set up
236  ! ------
237  ! Default is to test ALL the pointer members
238  ! for a true association status....
239  all_test = .true.
240  ! ...unless the ANY_Test argument is set.
241  IF ( PRESENT( any_test ) ) THEN
242  IF ( any_test == set ) all_test = .false.
243  END IF
244 
245  ! Test the members that MUST be associated
246  ! ----------------------------------------
247  association_status = .false.
248  IF ( all_test ) THEN
249  IF ( ASSOCIATED( odas%Sensor_Channel ) .AND. &
250  ASSOCIATED( odas%Absorber_ID ) .AND. &
251  ASSOCIATED( odas%Max_Order ) .AND. &
252  ASSOCIATED( odas%Alpha ) .AND. &
253  ASSOCIATED( odas%Order ) .AND. &
254  ASSOCIATED( odas%Pre_Index ) .AND. &
255  ASSOCIATED( odas%Pos_Index ) .AND. &
256  ASSOCIATED( odas%C ) ) THEN
257  association_status = .true.
258  END IF
259  ELSE
260  IF ( ASSOCIATED( odas%Sensor_Channel ) .OR. &
261  ASSOCIATED( odas%Absorber_ID ) .OR. &
262  ASSOCIATED( odas%Max_Order ) .OR. &
263  ASSOCIATED( odas%Alpha ) .OR. &
264  ASSOCIATED( odas%Order ) .OR. &
265  ASSOCIATED( odas%Pre_Index ) .OR. &
266  ASSOCIATED( odas%Pos_Index ) .OR. &
267  ASSOCIATED( odas%C ) ) THEN
268  association_status = .true.
269  END IF
270  END IF
271 
272  END FUNCTION associated_odas
273 
274 
275 !------------------------------------------------------------------------------
276 !
277 ! NAME:
278 ! Destroy_ODAS
279 !
280 ! PURPOSE:
281 ! Function to re-initialize the scalar and pointer members of ODAS
282 ! data structures.
283 !
284 ! CALLING SEQUENCE:
285 ! Error_Status = Destroy_ODAS( ODAS , & ! Output
286 ! RCS_Id =RCS_Id , & ! Revision control
287 ! Message_Log=Message_Log ) ! Error messaging
288 !
289 ! OUTPUT ARGUMENTS:
290 ! ODAS: Re-initialized ODAS structure.
291 ! UNITS: N/A
292 ! TYPE: ODAS_type
293 ! DIMENSION: Scalar
294 ! ATTRIBUTES: INTENT(IN OUT)
295 !
296 ! OPTIONAL INPUT ARGUMENTS:
297 ! Message_Log: Character string specifying a filename in which any
298 ! messages will be logged. If not specified, or if an
299 ! error occurs opening the log file, the default action
300 ! is to output messages to standard output.
301 ! UNITS: N/A
302 ! TYPE: CHARACTER(*)
303 ! DIMENSION: Scalar
304 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
305 !
306 ! OPTIONAL OUTPUT ARGUMENTS:
307 ! RCS_Id: Character string containing the Revision Control
308 ! System Id field for the module.
309 ! UNITS: N/A
310 ! TYPE: CHARACTER(*)
311 ! DIMENSION: Scalar
312 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
313 !
314 ! FUNCTION RESULT:
315 ! Error_Status: The return value is an integer defining the error status.
316 ! The error codes are defined in the Message_Handler module.
317 ! If == SUCCESS the structure re-initialisation was successful
318 ! == FAILURE - an error occurred, or
319 ! - the structure internal allocation counter
320 ! is not equal to zero (0) upon exiting this
321 ! function. This value is incremented and
322 ! decremented for every structure allocation
323 ! and deallocation respectively.
324 ! UNITS: N/A
325 ! TYPE: INTEGER
326 ! DIMENSION: Scalar
327 !
328 ! COMMENTS:
329 ! Note the INTENT on the output ODAS argument is IN OUT rather than
330 ! just OUT. This is necessary because the argument may be defined upon
331 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
332 !
333 !------------------------------------------------------------------------------
334 
335  FUNCTION destroy_odas( ODAS , & ! Output
336  No_Clear , & ! Optional input
337  RCS_Id , & ! Revision control
338  Message_Log) & ! Error messaging
339  result( error_status )
340  ! Arguments
341  TYPE(odas_type) , INTENT(IN OUT) :: odas
342  INTEGER, OPTIONAL, INTENT(IN) :: no_clear
343  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
344  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
345  ! Function result
346  INTEGER :: error_status
347  ! Local parameters
348  CHARACTER(*), PARAMETER :: routine_name = 'Destroy_ODAS'
349  ! Local variables
350  CHARACTER(ML) :: message
351  LOGICAL :: clear
352  INTEGER :: allocate_status
353 
354  ! Set up
355  ! ------
356  error_status = success
357  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
358 
359  ! Reinitialise the dimensions
360  odas%n_Predictors = 0
361  odas%n_Absorbers = 0
362  odas%n_Channels = 0
363  odas%n_Alphas = 0
364  odas%n_Coeffs = 0
365 
366  ! Default is to clear scalar members...
367  clear = .true.
368  ! ....unless the No_Clear argument is set
369  IF ( PRESENT( no_clear ) ) THEN
370  IF ( no_clear == set ) clear = .false.
371  END IF
372  IF ( clear ) CALL clear_odas( odas )
373 
374  ! If ALL components are NOT associated, do nothing
375  IF ( .NOT. associated_odas( odas ) ) RETURN
376 
377 
378  ! Deallocate the regular arrays components
379  ! ----------------------------------------
380  DEALLOCATE( odas%Sensor_Channel , &
381  odas%Absorber_ID , &
382  odas%Max_Order , &
383  odas%Alpha , &
384  odas%Order , &
385  odas%Pre_Index , &
386  odas%Pos_Index , &
387  odas%C , &
388  stat=allocate_status )
389  IF ( allocate_status /= 0 ) THEN
390  error_status = failure
391  WRITE( message,'("Error deallocating ODAS components. STAT = ",i0)' ) &
392  allocate_status
393  CALL display_message( routine_name, &
394  trim(message), &
395  error_status, &
396  message_log=message_log )
397  END IF
398 
399 
400  ! Decrement and test allocation counter
401  ! -------------------------------------
402  odas%n_Allocates = odas%n_Allocates - 1
403  IF ( odas%n_Allocates /= 0 ) THEN
404  error_status = failure
405  WRITE( message,'("Allocation counter /= 0, Value = ",i0)' ) &
406  odas%n_Allocates
407  CALL display_message( routine_name, &
408  trim(message), &
409  error_status, &
410  message_log=message_log )
411  END IF
412  END FUNCTION destroy_odas
413 
414 
415 !------------------------------------------------------------------------------
416 !
417 ! NAME:
418 ! Allocate_ODAS
419 !
420 ! PURPOSE:
421 ! Function to allocate the pointer members of the ODAS
422 ! data structure.
423 !
424 ! CALLING SEQUENCE:
425 ! Error_Status = Allocate_ODAS( n_Predictors , & ! Input
426 ! n_Absorbers , & ! Input
427 ! n_Channels , & ! Input
428 ! n_Alphas , & ! Input
429 ! n_Coeffs , & ! Input
430 ! ODAS , & ! Output
431 ! RCS_Id =RCS_Id , & ! Revision control
432 ! Message_Log=Message_Log ) ! Error messaging
433 !
434 ! INPUT ARGUMENTS:
435 !
436 ! n_Predictors: Maximum number of predictors dimension.
437 ! Must be > 0.
438 ! UNITS: N/A
439 ! TYPE: INTEGER
440 ! DIMENSION: Scalar
441 ! ATTRIBUTES: INTENT(IN)
442 !
443 ! n_Absorbers: Number of absorbers dimension.
444 ! Must be > 0.
445 ! UNITS: N/A
446 ! TYPE: INTEGER
447 ! DIMENSION: Scalar
448 ! ATTRIBUTES: INTENT(IN)
449 !
450 ! n_Channels: Number of channels dimension.
451 ! Must be > 0.
452 ! UNITS: N/A
453 ! TYPE: INTEGER
454 ! DIMENSION: Scalar
455 ! ATTRIBUTES: INTENT(IN)
456 !
457 ! n_Alphas: Number of Alpha dimension.
458 ! Must be > 0.
459 ! UNITS: N/A
460 ! TYPE: INTEGER
461 ! DIMENSION: Scalar
462 ! ATTRIBUTES: INTENT(IN)
463 !
464 ! n_Coeffs: Number of coefficient dimension.
465 ! Must be > 0.
466 ! UNITS: N/A
467 ! TYPE: INTEGER
468 ! DIMENSION: Scalar
469 ! ATTRIBUTES: INTENT(IN)
470 !
471 ! OUTPUT ARGUMENTS:
472 ! ODAS: ODAS structure with allocated
473 ! pointer members
474 ! UNITS: N/A
475 ! TYPE: ODAS_type
476 ! DIMENSION: Scalar
477 ! ATTRIBUTES: INTENT(OUT)
478 !
479 ! OPTIONAL INPUT ARGUMENTS:
480 ! Message_Log: Character string specifying a filename in
481 ! which any messages will be logged. If not
482 ! specified, or if an error occurs opening
483 ! the log file, the default action is to
484 ! output messages to standard output.
485 ! UNITS: N/A
486 ! TYPE: CHARACTER(*)
487 ! DIMENSION: Scalar
488 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
489 !
490 ! OPTIONAL OUTPUT ARGUMENTS:
491 ! RCS_Id: Character string containing the Revision Control
492 ! System Id field for the module.
493 ! UNITS: N/A
494 ! TYPE: CHARACTER(*)
495 ! DIMENSION: Scalar
496 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
497 !
498 ! FUNCTION RESULT:
499 ! Error_Status: The return value is an integer defining the error status.
500 ! The error codes are defined in the Message_Handler module.
501 ! If == SUCCESS the structure re-initialisation was successful
502 ! == FAILURE - an error occurred, or
503 ! - the structure internal allocation counter
504 ! is not equal to one (1) upon exiting this
505 ! function. This value is incremented and
506 ! decremented for every structure allocation
507 ! and deallocation respectively.
508 ! UNITS: N/A
509 ! TYPE: INTEGER
510 ! DIMENSION: Scalar
511 !
512 ! COMMENTS:
513 ! Note the INTENT on the output ODAS argument is IN OUT rather than
514 ! just OUT. This is necessary because the argument may be defined upon
515 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
516 !
517 !------------------------------------------------------------------------------
518 
519  FUNCTION allocate_odas( n_Predictors, & ! Input
520  n_Absorbers , & ! Input
521  n_Channels , & ! Input
522  n_Alphas , & ! Input
523  n_Coeffs , & ! Input
524  ODAS , & ! Output
525  RCS_Id , & ! Revision control
526  Message_Log ) & ! Error messaging
527  result( error_status )
528  ! Arguments
529  INTEGER , INTENT(IN) :: n_predictors
530  INTEGER , INTENT(IN) :: n_absorbers
531  INTEGER , INTENT(IN) :: n_channels
532  INTEGER , INTENT(IN) :: n_alphas
533  INTEGER , INTENT(IN) :: n_coeffs
534  TYPE(odas_type) , INTENT(IN OUT) :: odas
535  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
536  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
537  ! Function result
538  INTEGER :: error_status
539  ! Local parameters
540  CHARACTER(*), PARAMETER :: routine_name = 'Allocate_ODAS'
541  ! Local variables
542  CHARACTER(ML) :: message
543  INTEGER :: allocate_status
544 
545  ! Set up
546  ! ------
547  error_status = success
548  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
549 
550  ! Check dimension input
551  IF ( n_predictors < 1 .OR. &
552  n_absorbers < 1 .OR. &
553  n_channels < 1 .OR. &
554  n_alphas < 1 .OR. &
555  n_coeffs < 1 ) THEN
556  error_status = failure
557  CALL display_message( routine_name, &
558  'Input ODAS dimensions must all be > 0.', &
559  error_status, &
560  message_log=message_log )
561  RETURN
562  END IF
563 
564  ! Check if ANY pointers are already associated.
565  ! If they are, deallocate them but leave scalars.
566  IF ( associated_odas( odas, any_test=set ) ) THEN
567  error_status = destroy_odas( odas, &
568  no_clear=set, &
569  message_log=message_log )
570  IF ( error_status /= success ) THEN
571  CALL display_message( routine_name, &
572  'Error deallocating ODAS prior to reallocation.', &
573  error_status, &
574  message_log=message_log )
575  RETURN
576  END IF
577  END IF
578 
579  ! Allocate the data arrays
580  ! ------------------------
581  ALLOCATE( odas%Sensor_Channel( n_channels ), &
582  odas%Absorber_ID( n_absorbers ), &
583  odas%Max_Order( n_absorbers ), &
584  odas%Alpha( n_alphas, n_absorbers ), &
585  odas%Order( n_absorbers, n_channels ), &
586  odas%Pre_Index( 0:n_predictors, n_absorbers, n_channels ), &
587  odas%Pos_Index( n_absorbers, n_channels ), &
588  odas%C( n_coeffs ), &
589  stat=allocate_status )
590  IF ( allocate_status /= 0 ) THEN
591  error_status = failure
592  WRITE( message,'("Error allocating ODAS data arrays. STAT = ",i0)' ) &
593  allocate_status
594  CALL display_message( routine_name, &
595  trim(message), &
596  error_status, &
597  message_log=message_log )
598  RETURN
599  END IF
600 
601  ! Assign the dimensions and initialise arrays
602  odas%n_Predictors = n_predictors
603  odas%n_Absorbers = n_absorbers
604  odas%n_Channels = n_channels
605  odas%n_Alphas = n_alphas
606  odas%n_Coeffs = n_coeffs
607 
608  odas%Sensor_Channel = 0
609  odas%Absorber_ID = ip_invalid
610  odas%Max_Order = ip_invalid
611  odas%Alpha = fp_invalid
612  odas%Order = ip_invalid
613  odas%Pre_Index = ip_invalid
614  odas%Pos_Index = ip_invalid
615  odas%C = fp_invalid
616 
617 
618  ! Increment and test allocation counter
619  ! -------------------------------------
620  odas%n_Allocates = odas%n_Allocates + 1
621  IF ( odas%n_Allocates /= 1 ) THEN
622  error_status = failure
623  WRITE( message,'("Allocation counter /= 1, Value = ",i0)' ) &
624  odas%n_Allocates
625  CALL display_message( routine_name, &
626  trim(message), &
627  error_status, &
628  message_log=message_log )
629  RETURN
630  END IF
631 
632  END FUNCTION allocate_odas
633 
634 !------------------------------------------------------------------------------
635 !
636 ! NAME:
637 ! Assign_ODAS
638 !
639 ! PURPOSE:
640 ! Function to copy valid ODAS structures.
641 !
642 ! CALLING SEQUENCE:
643 ! Error_Status = Assign_ODAS( ODAS_in , & ! Input
644 ! ODAS_out , & ! Output
645 ! RCS_Id =RCS_Id , & ! Revision control
646 ! Message_Log=Message_Log ) ! Error messaging
647 !
648 ! INPUT ARGUMENTS:
649 ! ODAS_in: ODAS structure which is to be copied.
650 ! UNITS: N/A
651 ! TYPE: ODAS_type
652 ! DIMENSION: Scalar
653 ! ATTRIBUTES: INTENT(IN)
654 !
655 ! OUTPUT ARGUMENTS:
656 ! ODAS_out: Copy of the input structure, ODAS_in.
657 ! UNITS: N/A
658 ! TYPE: ODAS_type
659 ! DIMENSION: Scalar
660 ! ATTRIBUTES: INTENT(IN OUT)
661 !
662 ! OPTIONAL INPUT ARGUMENTS:
663 ! Message_Log: Character string specifying a filename in which any
664 ! messages will be logged. If not specified, or if an
665 ! error occurs opening the log file, the default action
666 ! is to output messages to standard output.
667 ! UNITS: N/A
668 ! TYPE: CHARACTER(*)
669 ! DIMENSION: Scalar
670 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
671 !
672 ! OPTIONAL OUTPUT ARGUMENTS:
673 ! RCS_Id: Character string containing the Revision Control
674 ! System Id field for the module.
675 ! UNITS: N/A
676 ! TYPE: CHARACTER(*)
677 ! DIMENSION: Scalar
678 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
679 !
680 ! FUNCTION RESULT:
681 ! Error_Status: The return value is an integer defining the error status.
682 ! The error codes are defined in the Message_Handler module.
683 ! If == SUCCESS the structure assignment was successful
684 ! == FAILURE an error occurred
685 ! UNITS: N/A
686 ! TYPE: INTEGER
687 ! DIMENSION: Scalar
688 !
689 ! COMMENTS:
690 ! Note the INTENT on the output ODAS argument is IN OUT rather than
691 ! just OUT. This is necessary because the argument may be defined upon
692 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
693 !
694 !------------------------------------------------------------------------------
695 
696  FUNCTION assign_odas( ODAS_in , & ! Input
697  ODAS_out , & ! Output
698  RCS_Id , & ! Revision control
699  Message_Log ) & ! Error messaging
700  result( error_status )
701  ! Arguments
702  TYPE(odas_type) , INTENT(IN) :: odas_in
703  TYPE(odas_type) , INTENT(IN OUT) :: odas_out
704  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
705  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
706  ! Function result
707  INTEGER :: error_status
708  ! Local parameters
709  CHARACTER(*), PARAMETER :: routine_name = 'Assign_ODAS'
710 
711  ! Set up
712  ! ------
713  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
714 
715  ! ALL *input* pointers must be associated
716  IF ( .NOT. associated_odas( odas_in ) ) THEN
717  error_status = failure
718  CALL display_message( routine_name, &
719  'Some or all INPUT ODAS pointer '//&
720  'members are NOT associated.', &
721  error_status, &
722  message_log=message_log )
723  RETURN
724  END IF
725 
726 
727  ! Allocate the structure
728  ! ----------------------
729  error_status = allocate_odas( odas_in%n_Predictors, &
730  odas_in%n_Absorbers , &
731  odas_in%n_Channels , &
732  odas_in%n_Alphas , &
733  odas_in%n_Coeffs , &
734  odas_out, &
735  message_log=message_log )
736  IF ( error_status /= success ) THEN
737  CALL display_message( routine_name, &
738  'Error allocating output ODAS arrays.', &
739  error_status, &
740  message_log=message_log )
741  RETURN
742  END IF
743 
744 
745  ! Assign intrinsic data types
746  ! ---------------------------
747  odas_out%Release = odas_in%Release
748  odas_out%Version = odas_in%Version
749 
750  odas_out%Sensor_Id = odas_in%Sensor_Id
751  odas_out%Sensor_Type = odas_in%Sensor_Type
752  odas_out%WMO_Satellite_ID = odas_in%WMO_Satellite_ID
753  odas_out%WMO_Sensor_ID = odas_in%WMO_Sensor_ID
754  odas_out%Sensor_Channel = odas_in%Sensor_Channel
755  odas_out%Absorber_ID = odas_in%Absorber_ID
756  odas_out%Max_Order = odas_in%Max_Order
757  odas_out%Alpha = odas_in%Alpha
758  odas_out%Order = odas_in%Order
759  odas_out%Pre_Index = odas_in%Pre_Index
760  odas_out%Pos_Index = odas_in%Pos_Index
761  odas_out%C = odas_in%C
762 
763  END FUNCTION assign_odas
764 
765 !------------------------------------------------------------------------------
766 !
767 ! NAME:
768 ! Equal_ODAS
769 !
770 ! PURPOSE:
771 ! Function to test if two ODAS structures are equal.
772 !
773 ! CALLING SEQUENCE:
774 ! Error_Status = Equal_ODAS( ODAS_LHS , & ! Input
775 ! ODAS_RHS , & ! Input
776 ! ULP_Scale =ULP_Scale , & ! Optional input
777 ! Check_All =Check_All , & ! Optional input
778 ! RCS_Id =RCS_Id , & ! Revision control
779 ! Message_Log=Message_Log ) ! Error messaging
780 !
781 ! INPUT ARGUMENTS:
782 ! ODAS_LHS: ODAS structure to be compared; equivalent to the
783 ! left-hand side of a lexical comparison, e.g.
784 ! IF ( ODAS_LHS == ODAS_RHS ).
785 ! UNITS: N/A
786 ! TYPE: ODAS_type
787 ! DIMENSION: Scalar
788 ! ATTRIBUTES: INTENT(IN)
789 !
790 ! ODAS_RHS: ODAS structure to be compared to; equivalent to
791 ! right-hand side of a lexical comparison, e.g.
792 ! IF ( ODAS_LHS == ODAS_RHS ).
793 ! UNITS: N/A
794 ! TYPE: ODAS_type
795 ! DIMENSION: Scalar
796 ! ATTRIBUTES: INTENT(IN)
797 !
798 ! OPTIONAL INPUT ARGUMENTS:
799 ! ULP_Scale: Unit of data precision used to scale the floating
800 ! point comparison. ULP stands for "Unit in the Last Place,"
801 ! the smallest possible increment or decrement that can be
802 ! made using a machine's floating point arithmetic.
803 ! Value must be positive - if a negative value is supplied,
804 ! the absolute value is used. If not specified, the default
805 ! value is 1.
806 ! UNITS: N/A
807 ! TYPE: INTEGER
808 ! DIMENSION: Scalar
809 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
810 !
811 ! Check_All: Set this argument to check ALL the *floating point*
812 ! channel data of the ODAS structures. The default
813 ! action is return with a FAILURE status as soon as
814 ! any difference is found. This optional argument can
815 ! be used to get a listing of ALL the differences
816 ! between data in ODAS structures.
817 ! If == 0, Return with FAILURE status as soon as
818 ! ANY difference is found *DEFAULT*
819 ! == 1, Set FAILURE status if ANY difference is
820 ! found, but continue to check ALL data.
821 ! Note: Setting this argument has no effect if, for
822 ! example, the structure dimensions are different,
823 ! or the sensor ids/channels are different, or the
824 ! absorber ids are different, etc.
825 ! UNITS: N/A
826 ! TYPE: INTEGER
827 ! DIMENSION: Scalar
828 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
829 !
830 ! Message_Log: Character string specifying a filename in which any
831 ! messages will be logged. If not specified, or if an
832 ! error occurs opening the log file, the default action
833 ! is to output messages to standard output.
834 ! UNITS: N/A
835 ! TYPE: CHARACTER(*)
836 ! DIMENSION: Scalar
837 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
838 !
839 ! OPTIONAL OUTPUT ARGUMENTS:
840 ! RCS_Id: Character string containing the Revision Control
841 ! System Id field for the module.
842 ! UNITS: N/A
843 ! TYPE: CHARACTER(*)
844 ! DIMENSION: Scalar
845 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
846 !
847 ! FUNCTION RESULT:
848 ! Error_Status: The return value is an integer defining the error status.
849 ! The error codes are defined in the Message_Handler module.
850 ! If == SUCCESS the structures were equal
851 ! == FAILURE - an error occurred, or
852 ! - the structures were different.
853 ! UNITS: N/A
854 ! TYPE: INTEGER
855 ! DIMENSION: Scalar
856 !
857 ! COMMENTS:
858 ! Congruency of the structure data is a prerequisite of equality.
859 ! That is, the *order* of the data is important. For example, if
860 ! two structures contain the same absorber information, but in a
861 ! different order, the structures are not considered equal.
862 !
863 !------------------------------------------------------------------------------
864 
865  FUNCTION equal_odas( ODAS_LHS , & ! Input
866  ODAS_RHS , & ! Input
867  ULP_Scale , & ! Optional input
868  Check_All , & ! Optional input
869  RCS_Id , & ! Revision control
870  Message_Log) & ! Error messaging
871  result( error_status )
872  ! Arguments
873  TYPE(odas_type) , INTENT(IN) :: odas_lhs
874  TYPE(odas_type) , INTENT(IN) :: odas_rhs
875  INTEGER, OPTIONAL, INTENT(IN) :: ulp_scale
876  INTEGER, OPTIONAL, INTENT(IN) :: check_all
877  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
878  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
879  ! Function result
880  INTEGER :: error_status
881  ! Local parameters
882  CHARACTER(*), PARAMETER :: routine_name = 'Equal_ODAS'
883  ! Local variables
884  CHARACTER(ML) :: message
885  INTEGER :: ulp
886  LOGICAL :: check_once
887  INTEGER(LONG) :: i, j, l, ip
888 
889  ! Set up
890  ! ------
891  error_status = success
892  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
893 
894  ! Default precision is a single unit in last place
895  ulp = 1
896  ! ... unless the ULP_Scale argument is set and positive
897  IF ( PRESENT( ulp_scale ) ) THEN
898  IF ( ulp_scale > 0 ) ulp = ulp_scale
899  END IF
900 
901  ! Default action is to return on ANY difference...
902  check_once = .true.
903  ! ...unless the Check_All argument is set
904  IF ( PRESENT( check_all ) ) THEN
905  IF ( check_all == 1 ) check_once = .false.
906  END IF
907 
908  ! Check the structure association status
909  IF ( .NOT. associated_odas( odas_lhs ) ) THEN
910  error_status = failure
911  CALL display_message( routine_name, &
912  'Some or all INPUT ODAS_LHS pointer '//&
913  'members are NOT associated.', &
914  error_status, &
915  message_log=message_log )
916  RETURN
917  END IF
918  IF ( .NOT. associated_odas( odas_rhs ) ) THEN
919  error_status = failure
920  CALL display_message( routine_name, &
921  'Some or all INPUT ODAS_RHS pointer '//&
922  'members are NOT associated.', &
923  error_status, &
924  message_log=message_log )
925  RETURN
926  END IF
927 
928 
929  ! Check structure Release/Version
930  ! -------------------------------
931  IF ( ( odas_lhs%Release /= odas_rhs%Release ) .OR. &
932  ( odas_lhs%Version /= odas_rhs%Version ) ) THEN
933  error_status = failure
934  WRITE( message, '( "Release/Version numbers are different : ", &
935  &i2, ".", i2.2, " vs. ", i2, ".", i2.2 )' ) &
936  odas_lhs%Release, odas_lhs%Version, &
937  odas_rhs%Release, odas_rhs%Version
938  CALL display_message( routine_name, &
939  trim(message), &
940  error_status, &
941  message_log=message_log )
942  IF ( check_once ) RETURN
943  END IF
944 
945 
946  ! Check dimensions
947  ! ----------------
948  IF ( odas_lhs%n_Predictors /= odas_rhs%n_Predictors .OR. &
949  odas_lhs%n_Absorbers /= odas_rhs%n_Absorbers .OR. &
950  odas_lhs%n_Channels /= odas_rhs%n_Channels .OR. &
951  odas_lhs%n_Alphas /= odas_rhs%n_Alphas .OR. &
952  odas_lhs%n_Coeffs /= odas_rhs%n_Coeffs ) THEN
953  error_status = failure
954  CALL display_message( routine_name, &
955  'Structure dimensions are different', &
956  error_status, &
957  message_log=message_log )
958  RETURN
959  END IF
960 
961  ! Compare the values
962  ! ------------------
963  ! The Sensor_ID
964  IF ( odas_lhs%Sensor_Id /= odas_rhs%Sensor_Id ) THEN
965  error_status = failure
966  WRITE( message, '( "Sensor_ID values are different, ", &
967  &a, " vs. ", a )' ) &
968  trim( odas_lhs%Sensor_Id), &
969  trim( odas_rhs%Sensor_Id)
970  CALL display_message( routine_name, &
971  trim(message), &
972  error_status, &
973  message_log=message_log )
974  IF ( check_once ) RETURN
975  END IF
976 
977  ! The Sensor_Type
978  IF ( odas_lhs%Sensor_Type /= odas_rhs%Sensor_Type ) THEN
979  WRITE( message,'("Sensor types are different, ", &
980  &i0,"(",a,") vs. ", i0,"(",a,")")' ) &
981  odas_lhs%Sensor_Type, &
982  trim(sensor_type_name(odas_lhs%Sensor_Type)), &
983  odas_rhs%Sensor_Type, &
984  trim(sensor_type_name(odas_rhs%Sensor_Type))
985  CALL display_message( routine_name, &
986  trim(message), &
987  error_status, &
988  message_log=message_log )
989  IF ( check_once ) RETURN
990  END IF
991 
992  ! The WMO Satellite ID
993  IF ( odas_lhs%WMO_Satellite_ID /= odas_rhs%WMO_Satellite_ID ) THEN
994  error_status = failure
995  WRITE( message,'("WMO_Satellite_ID values are different, ",i0,&
996  &" vs. ",i0 )' ) &
997  odas_lhs%WMO_Satellite_ID, &
998  odas_rhs%WMO_Satellite_ID
999  CALL display_message( routine_name, &
1000  trim(message), &
1001  error_status, &
1002  message_log=message_log )
1003  IF ( check_once ) RETURN
1004  END IF
1005 
1006  ! The WMO Sensor ID
1007  IF ( odas_lhs%WMO_Sensor_ID /= odas_rhs%WMO_Sensor_ID ) THEN
1008  error_status = failure
1009  WRITE( message,'("WMO_Sensor_ID values are different, ",i0,&
1010  &" vs. ",i0)' ) &
1011  odas_lhs%WMO_Sensor_ID, &
1012  odas_rhs%WMO_Sensor_ID
1013  CALL display_message( routine_name, &
1014  trim(message), &
1015  error_status, &
1016  message_log=message_log )
1017  IF ( check_once ) RETURN
1018  END IF
1019 
1020  ! The Sensor_Channel
1021  DO l = 1, odas_rhs%n_Channels
1022  IF ( odas_lhs%Sensor_Channel(l) /= odas_rhs%Sensor_Channel(l) ) THEN
1023  error_status = failure
1024  WRITE( message,'("Sensor_Channel values are different, ",i0,&
1025  &" vs. ",i0,", for channel index # ",i0)' ) &
1026  odas_lhs%Sensor_Channel(l), &
1027  odas_rhs%Sensor_Channel(l), &
1028  l
1029  CALL display_message( routine_name, &
1030  trim(message), &
1031  error_status, &
1032  message_log=message_log )
1033  IF ( check_once ) RETURN
1034  END IF
1035  END DO
1036 
1037  ! The Absorber_ID
1038  DO j = 1, odas_rhs%n_Absorbers
1039  IF ( odas_lhs%Absorber_ID(j) /= odas_rhs%Absorber_ID(j) ) THEN
1040  error_status = failure
1041  WRITE( message,'("Absorber_ID values are different, ",i0,&
1042  &" vs. ",i0,", for absorber index # ",i0)' ) &
1043  odas_lhs%Absorber_ID(j), &
1044  odas_rhs%Absorber_ID(j), &
1045  j
1046  CALL display_message( routine_name, &
1047  trim(message), &
1048  error_status, &
1049  message_log=message_log )
1050  IF ( check_once ) RETURN
1051  END IF
1052  END DO
1053 
1054  ! The Max Order array
1055  DO j = 1, odas_rhs%n_Absorbers
1056  IF ( odas_lhs%Max_Order(j) /= odas_rhs%Max_Order(j) ) THEN
1057  error_status = failure
1058  WRITE( message,'("Order values are different, ",i0,&
1059  &" vs. ",i0,", for index (",i0,")")' ) &
1060  odas_lhs%Max_Order(j), &
1061  odas_rhs%Max_Order(j), &
1062  j
1063  CALL display_message( routine_name, &
1064  trim(message), &
1065  error_status, &
1066  message_log=message_log )
1067  IF ( check_once ) RETURN
1068  END IF
1069  END DO
1070 
1071  ! The Alpha value
1072  DO j = 1, odas_rhs%n_Absorbers
1073  DO i = 1, odas_rhs%n_Alphas
1074  IF ( .NOT. ( compare_float( odas_lhs%Alpha(i,j), &
1075  odas_rhs%Alpha(i,j), &
1076  ulp = ulp ) ) ) THEN
1077  error_status = failure
1078  WRITE( message,'("Alpha values are different, ",es13.6,&
1079  &" vs. ",es13.6,", for alpha index # ",i0,&
1080  &" and absorber index #",i0 )' ) &
1081  odas_lhs%Alpha(i,j), &
1082  odas_rhs%Alpha(i,j), &
1083  i,j
1084  CALL display_message( routine_name, &
1085  trim(message), &
1086  error_status, &
1087  message_log=message_log )
1088  IF ( check_once ) RETURN
1089  END IF
1090  END DO
1091  END DO
1092 
1093  ! The Order array
1094  DO l = 1, odas_rhs%n_Channels
1095  DO j = 1, odas_rhs%n_Absorbers
1096  IF ( odas_lhs%Order(j,l) /= odas_rhs%Order(j,l) ) THEN
1097  error_status = failure
1098  WRITE( message,'("Order values are different, ",i0,&
1099  &" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
1100  odas_lhs%Order(j,l), &
1101  odas_rhs%Order(j,l), &
1102  j,l
1103  CALL display_message( routine_name, &
1104  trim(message), &
1105  error_status, &
1106  message_log=message_log )
1107  IF ( check_once ) RETURN
1108  END IF
1109  END DO
1110  END DO
1111 
1112  ! The Pre_Index
1113  DO l = 1, odas_rhs%n_Channels
1114  DO j = 1, odas_rhs%n_Absorbers
1115  DO ip = 0, odas_rhs%n_Predictors
1116  IF ( odas_lhs%Pre_Index(ip,j,l) /= odas_rhs%Pre_Index(ip,j,l) ) THEN
1117  error_status = failure
1118  WRITE( message,'("Predictor_Index values are different, ",i0,&
1119  &" vs. ",i0,", for index (",i0,1x,i0,1x,i0,")")' ) &
1120  odas_lhs%Pre_Index(ip,j,l), &
1121  odas_rhs%Pre_Index(ip,j,l), &
1122  ip,j,l
1123  CALL display_message( routine_name, &
1124  trim(message), &
1125  error_status, &
1126  message_log=message_log )
1127  IF ( check_once ) RETURN
1128  END IF
1129  END DO
1130  END DO
1131  END DO
1132 
1133  ! The Pos_Index
1134  DO l = 1, odas_rhs%n_Channels
1135  DO j = 1, odas_rhs%n_Absorbers
1136  IF ( odas_lhs%Pos_Index(j,l) /= odas_rhs%Pos_Index(j,l) ) THEN
1137  error_status = failure
1138  WRITE( message,'("Predictor_Index values are different, ",i0,&
1139  &" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
1140  odas_lhs%Pos_Index(j,l), &
1141  odas_rhs%Pos_Index(j,l), &
1142  j,l
1143  CALL display_message( routine_name, &
1144  trim(message), &
1145  error_status, &
1146  message_log=message_log )
1147  IF ( check_once ) RETURN
1148  END IF
1149  END DO
1150  END DO
1151 
1152  ! The Coefficients
1153  DO i = 1, odas_rhs%n_Coeffs
1154  IF ( odas_lhs%C(i) /= odas_rhs%C(i) ) THEN
1155  error_status = failure
1156  WRITE( message,'("C values are different, ",i0,&
1157  &" vs. ",i0,", for index (",i0,")")' ) &
1158  odas_lhs%C(i), &
1159  odas_rhs%C(i), &
1160  i
1161  CALL display_message( routine_name, &
1162  trim(message), &
1163  error_status, &
1164  message_log=message_log )
1165  IF ( check_once ) RETURN
1166  END IF
1167  END DO
1168 
1169  END FUNCTION equal_odas
1170 
1171 !----------------------------------------------------------------------------------
1172 !
1173 ! NAME:
1174 ! CheckRelease_ODAS
1175 !
1176 ! PURPOSE:
1177 ! Function to check the ODAS Release value.
1178 !
1179 ! CALLING SEQUENCE:
1180 ! Error_Status = CheckRelease_ODASe( ODAS , & ! Input
1181 ! RCS_Id = RCS_Id , & ! Revision control
1182 ! Message_Log=Message_Log ) ! Error messaging
1183 !
1184 ! INPUT ARGUMENTS:
1185 ! ODAS: ODAS structure for which the Release member
1186 ! is to be checked.
1187 ! UNITS: N/A
1188 ! TYPE: ODAS_type
1189 ! DIMENSION: Scalar
1190 ! ATTRIBUTES: INTENT(OUT)
1191 !
1192 ! OPTIONAL INPUT ARGUMENTS:
1193 ! Message_Log: Character string specifying a filename in which any
1194 ! messages will be logged. If not specified, or if an
1195 ! error occurs opening the log file, the default action
1196 ! is to output messages to standard output.
1197 ! UNITS: N/A
1198 ! TYPE: CHARACTER(*)
1199 ! DIMENSION: Scalar
1200 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1201 ! OPTIONAL OUTPUT ARGUMENTS:
1202 ! RCS_Id: Character string containing the Revision Control
1203 ! System Id field for the module.
1204 ! UNITS: N/A
1205 ! TYPE: CHARACTER(*)
1206 ! DIMENSION: Scalar
1207 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1208 !
1209 ! FUNCTION RESULT:
1210 ! Error_Status: The return value is an integer defining the error status.
1211 ! The error codes are defined in the Message_Handler module.
1212 ! If == SUCCESS the structure Release value is valid.
1213 ! == FAILURE the structure Release value is NOT valid
1214 ! and either a data file file or software
1215 ! update is required.
1216 ! UNITS: N/A
1217 ! TYPE: INTEGER
1218 ! DIMENSION: Scalar
1219 !
1220 !----------------------------------------------------------------------------------
1221 
1222  FUNCTION checkrelease_odas( ODAS , & ! Input
1223  RCS_Id , & ! Revision control
1224  Message_Log) & ! Error messaging
1225  result( error_status )
1226  ! Arguments
1227  TYPE(odas_type) , INTENT(IN) :: odas
1228  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1229  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1230  ! Function result
1231  INTEGER :: error_status
1232  ! Local parameters
1233  CHARACTER(*), PARAMETER :: routine_name = 'CheckRelease_ODAS'
1234  ! Local variables
1235  CHARACTER(ML) :: message
1236 
1237  ! Set up
1238  ! ------
1239  error_status = success
1240  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
1241 
1242 
1243  ! Check the release
1244  ! -----------------
1245  ! Check that release is not too old
1246  IF ( odas%Release < odas_release ) THEN
1247  error_status = failure
1248  WRITE( message, '( "An ODAS data update is needed. ", &
1249  &"ODAS release is ", i2, &
1250  &". Valid release is ",i2,"." )' ) &
1251  odas%Release, odas_release
1252  CALL display_message( routine_name, &
1253  trim(message), &
1254  error_status, &
1255  message_log=message_log )
1256  RETURN
1257  END IF
1258 
1259  ! Check that release is not too new
1260  IF ( odas%Release > odas_release ) THEN
1261  error_status = failure
1262  WRITE( message, '( "An ODAS software update is needed. ", &
1263  &"ODAS release is ", i2, &
1264  &". Valid release is ",i2,"." )' ) &
1265  odas%Release, odas_release
1266  CALL display_message( routine_name, &
1267  trim(message), &
1268  error_status, &
1269  message_log=message_log )
1270  RETURN
1271  END IF
1272 
1273  END FUNCTION checkrelease_odas
1274 
1275 
1276 !----------------------------------------------------------------------------------
1277 !
1278 ! NAME:
1279 ! CheckAlgorithm_ODAS
1280 !
1281 ! PURPOSE:
1282 ! Function to check the ODAS Algorithm value.
1283 !
1284 ! CALLING SEQUENCE:
1285 ! Error_Status = CheckAlgorithm_ODAS( ODAS , & ! Input
1286 ! RCS_Id = RCS_Id , & ! Revision control
1287 ! Message_Log=Message_Log ) ! Error messaging
1288 !
1289 ! INPUT ARGUMENTS:
1290 ! ODAS: ODAS structure for which the Algorithm member
1291 ! is to be checked.
1292 ! UNITS: N/A
1293 ! TYPE: ODAS_type
1294 ! DIMENSION: Scalar
1295 ! ATTRIBUTES: INTENT(OUT)
1296 !
1297 ! OPTIONAL INPUT ARGUMENTS:
1298 ! Message_Log: Character string specifying a filename in which any
1299 ! messages will be logged. If not specified, or if an
1300 ! error occurs opening the log file, the default action
1301 ! is to output messages to standard output.
1302 ! UNITS: N/A
1303 ! TYPE: CHARACTER(*)
1304 ! DIMENSION: Scalar
1305 ! ATTRIBUTES: OPTIONAL, INTENT(IN)
1306 ! OPTIONAL OUTPUT ARGUMENTS:
1307 ! RCS_Id: Character string containing the Revision Control
1308 ! System Id field for the module.
1309 ! UNITS: N/A
1310 ! TYPE: CHARACTER(*)
1311 ! DIMENSION: Scalar
1312 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1313 !
1314 ! FUNCTION RESULT:
1315 ! Error_Status: The return value is an integer defining the error status.
1316 ! The error codes are defined in the Message_Handler module.
1317 ! If == SUCCESS the structure Algorithm value is valid.
1318 ! == FAILURE the structure Algorithm value is NOT valid.
1319 ! UNITS: N/A
1320 ! TYPE: INTEGER
1321 ! DIMENSION: Scalar
1322 !
1323 !----------------------------------------------------------------------------------
1324 
1325  FUNCTION checkalgorithm_odas( ODAS , & ! Input
1326  RCS_Id , & ! Revision control
1327  Message_Log) & ! Error messaging
1328  result( error_status )
1329  ! Arguments
1330  TYPE(odas_type) , INTENT(IN) :: odas
1331  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1332  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1333  ! Function result
1334  INTEGER :: error_status
1335  ! Local parameters
1336  CHARACTER(*), PARAMETER :: routine_name = 'CheckAlgorithm_ODAS'
1337 
1338  ! Set up
1339  ! ------
1340  error_status = success
1341  IF ( PRESENT(rcs_id) ) rcs_id = module_rcs_id
1342 
1343 
1344  ! Check the algorithm ID
1345  ! ----------------------
1346  IF ( odas%Algorithm /= odas_algorithm ) THEN
1347  error_status = failure
1348  CALL display_message( routine_name, &
1349  'The ODAS Algorithm ID check failed. '//&
1350  'The data structure is not an ODAS structure', &
1351  error_status, &
1352  message_log=message_log )
1353  RETURN
1354  END IF
1355 
1356  END FUNCTION checkalgorithm_odas
1357 
1358 
1359 !------------------------------------------------------------------------------
1360 !
1361 ! NAME:
1362 ! Info_ODAS
1363 !
1364 ! PURPOSE:
1365 ! Subroutine to return a string containing version and dimension
1366 ! information about the ODAS data structure.
1367 !
1368 ! CALLING SEQUENCE:
1369 ! CALL Info_ODAS( ODAS , & ! Input
1370 ! Info , & ! Output
1371 ! RCS_Id=RCS_Id ) ! Revision control
1372 !
1373 ! INPUT ARGUMENTS:
1374 ! ODAS: Filled ODAS structure.
1375 ! UNITS: N/A
1376 ! TYPE: ODAS_type
1377 ! DIMENSION: Scalar
1378 ! ATTRIBUTES: INTENT(IN)
1379 !
1380 ! OUTPUT ARGUMENTS:
1381 ! Info: String containing version and dimension information
1382 ! about the passed ODAS data structure.
1383 ! UNITS: N/A
1384 ! TYPE: CHARACTER(*)
1385 ! DIMENSION: Scalar
1386 ! ATTRIBUTES: INTENT(OUT)
1387 !
1388 ! OPTIONAL OUTPUT ARGUMENTS:
1389 ! RCS_Id: Character string containing the Revision Control
1390 ! System Id field for the module.
1391 ! UNITS: N/A
1392 ! TYPE: CHARACTER(*)
1393 ! DIMENSION: Scalar
1394 ! ATTRIBUTES: OPTIONAL, INTENT(OUT)
1395 !
1396 !------------------------------------------------------------------------------
1397 
1398  SUBROUTINE info_odas( ODAS , & ! Input
1399  Info , & ! Output
1400  RCS_Id ) ! Revision control
1401  ! Arguments
1402  TYPE(odas_type) , INTENT(IN) :: odas
1403  CHARACTER(*), INTENT(OUT) :: info
1404  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
1405  ! Local variables
1406  CHARACTER(2000) :: longstring
1407 
1408  ! Set up
1409  ! ------
1410  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
1411 
1412  ! Write the required data to the local string
1413  ! -------------------------------------------
1414  WRITE( longstring,'( a,3x,"ODAS RELEASE.VERSION: ",i2,".",i2.2,2x,&
1415  &"N_PREDICTORS=",i2,2x,&
1416  &"N_ABSORBERS=",i2,2x,&
1417  &"N_CHANNELS=",i0,2x, &
1418  &"N_Alphas=",i2,2x, &
1419  &"N_Coeffs=",i0)' ) &
1420  achar(carriage_return)//achar(linefeed), &
1421  odas%Release, odas%Version, &
1422  odas%n_Predictors, &
1423  odas%n_Absorbers, &
1424  odas%n_Channels, &
1425  odas%n_Alphas, &
1426  odas%n_Coeffs
1427 
1428  ! Trim the output based on the
1429  ! dummy argument string length
1430  ! ----------------------------
1431  info = longstring(1:min( len(info), len_trim(longstring) ))
1432 
1433  END SUBROUTINE info_odas
1434 
1435 
1436 !##################################################################################
1437 !##################################################################################
1438 !## ##
1439 !## ## PRIVATE MODULE ROUTINES ## ##
1440 !## ##
1441 !##################################################################################
1442 !##################################################################################
1443 
1444 !----------------------------------------------------------------------------------
1445 !
1446 ! NAME:
1447 ! Clear_ODAS
1448 !
1449 ! PURPOSE:
1450 ! Subroutine to clear the scalar members of a ODAS structure.
1451 !
1452 ! CALLING SEQUENCE:
1453 ! CALL Clear_ODAS( ODAS ) ! Output
1454 !
1455 ! OUTPUT ARGUMENTS:
1456 ! ODAS: ODAS structure for which the scalar members have
1457 ! been cleared.
1458 ! UNITS: N/A
1459 ! TYPE: ODAS_type
1460 ! DIMENSION: Scalar
1461 ! ATTRIBUTES: INTENT(IN OUT)
1462 !
1463 ! COMMENTS:
1464 ! Note the INTENT on the output ODAS argument is IN OUT rather than
1465 ! just OUT. This is necessary because the argument may be defined upon
1466 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
1467 !
1468 !----------------------------------------------------------------------------------
1469 
1470  SUBROUTINE clear_odas( ODAS )
1471  TYPE(ODAS_type), INTENT(IN OUT) :: ODAS
1472  odas%Release = odas_release
1473  odas%Version = odas_version
1474  odas%Algorithm = odas_algorithm
1475  odas%Sensor_Id = ' '
1476  odas%Sensor_Type = invalid_sensor
1477  odas%WMO_Satellite_ID = invalid_wmo_satellite_id
1478  odas%WMO_Sensor_ID = invalid_wmo_sensor_id
1479  END SUBROUTINE clear_odas
1480 
1481 END MODULE odas_define
compare_float_numbers::compare_float
Definition: Compare_Float_Numbers.f90:45
odas_define::assign_odas
integer function, public assign_odas(ODAS_in, ODAS_out, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:701
odas_define::linefeed
integer, parameter linefeed
Definition: ODAS_Define.f90:88
message_handler::failure
integer, parameter, public failure
Definition: Message_Handler.f90:30
message_handler::warning
integer, parameter, public warning
Definition: Message_Handler.f90:29
type_kinds::long
integer, parameter, public long
Definition: Type_Kinds.f90:76
odas_define::n_sensor_types
integer, parameter, public n_sensor_types
Definition: ODAS_Define.f90:93
odas_define::invalid_wmo_satellite_id
integer, parameter, public invalid_wmo_satellite_id
Definition: ODAS_Define.f90:90
odas_define::ml
integer, parameter ml
Definition: ODAS_Define.f90:80
odas_define::visible_sensor
integer, parameter, public visible_sensor
Definition: ODAS_Define.f90:97
crtm_parameters
Definition: CRTM_Parameters.f90:12
odas_define::fp_invalid
real(double), parameter fp_invalid
Definition: ODAS_Define.f90:75
odas_define::odas_release
integer, parameter, public odas_release
Definition: ODAS_Define.f90:82
odas_define::sensor_type_name
character(*), dimension(0:n_sensor_types), parameter, public sensor_type_name
Definition: ODAS_Define.f90:99
type_kinds::double
integer, parameter, public double
Definition: Type_Kinds.f90:106
odas_define::equal_odas
integer function, public equal_odas(ODAS_LHS, ODAS_RHS, ULP_Scale, Check_All, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:872
sort_utility::insertionsort
Definition: Sort_Utility.f90:37
odas_define::odas_algorithm_name
character(*), parameter odas_algorithm_name
Definition: ODAS_Define.f90:85
message_handler
Definition: Message_Handler.f90:4
odas_define::odas_type
Definition: ODAS_Define.f90:109
odas_define::infrared_sensor
integer, parameter, public infrared_sensor
Definition: ODAS_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
odas_define::destroy_odas
integer function, public destroy_odas(ODAS, No_Clear, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:340
odas_define::ultraviolet_sensor
integer, parameter ultraviolet_sensor
Definition: ODAS_Define.f90:98
odas_define::clear_odas
subroutine clear_odas(ODAS)
Definition: ODAS_Define.f90:1471
odas_define::ip_invalid
integer, parameter ip_invalid
Definition: ODAS_Define.f90:74
odas_define::associated_odas
logical function, public associated_odas(ODAS, ANY_Test)
Definition: ODAS_Define.f90:227
crtm_parameters::odas_algorithm
integer, parameter, public odas_algorithm
Definition: CRTM_Parameters.f90:124
odas_define::set
integer, parameter set
Definition: ODAS_Define.f90:77
odas_define::odas_version
integer, parameter odas_version
Definition: ODAS_Define.f90:83
odas_define::info_odas
subroutine, public info_odas(ODAS, Info, RCS_Id)
Definition: ODAS_Define.f90:1401
odas_define::allocate_odas
integer function, public allocate_odas(n_Predictors, n_Absorbers, n_Channels, n_Alphas, n_Coeffs, ODAS, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:528
type_kinds
Definition: Type_Kinds.f90:12
odas_define::checkalgorithm_odas
integer function, public checkalgorithm_odas(ODAS, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:1329
odas_define::microwave_sensor
integer, parameter, public microwave_sensor
Definition: ODAS_Define.f90:95
odas_define::invalid_sensor
integer, parameter, public invalid_sensor
Definition: ODAS_Define.f90:94
min
#define min(a, b)
Definition: mosaic_util.h:32
odas_define::checkrelease_odas
integer function, public checkrelease_odas(ODAS, RCS_Id, Message_Log)
Definition: ODAS_Define.f90:1226
odas_define::sl
integer, parameter sl
Definition: ODAS_Define.f90:79
odas_define
Definition: ODAS_Define.f90:13
message_handler::success
integer, parameter, public success
Definition: Message_Handler.f90:27
odas_define::carriage_return
integer, parameter carriage_return
Definition: ODAS_Define.f90:87
odas_define::module_rcs_id
character(*), parameter module_rcs_id
Definition: ODAS_Define.f90:71
odas_define::invalid_wmo_sensor_id
integer, parameter, public invalid_wmo_sensor_id
Definition: ODAS_Define.f90:91