FV3 Bundle
CRTM_TauCoeff.f90
Go to the documentation of this file.
1 !
2 ! CRTM_TauCoeff
3 !
4 ! Module containing the shared CRTM absorption coefficients (TauCoeff)
5 ! and their load/destruction routines.
6 !
7 ! PUBLIC DATA:
8 ! TC: Data structure containing the transmittance model
9 ! coefficient data for one or multiple transmittance
10 ! algorithms for the requested sensors.
11 !
12 ! SIDE EFFECTS:
13 ! Routines in this module modify the contents of the public
14 ! data structure TC.
15 !
16 ! RESTRICTIONS:
17 ! Routines in this module should only be called during the
18 ! CRTM initialisation.
19 !
20 ! CREATION HISTORY:
21 ! Written by: Yong Han, JCSDA, NOAA/NESDIS 20-Jun-2008
22 ! Modified by: David Groff, SAIC 5-Nov-2009
23 MODULE crtm_taucoeff
24 
25  ! -----------------
26  ! Environment setup
27  ! -----------------
28  ! Module use
29  USE type_kinds , ONLY: long
30  USE file_utility , ONLY: file_exists
31  USE binary_file_utility , ONLY: open_binary_file
32  USE message_handler , ONLY: success, failure, warning, display_message
33  USE crtm_parameters , ONLY: max_n_sensors, set
34  USE odas_taucoeff , ONLY: odas_load_taucoeff => load_taucoeff , &
35  odas_destroy_taucoeff => destroy_taucoeff, &
36  odas_tc => tc
37  USE odas_define , ONLY: odas_type, odas_algorithm
38  USE odps_taucoeff , ONLY: odps_load_taucoeff => load_taucoeff , &
39  odps_destroy_taucoeff => destroy_taucoeff, &
40  odps_tc => tc
41  USE odps_define , ONLY: odps_type, odps_algorithm
42  USE odssu_taucoeff , ONLY: odssu_load_taucoeff => load_taucoeff , &
43  odssu_destroy_taucoeff => destroy_taucoeff, &
44  odssu_tc => tc
45  USE odssu_define , ONLY: odssu_type, odssu_algorithm
46  USE taucoeff_define , ONLY: taucoeff_type, &
47  taucoeff_destroy, &
48  taucoeff_create
49  USE odzeeman_taucoeff , ONLY: odzeeman_load_taucoeff => load_taucoeff , &
50  odzeeman_destroy_taucoeff => destroy_taucoeff, &
51  odzeeman_tc => tc
52  USE crtm_sensorinfo , ONLY: wmo_ssmis, wmo_amsua
53  USE taucoeff_define , ONLY: taucoeff_type, &
54  taucoeff_destroy, &
55  taucoeff_create
56 
57  ! Disable all implicit typing
58  IMPLICIT NONE
59 
60  ! ------------
61  ! Visibilities
62  ! ------------
63  ! Everything private by default
64  PRIVATE
65  ! The shared data
66  PUBLIC :: tc
67 
68  ! Public routines in this module
69  PUBLIC :: crtm_load_taucoeff
70  PUBLIC :: crtm_destroy_taucoeff
71 
72  ! -----------------
73  ! Module parameters
74  ! -----------------
75  CHARACTER(*), PARAMETER :: module_rcs_id = &
76  '$Id: CRTM_TauCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
77 
78 
79  ! --------------------------------------
80  ! The shared data for the gas absorption
81  ! (AtmAbsorption) model
82  ! --------------------------------------
83  TYPE(taucoeff_type), SAVE :: tc
84 
85 
86 CONTAINS
87 
88 
89 !------------------------------------------------------------------------------
90 !
91 ! NAME:
92 ! CRTM_Load_TauCoeff
93 !
94 ! PURPOSE:
95 ! Function to load the TauCoeff transmittance coefficient data into
96 ! the shared data structure.
97 !
98 ! CALLING SEQUENCE:
99 ! Error_Status = CRTM_Load_TauCoeff( Sensor_ID =Sensor_ID, & ! Optional input
100 ! File_Path =File_Path, & ! Optional input
101 ! Quiet =Quiet, & ! Optional input
102 ! Process_ID =Process_ID, & ! Optional input
103 ! Output_Process_ID=Output_Process_ID, & ! Optional input
104 ! Message_Log =Message_Log ) ! Error messaging
105 !
106 ! OPTIONAL INPUT ARGUMENTS:
107 ! Sensor_ID: List of the sensor IDs (e.g. hirs3_n17, amsua_n18,
108 ! ssmis_f16, etc) with which the CRTM is to be
109 ! initialised. These Sensor ID are used to construct
110 ! the sensor specific TauCoeff filenames containing
111 ! the necessary coefficient data, i.e.
112 ! <Sensor_ID>.TauCoeff.bin
113 ! If this argument is not specified, the default
114 ! TauCoeff filename is
115 ! TauCoeff.bin
116 ! UNITS: N/A
117 ! TYPE: CHARACTER(*)
118 ! DIMENSION: Rank-1
119 ! ATTRIBUTES: INTENT(IN)
120 !
121 ! File_Path: Character string specifying a file path for the
122 ! input data files. If not specified, the current
123 ! directory is the default.
124 ! UNITS: N/A
125 ! TYPE: CHARACTER(*)
126 ! DIMENSION: Scalar
127 ! ATTRIBUTES: INTENT(IN), OPTIONAL
128 !
129 ! Quiet: Set this argument to suppress INFORMATION messages
130 ! being printed to standard output (or the message
131 ! log file if the Message_Log optional argument is
132 ! used.) By default, INFORMATION messages are printed.
133 ! If QUIET = 0, INFORMATION messages are OUTPUT.
134 ! QUIET = 1, INFORMATION messages are SUPPRESSED.
135 ! UNITS: N/A
136 ! TYPE: INTEGER
137 ! DIMENSION: Scalar
138 ! ATTRIBUTES: INTENT(IN), OPTIONAL
139 !
140 ! Process_ID: Set this argument to the MPI process ID that this
141 ! function call is running under. This value is used
142 ! solely for controlling INFORMATIOn message output.
143 ! If MPI is not being used, ignore this argument.
144 ! This argument is ignored if the Quiet argument is set.
145 ! UNITS: N/A
146 ! TYPE: INTEGER
147 ! DIMENSION: Scalar
148 ! ATTRIBUTES: INTENT(IN), OPTIONAL
149 !
150 ! Output_Process_ID: Set this argument to the MPI process ID in which
151 ! all INFORMATION messages are to be output. If
152 ! the passed Process_ID value agrees with this value
153 ! the INFORMATION messages are output.
154 ! This argument is ignored if the Quiet argument
155 ! is set.
156 ! UNITS: N/A
157 ! TYPE: INTEGER
158 ! DIMENSION: Scalar
159 ! ATTRIBUTES: INTENT(IN), OPTIONAL
160 !
161 ! Message_Log: Character string specifying a filename in which
162 ! any messages will be logged. If not specified,
163 ! or if an error occurs opening the log file, the
164 ! default action is to output messages to standard
165 ! output.
166 ! UNITS: N/A
167 ! TYPE: CHARACTER(*)
168 ! DIMENSION: Scalar
169 ! ATTRIBUTES: INTENT(IN), OPTIONAL
170 !
171 ! FUNCTION RESULT:
172 ! Error_Status: The return value is an integer defining the error
173 ! status. The error codes are defined in the
174 ! Message_Handler module.
175 ! If == SUCCESS the TauCoeff data load was successful
176 ! == FAILURE an unrecoverable error occurred.
177 ! == WARNING the number of channels read in differs
178 ! from that stored in the CRTM_Parameters
179 ! module.
180 ! UNITS: N/A
181 ! TYPE: INTEGER
182 ! DIMENSION: Scalar
183 !
184 ! SIDE EFFECTS:
185 ! This function modifies the contents of the public data structures
186 ! in this module.
187 !
188 !------------------------------------------------------------------------------
189 
190  FUNCTION crtm_load_taucoeff( Sensor_ID , & ! Input
191  File_Path , & ! Optional input
192  Quiet , & ! Optional input
193  Process_ID , & ! Optional input
194  Output_Process_ID, & ! Optional input
195  Message_Log ) & ! Error messaging
196  result( error_status )
197 
198  ! Arguments
199  CHARACTER(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: sensor_id
200  CHARACTER(*), OPTIONAL, INTENT(IN) :: file_path
201  INTEGER, OPTIONAL, INTENT(IN) :: quiet
202  INTEGER, OPTIONAL, INTENT(IN) :: process_id
203  INTEGER, OPTIONAL, INTENT(IN) :: output_process_id
204  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
205  ! Function result
206  INTEGER :: error_status
207  ! Local parameters
208  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Load_TauCoeff'
209  ! Local variables
210  CHARACTER(256) :: message
211  CHARACTER(256) :: process_id_tag
212  CHARACTER(256) :: local_path
213  CHARACTER(256), DIMENSION(MAX_N_SENSORS) :: taucoeff_file
214  INTEGER :: allocate_status, deallocate_status
215  INTEGER :: n, n_sensors
216  INTEGER :: i, j
217  INTEGER, PARAMETER :: sl = 128
218  INTEGER :: algorithm_id
219  CHARACTER(SL), ALLOCATABLE :: sensorids(:)
220  CHARACTER(SL), ALLOCATABLE :: zfnames(:)
221  INTEGER, ALLOCATABLE :: sensorindex(:)
222 
223  ! Set up
224  error_status = success
225  ! ...Test for the optional file path argument
226  local_path = ''
227  IF ( PRESENT(file_path) ) local_path = trim(adjustl(file_path))
228  ! Create a process ID message tag for
229  ! WARNING and FAILURE messages
230  IF ( PRESENT(process_id) ) THEN
231  WRITE( process_id_tag, '("; MPI Process ID: ",i0)' ) process_id
232  ELSE
233  process_id_tag = ' '
234  END IF
235 
236  ! Determine the number of sensors and construct their filenames
237  IF ( PRESENT(sensor_id) ) THEN
238 
239  ! Construct filenames for specified sensors
240  n_sensors = SIZE(sensor_id)
241  IF ( n_sensors > max_n_sensors ) THEN
242  error_status = failure
243  WRITE(message,'("Too many sensors, ",i0," specified. Maximum of ",i0," sensors allowed.")') &
244  n_sensors, max_n_sensors
245  CALL display_message( routine_name, &
246  trim(message)//trim(process_id_tag), &
247  error_status, &
248  message_log=message_log)
249  RETURN
250  END IF
251  DO n=1,n_sensors
252  taucoeff_file(n) = trim(adjustl(sensor_id(n)))//'.TauCoeff.bin'
253  END DO
254  ELSE
255  ! No sensors specified. Use default filename.
256  n_sensors=1
257  taucoeff_file(1) = 'TauCoeff.bin'
258  END IF
259 
260  ! Add the file path
261  DO n=1,n_sensors
262  taucoeff_file(n) = trim(local_path)//trim(taucoeff_file(n))
263  END DO
264 
265  ! set the sensor dimension for structure TC
266  tc%n_Sensors = n_sensors
267 
268 
269  ! Allocate memory for the local arrays
270  ALLOCATE( sensorids( n_sensors ), &
271  zfnames( n_sensors ), &
272  sensorindex( n_sensors ), &
273  stat = allocate_status )
274  IF ( allocate_status /= 0 ) THEN
275  error_status = failure
276  WRITE( message, '( "Error allocating local arrays with an n_Sensors dimension. STAT = ", i5 )' ) &
277  allocate_status
278  CALL display_message( routine_name, &
279  trim( message ), &
280  error_status, &
281  message_log = message_log )
282  RETURN
283  END IF
284 
285  CALL taucoeff_create(tc, n_sensors, error_status)
286  IF ( error_status /= success ) THEN
287  message = 'Error creating TC'
288  CALL display_message( routine_name, trim(message), error_status)
289  RETURN
290  END IF
291 
292  !----------------------------------------------------
293  ! Determine algorithm IDs from the TauCoeff files
294  !----------------------------------------------------
295  sensor_loop: DO n = 1, n_sensors
296 
297  ! set global sensor index
298  tc%Sensor_Index(n) = n
299 
300  ! Get the transmittance algorithm ID
301  error_status = inquire_algorithmid( trim(taucoeff_file(n)), &
302  algorithm_id, &
303  message_log = message_log )
304  IF ( error_status /= success ) THEN
305  CALL display_message( routine_name, &
306  'cannot obtain transmittance algorithm ID from file '//&
307  trim( taucoeff_file(n) )//trim( process_id_tag ), &
308  error_status, &
309  message_log = message_log )
310  RETURN
311  END IF
312 
313  tc%Algorithm_ID(n) = algorithm_id
314 
315  ! update the sensor counter and sensor (local) index for a specific algorithm
316  SELECT CASE( algorithm_id )
317  CASE ( odas_algorithm )
318 
319  tc%n_ODAS = tc%n_ODAS + 1
320  ! local sensor index, which is used within the algorithm
321  tc%Sensor_LoIndex(n) = tc%n_ODAS
322 
323  CASE ( odps_algorithm )
324 
325  tc%n_ODPS = tc%n_ODPS + 1
326  ! local sensor index, which is used within the algorithm
327  tc%Sensor_LoIndex(n) = tc%n_ODPS
328 
329  CASE ( odssu_algorithm )
330 
331  tc%n_ODSSU = tc%n_ODSSU + 1
332  ! local sensor index, which is used within the algorithm
333  tc%Sensor_LoIndex(n) = tc%n_ODSSU
334 
335  CASE DEFAULT
336 
337  error_status = failure
338 
339  IF(algorithm_id==10) THEN
340  message='The algorithm ID does not exist, TauCoeff file need to be converted to new format'
341  ELSE
342  WRITE( message, '( "The algorithm ID = ", i5, " does not exist ")' ) &
343  algorithm_id
344 
345  ENDIF
346  CALL display_message( routine_name, &
347  trim( message )//trim( process_id_tag ), &
348  failure, &
349  message_log = message_log )
350 
351  RETURN
352 
353  END SELECT
354 
355  END DO sensor_loop
356 
357  !-----------------------------------------------------------
358  ! Load algorithm-specific coefficient data
359  !-----------------------------------------------------------
360 
361  ! *** ODAS algorithm (Compact OPTRAN) ***
362 
363  n = tc%n_ODAS
364  IF( n > 0 )THEN
365  IF ( PRESENT(sensor_id) ) THEN
366  CALL extract_sensorinfo(odas_algorithm, tc%Algorithm_ID, &
367  sensorids, sensorindex, &
368  sensorid_in = sensor_id )
369  error_status = odas_load_taucoeff( &
370  sensor_id =sensorids(1:n) , &
371  file_path =file_path , &
372  quiet =quiet , &
373  process_id =process_id , &
374  output_process_id=output_process_id, &
375  message_log =message_log )
376  ELSE
377  ! for the case that the Sensor_ID is not present (in this case, 1 sensor only)
378  error_status = odas_load_taucoeff( &
379  file_path =file_path , &
380  quiet =quiet , &
381  process_id =process_id , &
382  output_process_id=output_process_id, &
383  message_log =message_log )
384  END IF
385 
386  IF ( error_status /= success ) THEN
387  CALL display_message( routine_name, &
388  'Error loading ODAS TauCoeff data', &
389  error_status, &
390  message_log=message_log )
391  RETURN
392  END IF
393 
394  ! set the pointer pointing to the local (algorithm specific) TC array
395  tc%ODAS => odas_tc
396 
397  ! Copy over sensor types and IDs
398  DO i = 1, n
399  j = sensorindex(i)
400  tc%Sensor_ID(j) = tc%ODAS(i)%Sensor_ID
401  tc%WMO_Satellite_ID(j) = tc%ODAS(i)%WMO_Satellite_ID
402  tc%WMO_Sensor_ID(j) = tc%ODAS(i)%WMO_Sensor_ID
403  tc%Sensor_Type(j) = tc%ODAS(i)%Sensor_Type
404  END DO
405 
406  END IF
407 
408  ! *** ODPS algorithm ***
409 
410  n = tc%n_ODPS
411  IF( n > 0 )THEN
412  IF ( PRESENT(sensor_id) ) THEN
413  CALL extract_sensorinfo(odps_algorithm, tc%Algorithm_ID, &
414  sensorids, sensorindex, &
415  sensorid_in = sensor_id )
416  error_status = odps_load_taucoeff( &
417  sensor_id =sensorids(1:n) , &
418  file_path =file_path , &
419  quiet =quiet , &
420  process_id =process_id , &
421  output_process_id=output_process_id, &
422  message_log =message_log )
423  ELSE
424  ! for the case that the Sensor_ID is not present (in this case, 1 sensor only)
425  error_status = odps_load_taucoeff( &
426  file_path =file_path , &
427  quiet =quiet , &
428  process_id =process_id , &
429  output_process_id=output_process_id, &
430  message_log =message_log )
431  END IF
432 
433  IF ( error_status /= success ) THEN
434  CALL display_message( routine_name, &
435  'Error loading ODPS TauCoeff data', &
436  error_status, &
437  message_log=message_log )
438  RETURN
439  END IF
440 
441  ! set the pointer pointing to the local (algorithm specific) TC array
442  tc%ODPS => odps_tc
443 
444  ! Copy over sensor types and IDs
445  DO i = 1, n
446  j = sensorindex(i)
447  tc%Sensor_ID(j) = tc%ODPS(i)%Sensor_ID
448  tc%WMO_Satellite_ID(j) = tc%ODPS(i)%WMO_Satellite_ID
449  tc%WMO_Sensor_ID(j) = tc%ODPS(i)%WMO_Sensor_ID
450  tc%Sensor_Type(j) = tc%ODPS(i)%Sensor_Type
451  END DO
452 
453  END IF
454 
455  ! *** ODSSU algorithm ***
456 
457  n = tc%n_ODSSU
458  IF( n > 0 )THEN
459  IF ( PRESENT(sensor_id) ) THEN
460  CALL extract_sensorinfo(odssu_algorithm, tc%Algorithm_ID, &
461  sensorids, sensorindex, &
462  sensorid_in = sensor_id )
463  error_status = odssu_load_taucoeff( &
464  sensor_id =sensorids(1:n) , &
465  file_path =file_path , &
466  quiet =quiet , &
467  process_id =process_id , &
468  output_process_id=output_process_id, &
469  message_log =message_log )
470  ELSE
471  ! for the case that the Sensor_ID is not present (in this case, 1 sensor only)
472  error_status = odssu_load_taucoeff( &
473  file_path =file_path , &
474  quiet =quiet , &
475  process_id =process_id , &
476  output_process_id=output_process_id, &
477  message_log =message_log )
478  END IF
479 
480  IF ( error_status /= success ) THEN
481  CALL display_message( routine_name, &
482  'Error loading ODSSU TauCoeff data', &
483  error_status, &
484  message_log=message_log )
485  RETURN
486  END IF
487 
488  ! set the pointer pointing to the local (algorithm specific) TC array
489  tc%ODSSU => odssu_tc
490 
491  ! Copy over sensor types and IDs
492  DO i = 1, n
493  j = sensorindex(i)
494  tc%Sensor_ID(j) = tc%ODSSU(i)%Sensor_ID
495  tc%WMO_Satellite_ID(j) = tc%ODSSU(i)%WMO_Satellite_ID
496  tc%WMO_Sensor_ID(j) = tc%ODSSU(i)%WMO_Sensor_ID
497  tc%Sensor_Type(j) = tc%ODSSU(i)%Sensor_Type
498  END DO
499 
500  END IF
501 
502  !----------------------------------------------------------------------------------
503  ! Load auxiliary tau coeff. data for sensors which require special Tau algorithms
504  ! for some of the channels (i.g. the Zeeman algorithms for SSMIS and AMSU-A.
505  !----------------------------------------------------------------------------------
506  tc%ZSensor_LoIndex = 0
507  tc%n_ODZeeman = 0
508  i = 1
509  DO n = 1, n_sensors
510  IF(tc%WMO_Sensor_ID(n) == wmo_ssmis .OR. tc%WMO_Sensor_ID(n) == wmo_amsua )THEN
511 
512  ! file name: i.g. zssmis_n16.TauCoeff.bin
513  zfnames(i) = 'z'//trim(tc%Sensor_ID(n))//'.TauCoeff.bin'
514  IF( file_exists(trim(local_path)//trim(zfnames(i))) ) THEN
515  tc%ZSensor_LoIndex(n) = i
516  tc%n_ODZeeman = i
517  i = i + 1
518  END IF
519  END IF
520  END DO
521  IF( tc%n_ODZeeman > 0 )THEN
522  error_status = odzeeman_load_taucoeff( &
523  zfnames(1:tc%n_ODZeeman) , &
524  file_path =file_path , &
525  quiet =quiet , &
526  process_id =process_id , &
527  output_process_id=output_process_id, &
528  message_log =message_log )
529  IF ( error_status /= success ) THEN
530  CALL display_message( routine_name, &
531  'Error loading ODZeeman TauCoeff data', &
532  error_status, &
533  message_log=message_log )
534  RETURN
535  END IF
536  tc%ODZeeman => odzeeman_tc
537  END IF
538 
539  !----------------------------------------------
540  ! deallocate local arrays
541  !----------------------------------------------
542 
543  DEALLOCATE(sensorids, &
544  zfnames, &
545  sensorindex, &
546  stat = deallocate_status)
547  IF ( deallocate_status /= 0 ) THEN
548  error_status = failure
549  CALL display_message( routine_name, &
550  'Error deallocating the local arrays', &
551  error_status, &
552  message_log=message_log )
553  RETURN
554  END IF
555 
556  END FUNCTION crtm_load_taucoeff
557 
558 !------------------------------------------------------------------------------
559 !
560 ! NAME:
561 ! CRTM_Destroy_TauCoeff
562 !
563 ! PURPOSE:
564 ! Function to deallocate the public shared data structure containing
565 ! the CRTM TauCoeff transmittance coefficient data.
566 !
567 ! CALLING SEQUENCE:
568 ! Error_Status = CRTM_Destroy_TauCoeff( Process_ID = Process_ID, & ! Optional input
569 ! Message_Log = Message_Log ) ! Error messaging
570 !
571 ! OPTIONAL INPUT ARGUMENTS:
572 ! Process_ID: Set this argument to the MPI process ID that this
573 ! function call is running under. This value is used
574 ! solely for controlling message output. If MPI is not
575 ! being used, ignore this argument.
576 ! UNITS: N/A
577 ! TYPE: INTEGER
578 ! DIMENSION: Scalar
579 ! ATTRIBUTES: INTENT(IN), OPTIONAL
580 !
581 ! Message_Log: Character string specifying a filename in which any
582 ! messages will be logged. If not specified, or if an
583 ! error occurs opening the log file, the default action
584 ! is to output messages to the screen.
585 ! UNITS: N/A
586 ! TYPE: CHARACTER(*)
587 ! DIMENSION: Scalar
588 ! ATTRIBUTES: INTENT(IN), OPTIONAL
589 !
590 ! FUNCTION RESULT:
591 ! Error_Status: The return value is an integer defining the error
592 ! status. The error codes are defined in the
593 ! Message_Handler module.
594 ! If == SUCCESS the deallocation of the public TC data
595 ! structure was successful
596 ! == FAILURE an unrecoverable error occurred.
597 ! UNITS: N/A
598 ! TYPE: INTEGER
599 ! DIMENSION: Scalar
600 !
601 !
602 ! SIDE EFFECTS:
603 ! This function modifies the contents of the public data structures
604 ! in this module.
605 !
606 !------------------------------------------------------------------------------
607 
608  FUNCTION crtm_destroy_taucoeff( Process_ID, & ! Optional input
609  Message_Log ) & ! Error messaging
610  result( error_status )
611 
612  ! Arguments
613  INTEGER, OPTIONAL, INTENT(IN) :: process_id
614  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
615  ! Function result
616  INTEGER :: error_status
617  ! Local parameters
618  CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Destroy_TauCoeff'
619  ! Local variables
620  CHARACTER(256) :: message
621  CHARACTER(256) :: process_id_tag
622  INTEGER :: destroy_status
623 
624  ! Set up
625  error_status = success
626  ! Create a process ID message tag for
627  ! WARNING and FAILURE messages
628  IF ( PRESENT( process_id ) ) THEN
629  WRITE( process_id_tag, '("; MPI Process ID: ",i0)' ) process_id
630  ELSE
631  process_id_tag = ' '
632  END IF
633 
634  ! ----------------------------------------------
635  ! Destroy TauCoeff structures
636  ! ----------------------------------------------
637 
638  IF( tc%n_ODAS > 0 )THEN
639 
640  ! disassociate the TC%ODAS pointer (which is pointing to TauCoeff_ODAS)
641  NULLIFY( tc%ODAS )
642 
643  ! Destroy local TC, i.e TauCoeff_ODAS
644  destroy_status = odas_destroy_taucoeff( process_id =process_id , &
645  message_log=message_log )
646  IF ( destroy_status /= success ) THEN
647  error_status = destroy_status
648  CALL display_message( routine_name, &
649  'Error deallocating shared TauCoeff_ODAS data structure', &
650  error_status, &
651  message_log=message_log )
652  END IF
653 
654  tc%n_ODAS = 0
655 
656  END IF
657 
658  IF( tc%n_ODPS > 0 )THEN
659 
660  ! disassociate the TC%ODPS pointer (which is pointing to TauCoeff_ODPS)
661  NULLIFY( tc%ODPS )
662 
663  ! Destroy local TC, i.e TauCoeff_ODPS
664  destroy_status = odps_destroy_taucoeff( process_id =process_id , &
665  message_log=message_log )
666  IF ( destroy_status /= success ) THEN
667  error_status = destroy_status
668  CALL display_message( routine_name, &
669  'Error deallocating shared TauCoeff_ODPS data structure', &
670  error_status, &
671  message_log=message_log )
672  END IF
673 
674  tc%n_ODPS = 0
675 
676  END IF
677 
678  IF( tc%n_ODSSU > 0 )THEN
679 
680  ! disassociate the TC%ODAS pointer (which is pointing to TauCoeff_ODAS)
681  NULLIFY( tc%ODSSU )
682 
683  ! Destroy local TC, i.e TauCoeff_ODAS
684  destroy_status = odssu_destroy_taucoeff( process_id =process_id , &
685  message_log=message_log )
686  IF ( destroy_status /= success ) THEN
687  error_status = destroy_status
688  CALL display_message( routine_name, &
689  'Error deallocating shared TauCoeff_SSU data structure', &
690  error_status, &
691  message_log=message_log )
692  END IF
693 
694  tc%n_ODSSU = 0
695 
696  END IF
697 
698  IF( tc%n_ODZeeman > 0 )THEN
699 
700  ! disassociate the TC%ODAS pointer (which is pointing to TauCoeff_ODAS)
701  NULLIFY( tc%ODZeeman )
702 
703  ! Destroy local TC, i.e TauCoeff_ODAS
704  destroy_status = odzeeman_destroy_taucoeff( process_id =process_id , &
705  message_log=message_log )
706  IF ( destroy_status /= success ) THEN
707  error_status = destroy_status
708  CALL display_message( routine_name, &
709  'Error deallocating shared TauCoeff Zeeman data structure', &
710  error_status, &
711  message_log=message_log )
712  END IF
713 
714  tc%n_ODZeeman = 0
715 
716  END IF
717 
718  ! Destroy TC
719  CALL taucoeff_destroy(tc, error_status)
720  IF ( error_status /= success ) THEN
721  message = 'Error destroying TC'
722  CALL display_message( routine_name, trim(message), error_status)
723  RETURN
724  END IF
725 
726  END FUNCTION crtm_destroy_taucoeff
727 
728  FUNCTION inquire_algorithmid( Filename , & ! Input
729  Algorithm_ID , & ! Output
730  RCS_Id , & ! Revision control
731  Message_Log ) & ! Error messaging
732  result( error_status )
733  ! Arguments
734  CHARACTER(*), INTENT(IN) :: filename
735  INTEGER, INTENT(OUT) :: algorithm_id
736  CHARACTER(*), OPTIONAL, INTENT(OUT) :: rcs_id
737  CHARACTER(*), OPTIONAL, INTENT(IN) :: message_log
738  ! Function result
739  INTEGER :: error_status
740  ! Function parameters
741  CHARACTER(*), PARAMETER :: routine_name = 'Inquire_AlgorithmID'
742 
743  ! Function variables
744  CHARACTER(256) :: message
745  INTEGER :: io_status
746  INTEGER :: fileid
747  INTEGER(Long) :: algorithm_id_in
748  INTEGER(Long) :: release_in
749  INTEGER(Long) :: version_in
750 
751 
752  ! Set up
753  ! ------
754  error_status = success
755  IF ( PRESENT( rcs_id ) ) rcs_id = module_rcs_id
756 
757  ! Check that the file exists
758  IF ( .NOT. file_exists( trim(filename) ) ) THEN
759  message = 'File '//trim(filename)//' not found.'
760  CALL inquire_cleanup(); RETURN
761  END IF
762 
763 
764  ! Open the file
765  ! -------------
766  error_status = open_binary_file( filename, fileid )
767  IF ( error_status /= success ) THEN
768  message = 'Error opening TauCoeff Binary file '//trim(filename)
769  CALL inquire_cleanup(); RETURN
770  END IF
771 
772 
773  ! Read the Release and Version information
774  ! ----------------------------------------
775  READ( fileid, iostat=io_status ) release_in, version_in
776  IF ( io_status /= 0 ) THEN
777  WRITE( message,'("Error reading Release/Version values from ",a,&
778  &". IOSTAT = ",i0)' ) &
779  trim(filename), io_status
780  CALL inquire_cleanup(close_file=set); RETURN
781  END IF
782 
783 
784  ! Read the Alorithm ID
785  ! --------------------
786  READ( fileid, iostat=io_status ) algorithm_id_in
787  IF ( io_status /= 0 ) THEN
788  WRITE( message,'("Error reading Algorithm ID from ",a,&
789  &". IOSTAT = ",i0)' ) &
790  trim(filename), io_status
791  CALL inquire_cleanup(close_file=set); RETURN
792  END IF
793 
794  ! Assign the return argument
795  algorithm_id = algorithm_id_in
796 
797  ! Close the file
798  ! --------------
799  CLOSE( fileid, iostat=io_status )
800  IF ( io_status /= 0 ) THEN
801  WRITE( message,'("Error closing ",a,". IOSTAT = ",i0)' ) &
802  trim(filename), io_status
803  CALL inquire_cleanup(); RETURN
804  END IF
805 
806  CONTAINS
807 
808  SUBROUTINE inquire_cleanup( Close_File )
809  INTEGER, OPTIONAL, INTENT(IN) :: Close_File
810  CHARACTER(256) :: Close_Message
811  ! Close file if necessary
812  IF ( PRESENT(close_file) ) THEN
813  IF ( close_file == set ) THEN
814  CLOSE( fileid, iostat=io_status )
815  IF ( io_status /= 0 ) THEN
816  WRITE( close_message,'("; Error closing input file during error cleanup. IOSTAT=",i0)') &
817  io_status
818  message = trim(message)//trim(close_message)
819  END IF
820  END IF
821  END IF
822  ! Set error status and print error message
823  error_status = failure
824  CALL display_message( routine_name, &
825  trim(message), &
826  error_status, &
827  message_log=message_log )
828  END SUBROUTINE inquire_cleanup
829 
830  END FUNCTION inquire_algorithmid
831 
832  !------------------------------------------------------------------------------------------
833  ! Extract sensor IDs and sensor indexes
834  ! Inputs:
835  ! TheAlgorithmID - an algorithm ID
836  ! AlgorithmID - algorithm ID array holding the ID data
837  ! Outputs:
838  ! SensorID_subset - subset of the sensor IDs with the same algorithm ID TheAlgorithmID,
839  ! extracted from the array AlgorithmID
840  ! SensorIndex - the subset of the sensor indexes, corresponding to SensorID_subset
841  ! Optional inputs:
842  ! SensorID_in - sensor ID array
843  !
844  ! Note: if Sensor_ID is not present, no Sensor ID will be extracted and the sensor index
845  ! is set to 1 (this is the case if user does not specify sensor ID).
846  !------------------------------------------------------------------------------------------
847  SUBROUTINE extract_sensorinfo(TheAlgorithmID, AlgorithmID, & ! Inputs
848  SensorID_subset, SensorIndex, & ! Output
849  SensorID_in ) ! Optional input
850  INTEGER, INTENT(IN) :: TheAlgorithmID
851  INTEGER, INTENT(IN) :: AlgorithmID(:)
852  CHARACTER(*), INTENT(OUT) :: SensorID_subset(:)
853  INTEGER, INTENT(OUT) :: SensorIndex(:)
854  CHARACTER(*), OPTIONAL, INTENT(IN) :: SensorID_in(:)
855 
856  ! LOCAL variables
857  INTEGER :: i, ii
858 
859  IF(PRESENT(sensorid_in))THEN
860  ii = 0
861  DO i = 1, SIZE(algorithmid)
862  IF(tc%Algorithm_ID(i) == thealgorithmid) THEN
863  ii = ii + 1
864  sensorid_subset(ii) = sensorid_in(i)
865  sensorindex(ii) = i
866  END IF
867  END DO
868  ELSE
869  sensorindex(1) = 1
870  END IF
871 
872  END SUBROUTINE extract_sensorinfo
873 
874 END MODULE crtm_taucoeff
odzeeman_taucoeff
Definition: ODZeeman_TauCoeff.f90:23
message_handler::failure
integer, parameter, public failure
Definition: Message_Handler.f90:30
crtm_parameters::set
integer, parameter, public set
Definition: CRTM_Parameters.f90:113
message_handler::warning
integer, parameter, public warning
Definition: Message_Handler.f90:29
crtm_sensorinfo
Definition: CRTM_SensorInfo.f90:11
taucoeff_define::taucoeff_create
subroutine, public taucoeff_create(self, n_Sensors, err_stat)
Definition: TauCoeff_Define.f90:277
type_kinds::long
integer, parameter, public long
Definition: Type_Kinds.f90:76
odas_taucoeff
Definition: ODAS_TauCoeff.f90:27
taucoeff_define::taucoeff_destroy
subroutine, public taucoeff_destroy(self, err_stat)
Definition: TauCoeff_Define.f90:193
odssu_define
Definition: ODSSU_Define.f90:14
crtm_parameters
Definition: CRTM_Parameters.f90:12
taucoeff_define::taucoeff_type
Definition: TauCoeff_Define.f90:73
crtm_taucoeff::extract_sensorinfo
subroutine extract_sensorinfo(TheAlgorithmID, AlgorithmID, SensorID_subset, SensorIndex, SensorID_in)
Definition: CRTM_TauCoeff.f90:850
crtm_sensorinfo::wmo_ssmis
integer, parameter, public wmo_ssmis
Definition: CRTM_SensorInfo.f90:51
taucoeff_define
Definition: TauCoeff_Define.f90:16
odssu_define::odssu_type
Definition: ODSSU_Define.f90:89
inquire_cleanup
subroutine inquire_cleanup()
Definition: ACCoeff_Binary_IO.f90:249
crtm_taucoeff
Definition: CRTM_TauCoeff.f90:23
crtm_taucoeff::inquire_algorithmid
integer function inquire_algorithmid(Filename, Algorithm_ID, RCS_Id, Message_Log)
Definition: CRTM_TauCoeff.f90:733
message_handler
Definition: Message_Handler.f90:4
crtm_taucoeff::module_rcs_id
character(*), parameter module_rcs_id
Definition: CRTM_TauCoeff.f90:75
odas_taucoeff::load_taucoeff
integer function, public load_taucoeff(Sensor_ID, File_Path, Quiet, Process_ID, Output_Process_ID, Message_Log)
Definition: ODAS_TauCoeff.f90:185
odas_define::odas_type
Definition: ODAS_Define.f90:109
binary_file_utility
Definition: Binary_File_Utility.f90:13
odssu_taucoeff
Definition: ODSSU_TauCoeff.f90:26
binary_file_utility::open_binary_file
integer function, public open_binary_file(Filename, FileID, For_Output, No_Check)
Definition: Binary_File_Utility.f90:162
message_handler::display_message
recursive subroutine, public display_message(Routine_Name, Message, Error_State, Message_Log)
Definition: Message_Handler.f90:118
crtm_sensorinfo::wmo_amsua
integer, parameter, public wmo_amsua
Definition: CRTM_SensorInfo.f90:41
file_utility::file_exists
Definition: File_Utility.f90:51
odps_define::odps_type
Definition: ODPS_Define.f90:112
odas_taucoeff::destroy_taucoeff
integer function, public destroy_taucoeff(Process_ID, Message_Log)
Definition: ODAS_TauCoeff.f90:330
type_kinds
Definition: Type_Kinds.f90:12
crtm_taucoeff::crtm_load_taucoeff
integer function, public crtm_load_taucoeff(Sensor_ID, File_Path, Quiet, Process_ID, Output_Process_ID, Message_Log)
Definition: CRTM_TauCoeff.f90:197
odps_taucoeff
Definition: ODPS_TauCoeff.f90:23
crtm_taucoeff::tc
type(taucoeff_type), save, public tc
Definition: CRTM_TauCoeff.f90:83
odas_define
Definition: ODAS_Define.f90:13
message_handler::success
integer, parameter, public success
Definition: Message_Handler.f90:27
crtm_taucoeff::crtm_destroy_taucoeff
integer function, public crtm_destroy_taucoeff(Process_ID, Message_Log)
Definition: CRTM_TauCoeff.f90:611
file_utility
Definition: File_Utility.f90:26
odps_define
Definition: ODPS_Define.f90:13
crtm_parameters::max_n_sensors
integer, parameter, public max_n_sensors
Definition: CRTM_Parameters.f90:58