SUBROUTINE CTR3PSAS_CG
C===================================================================
C=========== 3D-PSAS with the Conjugate Gradient ============
C===================================================================
IMPLICIT NONE
include 'champ.cdk'
include 'chobs.cdk'
INTEGER KDIM,INCRM,NINCRM,LDIM
PARAMETER(KDIM=2624)
PARAMETER(LDIM=8192)
REAL*8 XX(LDIM),XX1(LDIM),Xb(KDIM)
REAL*8 JX,PX(KDIM),PY(KDIM)
REAL*8 ZZS(1)
REAL dl_v(LDIM)
INTEGER IZ(5)
INTEGER IMODE,ISIMMAX,NGUESS
INTEGER KINDIC,IR,CMP,PTFLAG
REAL*8 ZXMIN,ZDF1,ZEPS,RE,IM,KX,KY,KWW
INTEGER II
REAL*8 XXO(KDIM)
REAL*8 DLALPHA,DLGNORM,JX0,JXF,ZTEST
INTEGER KMIN,KMAX,KRANGE
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(LDIM), a(1)
REAL*8 b(LDIM)
REAL*8 x2(LDIM), b2(LDIM),ilm0(1),ilm1(1)
REAL*8 pmat0(LDIM,LDIM), pmat1(LDIM,LDIM)
REAL*8 zeps1, zzsunused(1),dlds(1),wlm0(12*LDIM+7),wlm1(12*LDIM+7)
REAL*8 zepsneg
REAL*8 dl_vatra(6*LDIM + 6)
LOGICAL two
INTEGER i,NOBS
REAL*8 mean
REAL somme
EXTERNAL mvprod_psas
C Settings for the conjugate gradient
C -----------------------------------
m0 = 6
m1 = 6
nwlm0 = 12*LDIM + 7
nwlm1 = 12*LDIM + 7
npmat0 = LDIM**2
npmat1 = LDIM**2
imtra = 6*LDIM + 6
two = .false.
preco = 0
bfgsb = 0
select = 0
kmode(1) = 0
kmode(2) = 0
kmode(3) = 0
IMPRES = 5
DO II = 1,LDIM
dl_u(II)=0.0
XX(II)=0.0
END DO
DO II =1,KDIM
Xb(II) = 0.0
END DO
NINCRM = 1
c NGUESS = 1
NGUESS = 0
NOITR = 0
NOSTR = 1
NULOUT = 23
PTFLAG = 0
RMFLAG = 1
zeps1 = 0.1E-3
zepsneg = .1E-9
itermax = 200
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
IF(NCO.NE.KDIM) THEN
PRINT*,'NCO NE KDIM',NCO,KDIM
STOP
ELSE
PRINT*,'NCO EQ KDIM',NCO,KDIM
ENDIF
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
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
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,LDIM
yprime(IR) = dl_y(IR) - HX(IR)
END DO
C The initial residual b= sqrtR-1 yprime
C --------------------------------------
DO IW = 1,LDIM
b(IW)=DBLE(yprime(IW)/sigmao(IW))
by(IW)=DBLE(yprime(IW)/sigmao(IW))
END DO
C Minimization
C ------------
open(23,file='mini_psas.out',status='unknown')
call conjgrad(mvprod_psas,LDIM,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 ------------------
DO IR =1,LDIM
dl_v(IR) = XX(IR)/sigmao(IR)
END DO
CALL HT(dl_v,ZF,SO)
CALL SQRTBT(ZF,ZR)
CALL SQRTB(ZR,ZF)
CALL KR(ZF,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
open(16,file='incr_psas_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
ZO(IKX,IKY) = ZF(IKX,IKY) + Zb(IKX,IKY,NSTOP)
ZA(IKX,IKY) = ZO(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='anal_psas_cg.dat',status='unknown')
DO IW =1,N
DO JW=1,N
write(17,88) ZR(IW,JW)
END DO
END DO
CLOSE(17)
C New guess
C ---------
open (15,file='newguess.io',status='unknown')
write(15,102) ((ZO(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 = 0
TRFLAG = 1
JXFLAG = 0
TEFLAG = 0
CALL MODDIR(JX)
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)
1000 CONTINUE
STOP
END