!-------------------------------------- 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 SUIMP(KDIM,PX,CDCTL) 1,14
#if defined (DOC)
*
***s/r SUIMP - Define the starting point of the minimization
*
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
*
* . P. Koclas *CMC/CMDA February 94
* . -Add comgdpar
* . -New call sequence to GETFST
* . L. Fillion *ARMA/AES Nov 94.
* . -Implementation of the multivariate mode.
* . Option validated for NCNTVAR.EQ.2,CFGERR.EQ.'G'.
* . P. Gauthier *ARMA/AES April, 1996
* . Introduce SP2SPA to build the analysis variables
* . 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).
* . L. Fillion ARMA/EC - 13 Jan 2009 - Upgrade lam4d to v_10_1_2 of 3dvar.
* . L. Fillion ARMA/EC - 21 Jun 2010 - Limit printout to root.
* -------------------
** Purpose: to define the starting point of the minimization (PX)
* . as the control variable
*
*Arguments
* PX(KDIM): control variable
* KDIM : dimension of the control variable
* CDCTL : 'R' --> PX is randomly initialized
* . 'H' --> PX is defined as a single spectral component
* . defined through the namelist NAMTEMP in SPINIT
* . 'F' --> PX is read from a RPN standard file
* . 'G' --> PX corresponds to the first-guess
#endif
USE procs_topo
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comsp.cdk"
#include "comsp1.cdk"
#include "comspg.cdk"
#include "com2ini.cdk"
#include "comsv.cdk"
#include "comgrd_param.cdk"
*
INTEGER KDIM
REAL*8 PX(KDIM)
CHARACTER*1 CDCTL
C
INTEGER JK, JLA, JLATBIN
REAL*8 ZLAMBDA
EXTERNAL ABORT3D, INITRND, SPINIT, GETFST, TRANSFER, DOTEUCL
EXTERNAL GDSP, SPGD, CAININ, PROJ, FGERR, POSTPROC
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(//,1X,"-SUIMP: defining the starting point of the"
S ," minimization")
C
ZLAMBDA = 0.1
C
IF(CDCTL.EQ.'R') THEN
C
C* 1. The control variable is initialized randomly
C . --------------------------------------------
C
100 CONTINUE
C
WRITE(NULOUT,FMT='(8X,"- random definition -")')
C
SINVOR = 0.1
SINDIV = 0.1
SINGZ = 0.1
SINQ = 0.1
SINPS = 0.1
CALL INITRND('S')
ELSE IF(CDCTL.EQ.'H') THEN
C
C* 2. The control variable is initialized as a single wave
C . ------------------------------------------
C
200 CONTINUE
C
WRITE(NULOUT,FMT='(8X,"- as a single wave -")')
C
CALL SPINIT
ELSE IF(CDCTL.EQ.'F') THEN
C
C* 3. The control variable is read from a grid point file
C . ---------------------------------------------------
C
300 CONTINUE
C
WRITE(NULOUT,FMT='(8X,"- read from a file -",//)')
C
CALL GETFST(NINMPG,'G','I',-1)
CALL TRANSFER('GD01')
CALL DOTEUCL('G',NULOUT)
CALL GDSP
CALL SPGD
CALL DOTEUCL('G',NULOUT)
ELSE IF(CDCTL.EQ.'G') THEN
C
C* 4. First-guess is used to define the starting point
C . ------------------------------------------------
C
400 CONTINUE
C
WRITE(NULOUT,FMT='(8X,"- as the first-guess -",//)')
C
CALL TRANSFER('SPG0')
ELSE
C
C* 5. Other options...
C
500 CONTINUE
WRITE(NULOUT,FMT=9500)CDCTL
CALL ABORT3D(NULOUT,'SUIMP ')
END IF
C
9500 FORMAT(//,12X,'Wrong value of CDCTL in SUIMP. CDTL =',A1)
C
C* 6. Starting point is formed by adding noise to the first-guess
C . (only when this point is artificially generated)
C . -----------------------------------------------------------
C
600 CONTINUE
C
IF(CDCTL.EQ.'R'.OR.CDCTL.EQ.'S'.OR.CDCTL.EQ.'H')THEN
DO 601 JK = 1, NKSDIM
DO 602 JLA = 1, NLA
SP1(JLA,1,JK) = ZLAMBDA*SPG(JLA,1,JK)
S + (1. - ZLAMBDA)*SP(JLA,1,JK)
SP1(JLA,2,JK) = ZLAMBDA*SPG(JLA,2,JK)
S + (1. - ZLAMBDA)*SP(JLA,2,JK)
602 CONTINUE
601 CONTINUE
CALL TRANSFER('SP10')
END IF
C
C* 7. Transfer to the canonical state
C . -------------------------------
C
700 CONTINUE
CCC
CCC CALL POSTPROC(NULUSR5,999,'GRID','TESTIMP1')
CCC
C
C* 7.1. Control variable computed from spectral increments
C
710 CONTINUE
IF(NCNTVAR.EQ.2) THEN
IF(myid == 0) WRITE(NULOUT,FMT='(8X,"dans suimp: ncntvar = 2",//)')
if(nanalvar.eq.4) then
DO JLATBIN=1,NLATBIN
DO JK = 1, NKSDIM
DO JLA = 1, NLA
SPLAT(JLA,1,JK,JLATBIN) = DBLE(SP(JLA,1,JK)) - DBLE(SPG(JLA,1,JK))
SPLAT(JLA,2,JK,JLATBIN) = DBLE(SP(JLA,2,JK)) - DBLE(SPG(JLA,2,JK))
ENDDO
ENDDO
ENDDO
else
DO 711 JK = 1, NKSDIM
DO 712 JLA = 1, NLA
SP(JLA,1,JK) = DBLE(SP(JLA,1,JK)) - DBLE(SPG(JLA,1,JK))
SP(JLA,2,JK) = DBLE(SP(JLA,2,JK)) - DBLE(SPG(JLA,2,JK))
712 CONTINUE
711 CONTINUE
endif
CBUE THIS SUBROUTINE DOES NOT KNOW ABOUT SPLAT, BUT INPUT=OUTPUT=0 ANYWAYS
if(grd_typ.eq.'GU') then
CALL SP2SPA
endif
END IF
C
C Do not call CAININ if only SV's used for B
C
IF(NSVMODE.ne.1) THEN
CALL CAININ(KDIM,PX)
ENDIF
C
RETURN
END