SUBROUTINE CTR4PSAS_M,29
C===================================================================
C=========== 4D-PSAS with MINRES ============
C===================================================================
IMPLICIT NONE
INCLUDE 'champ.cdk'
INCLUDE 'chinc.cdk'
INCLUDE 'chobs.cdk'
INTEGER KDIM,INCRM,NINCRM
INTEGER CDIM
PARAMETER(KDIM=4096)
PARAMETER(CDIM=425984)
C PARAMETER(CDIM=212992)
INTEGER NVAMAJ,NMTRA
PARAMETER(NVAMAJ=10)
PARAMETER(NMTRA=4*KDIM+NVAMAJ*(2*KDIM+1))
REAL VATRA(NMTRA),JX,GX(KDIM),PY(KDIM)
REAL*8 PX(KDIM)
REAL ZZS(1)
COMPLEX ZW(IKTX,IKTY,52),SW(IKTX,IKTY,52)
INTEGER IMODE,ISIMMAX,KINDIC,IR
REAL ZXMIN,ZDF1,ZEPS,RE,IM
REAL RA(10000),AMRA,AMZO,AMZT,AMSO,AMST
INTEGER IKTX1,IKTY1,NTRAJ1,N1
INTEGER II
C Variables needed for MINRES
C ---------------------------
integer nulout, itermax, istop, itn
logical checkA, precon
double precision shift, rtol, Anorm, Acond, rnorm,ynorm
double precision b(CDIM), r1(CDIM), r2(CDIM)
double precision v(CDIM), w(CDIM),w1(CDIM),w2(CDIM)
double precision XX(CDIM), y(CDIM)
real*8 dl_u(CDIM)
real*8 dl_vatra(6*CDIM + 6)
logical two
real dl_v(2*N*N*52)
C+++ DEBUG
COMPLEX ZDEB(IKTX,IKTY), ZZDEB(IKTX,IKTY), SDEB(IKTX,IKTY)
REAL XDEB(CDIM), YDEB(CDIM)
REAL XDIFF
REAL ZRDEB(N,N), ZRRDEB(N,N)
C+++
EXTERNAL SETTING
EXTERNAL MV4PSAS_M,MPRECON
AMRA = 0.
NINCRM = 1
N1 = 64
IKTX1 = N1/3 + 1
IKTY1 = 2*N1/3 + 1
NTRAJ1 = 52
C Settings for Minres
C -------------------
nulout = 23
itermax = 500
checkA = .TRUE.
precon = .FALSE.
shift = 0.
rtol = 0.1E-5
DO II =1,CDIM
XX(II) = 0.0
b(II) = 0.0
END DO
CALL SETTING
NSTOP = 50
open (21,file='./files/cougra.dat',status='unknown')
open (22,file='./files/couzqs.dat',status='unknown')
open(1,file='./files/random.io',status='old')
read(1,101) (ra(ikx),ikx=1,10000)
close(1)
C Get observations
C ----------------
CALL OBSERVATIONS
C Get control values of Z for comparison
C --------------------------------------
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)
C Get the background state
C -----------------------
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 & the initial residual
C --------------------------------------------
C+++ DIAG SYMMETRIC
print*,'test sqrtB and sqrtB'
print*, '-------------------'
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = Zb(IW,JW,1)
END DO
END DO
CALL SQRTBT(ZO,ZR)
c CALL SQRTB(ZR,ZO)
c call KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
c . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
xdiff= 0
DO Iw = 1,N
DO JW =1,N
xdiff = xdiff + ZR(IW,JW)**2
ENDDo
end do
print*,'LHS B =', xdiff
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = Zb(IW,JW,1)
END DO
END DO
call KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
CALL SQRTB(ZR,ZO)
c CALL SQRTBT(ZO,ZR)
call KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
xdiff= 0
DO Iw = 1,N
DO JW =1,N
xdiff = xdiff + ZR(IW,JW)**2
ENDDo
end do
print*,'RHS B =', xdiff
print*, 'test H and HT'
print*, '-------------'
NT =1
DO IW =1,IKTX1
DO JW =1,IKTY1
ZDEB(IW,JW) = Zb(IW,JW,1)
ZZDEB(IW,JW)= (0.,0.)
SDEB(IW,JW) = (0.,0.)
END DO
END DO
DO IR = 1,CDIM
XDEB(IR) = 0.
YDEB(IR) = dl_y(IR)
ENDDO
call H(ZDEB,SDEB,XDEB,NT)
xdiff= 0
DO IR = 1,CDIM
xdiff = xdiff + XDEB(IR)*dl_y(IR)
ENDDO
print*, ' RHS = ',xdiff
call HT(YDEB,ZZDEB,SDEB,NT)
call KR(ZDEB,ZRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
call KR(ZZDEB,ZRRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
xdiff = 0.
DO IW =1,N
DO JW =1,N
xdiff = xdiff + ZRDEB(IW,JW)*ZRRDEB(IW,JW)
END DO
END DO
print*,' LHS = ', xdiff
print*, 'test M and MT'
print*, '-------------'
xdiff = 0.
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = Zb(IW,JW,1)
END DO
ENDDO
call lininc(xdiff)
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = ZTRA2(IW,JW,52)
ENDDO
ENDDO
call KR(ZO,ZRRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = ZB(IW,JW,52)
ENDDO
ENDDO
call KR(ZO,ZRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
xdiff = 0.
DO IW =1,N
DO JW =1,N
xdiff = xdiff + ZRDEB(IW,JW)*ZRRDEB(IW,JW)
END DO
END DO
print*,' RHS = ', xdiff
DO NT = 1,NTRAJ1
DO IKX=1,IKTX
DO IKY=1,IKTY
if(NT==52) then
ZTRA2(IKX,IKY,NT) = ZB(IKX,IKY,NT)
else
ZTRA2(IKX,IKY,NT) = (0.,0.)
endif
ENDDO
ENDDO
ENDDO
call ADJINC
call KR(ZO,ZRRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO IW =1,IKTX1
DO JW =1,IKTY1
ZO(IW,JW) = Zb(IW,JW,1)
END DO
ENDDO
call KR(ZO,ZRDEB,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
xdiff = 0.
DO IW =1,N
DO JW =1,N
xdiff = xdiff + ZRDEB(IW,JW)*ZRRDEB(IW,JW)
END DO
END DO
print*,' RHS = ', xdiff
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
CALL H_4d(ZW,SW,yprime)
DO IR = 1,CDIM
yprime(IR) = - yprime(IR) + dl_y(IR)
b(IR) = DBLE(yprime(IR))/DBLE(sigmao(IR))
END DO
open(10,file='./files/specin.dat',status='unknown')
C ---------------- DEBUT DES INCREMENTS TEMPORELS -------------
DO INCRM=1,NINCRM
ZXMIN = 1E-10
ZEPS = 1E-6
NULOUT = 23
ITERMAX = 100
ISIMMAX = 20
C ------------------- LIRE TRAJECTOIRE ------------------------
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 ------------------------- FIRST GUESS ----------------------
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,CDIM
XX(IR) = 0.0
END DO
C Minimization
C ------------
open(23,file='mini.out',status='unknown')
call minres_customer(CDIM,b,r1,r2,v,w,w1,w2,XX,y,
. mv4psas_m,mprecon,
. checkA,precon,shift,nulout,itermax,rtol,
. istop,itn,Anorm,Acond,rnorm,ynorm)
C Analysis increment
C ------------------
DO IR = 1,CDIM
dl_v(IR) = XX(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 SQRTBT(ZO,ZR)
CALL SQRTB(ZR,ZO)
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_4psas_m.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_4psas_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)
101 format(8f10.7)
2000 CONTINUE
STOP
END