SUBROUTINE ch_splitting 2,3
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r ch_splitting - update the unobserved variables from the observed ones
* . and write into RPN file
*
*Author : Y.Yang June 2005 based on some existing 3dvar subroutines
*
*Revision:
*
*Arguments
*
*Purpose: implement the splitting analysis scheme to update the increments for
* unobserved variables using the analysed ones and their cross-correlation.
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "cominterp.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "namfilt.cdk"
#include "cparbrp.cdk"
#include "comstate.cdk"
#include "comsplit.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
*
integer maxkeys, nkeys
parameter(maxkeys=100)
integer jvar
integer jlev, instatlev
logical ldiagno
integer iip1,iip2, iip3, date0
integer nlun
real*8 zlevstatsrc(jpnflev),zoper(1),zlevstattrg
real*8 zvaranal, zvarunobs
pointer (ptzvaranal, zvaranal(ni,nflev,nj)), (ptzvarunobs, zvarunobs(ni,nflev,nj))
pointer (pxzoper,zoper),(pxzlevstattrg,zlevstattrg(nflev))
real*8 zbuf(1)
pointer (ptzbuf, zbuf)
real*8 zvarout
pointer (ptzvarout, zvarout(ni,nj,nflev,1))
c real*8 SPLITOPER(1,1,1), SPLITOPERD(1,1)
c pointer (ptsplitoper, splitoper), (ptsplitoperd, splitoperd)
integer ji, jj, jk1, jk2, jlat, jlon, ilon, ikey
integer ikeys(maxkeys)
integer ibrpstamp
integer nposbuf
integer vfstluk, fstnbr
c
c---------------------------------------------------------------------
c
WRITE(NULOUT,FMT='(/,4X,"Start SPLITTING",//)')
C
c if(l4dvar) then
c ibrpstamp=nstamplist(1)
c else
c ibrpstamp=nbrpstamp
c endif
C
C set incremental field parameter for allocating space
C
nlun = nulinclr_obs
iip1 = -1
iip2 = -1
iip3 = -1
date0 = -1
cltypvar = ' '
cletiket = ' '
clnomvar = cvaranal(1)
ikey = FSTINF(nlun, INI, INJ, INK, date0, cletiket,
& iip1, iip2, iip3,cltypvar,clnomvar)
if(ikey .ge. 0) then
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
else
write(nulout, *)' increment file problem! '
endif
c
c allocate space
c
call hpalloc(ptzbuf, max(ini*inj,1),ierr,8)
call hpalloc(ptzvarunobs, max(ini*inj*nflev, 1), ierr,8)
call hpalloc(ptzvaranal, max(ini*inj*nflev, 1), ierr,8)
call hpalloc(ptzvarout, max(ini*inj*nflev*npairs,1),ierr,8)
c call hpalloc(ptsplitoper, max(nflev*nflev*inj, 1), ierr,8)
c call hpalloc(ptsplitoperd, max(nflev*inj, 1), ierr,8)
c
C build vertical interpolation operator
c
kulsplitgd = 0
ierr = fnom(kulsplitgd,'newsplitoper_gd','RND',0)
ierr = fstouv(kulsplitgd,'RND')
call hpalloc(pxzlevstattrg,nflev,ierr,8)
call rdstatlev(zlevstattrg,nflev,zlevstatsrc,instatlev,jpnflev
& ,kulsplitgd)
c
call hpalloc(pxzoper,nflev*instatlev,ierr,8)
call suvintoper(zoper,zlevstattrg,nflev,zlevstatsrc,instatlev,1)
C
c loop through the pairs of variables to be updated
C
do jvar=1, npairs
zvarunobs(:,:,:) = 0.0
c
c read the increment field of the analysed variable
c
iip1 = -1
iip2 = -1
iip3 = -1
date0 = -1
cltypvar = ' '
cletiket = ' '
c ibrpstamp=nbrpstamp
DO JLEV = 1, NFLEV
IERR = VFSTLIR(ZBUF,NLUN,INI,INJ,INK,DATE0,CLETIKET
& ,NIP1(JLEV),-1,-1,CLTYPVAR,CVARANAL(JVAR))
c ikey = FSTINF(nlun, INI, INJ, INK, date0, cletiket,
c & nip1(jlev), iip2, iip3,cltypvar,CVARANAL(JVAR))
c
if (ierr.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,CVARANAL(JVAR),' at level ',nip1(jlev)
& ,' in rebm file'
else
c ierr = VFSTLUK(zbuf,ikey, INI, INJ, INK)
if(ini .ne. ni .or. inj .ne. nj) then
write(nulout, *)' increment dimension not consistent!'
write(nulout, *)' ini= ' , ini, ' ni= ' ,ni, ' inj= ' , inj, ' nj= ' ,nj
endif
C
DO JJ = 1, NJ
DO JI = 1, NI
nposbuf=(jj-1)*ini+ji
zvaranal(JI,JLEV,JJ) = zbuf(nposbuf)
ENDDO
ENDDO
endif
ENDDO !jlev
c
c if required to remove the mean bias of the increments of observed variable,
c read the mean increment field
c
IF(LREMVE_MEAN_INC)THEN
iip1 = -1
iip2 = -1
iip3 = -1
date0 = -1
cltypvar = ' '
cletiket = ' '
c ibrpstamp=nbrpstamp
c
c ip1 in the mean increment field after averaging with rdiag may be changed and wrong. do not use that and rather read out
C all records in a bunch. assuming it's in the same sequence as the individual incremental field
c
ierr = fstinl(nulinc_mean, INI,INJ,INK, DATE0,CLETIKET,iip1,iip2,iip3,cltypvar, CVARANAL(JVAR), ikeys, nkeys, maxkeys)
if (ierr.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,CVARANAL(JVAR),' in mean increment file'
else
write(nulout, *)' number of records in mean incr field = ' , nkeys, ' number of vlevels = ' , nflev
if(nkeys .ne. nflev) call abort3d(nulout,'vertical levels in mean incrment field not consistent!')
DO JLEV = 1, NFLEV
c IERR = VFSTLIR(ZBUF,nulinc_mean,INI,INJ,INK,DATE0,CLETIKET
c & ,NIP1(JLEV),-1,-1,CLTYPVAR,CVARANAL(JVAR))
c ikey = FSTINF(nulinc_mean, INI, INJ, INK, date0, cletiket,
c & nip1(jlev), iip2, iip3,cltypvar,CVARANAL(JVAR))
c
ierr = VFSTLUK(zbuf,ikeys(jlev), INI, INJ, INK)
if(ini .ne. ni .or. inj .ne. nj) then
write(nulout, *)' increment dimension not consistent with that of mean!'
write(nulout, *)' ini= ' , ini, ' ni= ' ,ni, ' inj= ' , inj, ' nj= ' ,nj
endif
C
DO JJ = 1, NJ
DO JI = 1, NI
nposbuf=(jj-1)*ini+ji
zvaranal(JI,JLEV,JJ) = zvaranal(JI,JLEV,JJ) - zbuf(nposbuf)
ENDDO
ENDDO
ENDDO !jlev
endif
ENDIF !! LREMVE_MEAN_INC
c
C read in split operator (splitoper)
C
call ch_rdsplitoper(zoper, instatlev, jvar,SPLITOPER, SPLITOPERD)
C
if (LDIAGNO) then
C
C update unobserved variables with diagno splitoper
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
do jk1=1,NFLEV
zvarunobs(jlon,jk1,jlat)= splitoperd(jk1,jlat)*zvaranal(jlon,jk1,jlat)
enddo
END DO
END DO
else
C
C update unobserved variables with non-diagno splitoper (Pux(Pxx)^-1)
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
do jk2=1,NFLEV
do jk1=1,NFLEV
zvarunobs(jlon,jk1,jlat)=zvarunobs(jlon,jk1,jlat) +
+ splitoper(jk1,jk2,jlat)*zvaranal(jlon,jk2,jlat)
enddo
enddo
END DO
END DO
endif
c
c store the variable in a big array
c
do jk1=1,NFLEV
do ji =1,ni
do jlat = 1,nj
zvarout(ji, jlat, jk1, jvar) = zvarunobs(ji,jk1,jlat)
enddo
enddo
enddo
enddo ! done with jvar
C
C writeout the updated unobserved variables to RPN file
c
call ch_writeunobs (zvarout, ni, nflev, nj, npairs)
C
c deallocate space
c
call hpdeallc(pxzoper,ierr,1)
call hpdeallc(pxzlevstattrg,ierr,1)
call hpdeallc(ptzvarout, ierr,1)
call hpdeallc(ptzvaranal,ierr,1)
call hpdeallc(ptzvarunobs,ierr,1)
call hpdeallc(ptzbuf,ierr,1)
WRITE(NULOUT,FMT='(/,4X,"END SPLITTING",//)')
return
end