!-------------------------------------- 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 BILINAD 1,1
*
#if defined (DOC)
*
***s/r BILINAD - Adjoint of the horizontal interpolation:
* . Simple multiplication by the weights of
* . the horizontal bilinear interpolation.
* . (based on HOR4AD from the ARPEGE/IFS model)
*
*
*Author : J. Pailleux ECMWF 90-01-11
* . Luc Fillion RPN/AES Jan 1993
*
*Revision:
* . P. Gauthier *ARMA/AES May 20,1993: modifications to the CMA files
* . P. Gauthier *ARMA/AES May 25,1993: -Treatment of specific humidity
* . and surface pressure
* . P. Koclas *CMC/AES Sept 08,1994: removal of call to isrchila by
* access to "transormed latitudes" contained in observation
* headers.
* . S. Pellerin *ARMA/AES Sept 97.
* - Control of the different model state of the 3Dvar
* through COMSTATE, COMSTATEC and COMSTNUM common
* blocks variables (comstate.cdk).
* . J. Halle *CMDA/AES Oct 99.
* - Added ground temperature (TG) to the model state.
*
** Purpose: Update the estimate of GD0 from the gradient components
* at the observation points which have been stored in
* GOMU, GOMV, GOMT.
*
*
*
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.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"
*
INTEGER JLEV, JGL, JLON, JOBS, IOBTYP
INTEGER ILON, ILOS, ILA, IMIDDLE, ISYM, IMAX
REAL*8 DLMEAN, DLMEAS, DLLAO, DLLOO, DLDLON, DLDLOS
REAL*8 DLDXN, DLDXS, DLDY, DLW1, DLW2, DLW3, DLW4
C
C* 0. PUT TO ZERO EXTRA ROWS IN GRAD TABLES
C ----------------------------------------
C
CALL TRANSFER('ZGD0')
C
C* 2. LOOP OVER ALL THE OBSERVATIONS
C ---------------------------------
C
200 CONTINUE
C
DO 201 JOBS = 1, NOBTOT
DLLAO = ROBHDR(NCMLAT,JOBS)
DLLOO = ROBHDR(NCMLON,JOBS)
IOBTYP = MOBHDR(NCMOTP,JOBS)
C
C* 2.1. LOCATE FIRST LATITUDE ROW NUMBER (ILA) TO THE NORTH
C* OF ZLAO, AND THE TWO LONGITUDE POINT NUMBERS IMMEDIATELY
C TO THE WEST (ILON AND ILOS)
C
ILA=MOBHDR(NCMTLA,JOBS)
C
IF(DLLOO.LT.0.) DLLOO = DLLOO + 2.*RPI
IF(DLLOO.GE.2.*RPI) DLLOO = DLLOO - 2.*RPI
DLDLON = 2.*RPI/NILON(ILA)
DLDLOS = 2.*RPI/NILON(ILA+1)
ILON = INT(DLLOO/DLDLON) + 1
ILOS = INT(DLLOO/DLDLOS) + 1
C
C* 2.2 COMPUTE THE 4 WEIGHTS OF THE BILINEAR INTERPOLATION
C
DLDXN = DLLOO/DLDLON + 1. - ILON
DLDXS = DLLOO/DLDLOS + 1. - ILOS
DLDY = (RLATI(ILA)-DLLAO)/(RLATI(ILA)-RLATI(ILA+1))
DLW1 = (1.-DLDXN)*(1.-DLDY)
DLW2 = DLDXN*(1.-DLDY)
DLW3 = (1.-DLDXS)*DLDY
DLW4 = DLDXS*DLDY
C
C* 2.3 TREAT U, V, T
C
DO JLEV = 1, NFLEV
C
IF(ngexist(nguu).eq.1) THEN
UT0(ILON,JLEV,ILA) = UT0(ILON,JLEV,ILA)
+ + DLW1 * GOMU(JLEV,JOBS)
UT0(ILON+1,JLEV,ILA) = UT0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMU(JLEV,JOBS)
UT0(ILOS,JLEV,ILA+1) = UT0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMU(JLEV,JOBS)
UT0(ILOS+1,JLEV,ILA+1) = UT0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMU(JLEV,JOBS)
end if
C
IF(ngexist(ngvv).eq.1) THEN
VT0(ILON,JLEV,ILA) = VT0(ILON,JLEV,ILA)
+ + DLW1 * GOMV(JLEV,JOBS)
VT0(ILON+1,JLEV,ILA) = VT0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMV(JLEV,JOBS)
VT0(ILOS,JLEV,ILA+1) = VT0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMV(JLEV,JOBS)
VT0(ILOS+1,JLEV,ILA+1) = VT0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMV(JLEV,JOBS)
end if
C
IF(ngexist(ngtt).eq.1) THEN
TT0(ILON,JLEV,ILA) = TT0(ILON,JLEV,ILA)
+ + DLW1 * GOMT(JLEV,JOBS)
TT0(ILON+1,JLEV,ILA) = TT0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMT(JLEV,JOBS)
TT0(ILOS,JLEV,ILA+1) = TT0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMT(JLEV,JOBS)
TT0(ILOS+1,JLEV,ILA+1) = TT0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMT(JLEV,JOBS)
end if
C
IF(ngexist(ngq).eq.1) THEN
Q0(ILON,JLEV,ILA) = Q0(ILON,JLEV,ILA)
+ + DLW1 * GOMQ(JLEV,JOBS)
Q0(ILON+1,JLEV,ILA) = Q0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMQ(JLEV,JOBS)
Q0(ILOS,JLEV,ILA+1) = Q0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMQ(JLEV,JOBS)
Q0(ILOS+1,JLEV,ILA+1) = Q0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMQ(JLEV,JOBS)
end if
C
IF(ngexist(nggz).eq.1) THEN
GZ0(ILON,JLEV,ILA) = GZ0(ILON,JLEV,ILA)
+ + DLW1 * GOMGZ(JLEV,JOBS)
GZ0(ILON+1,JLEV,ILA) = GZ0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMGZ(JLEV,JOBS)
GZ0(ILOS,JLEV,ILA+1) = GZ0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMGZ(JLEV,JOBS)
GZ0(ILOS+1,JLEV,ILA+1) = GZ0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMGZ(JLEV,JOBS)
end if
C
IF(ngexist(ngoz).eq.1) THEN
GOZ0(ILON,JLEV,ILA) = GOZ0(ILON,JLEV,ILA)
+ + DLW1 * GOMOZ(JLEV,JOBS)
GOZ0(ILON+1,JLEV,ILA) = GOZ0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMOZ(JLEV,JOBS)
GOZ0(ILOS,JLEV,ILA+1) = GOZ0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMOZ(JLEV,JOBS)
GOZ0(ILOS+1,JLEV,ILA+1) = GOZ0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMOZ(JLEV,JOBS)
end if
C
IF(ngexist(ngtr).eq.1) THEN
GTR0(ILON,JLEV,ILA) = GTR0(ILON,JLEV,ILA)
+ + DLW1 * GOMTR(JLEV,JOBS)
GTR0(ILON+1,JLEV,ILA) = GTR0(ILON+1,JLEV,ILA)
+ + DLW2 * GOMTR(JLEV,JOBS)
GTR0(ILOS,JLEV,ILA+1) = GTR0(ILOS,JLEV,ILA+1)
+ + DLW3 * GOMTR(JLEV,JOBS)
GTR0(ILOS+1,JLEV,ILA+1) = GTR0(ILOS+1,JLEV,ILA+1)
+ + DLW4 * GOMTR(JLEV,JOBS)
end if
C
end do
C
IF(ngexist(ngps).eq.1) THEN
GPS0(ILON,1,ILA) = GPS0(ILON,1,ILA)
+ + DLW1 * GOMPS(1,JOBS)
GPS0(ILON+1,1,ILA) = GPS0(ILON+1,1,ILA)
+ + DLW2 * GOMPS(1,JOBS)
GPS0(ILOS,1,ILA+1) = GPS0(ILOS,1,ILA+1)
+ + DLW3 * GOMPS(1,JOBS)
GPS0(ILOS+1,1,ILA+1) = GPS0(ILOS+1,1,ILA+1)
+ + DLW4 * GOMPS(1,JOBS)
END IF
C
IF(ngexist(ngtg).eq.1) THEN
GTG0(ILON,1,ILA) = GTG0(ILON,1,ILA)
+ + DLW1 * GOMTGR(1,JOBS)
GTG0(ILON+1,1,ILA) = GTG0(ILON+1,1,ILA)
+ + DLW2 * GOMTGR(1,JOBS)
GTG0(ILOS,1,ILA+1) = GTG0(ILOS,1,ILA+1)
+ + DLW3 * GOMTGR(1,JOBS)
GTG0(ILOS+1,1,ILA+1) = GTG0(ILOS+1,1,ILA+1)
+ + DLW4 * GOMTGR(1,JOBS)
END IF
C
201 CONTINUE
C
C
C* 1. REARRANGE GRID-POINTS ARRAYS GD0, BY CARRYING GRADIENTS
C CONTRIBUTIONS OF MERIDIAN 0, NILON(JGL)+1 AND NILON(JGL+2)
C INTO MERIDIANS NILON(JGL), 1, AND 2. SIMILAR TREATMENT NEAR POLES
C
C
C 1.2 EXTRA PARALLELS
C
DO 140 JLEV = 1, NKGDIM
C
C TREATMENT OF GRADIENTS FOR PARALLELS -1 AND NJ + 2 (WITH SYMETRIZATION)
C
IMIDDLE = NILON(1) / 2
DO 137 JLON = 0, IMIDDLE
ISYM = JLON + IMIDDLE
GD(ISYM,JLEV,1) = GD(JLON,JLEV,-1)
+ + GD(ISYM,JLEV,1)
GD(ISYM,JLEV,NJ) = GD(JLON,JLEV,NJ+2)
+ + GD(ISYM,JLEV,NJ)
137 CONTINUE
IMAX = NILON(1)
DO 138 JLON = IMIDDLE + 1, IMAX + 2
ISYM = JLON - IMIDDLE
GD(ISYM,JLEV,1) = GD(JLON,JLEV,-1)
+ + GD(ISYM,JLEV,1)
GD(ISYM,JLEV,NJ) = GD(JLON,JLEV,NJ+2)
+ + GD(ISYM,JLEV,NJ)
138 CONTINUE
C
C TREATMENT OF THE GRADIENTS AT NORTH AND SOUTH POLES.
C
DLMEAN = 0.
DLMEAS = 0.
IMAX = NILON(0)
DO 136 JLON = 0, IMAX + 2
DLMEAN = DLMEAN + GD(JLON,JLEV,0)
DLMEAS = DLMEAS + GD(JLON,JLEV,NJ+1)
136 CONTINUE
DLMEAN = DLMEAN/NILON(1)
DLMEAS = DLMEAS/NILON(NJ)
IMAX = NILON(1)
DO 135 JLON = 1, IMAX
GD(JLON,JLEV,1) = DLMEAN + GD(JLON,JLEV,1)
GD(JLON,JLEV,NJ) = DLMEAS + GD(JLON,JLEV,NJ)
135 CONTINUE
C
140 CONTINUE
C
C 1.1 EXTRA MERIDIANS
C
DO 110 JLEV = 1, NKGDIM
DO 111 JGL = 1, NJ
IMAX = NILON(JGL)
GD(IMAX,JLEV,JGL) = GD(0,JLEV,JGL)
+ + GD(IMAX,JLEV,JGL)
GD(1,JLEV,JGL) = GD(IMAX+1,JLEV,JGL)
+ + GD(1,JLEV,JGL)
GD(2,JLEV,JGL) = GD(IMAX+2,JLEV,JGL)
+ + GD(2,JLEV,JGL)
111 CONTINUE
110 CONTINUE
C
C 1.0 TRANSFORM PHYSICAL GRADIENTS INTO COVARIANTS
C
DO 105 JLEV = 1, NFLEV
DO 106 JGL = 1, NJ
IMAX = NILON(JGL)
DO 107 JLON = 1, IMAX
UT0(JLON,JLEV,JGL) = UT0(JLON,JLEV,JGL) * CONPHY(JGL)
VT0(JLON,JLEV,JGL) = VT0(JLON,JLEV,JGL) * CONPHY(JGL)
107 CONTINUE
106 CONTINUE
105 CONTINUE
C
DO 108 JLEV = 1, NKGDIM
DO 109 JGL = 1, NJ
IMAX = NILON(JGL)
DO 1091 JLON = 1, IMAX
GD(JLON,JLEV,JGL) = GD(JLON,JLEV,JGL) *
+ NILON(JGL) / RWT(JGL)
1091 CONTINUE
109 CONTINUE
108 CONTINUE
C
RETURN
END