!-------------------------------------- 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 oda_L(statevector,column,columng,lobsSpaceData) 3,30
use MathPhysConstants_mod
use mpivar_mod
use gridstatevector_mod
use obsSpaceData_mod
use columnData_mod
use timeCoord_mod
implicit none
!
! Purpose: Localisation (3D) operator
! Compute profiled increments from grided increments
!
type(struct_columnData) :: column, columng
type(struct_obs) :: lobsSpaceData
type(struct_gsv) :: statevector
integer :: nl_ilev, ierr, myLonEndP1, myLatEndP1, status, Vcode_anl
type(struct_vco), pointer :: vco_anl
myLonEndP1 = statevector%myLonEnd + 1
myLatEndP1 = min(statevector%myLatEnd + 1, statevector%nj)
!
!- 1. Interpolation to obs location
!
if ( mpi_myid == 0 ) THEN
write(*,*) ' ODA_L - Horizontal interpolation GD --> MVO'
end if
!- 1.1 Communicate extra latitude needed for interpolation
call tmg_start(38,'INTERP_BARR')
call rpn_comm_barrier("GRID",ierr)
call tmg_stop(38)
call tmg_start(39,'INTERP_COMM')
if (mpi_nprocs /= 1) call gsv_commLatLon(statevector)
call tmg_stop(39)
!$OMP PARALLEL
!$OMP SECTIONS PRIVATE(nl_ilev)
!- 1.2 3D fields interpolation
!$OMP SECTION
if (gsv_varExist('UU') ) call gd2mvo('UU',col_getNumLev(column,'MM'))
!$OMP SECTION
if (gsv_varExist('VV') ) call gd2mvo('VV',col_getNumLev(column,'MM'))
!$OMP SECTION
if (gsv_varExist('HU') ) call gd2mvo('HU',col_getNumLev(column,'TH'))
!$OMP SECTION
if (gsv_varExist('TT') ) call gd2mvo('TT',col_getNumLev(column,'TH'))
!- 1.3 2D fields interpolation
!$OMP SECTION
nl_ilev = 1
if (gsv_varExist('P0') ) call gd2mvo('P0',nl_ilev)
if (gsv_varExist('TG') ) call gd2mvo('TG',nl_ilev)
!$OMP END SECTIONS
!$OMP END PARALLEL
!
!- 2. Variable conversions
!
!- 2.1 Mass fields (TT,PS,HU) to hydrostatic geopotential
vco_anl => col_getVco(columng)
status = vgd_get(vco_anl%vgrid,key='ig_1 - vertical coord code',value=Vcode_anl)
call tmg_start(36,'INTERP_LTT2PHI')
if(Vcode_anl .eq. 5001) then
call ltt2phi(column,columng)
else
call ltt2phi_gem4(column,columng)
endif
call tmg_stop(36)
!- 2.2 Rotated wind to Meteorological wind
if ( gsv_varExist('UU') .and. gsv_varExist('VV') .and. statevector%hco%Rotated ) then
write(*,*) 'uvrot2uv Active'
call uvrot2uv('UU', 'VV', col_getNumLev(column,'MM')) ! IN
end if
CONTAINS
!--------------------------------------------------------------------------
! GD2MVO
!--------------------------------------------------------------------------
SUBROUTINE GD2MVO(varName,klev) 6,8
!*
!***s/r GD2MVO - Horizontal interpolation of the model variables
!* in grid-point space to observation locations.
!* Bilinear interpolation from the 4 nearest grid points.
!* (adapted from BILIN)
!
!*
!* VARNAME: identificator of the variable to be treated
!* KLEV : number of levels (typically 1 for 2D-fields and COL_GETNUMLEV(COLUMN) for 3D-fields)
!*
implicit none
character(len=*), intent(in) :: varName
integer, intent(in) :: klev
INTEGER :: JLEV, JLAT, JLON, headerIndex, JSTEP
INTEGER :: ILON, ILAT, ILO
REAL(8) :: DLMEAN, DLMEAS, DLDLON
REAL(8) :: DLDX, DLDY, DLDX_new, DLDY_new,DLW1, DLW2, DLW3, DLW4
real(8) :: xpos, ypos, lat, lon, latrot, lonrot
real(8), pointer :: column_ptr(:,:)
real(8), pointer :: field_ptr(:,:,:,:)
field_ptr => gsv_getField(statevector,varName)
if (col_getNumCol(column) > 0) then
column_ptr => col_getAllColumns(column,varName)
column_ptr(:,:) = 0.0d0
end if
! Note: We assume here the all the obs between the poles and the last grid points
! (i.e. outside the grid) have been moved within the grid by sugomobs
do jstep = 1, statevector%numStep
!
!- LOOP OVER ALL THE OBSERVATIONS
!
DO headerIndex = 1, col_getNumCol(column)
if ( tim_getTimeInterpWeight(headerIndex,jstep) > 0.0d0 .and. &
.not. btest(obs_headElem_i(lobsSpaceData,OBS_ST1,headerIndex),5) ) then
!- 2.1 Find the obs position within the analysis grid
call col_getLatLon( column, headerIndex, & ! IN
Lat, Lon, ypos, xpos, LatRot, LonRot ) ! OUT
!- Make sure we are within bounds
if ( ypos < real(statevector%myLatBeg,8) .or. &
ypos > real(myLatEndP1 ,8) .or. &
xpos < real(statevector%myLonBeg,8) .or. &
xpos > real(myLonEndP1 ,8) ) then
write(*,*) 'oda_L: Obs outside local domain for headerIndex = ', headerIndex
write(*,*) ' obs lat, lon position = ', Lat*MPC_DEGREES_PER_RADIAN_R8, Lon*MPC_DEGREES_PER_RADIAN_R8
write(*,*) ' obs x, y position = ', xpos, ypos
write(*,*) ' domain x_start, x_end, y_start, y_end bounds = ', &
statevector%myLonBeg, myLonEndP1, statevector%myLatBeg, myLatEndP1
! if obs above or below latitude band, move it to the edge of this latitude band
if( ypos < real(statevector%myLatBeg,8) ) ypos = real(statevector%myLatBeg,8)
if( ypos > real(myLatEndP1 ,8) ) ypos = real(myLatEndP1 ,8)
! abort if obs is to the left or right of the analysis domain
if( xpos < real(statevector%myLonBeg,8) ) xpos = real(statevector%myLonBeg,8)
if( xpos > real(myLonEndP1 ,8) ) xpos = real(myLonEndP1 ,8)
end if
!- 2.2 Find the lower-left grid point next to the observation
if ( xpos /= real(myLonEndP1,8) ) then
ILON = floor(xpos)
else
ILON = floor(xpos) - 1
end if
if ( ypos /= real(myLatEndP1,8) ) then
ILAT = floor(ypos)
else
ILAT = floor(ypos) - 1
end if
!- 2.3 Compute the 4 weights of the bilinear interpolation
DLDX = xpos - real(ILON,8)
DLDY = ypos - real(ILAT,8)
DLW1 = (1.d0-DLDX) * (1.d0-DLDY)
DLW2 = DLDX * (1.d0-DLDY)
DLW3 = (1.d0-DLDX) * DLDY
DLW4 = DLDX * DLDY
!- 2.4 Interpolate the model state to the obs point
DO JLEV = 1, KLEV
column_ptr(JLEV,headerIndex) = column_ptr(JLEV,headerIndex) + &
tim_getTimeInterpWeight(headerIndex,jstep) * &
( DLW1 * field_ptr(ILON ,JLEV,ILAT ,JSTEP) &
+ DLW2 * field_ptr(ILON+1,JLEV,ILAT ,JSTEP) &
+ DLW3 * field_ptr(ILON ,JLEV,ILAT+1,JSTEP) &
+ DLW4 * field_ptr(ILON+1,JLEV,ILAT+1,JSTEP) )
END DO
end if
END DO ! Obs
END DO ! JSTEP
END subroutine gd2mvo
!--------------------------------------------------------------------------
! UVROT2UV
!--------------------------------------------------------------------------
subroutine uvrot2uv (UUvarName,VVvarName,klev) 1,6
!
!- uvrot2uv - Transforms tangential (U,V) wind components at observation
! locations on GEM rotated frame to the real sphere.
use WindRotation_mod
implicit none
character(len=*), intent(in) :: UUvarName
character(len=*), intent(in) :: VVvarName
integer, intent(in) :: klev
real(8) :: lat, lon, latrot, lonrot, xpos, ypos
real(8), pointer :: UUcolumn(:), VVcolumn(:)
integer :: headerIndex
!
!- 1. Loop over all the observation locations
!
do headerIndex = 1, col_getNumCol(column)
!- 1.1 Extract (rotated) wind profiles
UUColumn => col_getColumn(column,headerIndex,UUvarName)
VVColumn => col_getColumn(column,headerIndex,VVvarName)
!- 1.2 Find the latitudes and longitudes
call col_getLatLon( column, headerIndex, & ! IN
Lat, Lon, ypos, xpos, LatRot, LonRot ) ! OUT
!- 1.3 Rotate Winds
call uvr_RotateWind( UUColumn, VVColumn, & ! INOUT
Lat, Lon, LatRot, LonRot, & ! IN
'ToMetWind', klev ) ! IN
end do
end subroutine uvrot2uv
end subroutine oda_L