MODULE module_obs_merge !------------------------------------------------------------------------------! ! Merge space duplicate stations (same type, same location and same time) ! For each variable and each level, keep (as defined by function keep_best) ! the best variables. ! ! D. GILL, April 1998 ! F. VANDENBERGHE, March 2001 !------------------------------------------------------------------------------! USE module_type USE module_func CONTAINS !------------------------------------------------------------------------------! ! SUBROUTINE merge_obs ( first , second ) ! SUBROUTINE keep_best ( field1 , field2 , best ) ! SUBROUTINE link_levels ( list1 , list2 , info1 , info2 , best ) ! SUBROUTINE merge_measurements ( first ,second , best ) ! ! ! -------------------------------------------------------------------------- SUBROUTINE merge_obs ( first , second, print_duplicate, iunit) ! Reports 'first' and 'second' have been found to have same location and ! time, therefore they must be merged and one of them discarded. ! The result of merge is put in 'first' report; second is discarded. ! If either has data and other has 'missing', keep data; if both have data, take ! data from one with greatest num_vld_fld or fewest 'num_error'. IMPLICIT NONE TYPE ( report ) , INTENT ( INOUT ) :: first , & second ! Guo..01/22/2007: TYPE (measurement), pointer :: surface1, surface2 INTEGER, INTENT (in) :: iunit LOGICAL, INTENT (in) :: print_duplicate INTEGER :: best CHARACTER (LEN = 80) :: sub_name = "merge_obs" CHARACTER (LEN = 160) :: error_message LOGICAL :: fatal ! INCLUDE 'error.inc' ! INTERFACE ! INCLUDE 'error.int' ! END INTERFACE IF ( first%info%num_vld_fld .GT. second%info%num_vld_fld ) THEN best = 1 ELSE IF ( first%info%num_vld_fld .LT. second%info%num_vld_fld ) THEN best = 2 ELSE IF ( first%info%num_error .LT. second%info%num_error ) THEN best = 1 ELSE IF ( first%info%num_error .GT. second%info%num_error ) THEN best = 2 ELSE IF ( first%info%num_warning .LT. second%info%num_warning ) THEN best = 1 ELSE IF ( first%info%num_warning .GT. second%info%num_warning ) THEN best = 2 ELSE IF ( first%info%seq_num .GT. second%info%seq_num ) THEN best = 1 ELSE IF ( first%info%seq_num .LT. second%info%seq_num ) THEN best = 2 ELSE best = 1 IF (print_duplicate) THEN error_message = & " Arbitrarily assuming first obs is better than second for " // & ! TRIM ( first%location%name ) // ' ' // & ! TRIM ( first%location%id ) // ' ' // & TRIM ( first%info%platform) // '.' WRITE (UNIT = iunit, FMT = '(A)') TRIM (error_message) ! fatal = .false. ! CALL error_handler (sub_name , error_message, "", fatal) ENDIF END IF ! Will put all useful information in first report; discard second ! report. Update report being kept with the num_vld_fld, num_error, ! num_warnings, etc, from best. IF ( best .EQ. 2 ) THEN first%info = second%info END IF ! Now look at all terrestrial fields, keeping the best values. ! foo ! IF ( .NOT. ( first%ground .EQ. second%ground ) ) THEN IF ( .NOT. ground_eq ( first%ground , second%ground ) ) THEN CALL keep_best ( first%ground%slp , second%ground%slp , best ) CALL keep_best ( first%ground%ref_pres , second%ground%ref_pres , best ) CALL keep_best ( first%ground%ground_t , second%ground%ground_t , best ) CALL keep_best ( first%ground%sst , second%ground%sst , best ) CALL keep_best ( first%ground%psfc , second%ground%psfc , best ) CALL keep_best ( first%ground%precip , second%ground%precip , best ) CALL keep_best ( first%ground%t_max , second%ground%t_max , best ) CALL keep_best ( first%ground%t_min , second%ground%t_min , best ) CALL keep_best ( first%ground%t_min_night , second%ground%t_min_night , best ) CALL keep_best ( first%ground%p_tend03 , second%ground%p_tend03 , best ) CALL keep_best ( first%ground%p_tend24 , second%ground%p_tend24 , best ) CALL keep_best ( first%ground%cloud_cvr , second%ground%cloud_cvr , best ) CALL keep_best ( first%ground%ceiling , second%ground%ceiling , best ) CALL keep_best ( first%ground%pw , second%ground%pw , best ) CALL keep_best ( first%ground%tb19v , second%ground%tb19v , best ) CALL keep_best ( first%ground%tb19h , second%ground%tb19h , best ) CALL keep_best ( first%ground%tb22v , second%ground%tb22v , best ) CALL keep_best ( first%ground%tb37v , second%ground%tb37v , best ) CALL keep_best ( first%ground%tb37h , second%ground%tb37h , best ) CALL keep_best ( first%ground%tb85v , second%ground%tb85v , best ) CALL keep_best ( first%ground%tb85h , second%ground%tb85h , best ) ! WRITE (iunit,*) first%ground%pw,second%ground%pw END IF ! Merge data at different levels, starting at ground (or lowest level). On return ! all of linked list from second is deallocated, so not much additional memory ! is used by keeping the absorbed observation. The info types are provided so ! that it can be determined if these are both surface observations. ! Guo.. 01/22/2007: If either both of reports have no 'surface' data or the ! "second" has no 'surface', no 'surface' data merging (link_levels) ! need to do. if ( (.not.associated(first%surface) .and. & .not.associated(second%surface)) .or. & (associated(first%surface) .and. & .not.associated(second%surface)) )then return ! Guo.. 01/22/2007: If the "first" has no 'surface' but the "second" does, ! link the second%surface to the first%surface because after merging, ! all useful information is put in first report; discard second ! else if (.not.associated(first%surface) .and. & associated(second%surface)) then surface2 => second%surface first%surface => surface2 ! nullify(second%surface) return endif CALL link_levels ( first%surface , second%surface , & first%info , second%info , best ) END SUBROUTINE merge_obs ! !--------------------------------------------------------------------------- SUBROUTINE keep_best ( field1 , field2 , best ) ! Use quality control (qc) info and keep the best value; if one is missing ! keep the one that is known; if both present keep the one with better qc ! flag; if qc flags the same, keep the one chosen 'best'. IMPLICIT none TYPE ( field ) , INTENT ( INOUT ) :: field1 TYPE ( field ) , INTENT ( IN ) :: field2 INTEGER , INTENT ( IN ) :: best CHARACTER ( LEN = 32 ) , PARAMETER :: sub_name = 'keep_best' CHARACTER ( LEN = 80 ) :: msg INCLUDE 'missing.inc' ! INCLUDE 'error.inc' ! INTERFACE ! INCLUDE 'error.int' ! END INTERFACE ! foo ! IF ( field1 .EQ. field2 ) THEN IF ( field_eq ( field1 , field2 ) ) THEN ! If there is no difference, have nothing to do. ELSE IF ( ( eps_equal ( field1%data , missing_r , 1. ) ) .AND. & ( .NOT. eps_equal ( field2%data , missing_r , 1. ) ) ) THEN ! Copy both data and quality control flag. field1 = field2 ELSE IF ( ( .NOT. eps_equal ( field1%data , missing_r , 1. ) ) .AND. & ( eps_equal ( field2%data , missing_r , 1. ) ) ) THEN ! Already have data in report1, so do nothing. ELSE IF ( ( eps_equal ( field1%data , missing_r , 1. ) ) .AND. & ( eps_equal ( field2%data , missing_r , 1. ) ) ) THEN ! When both data fields are empty, do nothing. ELSE IF ( ( .NOT. eps_equal ( field1%data , missing_r , 1. ) ) .AND. & ( .NOT. eps_equal ( field2%data , missing_r , 1. ) ) ) THEN ! There are several cases to consider if both fields have data: ! First, use quality control flags to differentiate the differences. IF ( field1%qc == missing ) THEN ! if field1 is a recovered value for a missing data field1 = field2 ELSE IF ( field2%qc == missing ) THEN ! if field2 is a recovered value from the missing data ! Do nothing, keep field1. ELSE IF ( field1%qc .LT. field2%qc ) THEN ! In case of no "missing", since the data is already in field1, do nothing. ELSE IF ( field1%qc .GT. field2%qc ) THEN field1 = field2 ELSE IF ( field1%qc .EQ. field2%qc ) THEN ! Second, if they have the same quality control values, use data ! that was chosen 'best' IF ( best .EQ. 1 ) THEN ! Again, since the data is already in field1, do nothing. ELSE IF ( best .EQ. 2 ) THEN field1 = field2 ELSE ! Should never execute this part; have invalid 'best' integer. msg = 'Internal logic error. Invalid value of ''best''' CALL error_handler (sub_name, msg, "", .TRUE.) END IF ELSE ! Should never execute this; if so, have fatal error msg = 'Internal logic error. Either the QCs are different or the same.' CALL error_handler (sub_name, msg, "", .TRUE. ) END IF ELSE ! should never execute this; if so have fatal error msg = 'Internal logic error. Only four combinations of fields missing are possible.' CALL error_handler (sub_name, msg , "", .TRUE.) END IF END SUBROUTINE keep_best ! !--------------------------------------------------------------------------- SUBROUTINE link_levels ( list1 , list2 , info1 , info2 , best ) ! Starting at the surface level, link levels into one list if pressure levels ! are different; if have two levels at the same pressure level (within ! epsilon) then keep the best data. The resulting (output) linked list ! starts from list1; list2 contains nothing useful on return. IMPLICIT NONE TYPE ( measurement ) , POINTER :: list1 , list2 INTEGER , INTENT ( IN ) :: best TYPE ( measurement ) , POINTER :: next1 , & next2 , & current , & delete_it TYPE ( source_info ) :: info1 , info2 INCLUDE 'missing.inc' ! Initialize both traversal pointers. next1 => list1 next2 => list2 NULLIFY ( current ) ! Merge until the end of either list1 or list2 is reached. still_associated : DO WHILE ( ASSOCIATED ( next1 ) .AND. ASSOCIATED ( next2 ) ) IF ( ( eps_equal ( next1%meas%pressure%data , & next2%meas%pressure%data , 1. ) ) & .OR. & ( ( eps_equal ( info1%elevation , & next1%meas%height%data , .1 ) ) .AND. & ( eps_equal ( info2%elevation , & next2%meas%height%data , .1 ) ) .AND. & ( .NOT. eps_equal ( info1%elevation , missing_r , 1. ) ) .AND. & ( eps_equal ( next1%meas%height%data , & next2%meas%height%data , .1 ) ) ) ) THEN ! There are two ways that cause us to merge the data into one level: ! 1) Both levels are at same pressure level within precision of pressure, ! so merge data from both levels into one measurement. ! 2) If both of the observations are surface reports, then the pressure ! may be different, but the height = terrain elevation, and the two ! heights are equal. CALL merge_measurements ( next1%meas , next2%meas , best ) ! Advance the pointers. IF ( .NOT. ASSOCIATED ( current ) ) THEN ! are at the head of the output linked list; ! already have list1 => next1 so do nothing ELSE current%next => next1 END IF current => next1 ! set so current points to next output node next1 => next1%next ! get next node in list1 delete_it => next2 ! record location of next2 to delete it next2 => next2%next ! get next node in list2 ! The bypassed observation can be deleted. DEALLOCATE ( delete_it ) ! Because of the way that the data is merged (allowing the surface data ! to be recognized through the elevation = height), there may arise ! conditions that allow replicated pressure surfaces. Those instances ! are what we check for in the next two IF blocks. duplicates_list1 : DO WHILE ( ASSOCIATED ( next1 ) ) IF ( ( eps_equal ( current%meas%pressure%data , next1%meas%pressure%data , 1. ) ) & .OR. & ( ( eps_equal ( current%meas%height%data , next1%meas%height%data , .1 ) ) .AND. & ( .NOT. eps_equal ( current%meas%height%data , missing_r , 1. ) ) .AND. & ( eps_equal ( info1%elevation , next1%meas%height%data , .1 ) ) ) ) THEN CALL merge_measurements ( current%meas , next1%meas , best ) ! Advance the next1 pointer, kill the old location. delete_it => next1 ! record location of next1 to delete it next1 => next1%next ! get next node in list1 ! The bypassed observation can be deleted. DEALLOCATE ( delete_it ) ! We need to continue checking for more duplicates. CYCLE duplicates_list1 ELSE ! There are no more duplicates. EXIT duplicates_list1 END IF END DO duplicates_list1 duplicates_list2 : DO WHILE ( ASSOCIATED ( next2 ) ) IF ( ( eps_equal ( current%meas%pressure%data , next2%meas%pressure%data , 1. ) ) & .OR. & ( ( eps_equal ( current%meas%height%data , next2%meas%height%data , .1 ) ) .AND. & ( .NOT. eps_equal ( current%meas%height%data , missing_r , 1. ) ) .AND. & ( eps_equal ( info2%elevation , next2%meas%height%data , .1 ) ) ) ) THEN CALL merge_measurements ( current%meas , next2%meas , best ) ! Advance the next2 pointer, kill the old location. delete_it => next2 ! record location of next2 to delete it next2 => next2%next ! get next node in list2 ! The bypassed observation can be deleted. DEALLOCATE ( delete_it ) ELSE ! There are no more duplicates. EXIT duplicates_list2 END IF END DO duplicates_list2 ELSE IF ( next1%meas%pressure%data .LT. next2%meas%pressure%data ) THEN ! Link node from list2 in current list. IF ( .NOT. ASSOCIATED ( current ) ) THEN ! are at the head of the output list list1 => next2 ELSE current%next => next2 END IF current => next2 next2 => next2%next ELSE ! Link node from list1 into the current list. IF ( .NOT. ASSOCIATED ( current ) ) THEN ! are at the head of the output list; list1 already points to next1 ! have list1 => next1 so do nothing ELSE current%next => next1 END IF current => next1 next1 => next1%next END IF END DO still_associated ! The end of either list1 or list2 was reached. The list that is still ! associated (not finished), still has data in the list tail. Have the ! current list include that tail. If both lists are exhausted, nullify ! the last pointer. IF ( ASSOCIATED ( next2 ) ) THEN current%next => next2 ELSE IF ( ASSOCIATED ( next1 ) ) THEN current%next => next1 ELSE NULLIFY ( current%next ) END IF END SUBROUTINE link_levels ! ! ------------------------------------------------------------------------ SUBROUTINE merge_measurements ( first ,second , best ) ! This takes two measurements that have been found to be at the same ! pressure level and takes the best data from each. Criterion for ! determining which to keep is which has better quality control value. IMPLICIT NONE TYPE ( meas_data ) , INTENT ( INOUT ) :: first TYPE ( meas_data ) , INTENT ( IN ) :: second INTEGER , INTENT ( IN ) :: best CALL keep_best ( first%pressure , second%pressure , best ) CALL keep_best ( first%height , second%height , best ) ! CALL keep_best ( first%zkc , second%zkc , best ) ! CALL keep_best ( first%zkd , second%zkd , best ) ! CALL keep_best ( first%zkc_lg , second%zkc_lg , best ) ! CALL keep_best ( first%zkd_lg , second%zkd_lg , best ) CALL keep_best ( first%temperature , second%temperature , best ) CALL keep_best ( first%dew_point , second%dew_point , best ) CALL keep_best ( first%speed , second%speed , best ) CALL keep_best ( first%direction , second%direction , best ) CALL keep_best ( first%u , second%u , best ) CALL keep_best ( first%v , second%v , best ) CALL keep_best ( first%rh , second%rh , best ) CALL keep_best ( first%thickness , second%thickness , best ) END SUBROUTINE merge_measurements END MODULE module_obs_merge