SUBROUTINE CTR4DI_CG,15
C===================================================================
C===========4DVAR with the Conjugate Gradient ==============
C===================================================================
IMPLICIT NONE
INCLUDE 'champ.cdk'
INCLUDE 'chinc.cdk'
INCLUDE 'chobs.cdk'
INTEGER :: INCRM,NINCRM
integer, PARAMETER :: KDIM=4096
integer, PARAMETER :: CDIM=212992
integer, parameter :: NVAMAJ=10
integer, PARAMETER :: NMTRA=4*KDIM+NVAMAJ*(2*KDIM+1)
REAL(KIND = double) :: PX(KDIM)
REAL(KIND = single) :: VATRA(NMTRA),JX,GX(KDIM),PY(KDIM)
REAL (KIND = double):: XX(KDIM)
REAL :: ZZS(1)
COMPLEX :: ZW(IKTX,IKTY,52),SW(IKTX,IKTY,52)
INTEGER :: IMODE,ISIMMAX,KINDIC,IR
REAL(KIND=single):: ZXMIN,ZDF1,ZEPS,RE,IM
REAL(KIND=SINGLE) :: RA(10000),AMRA,AMZO,AMZT,AMSO,AMST
INTEGER :: IKTX1,IKTY1,NTRAJ1,N1
INTEGER :: II, ierreur
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 (KIND = double) :: dl_u(KDIM), b(KDIM), a(1)
real (KIND = double) :: X2(KDIM),b2(KDIM),ilm0(1),ilm1(1)
real (KIND = double) :: pmat0(KDIM,KDIM), pmat1(KDIM,KDIM)
real (KIND = double) :: zeps1, zzsunused(1),dlds(1)
S ,wlm0(12*KDIM+7),wlm1(12*KDIM+7)
real (KIND = double) :: zepsneg
real (KIND = double) :: dl_vatra(6*KDIM + 6)
logical :: two
real :: dl_v(2*N*N*52)
EXTERNAL SETTING,SIMQNI
EXTERNAL MV4DVAR,MV3DVAR
write(6,*)'BEGINNING 4D-Var'
AMRA = 0.
NINCRM = 1
N1 = 64
IKTX1 = N1/3 + 1
IKTY1 = 2*N1/3 + 1
NTRAJ1 = 52
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
DO II =1,KDIM
XX(II) = 0.0
b(II) = 0.0
END DO
zeps1 = 0.1E-5
zepsneg = 0.1E-9
write(6,*)'Calling Setting...'
C
CALL SETTING
C
NSTOP = 50
write(6,*)'Setting Completed...'
write(6,*)'Opening Files...'
open (22,file='./files/couzqs.dat',status='unknown')
open (10,file='./files/specin.dat' ,status='unknown')
open (21,file='./files/cougra.dat',status='unknown')
open(1,file='./files/random.io',status='old',iostat= ierreur)
if (ierreur.eq.0) then
read(1,101) (ra(ikx),ikx=1,10000)
else
write(6,*)'Problem with file RANDOM.IO'
end if
close(1)
101 format(8f10.7)
C
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 Get observations
C ----------------
write(6,*)'Preparing observations...'
CALL OBSERVATIONS
C Get control values of Z for comparison
C --------------------------------------
write(6,*)'Reading Control values from file CONT.IO...'
open (16,file='./files/cont.io',form='unformatted')
DO NT=1,NTRAJC
read(16) ((ZCONT(IW,JW,NT),IW=1,IKTX),JW=1,IKTY)
ENDDO
close(16)
return
C Get the background state
C ------------------------
write(6,*)'Now the background state...'
CALL BACKGROUND
DO IW =1,IKTX1
DO JW =1,IKTY1
ZM(IW,JW) = Zb(IW,JW,1)
END DO
END DO
C The innovation vector
C ---------------------
DO NT = 1,NTRAJ1
DO IKX=1,IKTX
DO IKY = 1,IKTY
ZW(IKX,IKY,NT) = ZB(IKX,IKY,NT)
END DO
END DO
END DO
write(6,*)'Computing the innovations...'
CALL H_4d(ZW,SW,yprime)
DO IR = 1,CDIM
yprime(IR) = - yprime(IR) + dl_y(IR)
END DO
C The constant RHS 0.5 y'R-1y'
C ----------------------------
JX=0.0
DO IR =1,CDIM
JX = JX+0.5*yprime(IR)**2/sigmao(IR)
END DO
print*,'Constant to be added to the functional',JX
C ---------------- DEBUT DES INCREMENTS TEMPORELS -------------
DO INCRM=1,NINCRM
ZXMIN = 1E-10
ZEPS = 1E-6
IMPRES = 5
NULOUT = 23
ITERMAX = 200
ISIMMAX = 100
IF(INCRM==1) THEN
DO NT=1,NTRAJ1
DO IW=1,IKTX1
DO JW=1,IKTY1
ZTRA1(IW,JW,NT) = Zb(IW,JW,NT)
STRA1(IW,JW,NT) = (0.,0.)
END DO
END DO
END DO
ELSE
open (16,file='./files/traj.io',form='unformatted')
DO NT=1,NTRAJ1
read(16) ((ZTRA1(IW,JW,NT),IW=1,IKTX1),JW=1,IKTY1)
ENDDO
close(16)
ENDIF
DO IW=1,IKTX
DO JW=1,IKTY
DO NT=1,NTRAJ
ZTRAJ(IW,JW,NT) = ZTRA1(IW,JW,NT)
STRAJ(IW,JW,NT) = STRA1(IW,JW,NT)
ENDDO
ENDDO
ENDDO
C ------------------ SPECTRE DES DIFFERENCES -----------------
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).NE.1) THEN
RHZ(IKX,IKY) = 0.0
RHS(IKX,IKY) = 0.0
ELSE
RHZ(IKX,IKY)=ZM(IKX,IKY)-ZTRAJ(IKX,IKY,1)
RHS(IKX,IKY)=SM(IKX,IKY)-STRAJ(IKX,IKY,1)
ENDIF
ENDDO
ENDDO
CALL SPEC(RHZ,RHS,IKTX,IKTY,KTX,KTY,NS,SPZ,0,AJ,BJ,
. GRFLAG,NT*DELT)
C The initial residual b= B^T/2 HT R-1 y'
C --------------------------------------
DO IKX=1,IKTX
DO IKY=1,IKTY
ZO(IKX,IKY) = CMPLX(0.,0.)
SO(IKX,IKY) = CMPLX(0.,0.)
ENDDO
ENDDO
DO IR = 1,KDIM
XX(IR) = 0.0
END DO
DO NT = 1,NTRAJ1
DO IKX=1,IKTX
DO IKY=1,IKTY
ZW(IKX,IKY,NT) = ZTRAJ(IKX,IKY,NT)
END DO
END DO
END DO
CALL H_4d(ZW,SW,dl_v)
DO IR = 1,2*N*N*52
dl_v(IR) = (- dl_v(IR) + yprime(IR))/sigmao(IR)
END DO
CALL HT_4d(dl_v,ZW,SW)
DO NT = 1,NTRAJ1
DO IKX=1,IKTX
DO IKY=1,IKTY
ZTRA2(IKX,IKY,NT) = ZW(IKX,IKY,NT)
ENDDO
ENDDO
ENDDO
CALL ADJINC
CALL KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
NCO=0
DO IW =1,N
DO JW=1,N
NCO = NCO+1
b(NCO) = DBLE(ZR(IW,JW))
END DO
END DO
C Minimization
C ------------
open(23,file='mini.out',status='unknown')
call conjgrad(mv4dvar,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 Analysis increment
C ------------------
IR = 0
DO IW=1,N
DO JW=1,N
ZR(IW,JW)=XX(IR+1)
IR = IR+1
ENDDO
ENDDO
call RK(ZR,ZO,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).ne.1) THEN
ZO(IKX,IKY) = CMPLX(0.,0.)
ENDIF
SO(IKX,IKY) = CMPLX(0.,0.)
ENDDO
ENDDO
call KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
open(24,file='./files/incr_4var_cg.dat',status='unknown')
DO IW = 1,N
DO JW =1,N
write(24,88) ZR(IW,JW)
ENDDO
ENDDO
close(24)
C Update
C ------
AMZO=0.0
AMSO=0.0
AMZT=0.0
AMST=0.0
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).EQ.1) THEN
ZO(IKX,IKY) = ZO(IKX,IKY) + ZTRAJ(IKX,IKY,1)
SO(IKX,IKY) = SO(IKX,IKY) + STRAJ(IKX,IKY,1)
AMZO=AMZO+REAL(ZO(IKX,IKY)*CONJG(ZO(IKX,IKY)))
AMSO=AMSO+REAL(SO(IKX,IKY)*CONJG(SO(IKX,IKY)))
AMZT=AMZT+REAL(ZTRAJ(IKX,IKY,1)*CONJG(ZTRAJ(IKX,IKY,1)))
AMST=AMST+REAL(STRAJ(IKX,IKY,1)*CONJG(STRAJ(IKX,IKY,1)))
ENDIF
ENDDO
ENDDO
PRINT*,'AMZT,AMZO ',AMZT,AMZO
PRINT*,'AMST,AMSO ',AMST,AMSO
IF(INCRM.NE.NINCRM) THEN
GRFLAG = 0
OBFLAG = 0
TRFLAG = 1
JXFLAG = 0
TEFLAG = 1
CALL MODDIR(JX)
ELSE
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).NE.1) THEN
RHZ(IKX,IKY) = 0.0
RHS(IKX,IKY) = 0.0
ELSE
RHZ(IKX,IKY)=ZM(IKX,IKY)-ZO(IKX,IKY)
RHS(IKX,IKY)=SM(IKX,IKY)-SO(IKX,IKY)
ENDIF
ENDDO
ENDDO
CALL SPEC(RHZ,RHS,IKTX,IKTY,KTX,KTY,NS,SPZ,0,AJ,BJ,
. GRFLAG,NT*DELT)
ENDIF
ENDDO
C ----------------- FIN DES INCREMENTS TEMPORELS ----------------
call KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
open(24,file='./files/anal_4var_cg.dat',status='unknown')
DO IW = 1,N
DO JW =1,N
write(24,88) ZR(IW,JW)
ENDDO
ENDDO
close(24)
C Forecast
C --------
GRFLAG = 1
OBFLAG = 0
TRFLAG = 0
JXFLAG = 0
TEFLAG = 0
CALL MODDIR(JX)
close(21)
close(22)
close(23)
close(10)
88 FORMAT(E12.4)
2000 CONTINUE
return
END