SUBROUTINE SUSCAL(CDCTL) 3
#if defined (DOC)
*
***s/r SUSCAL : Initialisation of the inner product and different parameters
* . associated with the minimization algorithm
*
*Author : P. Gauthier *ARMA/AES January 27, 1993
*Revision:
* 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).
* P. Koclas *CMC/AES Nov 97.
* -compute scalpm1 vector
* J. Halle *CMDA/AES Oct 99.
* -Added ground temperature (TG) to the model state.
* Y. Yang Sep. 2003
* - Removed SPOZ(JLA,*)
* - Treatment for multiple species
*
* -------------------
** Purpose: to define the norm to be used for the minimization
*
*Arguments
* CDCTL : 'I' --> identity is used
* . 'S' --> rescaled version of the identity
* . 'P' --> inner product with the diagonal of the
* . forecast error correlation matrix
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comchem.cdk"
#include "comsp.cdk"
#include "comspg.cdk"
#include "comstate.cdk"
#include "comsv.cdk"
*
INTEGER JK, JLA, JLEV, JDIM, KK, JLATBIN
CHARACTER*1 CDCTL
REAL*8 ZVORSCALE, ZDIVSCALE, ZGZSCALE, ZQSCALE, ZPSSCALE
REAL*8 ZTRSCALE, ZTGSCALE
C
EXTERNAL CAININ
C
IF(CDCTL.EQ.'0') THEN
WRITE(NULOUT,9001)CDCTL
RETURN
END IF
WRITE(NULOUT,FMT=9000)
9000 FORMAT(//,1X,"-SUSCAL: defining the canonical inner product")
9001 FORMAT(//,1X,"-SUSCAL: inner product NOT DEFINED. CDCTL = "
S ,A1)
C
C* 0. Set COMSP to zero
C
CALL TRANSFER('ZSP0')
C
IF(CDCTL.EQ.'I') THEN
C
C* 1. Initialize the inner product to the identity
C
100 CONTINUE
WRITE(NULOUT,FMT='(6X,"- as the identity -")')
IF(NANALVAR.EQ.4) THEN
DO JLATBIN=1,NLATBIN
DO JK = 1, NKSDIM
DO JLA = 1, NLA
SPLAT(JLA,1,JK,JLATBIN) = 1.0
SPLAT(JLA,2,JK,JLATBIN) = 1.0
ENDDO
ENDDO
ENDDO
ELSE
DO 101 JK = 1, NKSDIM
DO 103 JLA = 1, NLA
SP(JLA,1,JK) = 1.0
SP(JLA,2,JK) = 1.0
103 CONTINUE
101 CONTINUE
ENDIF
C
ELSE IF(CDCTL.EQ.'S') THEN
C
C* 2. Rescaled version of the identity
C
200 CONTINUE
C
WRITE(NULOUT,FMT='(6X,"- as a rescaled version of the",
S " identity -")')
C
ZVORSCALE = 1.E13
ZDIVSCALE = 1.E13
ZGZSCALE = 1.
ZQSCALE = 1.
ZPSSCALE = 1.
ZTGSCALE = 1.
ZTRSCALE = 1.
DO 201 JK = 1, NFLEV
DO 202 JLA = 1, NLA
if(nsexist(nsvor).eq. 1) then
SPVOR(JLA,1,JK) = ZVORSCALE
SPVOR(JLA,2,JK) = ZVORSCALE
endif
if(nsexist(nsdiv).eq. 1) then
SPDIV(JLA,1,JK) = ZDIVSCALE
SPDIV(JLA,2,JK) = ZDIVSCALE
endif
if(nsexist(nsgz).eq. 1) then
SPGZ(JLA,1,JK) = ZGZSCALE
SPGZ(JLA,2,JK) = ZGZSCALE
endif
if(nsexist(nsq).eq. 1) then
SPQ(JLA,1,JK) = ZQSCALE
SPQ(JLA,2,JK) = ZQSCALE
endif
DO KK = 1,NSCMT
if(nsexist(nstr(KK)).eq. 1) then
SPTR(JLA,1,(KK-1)*NFLEV +JK) = ZTRSCALE
SPTR(JLA,2,(KK-1)*NFLEV +JK) = ZTRSCALE
endif
ENDDO
202 CONTINUE
201 CONTINUE
IF(NSEXIST(nsps).GE.1) THEN
DO 204 JLA = 1, NLA
SPPS(JLA,1,1) = ZPSSCALE
SPPS(JLA,2,1) = ZPSSCALE
204 CONTINUE
END IF
IF(NSEXIST(nstg).GE.1) THEN
DO JLA = 1, NLA
SPTG(JLA,1,1) = ZTGSCALE
SPTG(JLA,2,1) = ZTGSCALE
ENDDO
END IF
ELSE IF (CDCTL.EQ.'P') THEN
C
C* 3. Initialize the inner product with the diagonal of the
C . forecast error correlation matrix
C
300 CONTINUE
C
WRITE(NULOUT,FMT='(6X,"- with the diagonal of the forecast",
S " error correlation matrix -")')
C
DO 301 JK = 1, NKSDIM
DO 302 JLA = 1, NLA
SP(JLA,1,JK) = CORG(JLA,1,JK)
SP(JLA,2,JK) = CORG(JLA,2,JK)
302 CONTINUE
301 CONTINUE
END IF
C
c* 4. Transfer the content of COMSP in SCALP
C
400 CONTINUE
C
C* . 4.1 Set the imaginary part of the zonal modes to zero
C
410 CONTINUE
IF(NANALVAR.EQ.4) THEN
DO JLATBIN=1,NLATBIN
DO JK = 1, NKSDIM
DO JLA = 1, NTRUNC + 1
SPLAT(JLA,2,JK,JLATBIN) = 0.
ENDDO
ENDDO
ENDDO
ELSE
DO 411 JK = 1, NKSDIM
DO 412 JLA = 1, NTRUNC + 1
SP(JLA,2,JK) = 0.
412 CONTINUE
411 CONTINUE
ENDIF
C
C Do not call CAININ and initialize inner product scaling if only SV's used for B
C
IF(NSVMODE.ne.1) THEN
c
CALL CAININ(NVADIM,SCALP)
C
500 CONTINUE
JDIM = 0
DO JLATBIN=1,NLATBIN
DO 501 JLEV = 1, NKSDIM
DO 502 JLA = 1, NTRUNC+1
JDIM = JDIM+1
IF(SCALP(JDIM).EQ.0.) THEN
SCALPM1(JDIM) = 0.
ELSE
SCALPM1(JDIM) = 1.D0/DBLE(SCALP(JDIM))
END IF
502 CONTINUE
DO 503 JLA = NTRUNC + 2, NLA
JDIM = JDIM + 1
IF(SCALP(JDIM).EQ.0.) THEN
SCALPM1(JDIM) = 0.
ELSE
SCALPM1(JDIM) = 2.D0/DBLE(SCALP(JDIM))
END IF
JDIM = JDIM + 1
IF(SCALP(JDIM).EQ.0.) THEN
SCALPM1(JDIM) = 0.
ELSE
SCALPM1(JDIM) = 2.D0/DBLE(SCALP(JDIM))
END IF
503 CONTINUE
501 CONTINUE
ENDDO
C
ENDIF
C
RETURN
END