FV3 Bundle
ODPS_Binary_IO.f90
Go to the documentation of this file.
1 !
2 ! ODPS_Binary_IO
3 !
4 ! Module containing routines to read and write Binary format
5 ! ODPS files.
6 !
7 !
8 ! CREATION HISTORY:
9 ! Written by: Paul van Delst, CIMSS/SSEC 02-Jan-2003
10 ! paul.vandelst@ssec.wisc.edu
11 ! Modified by: Yong Han, 10-July-2008
12 ! Adapted the original code to work for ODPS
13 ! algorithm
14 !
15 
17 
18  ! ------------------
19  ! Environment set up
20  ! ------------------
21  ! Module use
22  USE type_kinds , ONLY: long
26  USE odps_define , ONLY: odps_type , &
27  associated_odps , &
28  allocate_odps , &
30  destroy_odps , &
33  info_odps
34  ! Disable implicit typing
35  IMPLICIT NONE
36 
37 
38  ! ------------
39  ! Visibilities
40  ! ------------
41  ! Everything private by default
42  PRIVATE
43  ! Structure procedures
44  PUBLIC :: inquire_odps_binary
45  PUBLIC :: read_odps_binary
46  PUBLIC :: write_odps_binary
47  PUBLIC :: read_odps_data
48  PUBLIC :: write_odps_data
49 
50 
51  ! -----------------
52  ! Module parameters
53  ! -----------------
54  CHARACTER(*), PARAMETER :: module_rcs_id = &
55  '$Id: ODPS_Binary_IO.f90 2169 2008-06-12 15:07:56Z paul.vandelst@noaa.gov $'
56  ! Keyword set value
57  INTEGER, PARAMETER :: set = 1
58  ! Message character length
59  INTEGER, PARAMETER :: ml = 512
60 
61 
62 CONTAINS
63 
64 
65 !################################################################################
66 !################################################################################
67 !## ##
68 !## ## PUBLIC MODULE ROUTINES ## ##
69 !## ##
70 !################################################################################
71 !################################################################################
72 
73 !------------------------------------------------------------------------------
74 !
75 ! NAME:
76 ! Inquire_ODPS_Binary
77 !
78 ! PURPOSE:
79 ! Function to inquire a Binary format ODPS file.
80 !
81 ! CALLING SEQUENCE:
82 ! Error_Status = Inquire_ODPS_Binary( Filename , & ! Input
83 ! n_Layers = n_Layers , & ! Optional output
84 ! n_Components = n_Components , & ! Optional output
85 ! n_Absorbers = n_Absorbers , & ! Optional output
86 ! n_Channels = n_Channels , & ! Optional output
87 ! n_Coeffs = n_Coeffs , & ! Optional output
88 ! n_OCoeffs = n_OCoeffs , & ! Optional output
89 ! Release = Release , & ! Optional Output
90 ! Version = Version , & ! Optional Output
91 ! Sensor_Id = Sensor_Id , & ! Optional output
92 ! WMO_Satellite_Id = WMO_Satellite_Id, & ! Optional output
93 ! WMO_Sensor_Id = WMO_Sensor_Id , & ! Optional output
94 ! RCS_Id = RCS_Id , & ! Revision control
95 ! Message_Log = Message_Log ) ! Error messaging
96 !
97 ! INPUT ARGUMENTS:
98 ! Filename: Character string specifying the name of the binary
99 ! ODPS data file to inquire.
100 ! UNITS: N/A
101 ! TYPE: CHARACTER(*)
102 ! DIMENSION: Scalar
103 ! ATTRIBUTES: INTENT(IN)
104 !
105 ! OPTIONAL INPUT ARGUMENTS:
106 ! Message_Log: Character string specifying a filename in which any
107 ! Messages will be logged. If not specified, or if an
108 ! error occurs opening the log file, the default action
109 ! is to output Messages to standard output.
110 ! UNITS: N/A
111 ! TYPE: CHARACTER(*)
112 ! DIMENSION: Scalar
113 ! ATTRIBUTES: INTENT(IN), OPTIONAL
114 !
115 ! OPTIONAL OUTPUT ARGUMENTS:
116 ! n_Layers: The number of profile layers
117 ! UNITS: N/A
118 ! TYPE: INTEGER
119 ! DIMENSION: Scalar
120 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
121 !
122 ! n_Components: The number of transmittance components (i.g. dry & wlo)
123 ! UNITS: N/A
124 ! TYPE: INTEGER
125 ! DIMENSION: Scalar
126 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
127 !
128 ! n_Absorbers: The number of absorbers dimension (i.g H2O & O3).
129 ! UNITS: N/A
130 ! TYPE: INTEGER
131 ! DIMENSION: Scalar
132 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
133 !
134 ! n_Channels: The number of channels dimension of the ODPS data.
135 ! UNITS: N/A
136 ! TYPE: INTEGER
137 ! DIMENSION: Scalar
138 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
139 !
140 ! n_Coeffs: The total number of tau coefficients.
141 ! Note, the Coeff data are now stored in a one-dimensional
142 ! array
143 ! UNITS: N/A
144 ! TYPE: INTEGER
145 ! DIMENSION: Scalar
146 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
147 !
148 ! n_OCoeffs: The total number of OPTRAN tau coefficients.
149 ! Note, the Coeff data are now stored in a one-dimensional
150 ! array
151 ! UNITS: N/A
152 ! TYPE: INTEGER
153 ! DIMENSION: Scalar
154 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
155 !
156 ! Release: The ODPS data/file release number. Used to check
157 ! for data/software mismatch.
158 ! UNITS: N/A
159 ! TYPE: INTEGER
160 ! DIMENSION: Scalar
161 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
162 !
163 ! Version: The ODPS data/file version number. Used for
164 ! purposes only in identifying the dataset for
165 ! a particular release.
166 ! UNITS: N/A
167 ! TYPE: INTEGER
168 ! DIMENSION: Scalar
169 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
170 !
171 ! Sensor_Id: Character string sensor/platform identifier.
172 ! UNITS: N/A
173 ! TYPE: CHARACTER(*)
174 ! DIMENSION: Scalar
175 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
176 !
177 ! WMO_Satellite_Id: The WMO code used to identify satellite platforms.
178 ! UNITS: N/A
179 ! TYPE: INTEGER
180 ! DIMENSION: Scalar
181 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
182 !
183 ! WMO_Sensor_Id: The WMO code used to identify sensors.
184 ! UNITS: N/A
185 ! TYPE: INTEGER
186 ! DIMENSION: Scalar
187 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
188 !
189 ! RCS_Id: Character string containing the Revision Control
190 ! System Id field for the module.
191 ! UNITS: N/A
192 ! TYPE: CHARACTER(*)
193 ! DIMENSION: Scalar
194 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
195 !
196 ! FUNCTION RESULT:
197 ! Error_Status: The return value is an integer defining the error status.
198 ! The error codes are defined in the Message_Handler module.
199 ! If == SUCCESS the Binary file inquiry was successful
200 ! == FAILURE an unrecoverable error occurred.
201 ! UNITS: N/A
202 ! TYPE: INTEGER
203 ! DIMENSION: Scalar
204 !
205 !------------------------------------------------------------------------------
206 
207  FUNCTION inquire_odps_binary( Filename , & ! Input
208  n_Layers , & ! Optional output
209  n_Components , & ! Optional output
210  n_Absorbers , & ! Optional output
211  n_Channels , & ! Optional output
212  n_Coeffs , & ! Optional output
213  n_OCoeffs , & ! Optional output
214  Release , & ! Optional Output
215  Version , & ! Optional Output
216  Sensor_Id , & ! Optional Output
217  WMO_Satellite_Id, & ! Optional Output
218  WMO_Sensor_Id , & ! Optional Output
219  RCS_Id , & ! Revision control
220  Message_Log ) & ! Error messaging
221  result( error_status )
222  ! Arguments
223  CHARACTER(*), INTENT(IN) :: filename
224  INTEGER , OPTIONAL, INTENT(OUT) :: n_layers
225  INTEGER , OPTIONAL, INTENT(OUT) :: n_components
226  INTEGER , OPTIONAL, INTENT(OUT) :: n_absorbers
227  INTEGER , OPTIONAL, INTENT(OUT) :: n_channels
228  INTEGER , OPTIONAL, INTENT(OUT) :: n_coeffs
229  INTEGER , OPTIONAL, INTENT(OUT) :: n_ocoeffs
230  INTEGER , OPTIONAL, INTENT(OUT) :: release
231  INTEGER , OPTIONAL, INTENT(OUT) :: version
232  CHARACTER(*), OPTIONAL, INTENT(OUT) :: sensor_id
233  INTEGER , OPTIONAL, INTENT(OUT) :: wmo_satellite_id
234  INTEGER , OPTIONAL, INTENT(OUT) :: wmo_sensor_id
235  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
236  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
237  ! Function result
238  INTEGER :: error_status
239  ! Function parameters
240  CHARACTER(*), PARAMETER :: routine_name = 'Inquire_ODPS_Binary'
241  ! Function variables
242  CHARACTER(ML) :: message
243  INTEGER :: io_status
244  INTEGER :: fileid
245  TYPE(odps_type) :: odps
246 
247 
248  ! Set up
249  ! ------
250  error_status = success
251  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
252 
253  ! Check that the file exists
254  IF ( .NOT. file_exists( trim(filename) ) ) THEN
255  message = 'File '//trim(filename)//' not found.'
256  CALL inquire_cleanup(); RETURN
257  END IF
258 
259 
260  ! Open the file
261  ! -------------
262  error_status = open_binary_file( filename, fileid )
263  IF ( error_status /= success ) THEN
264  message = 'Error opening ODPS Binary file '//trim(filename)
265  CALL inquire_cleanup(); RETURN
266  END IF
267 
268 
269  ! Read the Release and Version information
270  ! ----------------------------------------
271  READ( fileid, iostat=io_status ) odps%Release, odps%Version
272  IF ( io_status /= 0 ) THEN
273  WRITE( message,'("Error reading Release/Version values from ",a,&
274  &". IOSTAT = ",i0)' ) &
275  trim(filename), io_status
276  CALL inquire_cleanup(close_file=set); RETURN
277  END IF
278 
279 
280  ! Read the Alorithm ID
281  ! --------------------
282  READ( fileid, iostat=io_status ) odps%Algorithm
283  IF ( io_status /= 0 ) THEN
284  WRITE( message,'("Error reading Algorithm ID from ",a,&
285  &". IOSTAT = ",i0)' ) &
286  trim(filename), io_status
287  CALL inquire_cleanup(close_file=set); RETURN
288  END IF
289 
290 
291  ! Read the data dimensions
292  ! ------------------------
293  READ( fileid, iostat=io_status ) odps%n_Layers , &
294  odps%n_Components, &
295  odps%n_Absorbers , &
296  odps%n_Channels , &
297  odps%n_Coeffs , &
298  odps%n_OPIndex , &
299  odps%n_OCoeffs
300  IF ( io_status /= 0 ) THEN
301  WRITE( message,'("Error reading dimension values from ",a,&
302  &". IOSTAT = ",i0)' ) &
303  trim(filename), io_status
304  CALL inquire_cleanup(close_file=set); RETURN
305  END IF
306 
307 
308  ! Read the sensor ids
309  ! -------------------
310  READ( fileid, iostat=io_status ) odps%Sensor_Id , &
311  odps%WMO_Satellite_Id, &
312  odps%WMO_Sensor_Id
313  IF ( io_status /= 0 ) THEN
314  WRITE( message, '("Error reading sensor information from ",a,&
315  &". IOSTAT = ",i0)' ) &
316  trim(filename), io_status
317  CALL inquire_cleanup(close_file=set); RETURN
318  END IF
319 
320 
321  ! Close the file
322  ! --------------
323  CLOSE( fileid, iostat=io_status )
324  IF ( io_status /= 0 ) THEN
325  WRITE( message,'("Error closing ",a,". IOSTAT = ",i0)' ) &
326  trim(filename), io_status
327  CALL inquire_cleanup(); RETURN
328  END IF
329 
330 
331  ! Assign the return arguments
332  ! ---------------------------
333  ! Dimensions
334  IF ( PRESENT(n_layers ) ) n_layers = odps%n_Layers
335  IF ( PRESENT(n_components) ) n_components = odps%n_Components
336  IF ( PRESENT(n_absorbers ) ) n_absorbers = odps%n_Absorbers
337  IF ( PRESENT(n_channels ) ) n_channels = odps%n_Channels
338  IF ( PRESENT(n_coeffs) ) n_coeffs = odps%n_Coeffs
339  IF ( PRESENT(n_ocoeffs) ) n_ocoeffs = odps%n_OCoeffs
340 
341  ! Release/Version information
342  IF ( PRESENT(release) ) release = odps%Release
343  IF ( PRESENT(version) ) version = odps%Version
344 
345  ! Sensor ids
346  IF ( PRESENT(sensor_id ) ) sensor_id = odps%Sensor_Id(1:min(len(sensor_id),len_trim(odps%Sensor_Id)))
347  IF ( PRESENT(wmo_satellite_id) ) wmo_satellite_id = odps%WMO_Satellite_Id
348  IF ( PRESENT(wmo_sensor_id ) ) wmo_sensor_id = odps%WMO_Sensor_Id
349 
350  CONTAINS
351 
352  SUBROUTINE inquire_cleanup( Close_File )
353  INTEGER, OPTIONAL, INTENT(IN) :: Close_File
354  CHARACTER(256) :: Close_Message
355  ! Close file if necessary
356  IF ( PRESENT(close_file) ) THEN
357  IF ( close_file == set ) THEN
358  CLOSE( fileid, iostat=io_status )
359  IF ( io_status /= 0 ) THEN
360  WRITE( close_message,'("; Error closing input file during error cleanup. IOSTAT=",i0)') &
361  io_status
362  message = trim(message)//trim(close_message)
363  END IF
364  END IF
365  END IF
366  ! Set error status and print error message
367  error_status = failure
368  CALL display_message( routine_name, &
369  trim(message), &
370  error_status, &
371  message_log=message_log )
372  END SUBROUTINE inquire_cleanup
373 
374  END FUNCTION inquire_odps_binary
375 
376 
377 !--------------------------------------------------------------------------------
378 !
379 ! NAME:
380 ! Read_ODPS_Binary
381 !
382 ! PURPOSE:
383 ! Function to read data into an ODPS structure from a Binary format file.
384 !
385 ! CALLING SEQUENCE:
386 ! Error_Status = Read_ODPS_Binary( Filename , & ! Input
387 ! ODPS , & ! Output
388 ! Quiet = Quiet , & ! Optional input
389 ! Process_ID = Process_ID , & ! Optional input
390 ! Output_Process_ID = Output_Process_ID, & ! Optional input
391 ! RCS_Id = RCS_Id , & ! Revision control
392 ! Message_Log = Message_Log ) ! Error messaging
393 !
394 ! INPUT ARGUMENTS:
395 ! Filename: Character string specifying the name of the binary
396 ! format ODPS data file to read.
397 ! UNITS: N/A
398 ! TYPE: CHARACTER(*)
399 ! DIMENSION: Scalar
400 ! ATTRIBUTES: INTENT(IN)
401 !
402 ! OUTPUT ARGUMENTS:
403 ! ODPS: Structure containing the gas absorption coefficient
404 ! data read from the file.
405 ! UNITS: N/A
406 ! TYPE: ODPS_type
407 ! DIMENSION: Scalar
408 ! ATTRIBUTES: INTENT(IN OUT)
409 !
410 ! OPTIONAL INPUT ARGUMENTS:
411 ! Quiet: Set this argument to suppress INFORMATION messages
412 ! being printed to standard output (or the message
413 ! log file if the Message_Log optional argument is
414 ! used.) By default, INFORMATION messages are printed.
415 ! If QUIET = 0, INFORMATION messages are OUTPUT.
416 ! QUIET = 1, INFORMATION messages are SUPPRESSED.
417 ! UNITS: N/A
418 ! TYPE: INTEGER
419 ! DIMENSION: Scalar
420 ! ATTRIBUTES: INTENT(IN), OPTIONAL
421 !
422 ! Process_ID: Set this argument to the MPI process ID that this
423 ! function call is running under. This value is used
424 ! solely for controlling INFORMATIOn message output.
425 ! If MPI is not being used, ignore this argument.
426 ! This argument is ignored if the Quiet argument is set.
427 ! UNITS: N/A
428 ! TYPE: INTEGER
429 ! DIMENSION: Scalar
430 ! ATTRIBUTES: INTENT(IN), OPTIONAL
431 !
432 ! Output_Process_ID: Set this argument to the MPI process ID, specified
433 ! via the Process_ID argument, in which all INFORMATION
434 ! messages are to be output. If the passed Process_ID
435 ! value agrees with this value the INFORMATION messages
436 ! are output. If MPI is not being used, ignore this
437 ! argument.
438 ! This argument is ignored if:
439 ! - the optional Process_ID argument is not present.
440 ! - the optional Quiet argument is set.
441 ! UNITS: N/A
442 ! TYPE: INTEGER
443 ! DIMENSION: Scalar
444 ! ATTRIBUTES: INTENT(IN), OPTIONAL
445 !
446 ! Message_Log: Character string specifying a filename in which any
447 ! Messages will be logged. If not specified, or if an
448 ! error occurs opening the log file, the default action
449 ! is to output Messages to standard output.
450 ! UNITS: N/A
451 ! TYPE: CHARACTER(*)
452 ! DIMENSION: Scalar
453 ! ATTRIBUTES: INTENT(IN), OPTIONAL
454 !
455 ! OPTIONAL OUTPUT ARGUMENTS:
456 ! RCS_Id: Character string containing the Revision Control
457 ! System Id field for the module.
458 ! UNITS: N/A
459 ! TYPE: CHARACTER(*)
460 ! DIMENSION: Scalar
461 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
462 !
463 ! FUNCTION RESULT:
464 ! Error_Status: The return value is an integer defining the error status.
465 ! The error codes are defined in the Message_Handler module.
466 ! If == SUCCESS the Binary file read was successful
467 ! == FAILURE an unrecoverable read error occurred.
468 ! UNITS: N/A
469 ! TYPE: INTEGER
470 ! DIMENSION: Scalar
471 !
472 ! SIDE EFFECTS:
473 ! If the ODPS argument is defined upon input, it is redefined (or
474 ! reinitialised) at output.
475 !
476 ! COMMENTS:
477 ! Note the INTENT on the output ODPS argument is IN OUT rather than
478 ! just OUT. This is necessary because the argument may be defined upon
479 ! input. To prevent memory leaks, the IN OUT INTENT is a must.
480 !
481 !------------------------------------------------------------------------------
482 
483  FUNCTION read_odps_binary( Filename , & ! Input
484  ODPS , & ! Output
485  Quiet , & ! Optional input
486  Process_ID , & ! Optional input
487  Output_Process_ID, & ! Optional input
488  RCS_Id , & ! Revision control
489  Message_Log ) & ! Error messaging
490  result( error_status )
491  ! Arguments
492  CHARACTER(*) , INTENT(IN) :: filename
493  TYPE(odps_type) , INTENT(IN OUT) :: odps
494  INTEGER , OPTIONAL, INTENT(IN) :: quiet
495  INTEGER , OPTIONAL, INTENT(IN) :: process_id
496  INTEGER , OPTIONAL, INTENT(IN) :: output_process_id
497  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
498  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
499  ! Function result
500  INTEGER :: error_status
501  ! Function parameters
502  CHARACTER(*), PARAMETER :: routine_name = 'Read_ODPS_Binary'
503  ! Function variables
504  CHARACTER(ML) :: message
505  CHARACTER(ML) :: process_id_tag
506  LOGICAL :: noisy
507  INTEGER :: io_status
508  INTEGER :: fileid
509 
510  ! Set up
511  ! ------
512  error_status = success
513  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
514 
515  ! Check that the file is present
516  IF ( .NOT. file_exists( trim(filename) ) ) THEN
517  message = 'File '//trim(filename)//' not found.'
518  error_status = failure
519  RETURN
520  END IF
521 
522  ! Output informational messages....
523  noisy = .true.
524  ! ...unless...
525  IF ( PRESENT(quiet) ) THEN
526  IF ( quiet == set ) noisy = .false.
527  END IF
528  IF ( noisy .AND. PRESENT(process_id) .AND. PRESENT(output_process_id) ) THEN
529  IF ( process_id /= output_process_id ) noisy = .false.
530  END IF
531 
532  ! Create a process ID message tag for
533  ! WARNING and FAILURE messages
534  IF ( PRESENT(process_id) ) THEN
535  WRITE( process_id_tag,'("; MPI Process ID: ",i0)' ) process_id
536  ELSE
537  process_id_tag = ' '
538  END IF
539 
540 
541  ! Open the ODPS file
542  ! ------------------
543  error_status = open_binary_file( filename, fileid )
544  IF ( error_status /= success ) THEN
545  message = 'Error opening '//trim(filename)
546  error_status = failure
547  RETURN
548  END IF
549 
550  ! Read data and put them in ODAS
551  ! --------------------------------------------
552  error_status = read_odps_data( filename , &
553  fileid , &
554  odps , &
555  process_id_tag , &
556  message_log = message_log )
557  IF ( error_status /= success ) THEN
558  message = 'Error reading data from '//trim(filename)
559  error_status = failure
560  RETURN
561  END IF
562 
563  ! Close the file
564  ! --------------
565  CLOSE( fileid, iostat=io_status )
566  IF ( io_status /= 0 ) THEN
567  WRITE( message,'("Error closing ",a," after read. IOSTAT = ",i0)' ) &
568  trim(filename), io_status
569  CALL display_message( routine_name, &
570  trim(message)//trim(process_id_tag), &
571  warning, &
572  message_log=message_log )
573  END IF
574 
575  ! Output an info message
576  ! ----------------------
577  IF ( noisy ) THEN
578  CALL info_odps( odps, message )
579  CALL display_message( routine_name, &
580  'FILE: '//trim(filename)//'; '//trim(message), &
581  information, &
582  message_log = message_log )
583  END IF
584 
585 
586  END FUNCTION read_odps_binary
587 
588  FUNCTION read_odps_data( Filename , & ! Input
589  FileID , & ! Input
590  ODPS , & ! Output
591  Process_ID_Tag , & ! Optional input
592  Message_Log ) & ! Error messaging
593  result( error_status )
594  ! Arguments
595  CHARACTER(*) , INTENT(IN) :: filename
596  INTEGER , INTENT(IN) :: fileid
597  TYPE(odps_type) , INTENT(IN OUT) :: odps
598  CHARACTER(*) , INTENT(IN) :: process_id_tag
599  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
600  ! Function result
601  INTEGER :: error_status
602  ! Function parameters
603  CHARACTER(*), PARAMETER :: routine_name = 'Read_ODPS_Data'
604  ! Function variables
605  CHARACTER(ML) :: message
606  INTEGER :: io_status
607  INTEGER(Long) :: version
608  INTEGER(Long) :: algorithm
609  INTEGER(Long) :: n_layers
610  INTEGER(Long) :: n_components
611  INTEGER(Long) :: n_absorbers
612  INTEGER(Long) :: n_channels
613  INTEGER(Long) :: n_coeffs
614  INTEGER(Long) :: n_opindex
615  INTEGER(Long) :: n_ocoeffs
616 
617  ! Read the Release and Version information
618  ! ----------------------------------------
619  READ( fileid, iostat=io_status ) odps%Release, version
620  IF ( io_status /= 0 ) THEN
621  WRITE( message,'("Error reading Release/Version values from ",a,&
622  &". IOSTAT = ",i0)' ) &
623  trim(filename), io_status
624  CALL read_cleanup(); RETURN
625  END IF
626 
627  ! Check the release
628  error_status = checkrelease_odps( odps,message_log=message_log )
629  IF ( error_status /= success ) THEN
630  message = 'ODPS Release check failed for '//trim(filename)
631  CALL read_cleanup(); RETURN
632  END IF
633 
634 
635  ! Read the Alorithm ID
636  ! --------------------
637  READ( fileid, iostat=io_status ) algorithm
638  IF ( io_status /= 0 ) THEN
639  WRITE( message,'("Error reading Algorithm ID from ",a,&
640  &". IOSTAT = ",i0)' ) &
641  trim(filename), io_status
642  CALL read_cleanup(); RETURN
643  END IF
644 
645  ! Check the algorithm id
646  error_status = checkalgorithm_odps( odps,message_log=message_log )
647  IF ( error_status /= success ) THEN
648  message = 'ODPS Algorithm check failed for '//trim(filename)
649  CALL read_cleanup(); RETURN
650  END IF
651 
652 
653  ! Read the data dimensions
654  ! ------------------------
655  READ( fileid, iostat=io_status ) n_layers , &
656  n_components, &
657  n_absorbers , &
658  n_channels , &
659  n_coeffs , &
660  n_opindex , &
661  n_ocoeffs
662  IF ( io_status /= 0 ) THEN
663  WRITE( message,'("Error reading dimension values from ",a,&
664  &". IOSTAT = ",i0)' ) &
665  trim(filename), io_status
666  CALL read_cleanup(); RETURN
667  END IF
668 
669  ! Allocate the output structure
670  ! -----------------------------
671  error_status = allocate_odps( n_layers , &
672  n_components, &
673  n_absorbers , &
674  n_channels , &
675  n_coeffs , &
676  odps , &
677  message_log=message_log)
678  IF ( error_status /= success ) THEN
679  message = 'ODPS allocation failed'
680  CALL read_cleanup(); RETURN
681  END IF
682 
683  ! Assign the version number (which may be different)
684  odps%Version = version
685 
686 
687  ! Read the TC Group ID
688  ! -------------------------------
689  READ( fileid, iostat=io_status ) odps%Group_Index
690  IF ( io_status /= 0 ) THEN
691  WRITE( message,'("Error reading Group ID from ",a,&
692  &". IOSTAT = ",i0)' ) &
693  trim(filename), io_status
694  CALL read_cleanup(); RETURN
695  END IF
696 
697  ! Read the sensor info
698  ! --------------------
699  READ( fileid, iostat=io_status ) odps%Sensor_Id , &
700  odps%WMO_Satellite_Id, &
701  odps%WMO_Sensor_Id , &
702  odps%Sensor_Type
703  IF ( io_status /= 0 ) THEN
704  WRITE( message,'("Error reading sensor information from ",a,&
705  &". IOSTAT = ",i0)' ) &
706  trim(filename), io_status
707  CALL read_cleanup(); RETURN
708  END IF
709 
710 
711  ! Read the sensor channel numbers
712  ! -------------------------------
713  READ( fileid, iostat=io_status ) odps%Sensor_Channel
714  IF ( io_status /= 0 ) THEN
715  WRITE( message,'("Error reading sensor channel data from ",a,&
716  &". IOSTAT = ",i0)' ) &
717  trim(filename), io_status
718  CALL read_cleanup(); RETURN
719  END IF
720 
721  ! Read the transmittance component ID
722  ! ----------------------------------------------
723  READ( fileid, iostat=io_status ) odps%Component_ID
724  IF ( io_status /= 0 ) THEN
725  WRITE( message,'("Error reading tansmittance component ID from ",a,&
726  &". IOSTAT = ",i0)' ) &
727  trim(filename), io_status
728  CALL read_cleanup(); RETURN
729  END IF
730 
731  ! Read the absorber ID
732  ! ----------------------------------------------
733  READ( fileid, iostat=io_status ) odps%Absorber_ID
734  IF ( io_status /= 0 ) THEN
735  WRITE( message,'("Error reading absorber ID from ",a,&
736  &". IOSTAT = ",i0)' ) &
737  trim(filename), io_status
738  CALL read_cleanup(); RETURN
739  END IF
740 
741  ! Read the reference profiles
742  ! ----------------------------------------------
743  READ( fileid, iostat=io_status ) odps%Ref_Level_Pressure, &
744  odps%Ref_Pressure, &
745  odps%Ref_Temperature, &
746  odps%Ref_Absorber, &
747  odps%Min_Absorber, &
748  odps%Max_Absorber
749  IF ( io_status /= 0 ) THEN
750  WRITE( message,'("Error reading reference profiles from ",a,&
751  &". IOSTAT = ",i0)' ) &
752  trim(filename), io_status
753  CALL read_cleanup(); RETURN
754  END IF
755 
756  ! Read the n_Predictors and Pos_Index data
757  ! ----------------------------------------------------
758  READ( fileid, iostat=io_status ) odps%n_Predictors, &
759  odps%Pos_Index
760  IF ( io_status /= 0 ) THEN
761  WRITE( message,'("Error reading n_Predictors and Pos_Index data from ",a,&
762  &". IOSTAT = ",i0)' ) &
763  trim(filename), io_status
764  CALL read_cleanup(); RETURN
765  END IF
766 
767 
768  ! Read the regression coefficients
769  ! --------------------------------
770  IF( odps%n_Coeffs > 0 )THEN
771  READ( fileid, iostat=io_status ) odps%C
772  IF ( io_status /= 0 ) THEN
773  WRITE( message,'("Error reading regression coefficients from ",a,&
774  &". IOSTAT = ",i0)' ) &
775  trim(filename), io_status
776  CALL read_cleanup(); RETURN
777  END IF
778  END IF
779 
780  IF( n_ocoeffs > 0 )THEN
781 
782  error_status = allocate_odps_optran( n_ocoeffs , &
783  odps , &
784  message_log=message_log)
785  IF ( error_status /= success ) THEN
786  message = 'ODPS OPTRAN array allocation failed'
787  CALL read_cleanup(); RETURN
788  END IF
789 
790  READ( fileid, iostat=io_status ) odps%OSignificance, &
791  odps%Order, &
792  odps%OP_Index, &
793  odps%OPos_Index, &
794  odps%OC, &
795  odps%Alpha, odps%Alpha_C1, odps%Alpha_C2, &
796  odps%OComponent_Index
797  IF ( io_status /= 0 ) THEN
798  WRITE( message,'("Error reading ODPS OPTRAN data to ",a,&
799  &". IOSTAT = ",i0)' ) &
800  trim(filename), io_status
801  CALL read_cleanup(); RETURN
802  END IF
803  END IF
804 
805  CONTAINS
806 
807  SUBROUTINE read_cleanup()
808  CHARACTER(ML) :: Close_Message
809  INTEGER :: Destroy_Status
810  ! Close file if necessary
811  IF ( file_exists( filename ) ) THEN
812  IF ( file_open( filename ) ) THEN
813  CLOSE( fileid, iostat=io_status )
814  IF ( io_status /= 0 ) THEN
815  WRITE( close_message,'("; Error closing ",a," during error cleanup. IOSTAT=",i0)') &
816  trim(filename), io_status
817  message = trim(message)//trim(close_message)
818  END IF
819  END IF
820  END IF
821  ! Destroy the structure
822  destroy_status = destroy_odps( odps, message_log=message_log )
823  IF ( destroy_status /= success ) &
824  message = trim(message)//'; Error destroying ODPS structure during error cleanup.'
825  ! Set error status and print error message
826  error_status = failure
827  CALL display_message( routine_name, &
828  trim(message)//trim(process_id_tag), &
829  error_status, &
830  message_log=message_log )
831  END SUBROUTINE read_cleanup
832 
833  END FUNCTION read_odps_data
834 
835 !--------------------------------------------------------------------------------
836 !
837 ! NAME:
838 ! Write_ODPS_Binary
839 !
840 ! PURPOSE:
841 ! Function to write an ODPS structure to a Binary format file.
842 !
843 ! CALLING SEQUENCE:
844 ! Error_Status = Write_ODPS_Binary( Filename , & ! Input
845 ! ODPS , & ! Input
846 ! Quiet = Quiet , & ! Optional input
847 ! RCS_Id = RCS_Id , & ! Revision control
848 ! Message_Log = Message_Log ) ! Error messaging
849 !
850 ! INPUT ARGUMENTS:
851 ! Filename: Character string specifying the name of an output
852 ! ODPS format data file.
853 ! UNITS: N/A
854 ! TYPE: CHARACTER(*)
855 ! DIMENSION: Scalar
856 ! ATTRIBUTES: INTENT(IN)
857 !
858 ! ODPS: Structure containing the gas absorption coefficient
859 ! data to write to the file.
860 ! UNITS: N/A
861 ! TYPE: ODPS_type
862 ! DIMENSION: Scalar
863 ! ATTRIBUTES: INTENT(IN)
864 !
865 ! OPTIONAL INPUT ARGUMENTS:
866 ! Quiet: Set this keyword to suppress information Messages being
867 ! printed to standard output (or the Message log file if
868 ! the Message_Log optional argument is used.) By default,
869 ! information Messages are printed.
870 ! If QUIET = 0, information Messages are OUTPUT.
871 ! QUIET = 1, information Messages are SUPPRESSED.
872 ! UNITS: N/A
873 ! TYPE: INTEGER
874 ! DIMENSION: Scalar
875 ! ATTRIBUTES: INTENT(IN), OPTIONAL
876 !
877 ! Message_Log: Character string specifying a filename in which any
878 ! Messages will be logged. If not specified, or if an
879 ! error occurs opening the log file, the default action
880 ! is to output Messages to standard output.
881 ! UNITS: N/A
882 ! TYPE: CHARACTER(*)
883 ! DIMENSION: Scalar
884 ! ATTRIBUTES: INTENT(IN), OPTIONAL
885 !
886 ! OPTIONAL OUTPUT ARGUMENTS:
887 ! RCS_Id: Character string containing the Revision Control
888 ! System Id field for the module.
889 ! UNITS: N/A
890 ! TYPE: CHARACTER(*)
891 ! DIMENSION: Scalar
892 ! ATTRIBUTES: INTENT(OUT), OPTIONAL
893 !
894 ! FUNCTION RESULT:
895 ! Error_Status: The return value is an integer defining the error status.
896 ! The error codes are defined in the Message_Handler module.
897 ! If == SUCCESS the Binary file write was successful
898 ! == FAILURE - the input ODPS structure contains
899 ! unassociated pointer members, or
900 ! - a unrecoverable write error occurred.
901 ! UNITS: N/A
902 ! TYPE: INTEGER
903 ! DIMENSION: Scalar
904 !
905 ! SIDE EFFECTS:
906 ! - If the output file already exists, it is overwritten.
907 ! - If an error occurs, the output file is deleted.
908 !
909 !--------------------------------------------------------------------------------
910 
911  FUNCTION write_odps_binary( Filename , & ! Input
912  ODPS , & ! Input
913  Quiet , & ! Optional input
914  RCS_Id , & ! Revision control
915  Message_Log) & ! Error messaging
916  result( error_status )
917  ! Arguments
918  CHARACTER(*) , INTENT(IN) :: filename
919  TYPE(odps_type) , INTENT(IN) :: odps
920  INTEGER , OPTIONAL, INTENT(IN) :: quiet
921  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
922  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
923  ! Function result
924  INTEGER :: error_status
925  ! Function parameters
926  CHARACTER(*), PARAMETER :: routine_name = 'Write_ODPS_Binary'
927  ! Function variables
928  CHARACTER(ML) :: message
929  LOGICAL :: noisy
930  INTEGER :: io_status
931  INTEGER :: fileid
932 
933  ! Set up
934  ! ------
935  error_status = success
936  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
937 
938  ! Open the ODPS data file
939  ! -----------------------
940  error_status = open_binary_file( filename, fileid, for_output=.true. )
941  IF ( error_status /= success ) THEN
942  message = 'Error opening '//trim( filename )
943  error_status = failure
944  RETURN
945  END IF
946 
947  ! Output informational messages....
948  noisy = .true.
949  ! ....unless the QUIET keyword is set.
950  IF ( PRESENT( quiet ) ) THEN
951  IF ( quiet == 1 ) noisy = .false.
952  END IF
953 
954  error_status = write_odps_data( filename, &
955  fileid, &
956  odps, &
957  message_log=message_log )
958 
959  IF ( error_status /= success ) THEN
960  message = 'Error writing data to '//trim( filename )
961  error_status = failure
962  RETURN
963  END IF
964 
965 
966  ! Close the file
967  ! --------------
968  CLOSE( fileid, iostat=io_status )
969  IF ( io_status /= 0 ) THEN
970  WRITE( message,'("Error closing ",a," after write. IOSTAT = ",i0)' ) &
971  trim(filename), io_status
972  CALL display_message( routine_name, &
973  trim(message), &
974  warning, &
975  message_log=message_log )
976  END IF
977 
978 
979  ! Output an info message
980  ! ----------------------
981  IF ( noisy ) THEN
982  CALL info_odps( odps, message )
983  CALL display_message( routine_name, &
984  'FILE: '//trim(filename)//'; '//trim(message), &
985  information, &
986  message_log = message_log )
987  END IF
988 
989  END FUNCTION write_odps_binary
990 
991  FUNCTION write_odps_data( Filename , &
992  FileID , &
993  ODPS , &
994  Message_Log) &
995  result( error_status )
996  CHARACTER(*) , INTENT(IN) :: filename
997  INTEGER , INTENT(IN) :: fileid
998  TYPE(odps_type) , INTENT(IN) :: odps
999  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
1000 
1001  CHARACTER(*), PARAMETER :: routine_name = 'Write_ODPS_Data'
1002  ! Function result
1003  INTEGER :: error_status
1004  ! Function variables
1005  CHARACTER(ML) :: message
1006  INTEGER :: io_status
1007 
1008  ! Check structure association status
1009  IF ( .NOT. associated_odps( odps ) ) THEN
1010  message = 'Some or all INPUT ODPS pointer members are NOT associated.'
1011  CALL write_cleanup(); RETURN
1012  END IF
1013 
1014  ! Check the release
1015  error_status = checkrelease_odps( odps, message_log=message_log)
1016  IF ( error_status /= success ) THEN
1017  message = 'ODPS structure Release check failed.'
1018  CALL write_cleanup(); RETURN
1019  END IF
1020 
1021  ! Check the algorithm id
1022  error_status = checkalgorithm_odps( odps, message_log=message_log )
1023  IF ( error_status /= success ) THEN
1024  message = 'ODPS Algorithm check failed'
1025  CALL write_cleanup(); RETURN
1026  END IF
1027 
1028 
1029  ! Check the ODPS structure dimensions
1030  IF ( odps%n_Layers < 1 .OR. &
1031  odps%n_Components < 1 .OR. &
1032  odps%n_Absorbers < 1 .OR. &
1033  odps%n_Channels < 1 .OR. &
1034  odps%n_Coeffs < 0 .OR. &
1035  odps%n_OPIndex < 1 .OR. &
1036  odps%n_OCoeffs < 0 ) THEN
1037  message = "One or more ODPS dimension variables have incorrect values"
1038  CALL write_cleanup(); RETURN
1039  END IF
1040 
1041 
1042  ! Write the Release and Version information
1043  ! -----------------------------------------
1044  WRITE( fileid, iostat=io_status ) odps%Release, odps%Version
1045  IF ( io_status /= 0 ) THEN
1046  WRITE( message,'("Error writing Release/Version values to ",a,&
1047  &". IOSTAT = ",i0)' ) &
1048  trim(filename), io_status
1049  CALL write_cleanup(); RETURN
1050  END IF
1051 
1052 
1053  ! Write the Alorithm ID
1054  ! ---------------------
1055  WRITE( fileid, iostat=io_status ) odps%Algorithm
1056  IF ( io_status /= 0 ) THEN
1057  WRITE( message,'("Error writing Algorithm ID to ",a,&
1058  &". IOSTAT = ",i0)' ) &
1059  trim(filename), io_status
1060  CALL write_cleanup(); RETURN
1061  END IF
1062 
1063 
1064  ! Write the data dimensions
1065  ! -------------------------
1066  WRITE( fileid, iostat=io_status ) odps%n_Layers , &
1067  odps%n_Components, &
1068  odps%n_Absorbers , &
1069  odps%n_Channels , &
1070  odps%n_Coeffs , &
1071  odps%n_OPIndex , &
1072  odps%n_OCoeffs
1073  IF ( io_status /= 0 ) THEN
1074  WRITE( message,'("Error writing dimension values to ",a,&
1075  &". IOSTAT = ",i0)' ) &
1076  trim(filename), io_status
1077  CALL write_cleanup(); RETURN
1078  END IF
1079 
1080  ! Write the TC Group ID
1081  ! -----------------------------------------------
1082  WRITE( fileid, iostat=io_status ) odps%Group_Index
1083  IF ( io_status /= 0 ) THEN
1084  WRITE( message,'("Error writing Group ID to ",a,&
1085  &". IOSTAT = ",i0)' ) &
1086  trim(filename), io_status
1087  CALL write_cleanup(); RETURN
1088  END IF
1089 
1090  ! Write the sensor info
1091  ! ---------------------
1092  WRITE( fileid, iostat=io_status ) odps%Sensor_Id , &
1093  odps%WMO_Satellite_Id, &
1094  odps%WMO_Sensor_Id , &
1095  odps%Sensor_Type
1096  IF ( io_status /= 0 ) THEN
1097  WRITE( message,'("Error writing sensor information to ",a,&
1098  &". IOSTAT = ",i0)' ) &
1099  trim(filename), io_status
1100  CALL write_cleanup(); RETURN
1101  END IF
1102 
1103 
1104  ! Write the sensor channel numbers
1105  ! --------------------------------
1106  WRITE( fileid, iostat=io_status ) odps%Sensor_Channel
1107  IF ( io_status /= 0 ) THEN
1108  WRITE( message,'("Error writing sensor channel data to ",a,&
1109  &". IOSTAT = ",i0)' ) &
1110  trim(filename), io_status
1111  CALL write_cleanup(); RETURN
1112  END IF
1113 
1114 
1115  ! Write the Component ID
1116  ! -----------------------------------------------
1117  WRITE( fileid, iostat=io_status ) odps%Component_ID
1118  IF ( io_status /= 0 ) THEN
1119  WRITE( message,'("Error writing component ID to ",a,&
1120  &". IOSTAT = ",i0)' ) &
1121  trim(filename), io_status
1122  CALL write_cleanup(); RETURN
1123  END IF
1124 
1125  ! Write the absorber ID
1126  ! -----------------------------------------------
1127  WRITE( fileid, iostat=io_status ) odps%Absorber_ID
1128  IF ( io_status /= 0 ) THEN
1129  WRITE( message,'("Error writing absorber ID to ",a,&
1130  &". IOSTAT = ",i0)' ) &
1131  trim(filename), io_status
1132  CALL write_cleanup(); RETURN
1133  END IF
1134 
1135  ! Write reference profile data
1136  ! -----------------------------------------------------
1137  WRITE( fileid, iostat=io_status ) odps%Ref_Level_Pressure, &
1138  odps%Ref_Pressure, &
1139  odps%Ref_Temperature, &
1140  odps%Ref_Absorber, &
1141  odps%Min_Absorber, &
1142  odps%Max_Absorber
1143 
1144  IF ( io_status /= 0 ) THEN
1145  WRITE( message,'("Error writing reference profile data to ",a,&
1146  &". IOSTAT = ",i0)' ) &
1147  trim(filename), io_status
1148  CALL write_cleanup(); RETURN
1149  END IF
1150 
1151  ! Write the n_Predictors and Pos_Index data
1152  ! -----------------------------------------------------
1153  WRITE( fileid, iostat=io_status ) odps%n_Predictors, &
1154  odps%Pos_Index
1155  IF ( io_status /= 0 ) THEN
1156  WRITE( message,'("Error writing n_Predictors and Pos_Index data to ",a,&
1157  &". IOSTAT = ",i0)' ) &
1158  trim(filename), io_status
1159  CALL write_cleanup(); RETURN
1160  END IF
1161 
1162 
1163  ! Write the regression coefficients
1164  ! ---------------------------------
1165  IF( odps%n_Coeffs > 0 )THEN
1166  WRITE( fileid, iostat=io_status ) odps%C
1167  IF ( io_status /= 0 ) THEN
1168  WRITE( message,'("Error writing regression coefficients to ",a,&
1169  &". IOSTAT = ",i0)' ) &
1170  trim(filename), io_status
1171  CALL write_cleanup(); RETURN
1172  END IF
1173  END IF
1174 
1175  IF( odps%n_OCoeffs > 0 )THEN
1176  WRITE( fileid, iostat=io_status ) odps%OSignificance, &
1177  odps%Order, &
1178  odps%OP_Index, &
1179  odps%OPos_Index, &
1180  odps%OC, &
1181  odps%Alpha, odps%Alpha_C1, odps%Alpha_C2, &
1182  odps%OComponent_Index
1183  IF ( io_status /= 0 ) THEN
1184  WRITE( message,'("Error writing ODPS OPTRAN data to ",a,&
1185  &". IOSTAT = ",i0)' ) &
1186  trim(filename), io_status
1187  CALL write_cleanup(); RETURN
1188  END IF
1189  END IF
1190 
1191  CONTAINS
1192 
1193  SUBROUTINE write_cleanup()
1194  CHARACTER(ML) :: Close_Message
1195  ! Close file if necessary
1196  IF ( file_exists( filename ) ) THEN
1197  IF ( file_open( filename ) ) THEN
1198  CLOSE( fileid, iostat=io_status, status='DELETE' )
1199  IF ( io_status /= 0 ) THEN
1200  WRITE( close_message,'("; Error deleting ",a," during error cleanup. IOSTAT=",i0)') &
1201  trim(filename), io_status
1202  message = trim(message)//trim(close_message)
1203  END IF
1204  END IF
1205  END IF
1206  ! Set error status and print error message
1207  error_status = failure
1208  CALL display_message( routine_name, &
1209  trim(message), &
1210  error_status, &
1211  message_log=message_log )
1212  END SUBROUTINE write_cleanup
1213 
1214  END FUNCTION write_odps_data
1215 
1216 END MODULE odps_binary_io
integer, parameter, public failure
integer function, public checkalgorithm_odps(ODPS, RCS_Id, Message_Log)
integer, parameter, public set
character(*), parameter module_rcs_id
integer, parameter, public warning
integer function, public allocate_odps(n_Layers, n_Components, n_Absorbers, n_Channels, n_Coeffs, ODPS, RCS_Id, Message_Log)
integer, parameter, public long
Definition: Type_Kinds.f90:76
subroutine, public info_odps(ODPS, Info, RCS_Id)
integer function, public destroy_odps(ODPS, No_Clear, RCS_Id, Message_Log)
integer function, public write_odps_data(Filename, FileID, ODPS, Message_Log)
subroutine inquire_cleanup()
integer function, public inquire_odps_binary(Filename, n_Layers, n_Components, n_Absorbers, n_Channels, n_Coeffs, n_OCoeffs, Release, Version, Sensor_Id, WMO_Satellite_Id, WMO_Sensor_Id, RCS_Id, Message_Log)
integer function, public read_odps_binary(Filename, ODPS, Quiet, Process_ID, Output_Process_ID, RCS_Id, Message_Log)
subroutine read_cleanup()
subroutine write_cleanup()
integer function, public open_binary_file(Filename, FileID, For_Output, No_Check)
recursive subroutine, public display_message(Routine_Name, Message, Error_State, Message_Log)
logical function, public associated_odps(ODPS, ANY_Test)
integer function, public checkrelease_odps(ODPS, RCS_Id, Message_Log)
integer function, public write_odps_binary(Filename, ODPS, Quiet, RCS_Id, Message_Log)
integer function, public read_odps_data(Filename, FileID, ODPS, Process_ID_Tag, Message_Log)
#define min(a, b)
Definition: mosaic_util.h:32
integer, parameter ml
integer, parameter, public success
integer function, public allocate_odps_optran(n_OCoeffs, ODPS, RCS_Id, Message_Log)
integer, parameter, public information