!-------------------------------------- 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 CAINAD(KDIM,PX) 6,3
#if defined (DOC)
*
***s/r CAIN Adjoint of the canonical injection):
* . transfer of the model state from COMSP into
* . the control variable
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
* . (based on a subroutine by P.Courtier and M. Hamrud
* . from the ARPEGE/IFS model)
*Revision:
* M. Buehner *ARMA/MSC August 2002
* . Added control variables for SV extension to B
* M. Buehner *ARMA May 2008
* . Added control variables when using background
* error correlations specified over multiple latitude
* bands (NANALVAR=4)
* L. Fillion *ARMA/MSC - sept 2003 - Introduce Limited area LAM4D analysis.
* L. Fillion *ARMA/EC - 6 Nov 2009 - Upgrade to v_10_1_2 3dvar.
* L. Fillion *ARMA/EC 9 Mar 2009
* . Introduce nanalvar=4 option in lam4d (somewhat different than global case...).
*
* -------------------
** Purpose: identity transformation used to insure a communication
* . link between the model state and the minimization algo-
* . rithm. An adjustment is made according to the norm used.
* . (See SUSCAL where the norm is defined)
*
*Arguments
* i : KDIM = dimension of the control variable
* i : PX = control variable
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comsp.cdk"
#include "comsv.cdk"
#include "comgrd_param.cdk"
*
INTEGER KDIM, JDIM, JLEV, JLA, JLATBIN
REAL*8 PX(KDIM)
EXTERNAL ABORT3D
C
C* 1. Transfer of the model spectral state
C
IF(NSVMODE.eq.0) THEN
C
100 CONTINUE
JDIM = 0
!
if(grd_typ.eq.'GU') then
if(nanalvar.eq.4) then
DO JLATBIN=1,NLATBIN
DO JLEV = 1, NKSDIM
DO JLA = 1, NTRUNC+1
JDIM = JDIM+1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SPLAT(JLA,1,JLEV,JLATBIN))*SCALPM1(JDIM)
ENDDO
DO JLA = NTRUNC + 2, NLA
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SPLAT(JLA,1,JLEV,JLATBIN))*SCALPM1(JDIM)
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SPLAT(JLA,2,JLEV,JLATBIN))*SCALPM1(JDIM)
ENDDO
ENDDO
ENDDO
else
DO 101 JLEV = 1, NKSDIM
DO 102 JLA = 1, NTRUNC+1
JDIM = JDIM+1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,1,JLEV))*SCALPM1(JDIM)
102 CONTINUE
DO 103 JLA = NTRUNC + 2, NLA
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,1,JLEV))*SCALPM1(JDIM)
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,2,JLEV))*SCALPM1(JDIM)
103 CONTINUE
101 CONTINUE
endif
else if (grd_typ.eq.'LU') then
if(nanalvar.eq.4) then
do jlev = 1,nksdim
do jla = 1,nla
jdim = jdim + 1
px(jdim) = px(jdim) + splat(jla,1,jlev,1)
jdim = jdim + 1
px(jdim) = px(jdim) + splat(jla,2,jlev,1)
enddo
enddo
else
do jlev = 1,nksdim
do jla = 1,nla
jdim = jdim + 1
px(jdim) = px(jdim) + sp(jla,1,jlev)
jdim = jdim + 1
px(jdim) = px(jdim) + sp(jla,2,jlev)
enddo
enddo
endif
endif
C
C 2. Verify the dimension of the control variable
C
IF(JDIM.NE.KDIM) THEN
WRITE(NULOUT,FMT='(//,10X,''Error in CAINAD. Wrong dimension'',
S '' for the control variable. KDIM = '',I8,4X,''JDIM ='',
S I8)')KDIM, JDIM
CALL ABORT3D(NULOUT,'ERROR IN CAINAD ')
END IF
C
ELSEIF(NSVMODE.eq.1) THEN
c
JDIM = 0
C
DO JLA = 1, NSV
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SVCONTR(JLA))
ENDDO
C
C 2. Verify the dimension of the control variable
C
IF(JDIM.NE.KDIM) THEN
WRITE(NULOUT,FMT='(//,10X,''Error in CAIN. Wrong dimension'',
S '' for the control variable. KDIM = '',I8,4X,''JDIM ='',
S I8)')KDIM, JDIM
CALL ABORT3D(NULOUT,'ERROR IN CAINAD ')
END IF
c
ELSEIF(NSVMODE.eq.2) THEN
c
JDIM = 0
DO JLEV = 1, NKSDIM
DO JLA = 1, NTRUNC+1
JDIM = JDIM+1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,1,JLEV))*SCALPM1(JDIM)
ENDDO
DO JLA = NTRUNC + 2, NLA
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,1,JLEV))*SCALPM1(JDIM)
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SP(JLA,2,JLEV))*SCALPM1(JDIM)
ENDDO
ENDDO
C
DO JLA = 1, NSV
JDIM = JDIM + 1
PX(JDIM) = DBLE(PX(JDIM)) + DBLE(SVCONTR(JLA))
ENDDO
C
C 2. Verify the dimension of the control variable
C
IF(JDIM.NE.KDIM) THEN
WRITE(NULOUT,FMT='(//,10X,''Error in CAINAD. Wrong dimension'',
S '' for the control variable. KDIM = '',I8,4X,''JDIM ='',
S I8)')KDIM, JDIM
CALL ABORT3D(NULOUT,'ERROR IN CAINAD ')
END IF
c
ENDIF
RETURN
END