!--------------------------------------- LICENCE BEGIN -----------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
subroutine checkObsMpiIP(lobsSpaceData,burp_split_L) 1,34
!
! PURPOSE:
! check if all observations are correctly distributed along latitude bands
! if an observations is not, then don't assimilate this observation
!
use MathPhysConstants_mod
use obsSpaceData_mod
use HorizontalCoord_mod
use MathPhysConstants_mod, only: MPC_DEGREES_PER_RADIAN_R4
use mpivar_mod !! for variable 'mpi_myid'
implicit none
type(struct_obs), intent(inout) :: lobsSpaceData
logical, intent(in) :: burp_split_L
type(struct_hco), pointer :: hco_anl
real(8) :: epsilon_lat,delta_lat,epsilon_lon,delta_lon
real(8) :: lat_r8, lon_r8
real :: lat_r4, lon_r4
real :: xpos_r4, ypos_r4
integer :: headerIndex
integer :: latIndex, lonIndex
integer :: ierr
integer :: IP, IP_x, IP_y, count_obs_in
integer :: idata,idatend,jdata
integer :: gdxyfll
write(*,*) 'routine checkObsMpiIP: numHeader = ',obs_numheader(lobsSpaceData)
if (burp_split_L) then
! set tolerance on distance in radians from latitude band
hco_anl => hco_Get('Analysis')
epsilon_lat= abs(hco_anl % lat(1) - hco_anl % lat(2)) * 1.0d-4
epsilon_lon= abs(hco_anl % lon(1) - hco_anl % lon(2)) * 1.0d-4
write(*,*) 'routine checkObsMpiIP: epsilon_lat,_lon = ',epsilon_lat,epsilon_lon
count_obs_in = 0
do headerIndex = 1, obs_numheader(lobsSpaceData)
lat_r8 = obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)
lon_r8 = obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)
lat_r4 = real(lat_r8) * MPC_DEGREES_PER_RADIAN_R4
lon_r4 = real(lon_r8) * MPC_DEGREES_PER_RADIAN_R4
ierr = gdxyfll( hco_anl % EZscintID, & ! IN
xpos_r4, ypos_r4, & ! OUT
lat_r4, lon_r4, 1 ) ! IN
if ( trim(hco_anl % grtyp) == 'G' .and. hco_anl % ig2 == 1 ) then
! Revert latitudes since gdxyfll does not handle properly this grid type
ypos_r4 = real(hco_anl % nj,4) - ypos_r4 + 1.0
end if
latIndex = floor(ypos_r4)
lonIndex = floor(xpos_r4)
IP_y = ( mpi_npey * (latIndex-1) ) / hco_anl%nj
IP_x = ( mpi_npex * (lonIndex-1) ) / hco_anl%ni
IP = IP_x + IP_y*mpi_npex
! obs outside lat-lon tile, first check if only epsilon_lat away from latitude band
if ( IP .ne. mpi_myid ) then
write(*,*) 'checkObsMpiIP: obs outside lat-lon tile, will check to see by how much'
write(*,*) 'checkObsMpiIP: IP_x , IP_y , IP = ', IP_x, IP_y, IP
write(*,*) 'checkObsMpiIP: myidx, myidy, myid = ', mpi_myidx, mpi_myidy, mpi_myid
write(*,*) 'checkObsMpiIP: obs lon =',obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
lonIndex = 1 + (mpi_myidx * hco_anl % ni / mpi_npex)
write(*,*) 'checkObsMpiIP: tile lon west =',hco_anl % lon(lonIndex) * MPC_DEGREES_PER_RADIAN_R8
lonIndex = 1 + ((mpi_myidx+1) * hco_anl % ni / mpi_npex)
write(*,*) 'checkObsMpiIP: tile lon east =',hco_anl % lon(lonIndex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: obs lat =',obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
if(mpi_myidy.gt.0) then
latIndex = 1 + (mpi_myidy * hco_anl % nj / mpi_npey)
write(*,*) 'checkObsMpiIP: tile lat north =',hco_anl % lat(latIndex) * MPC_DEGREES_PER_RADIAN_R8
endif
if(mpi_myidy.lt.(mpi_npey-1)) then
latIndex = 1 + ((mpi_myidy+1) * hco_anl % nj / mpi_npey)
write(*,*) 'checkObsMpiIP: tile lat south =',hco_anl % lat(latIndex) * MPC_DEGREES_PER_RADIAN_R8
endif
write(*,*) 'checkObsMpiIP: now checking...'
! for obs west of the correct longitude band
lonIndex = 1 + (mpi_myidx * hco_anl % ni / mpi_npex)
delta_lon=obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex) - hco_anl % lon(lonindex)
if(IP_x .lt. mpi_myidx) then
if(abs(delta_lon) .lt. epsilon_lon) then
! obs kept and will be moved to the western boundary
write(*,*) 'checkObsMpiIP: keeping obs, will be moved to western boundary, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lon=',obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: modified lon=',hco_anl % lon(lonindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: delta_lon =',delta_lon*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lon =',epsilon_lon*MPC_DEGREES_PER_RADIAN_R8
IP = mpi_myid
else
! obs will be rejected, alert the user
write(*,*) 'checkObsMpiIP: removing obs, too far west of the correct longitude band, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lon=',obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: boundary lon=',hco_anl % lon(lonIndex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: assigned PE and PE_x, my PE and PE_x =',IP,IP_x,mpi_myid,mpi_myidx
write(*,*) 'checkObsMpiIP: delta_lon =',delta_lon*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lon =',epsilon_lon*MPC_DEGREES_PER_RADIAN_R8
endif
endif
! for obs east of the correct longitude band
lonIndex = 1 + ((mpi_myidx+1) * hco_anl % ni / mpi_npex)
delta_lon=obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex) - hco_anl % lon(lonindex)
if(IP_x .gt. mpi_myidx) then
if(abs(delta_lon) .lt. epsilon_lon) then
! obs kept and will be moved to the eastern boundary
write(*,*) 'checkObsMpiIP: keeping obs, will be moved to eastern boundary, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lon=',obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: modified lon=',hco_anl % lon(lonindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: delta_lon =',delta_lon*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lon =',epsilon_lon*MPC_DEGREES_PER_RADIAN_R8
IP = mpi_myid
else
! obs will be rejected, alert the user
write(*,*) 'checkObsMpiIP: removing obs, too far west of the correct longitude band, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lon=',obs_headElem_r(lobsSpaceData,OBS_LON,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: boundary lon=',hco_anl % lon(lonIndex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: assigned PE and PE_x, my PE and PE_x =',IP,IP_x,mpi_myid,mpi_myidx
write(*,*) 'checkObsMpiIP: delta_lon =',delta_lon*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lon =',epsilon_lon*MPC_DEGREES_PER_RADIAN_R8
endif
endif
! for obs north of the correct latitude band
if ( mpi_myidy .gt. 0 ) then ! ignore north pole
latIndex = 1 + (mpi_myidy * hco_anl % nj / mpi_npey)
delta_lat=obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex) - hco_anl % lat(latindex)
if(IP_y .lt. mpi_myidy) then
if(abs(delta_lat) .lt. epsilon_lat) then
! obs kept and will be moved to the northern boundary
write(*,*) 'checkObsMpiIP: keeping obs, will be moved to northern boundary, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lat=',obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: modified lat=',hco_anl % lat(latindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: delta_lat =',delta_lat*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lat =',epsilon_lat*MPC_DEGREES_PER_RADIAN_R8
IP = mpi_myid
else
! obs will be rejected, alert the user
write(*,*) 'checkObsMpiIP: removing obs, too far north of the correct latitude band, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lat=',obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: boundary lat=',hco_anl % lat(latindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: assigned PE and PE_y, my PE and PE_y =',IP,IP_y,mpi_myid,mpi_myidy
write(*,*) 'checkObsMpiIP: delta_lat =',delta_lat*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lat =',epsilon_lat*MPC_DEGREES_PER_RADIAN_R8
endif
endif
endif
! for obs south of the correct latitude band
if ( mpi_myidy .lt. (mpi_npey-1) ) then ! ignore south pole
latindex = 1 + ((mpi_myidy+1)*hco_anl % nj / mpi_npey)
delta_lat=obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex) - hco_anl % lat(latindex)
if(IP_y .gt. mpi_myidy) then
if(abs(delta_lat) .lt. epsilon_lat) then
! obs kept and will be moved to the southern boundary
write(*,*) 'checkObsMpiIP: keeping obs, will be moved to southern boundary, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lat=',obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: modified lat=',hco_anl % lat(latindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: delta_lat =',delta_lat*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lat =',epsilon_lat*MPC_DEGREES_PER_RADIAN_R8
IP = mpi_myid
else
! obs will be rejected, alert the user
write(*,*) 'checkObsMpiIP: removing obs, too far south of the correct latitude band, headerIndex=',headerIndex
write(*,*) 'checkObsMpiIP: original lat=',obs_headElem_r(lobsSpaceData,OBS_LAT,headerIndex)*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: boundary lat=',hco_anl % lat(latindex) * MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: assigned PE and PE_y, my PE and PE_y =',IP,IP_y,mpi_myid,mpi_myidy
write(*,*) 'checkObsMpiIP: delta_lat =',delta_lat*MPC_DEGREES_PER_RADIAN_R8
write(*,*) 'checkObsMpiIP: epsilon_lat =',epsilon_lat*MPC_DEGREES_PER_RADIAN_R8
endif
endif
endif
endif
! now filter out obs still outside latitude band
if ( IP .ne. mpi_myid ) then
idata = obs_headElem_i(lobsSpaceData,OBS_RLN,headerIndex)
idatend = obs_headElem_i(lobsSpaceData,OBS_NLV,headerIndex) + idata -1
do jdata = idata, idatend
call obs_bodySet_i(lobsSpaceData,OBS_ASS,JDATA, 0)
enddo
call obs_headSet_i(lobsSpaceData,OBS_ST1,headerIndex, &
ibset( obs_headElem_i(lobsSpaceData,OBS_ST1,headerIndex), 05))
else
count_obs_in = count_obs_in+1
call obs_headSet_i(lobsSpaceData,OBS_ST1,headerIndex, &
ibclr( obs_headElem_i(lobsSpaceData,OBS_ST1,headerIndex),05))
endif
enddo ! headerIndex
write(*,*) 'routine checkObsMpiIP: number of observation headers in this lat-lon tile: ', count_obs_in
else
do headerIndex = 1, obs_numheader(lobsSpaceData)
call obs_headSet_i(lobsSpaceData,OBS_ST1,headerIndex, &
ibclr( obs_headElem_i(lobsSpaceData,OBS_ST1,headerIndex),05))
enddo
endif
end subroutine checkObsMpiIP