!-------------------------------------- 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_LT(statevector,column,columng,lobsSpaceData) 1,30
use MathPhysConstants_mod
use mpivar_mod
use gridStateVector_mod
use obsSpaceData_mod
use columnData_mod
use timeCoord_mod
implicit none
!
! Purpose: Adjoint of Localisation (3D)
! Compute adjoint grided increments from adjoint profiled increments
!
type(struct_columnData) :: column,columng
type(struct_obs) :: lobsSpaceData
type(struct_gsv) :: statevector
integer :: ilev1, ilev2, deltalev, ierr, myLonEndP1, myLatEndP1, status, Vcode_anl
integer :: mythread, numthread, omp_get_num_threads, omp_get_thread_num
type(struct_vco), pointer :: vco_anl
myLonEndP1 = statevector%myLonEnd + 1
myLatEndP1 = min(statevector%myLatEnd + 1, statevector%nj)
!
!- 2. Variable conversions
!
!- 2.2 Rotated wind to Meteorological wind
if ( gsv_varExist('UU') .and. gsv_varExist('VV') .and. statevector%hco%Rotated ) then
write(*,*) 'uvrot2uvAdj Active'
call uvrot2uvAdj('UU', 'VV', col_getNumLev(column,'MM')) ! IN
end if
!- 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(37,'INTERP_ATT2PHI')
if(Vcode_anl .eq. 5001) then
call att2phi(column,columng)
else
call att2phi_gem4(column,columng)
endif
call tmg_stop(37)
!
!- 1. Interpolation to obs location
!
if ( mpi_myid == 0 ) THEN
write(*,*) ' ODA_LT - Adjoint of horizontal interpolation GD --> MVO'
endif
!- 1.2 3D fields interpolation
!$OMP PARALLEL PRIVATE(ilev1,ilev2,deltalev,mythread,numthread)
mythread=omp_get_thread_num()+1
numthread=omp_get_num_threads()
deltalev=ceiling(real(col_getNumLev(column,'MM'))/real(numthread))
ilev1=1+(mythread-1)*deltalev
ilev2=min(col_getNumLev(column,'MM'),mythread*deltalev)
if(gsv_varExist('UU')) call gd2mvoad('UU',ilev1,ilev2)
if(gsv_varExist('VV')) call gd2mvoad('VV',ilev1,ilev2)
deltalev=ceiling(real(col_getNumLev(column,'TH'))/real(numthread))
ilev1=1+(mythread-1)*deltalev
ilev2=min(col_getNumLev(column,'TH'),mythread*deltalev)
if(gsv_varExist('HU')) call gd2mvoad('HU',ilev1,ilev2)
if(gsv_varExist('TT')) call gd2mvoad('TT',ilev1,ilev2)
!$OMP END PARALLEL
!- 1.3 2D fields interpolation
ilev1=1
ilev2=1
if(gsv_varExist('P0')) call gd2mvoad('P0',ilev1,ilev2)
if(gsv_varExist('TG')) call gd2mvoad('TG',ilev1,ilev2)
!- 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_commLatLonAd(statevector)
call tmg_stop(39)
CONTAINS
!--------------------------------------------------------------------------
! GD2MVOAD
!--------------------------------------------------------------------------
SUBROUTINE GD2MVOAD (varName,klev1,klev2) 6,8
!*
!***s/r GD2MVOAD - Adjoint of the horizontal interpolation of the model variables
!* in grid-point space to observation locations.
!* Simple multiplication by the weights of
!* the horizontal bilinear interpolation.
!* (adapted from BILINAD)
!*
!** Purpose: Update the estimate of GD from the gradient components
!* at the observation points which have been stored in
!* column
!*
!* Arguments
!* VARNAME: identificator of the variable to be treated
!* KLEV : number of levels
implicit none
character(len=*), intent(in) :: varName
integer, intent(in) :: klev1,klev2
INTEGER JLEV, JLAT, JLON, headerIndex, JSTEP, JK
INTEGER ILON, ILAT, ILO
REAL*8 DLDX, DLDY, DLW1, DLW2, DLW3, DLW4, DInterpWeight
real(8) :: xpos, ypos, lat, lon, latrot, lonrot
real*8, pointer :: field_ptr(:,:,:,:)
real*8, pointer :: column_ptr(:,:)
if (col_getNumCol(column) > 0) column_ptr => col_getAllColumns(column,varName)
field_ptr => gsv_getField(statevector,varName)
! 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 previously
do jstep = 1, statevector%numStep
field_ptr(:,klev1:klev2,:,jstep) = 0.0D0
!
!- 2. 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_LT: Obs outside local domain for job = ', headerIndex
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)
DInterpWeight = tim_getTimeInterpWeight(headerIndex,jstep)
DLW1 = DInterpWeight * (1.d0-DLDX) * (1.d0-DLDY)
DLW2 = DInterpWeight * DLDX * (1.d0-DLDY)
DLW3 = DInterpWeight * (1.d0-DLDX) * DLDY
DLW4 = DInterpWeight * DLDX * DLDY
!- 2.4 Interpolate the model state to the obs point
do jlev = klev1, klev2
field_ptr(ILON ,jlev,ILAT, jstep) = field_ptr(ILON ,jlev,ILAT, jstep) &
+ DLW1 * column_ptr(jlev,headerIndex)
field_ptr(ILON+1,jlev,ILAT, jstep) = field_ptr(ILON+1,jlev,ILAT, jstep) &
+ DLW2 * column_ptr(jlev,headerIndex)
field_ptr(ILON ,jlev,ILAT+1,jstep) = field_ptr(ILON ,jlev,ILAT+1,jstep) &
+ DLW3 * column_ptr(jlev,headerIndex)
field_ptr(ILON+1,jlev,ILAT+1,jstep) = field_ptr(ILON+1,jlev,ILAT+1,jstep) &
+ DLW4 * column_ptr(jlev,headerIndex)
end do
end if
end do ! Obs
end do ! jstep
END SUBROUTINE GD2MVOAD
!--------------------------------------------------------------------------
! UVROT2UVADJ
!--------------------------------------------------------------------------
subroutine uvrot2uvAdj(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_RotateWindAdj( UUColumn, VVColumn, & ! INOUT
Lat, Lon, LatRot, LonRot, & ! IN
'ToMetWind', klev ) ! IN
end do
end subroutine uvrot2uvAdj
end subroutine oda_LT