!-------------------------------------- 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 gd2mvogenad (cdvarname, klev) 11,11
*
#if defined (DOC)
*
***s/r gd2mvogenad - Adjoint of gd2mvogen.
*
*Author : Luc. Fillion MSC- Oct 03
*
*Revision:
* Luc. Fillion ARMA/EC - 8 Oct 2009 - Change name gd2mvoad_la to gd2mvogenad since it can be used for global grid too.
! N.B.: A general LAM or Global (rotated or not, staggered or not)
! grid can be used here. Use lstagwinds effectively here.
! Bin He ARMA/MRB - Feb. 2012. MPI version .
* R. McTaggart-Cowan RPN Mar 2012
* - Use assumed-length declarations for string dummy args
!
*
** Purpose: Update the estimate of GD from the gradient components
* at the observation points which have been stored in
* GOMOBS
*
* Arguments
* CDVARNAME: identificator of the variable to be treated
* KLEV : number of levels (typically 1 for 2D-fields and NFLEV for 3D-fields)
*
*
*
#endif
USE obstag
use modstag, only: lstagwinds
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comleg.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comcst.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "comstate.cdk"
#include "namstag.cdk"
#include "comgrd_param.cdk"
*
* Arguments
*
character(len=*) :: cdvarname
integer klev
*
* Local Variables
*
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
INTEGER JLEV, ji, jj, JOBS, IOBTYP, jgl, jlon
INTEGER ILON, ILOS, ILA, IMIDDLE, ISYM, IMAX
integer ix,iy
REAL*8 DLMEAN, DLMEAS, DLLAO, DLLOO, DLDLON, DLDLOS
real zx_4,zy_4,zone
real*8 zx,zy
REAL*8 DLW1, DLW2, DLW3, DLW4
real*8 z2d(klev,nobtot)
*
real*8 zfield(nibeg:niend,1:klev,njbeg:njend)
*
integer :: ierr
real*8 ,allocatable,dimension(:,:) ,target :: GOMARR
real*8 ,pointer,dimension(:,:) :: zprofil
!
!!
*
* Transfer Grid point field into local array (for generecity)
*
zfield(:,:,:) = 0.D0
ALLOCATE(GOMARR(klev,nobtotp),STAT=ierr)
*
*
SELECT CASE (CDVARNAME)
*
* 2D fields
*
CASE('TG')
CALL GetGomarr(GOMARR,GOMTGR)
CASE('PS')
CALL GetGomarr(GOMARR,GOMPS)
*
* 3D fields
*
CASE('TT')
CALL GetGomarr(GOMARR,GOMT)
CASE('Q0')
CALL GetGomarr(GOMARR,GOMQ)
CASE('O3')
CALL GetGomarr(GOMARR,GOMOZ)
CASE('TR')
CALL GetGomarr(GOMARR,GOMTR)
CASE('UU')
CALL GetGomarr(GOMARR,GOMU)
CASE('VV')
CALL GetGomarr(GOMARR,GOMV)
CASE('GZ')
CALL GetGomarr(GOMARR,GOMGZ)
END SELECT
C
!** Set Array Alian
ZPROFIL => GOMARR(1:KLEV,1:NOBTOTP)
C* 2. LOOP OVER ALL THE OBSERVATIONS
C ---------------------------------
C
Observations: DO JOBS = 1, NOBTOTP
!
zx_4 = ROBHDR_G(NCMTLO,JOBS)
zy_4 = ROBHDR_G(NCMTLA,JOBS)
! if(JOBS.eq.1) then
! write(nulout,*) 'gd2mvogenad: robhdr(ncmtla,1)=',robhdr(ncmtla,1)
! write(nulout,*) 'gd2mvogenad: robhdr(ncmtlo,1)=',robhdr(ncmtlo,1)
! endif
!
if(lstagwinds) then ! actif seulement en Bi-Fourier pour l'instant et non mode REG-LAM....
if(cdvarname.eq.'UU') zx_4 = zx_4 - 0.5
if(cdvarname.eq.'VV') zy_4 = zy_4 - 0.5
endif
!
ix = int(zx_4)
iy = int(zy_4)
zone=1.0
zx = mod(zx_4,zone)
zy = mod(zy_4,zone)
!
dlw1 = (1.-zx)*(1.-zy)
dlw2 = zx*(1.-zy)
dlw3 = (1.-zx)*zy
dlw4 = zx*zy
!
do jlev = 1, klev
ZFIELD(ix,jlev,iy) = ZFIELD(ix,jlev,iy)
+ + DLW1 * ZPROFIL(jlev,JOBS)
ZFIELD(ix+1,jlev,iy) = ZFIELD(ix+1,jlev,iy)
+ + DLW2 * ZPROFIL(jlev,JOBS)
ZFIELD(ix,jlev,iy+1) = ZFIELD(ix,jlev,iy+1)
+ + DLW3 * ZPROFIL(jlev,JOBS)
ZFIELD(ix+1,jlev,iy+1) = ZFIELD(ix+1,jlev,iy+1)
+ + DLW4 * ZPROFIL(jlev,JOBS)
C
end do
*
end do OBSERVATIONS
DEALLOCATE(GOMARR,STAT=ierr)
*
* Adjoint of the identity (change of norm)
*
if(grd_typ.eq.'GU') then
DO JGL = 1, NJ
IMAX = NILON(JGL)
DO JLEV = 1, KLEV
DO JLON = 1, IMAX
ZFIELD(JLON,JLEV,JGL) = ZFIELD(JLON,JLEV,JGL) *
+ NILON(JGL) / RWT(JGL)
END DO
END DO
END DO
else if(grd_typ.eq.'LU') then
do jj=1,nj
do jlev = 1, klev
do ji=1,ni
ZFIELD(ji,JLEV,jj) = ZFIELD(ji,JLEV,jj)
END DO
END DO
END DO
endif
C
C Transfer local results to global array
C
select case (cdvarname)
*
* 2D fields
*
case('TG')
gtg0(:,1:klev,:) = zfield(:,1:klev,:)
case('PS')
gps0(:,1:klev,:) = zfield(:,1:klev,:)
*
* 3D fields
*
case('TT')
tt0(:,1:klev,:) = zfield(:,1:klev,:)
case('Q0')
q0 (:,1:klev,:) = zfield(:,1:klev,:)
case('O3')
GOZ0(:,1:klev,:) = zfield(:,1:klev,:)
case('TR')
GTR0(:,1:klev,:) = zfield(:,1:klev,:)
case('UU')
UT0(:,1:klev,:) = zfield(:,1:klev,:)
case('VV')
VT0(:,1:klev,:) = zfield(:,1:klev,:)
case ('GZ')
GZ0(:,1:klev,:) = zfield(:,1:klev,:)
end select
CONTAINS
SUBROUTINE GetGOMARR(Arr_g,Arr_l) 27
REAL*8,DIMENSION(klev,nobtotp) :: arr_g
REAL*8,DIMENSION(nkgdimo,nobtot) :: arr_l
!ping
REAL*8,DIMENSION(nkgdimo,nobtot) :: arr_t
INTEGER :: i,j,iobs ,ierr
INTEGER :: ArrSize
arr_g(1:klev,1:nobtotp)=0.0D0
DO i=1,NOBTOT
iobs=locObsTag(i)
DO j=1,klev
ARR_g(j,iobs)=arr_l(j,i)
ENDDO
ENDDO
ArrSize=klev*nobtotp
CALL rpn_comm_allreduce(arr_g,arr_t,ArrSize,
& "MPI_DOUBLE_PRECISION","MPI_SUM","GRID",ierr)
arr_g = arr_t
END SUBROUTINE GetGOMARR
!
END SUBROUTINE GD2MVOGENAD