SUBROUTINE CTR3D_CG
C===================================================================
C=========== 3DVAR with the Conjugate Gradient ==============
C===================================================================
IMPLICIT NONE
include 'champ.cdk'
include 'chobs.cdk'
INTEGER KDIM,INCRM,NINCRM
INTEGER KMIN,KMAX,KRANGE
INTEGER IMODE,ISIMMAX,NGUESS
INTEGER KINDIC,IR,CMP,PTFLAG
INTEGER IZ(5)
INTEGER II
PARAMETER(KDIM=4096)
REAL*8 XX(KDIM),XX1(KDIM),Xb(KDIM)
REAL*8 GX(KDIM),JX,PX(KDIM),PY(KDIM)
REAL*8 ZZS(1)
REAL*8 ZXMIN,ZDF1,ZEPS,RE,IM,KX,KY,KWW
REAL*8 XXO(KDIM)
REAL*8 DLALPHA,DLGNORM,JX0,JXF,ZTEST
LOGICAL VAR
C Variables needed for the Conjugate Gradient
C -------------------------------------------
integer itermax,impres,mode,preco,npmat0,m0,nilm0,nwlm0
integer bfgsb,npmat1,m1,nilm1,nwlm1,select, imtra
integer kmode(3), izs(1), nulout
real*8 dl_u(KDIM), b(KDIM), a(1)
real*8 x2(KDIM), b2(KDIM),ilm0(1),ilm1(1)
real*8 pmat0(KDIM,KDIM), pmat1(KDIM,KDIM)
real*8 zeps1, zzsunused(1),dlds(1),wlm0(12*KDIM+7),wlm1(12*KDIM+7)
real*8 zepsneg
real*8 dl_vatra(6*KDIM + 6)
logical two
integer i,j
real*8 mean,somme
EXTERNAL mv3dvar
C Settings for the Conjugate Gradient
C -----------------------------------
m0 = 6
m1 = 6
nwlm0 = 12*KDIM + 7
nwlm1 = 12*KDIM + 7
npmat0 = KDIM**2
npmat1 = KDIM**2
imtra = 6*KDIM + 6
two = .false.
preco = 0
bfgsb = 0
select = 0
kmode(1) = 0
kmode(2) = 0
kmode(3) = 0
IMPRES = 5
DO II =1,KDIM
PX(II) = 0.0
XX(II) = 0.0
GX(II) = 0.0
Xb(II) = 0.0
END DO
NINCRM = 1
NGUESS = 0
NOITR = 0
NOSTR = 1
NULOUT = 23
PTFLAG = 0
RMFLAG = 1
zeps1 = 0.1E-3
zepsneg = .1E-9
itermax = 200
VAR = .true.
CALL SETTING
open (21,file='cougra.dat',status='unknown')
open (22,file='couzqs.dat',status='unknown')
open (24,file='couzqsl.dat',status='unknown')
open (10,file='specal.dat',status='unknown')
C Number of control variables
C ---------------------------
NCO=0
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).EQ.1) THEN
NCO = NCO + 2
ENDIF
ENDDO
ENDDO
NCO = NCO*2
C Zeroing terms
C -------------
DO IKX=1,IKTX
DO IKY=1,IKTY
ZO(IKX,IKY) = CMPLX(0.,0.)
SO(IKX,IKY) = CMPLX(0.,0.)
ENDDO
ENDDO
C Get observations
C ----------------
CALL OBSERVATIONS
print*, 'Tout va bien (1)'
C Get control values of Z for comparison
C --------------------------------------
open (16,file='cont.io',form='unformatted')
DO NT=1,NTRAJC
read(16) ((ZCONT(IW,JW,NT),IW=1,IKTX),JW=1,IKTY)
ENDDO
close(16)
C Get the background state
C ------------------------
CALL BACKGROUND
print*, 'Tout va bien (2)'
DO IW=1,IKTX
DO JW=1,IKTY
ZO(IW,JW)= Zb(IW,JW,NSTOP)
END DO
END DO
DO IKX=1,IKTX
DO IKY=1,IKTY
ZG(IKX,IKY) = ZO(IKX,IKY)
ZGM1(IKX,IKY) = ZO(IKX,IKY)
ENDDO
ENDDO
C The innovation vector
C ---------------------
CALL H(ZO,SO,HX)
DO IR = 1,2*N*N
UWprime(IR) = dl_y(IR) - HX(IR)
END DO
C The constant RHS 0.5 y'R-1y'
C ----------------------------
somme = 0.0
DO IR = 1,2*N*N
somme = somme + 0.5*UWprime(IR)**2/sigmao(IR)**2
END DO
print*, '== CTR3D_CG == Constant in the functional',somme
C The initial residual b= B^T/2 HT R-1 y'
C --------------------------------------
DO IR = 1,2*N*N
HX(IR) = UWprime(IR)/sigmao(IR)**2
END DO
CALL HT(HX,ZF,SO)
CALL SQRTBT(ZF,ZR)
IR = 0
DO IW = 1,N
DO JW=1,N
IR = IR+1
b(IR) = ZR(IW,JW)
END DO
END DO
C Minimization
C ------------
open(23,file='mini_var.out',status='unknown')
write(23,*) 'Constant term to be added to the functional =',somme
call conjgrad(mv3dvar,KDIM,XX,b,0,x2,b2,two,
& zepsneg,zeps1,itermax,impres,
& nulout,kmode,mode,dl_vatra, imtra,
& preco,pmat0,npmat0,m0,ilm0,nilm0,wlm0,nwlm0,
& bfgsb,pmat1,npmat1,m1,ilm1,nilm1,wlm1,nwlm1,select,
& izs,zzsunused,dlds)
C -------------------- FIN DES MINIMIZATIONS ----------------------
c ----- TEST DU GRADIENT
C print*,'debut test du gradient'
C KMIN = 6
C KMAX = 13
C DO KRANGE = KMIN,KMAX
C DLGNORM = 0.
C DLALPHA = 10.**(-KRANGE)
C DO IKX=1,KDIM
C DLGNORM = DLGNORM + GX(IKX)*GX(IKX)
C XX(IKX) = XXO(IKX) - DLALPHA*GX(IKX)
C ENDDO
C call sim3d(KDIM,XX,JXF,GX)
C ZTEST = (JXF-JX)/(-DLALPHA*DLGNORM)
C print*,'ecritures test du gradient'
C WRITE(*,99) KRANGE, DLALPHA, JX,JXF, ZTEST
C 99 FORMAT(3X,I3,4X,1PE12.6,4X,G12.6,4X,G12.6,4X,G12.6)
C ENDDO
C print*,'fin test du gradient'
C ----------------------------------------------------------------
C Analysis increment
C ------------------
IR = 0
DO IW = 1,N
DO JW=1,N
ZR(IW,JW)=XX(IR+1)
IR=IR+1
END DO
END DO
CALL SQRTB(ZR,ZF)
print*, '*********ZR**********'
CALL KR(ZF,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
open(16,file='increments_var_cg.dat',status='unknown')
DO IW =1,N
DO JW=1,N
write(16,88) ZR(IW,JW)
END DO
END DO
close(16)
C Analysis state
C --------------
DO IKX=1,IKTX
DO IKY=1,IKTY
ZA(IKX,IKY) = ZF(IKX,IKY) + Zb(IKX,IKY,NSTOP)
ZO(IKX,IKY) = ZA(IKX,IKY)
END DO
END DO
CALL KR(ZA,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
OPEN(17,file='analysis.dat',status='unknown')
DO IW =1,N
DO JW=1,N
write(17,88) ZR(IW,JW)
END DO
END DO
CLOSE(17)
print*, 'Tout va bien (3)'
C New guess
C ---------
open (15,file='newguess.io',status='unknown')
write(15,102) ((ZA(IW,JW),IW=1,IKTX),JW=1,IKTY)
write(15,102) ((SO(IW,JW),IW=1,IKTX),JW=1,IKTY)
close(15)
C Forecast
C --------
GRFLAG = 1
OBFLAG = 1
TRFLAG = 1
JXFLAG = 0
TEFLAG = 0
CALL MODDIR(JX)
print*, 'Tout va bien (4)'
IF(PTFLAG.EQ.1) CALL PATH(XX,XX1,KDIM)
IF(RMFLAG.EQ.1) CALL RMSCON
close(21)
close(22)
close(23)
close(24)
close(10)
88 FORMAT(E12.4)
102 FORMAT(8e13.7)
print*, 'Tout va bien (fin)'
1000 CONTINUE
STOP
END