SUBROUTINE ch_susplit(mode) 2,2
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r ch_susplit - initialization for the splitting scheme
*
*Author : Y.Yang June 2005
*
*Revision:
*
*Arguments
*
* integer mode = 0 off-line mode, called by the highest-level control(cnt0)
* and should call ch_splitting immediately after setup
* = 1 in-line mode, called by ch_suchem just for setup and
* should not call ch_splitting, which will be called in
* ch_varout
*
*Purpose: preparation to call the splitting analysis routin, opening files,
* setting and passing the parameters
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "compost.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "comcst.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "namfilt.cdk"
#include "comchem.cdk"
#include "cparbrp.cdk"
#include "comstate.cdk"
#include "comsplit.cdk"
#include "namsplit.cdk"
*
integer mode
integer ierr, ierr2
integer kk, istat
logical lexist
integer inii,injj,inkk,ikey
character *12 cletikett
character *2 cltypvarr
integer kkstampv
integer kkip1,kkip2,kkip3
integer koutmpg
c
c---------------------------------------------------------------------
c
c check whether the splitting is required
if (.not. LSPLIT) return
c
C read the namelist for parameters related to splitting
c
WRITE(NULOUT,FMT='(/,4X,"Starting preperation for SPLITTING ...",//)')
C
C default values
C
CFNAMSPLIT = './stat_split_oper.dat'
CFTRLM_S = ''
CFREBM_S_OBS = ''
CFREBM_S_UNOBS = ''
CFREHM_S_UNOBS = ''
CFANLM_S_UNOBS = ''
NPAIRS = 0
LREMVE_MEAN_INC = .false.
LSCAL_OPER = .false.
CFNAME_MEAN_INC = ''
LDIAGNO = .FALSE.
do kk= 1, ncmtmax
CVARUNOBS(KK) = ''
CVARANAL(KK) = ''
enddo
CALL CH_READNML('NAMSPLIT',IERR)
if (npairs .eq. 0) then
write(nulout, *)'no unobserved variables to process!'
write(nulout, *)'exiting ...'
return
endif
c
c open the stats file that contains the splitting operator
c
IF (CFNAMSPLIT .ne. '') THEN
nulsplitoper=800
IERR=FNOM(nulsplitoper,CFNAMSPLIT,'RND+OLD',0)
IF ( ierr.EQ. 0 ) THEN
write(nulout,*) 'STATISTICS File : ', CFNAMSPLIT
write(nulout,*) ' opened as unit file ',nulsplitoper
ierr = fstouv(nulsplitoper,'RND+OLD')
ELSE
CALL ABORT3D(NULOUT,'CH_SUSPLIT:SPLIT-OPER STAT FILE DOES NOT EXIST!!')
ENDIF
ELSE
CALL ABORT3D(NULOUT,'CH_SUSPLIT:PLEASE SPECIFY THE SPLIT-OPER STAT FILE!!')
ENDIF
c
c open the input trial field
C if the name is not specified, it is assued to use the file that is already
C opened in sufilnam.ftn
c
IF(CFTRLM_S .ne. '')THEN
inquire(file='./'//CFTRLM_S, exist=lexist)
if(lexist) then
ninmpg_unobs=790
IERR=FNOM(ninmpg_unobs,CFTRLM_S,'STD+RND+OLD',0)
IF (ierr .EQ. 0 ) THEN
write(nulout,*) 'ITRIAL - File for unobserved:'
write(nulout,*) cftrlm_s
write(nulout,*) 'exists and opened as unit file ',ninmpg_unobs
ierr = fstouv(ninmpg_unobs,'STD+RND')
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFTRLM_S
write(nulout,*)'open ', CFTRLM_S, ' with fstouv = ' ,ierr
ELSE
write(nulout,*) 'problem with FNOM for ', CFTRLM_S
write(nulout,*) 'ierr= ',ierr
ENDIF
else
write(nulout,*) 'trial field for unobserved, ', CFTRLM_S, ' does not exist !!!'
endif
ELSE
c
c looking for original trial field
c
do kk=1,ntrials
ikey = FSTINF(ninmpg(kk), INIi, INJj, INKk, kkstampv, cletikett,
& kkip1, kkip2, kkip3,cltypvarr,'HY')
if(ikey >= 0) then
koutmpg=ninmpg(kk)
exit
endif
enddo
ninmpg_unobs=koutmpg
write(nulout,*) 'using original trial field ', ninmpg_unobs
ENDIF
c
c open the input low_resolution increment field for the observed variables
C if the name is not specified, it is assued to use the file that is already
C opened in sufilnam.ftn. i.e. use the increment of observed variables just produced in
C the analysis step
c
IF(CFREBM_S_OBS .ne. '')THEN
inquire(file='./'//CFREBM_S_OBS, exist=lexist)
if(lexist) then
nulinclr_obs =780
IERR=FNOM(nulinclr_obs,CFREBM_S_OBS,'STD+RND+OLD',0)
IF ( ierr .EQ. 0 ) THEN
write(nulout,*) 'input LR INCREMENT - File for observed:'
write(nulout,*) cfrebm_s_obs
write(nulout,*) 'exists and opened as unit file ',nulinclr_obs
ierr = fstouv(nulinclr_obs,'RND')
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFREBM_S_OBS
write(nulout,*)'open ', CFREBM_S_OBS , ' with fstouv = ' ,ierr
ELSE
write(nulout,*) 'problem with FNOM for ', CFREBM_S_OBS
write(nulout,*) 'ierr= ',ierr
ENDIF
else
write(nulout,*) 'increment field for observed, ',CFREBM_S_OBS , ' does not exist !!!'
endif
ELSE
nulinclr_obs=nulinclr
write(nulout,*) 'using original increment field ',nulinclr_obs
ENDIF
c
c if removing the bias of the increment field for the observed variables is required,
c open the file that contains the (time) mean increments.
C if the name is not specified, indicate an error
c
IF(LREMVE_MEAN_INC)THEN
IF(CFNAME_MEAN_INC .ne. '')THEN
inquire(file=CFNAME_MEAN_INC, exist=lexist)
if(lexist) then
nulinc_mean =740
IERR=FNOM(nulinc_mean,CFNAME_MEAN_INC,'STD+RND+OLD',0)
IF ( ierr .EQ. 0 ) THEN
write(nulout,*) 'input MEAN INCREMENT - File for mean increment:'
write(nulout,*) CFNAME_MEAN_INC
write(nulout,*) 'exists and opened as unit file ',nulinc_mean
ierr = fstouv(nulinc_mean,'RND')
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFNAME_MEAN_INC
write(nulout,*)'open ', CFNAME_MEAN_INC , ' with fstouv = ' ,ierr
ELSE
write(nulout,*) 'problem with FNOM for ', CFNAME_MEAN_INC
write(nulout,*) 'ierr= ',ierr
ENDIF
else
CALL ABORT3D(NULOUT,'CH_SUSPLIT: FILE CFNAME_MEAN_INC DOES NOT EXIST!!')
endif
ELSE
CALL ABORT3D(NULOUT,'CH_SUSPLIT: FILE CFNAME_MEAN_INC IS NOT SPECIFIED!!')
ENDIF
ENDIF !!LREMVE_MEAN_INC
c
c open the output low_resolution increment field for unobserved variables
C if the name is not specified, it is assued to use the file that is already
C opened in sufilnam.ftn. i.e output in the same increment file as the observed variables
C if the name is specifed but the file is not there, open a new file
c
IF(CFREBM_S_UNOBS .ne. '')THEN
nulinclr_unobs=770
inquire(file='./'//CFREBM_S_UNOBS, exist=lexist)
IERR=FNOM(nulinclr_unobs,CFREBM_S_UNOBS,'STD+RND',0)
ierr2 = fstouv(nulinclr_unobs,'RND')
if(lexist) then
write(nulout,*) 'file ', CFREBM_S_UNOBS, ' already exists!'
else
write(nulout,*) 'file ', CFREBM_S_UNOBS, ' is a new file!'
endif
IF ( ierr .EQ. 0 ) THEN
write(nulout,*) 'output LR INCREMENT - File for unobserved:'
write(nulout,*) cfrebm_s_unobs
write(nulout,*) ' is opened as file ',nulinclr_unobs
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFREBM_S_UNOBS
write(nulout,*)'open ', CFREBM_S_UNOBS, ' with fstouv = ' ,ierr2
ELSE
write(nulout,*) 'in ch_susplit, problem opening ',CFREBM_S_UNOBS
ENDIF
ELSE
nulinclr_unobs=nulinclr
write(nulout,*) 'output to original increment field ',nulinclr_unobs
ENDIF
c
c open the output high_resolution increment field for unobserved variables
C if the name is not specified, it is assued to use the file that is already
C opened in sufilnam.ftn. i.e output in the same increment file as the observed variables
C if the name is specifed but the file is not there, open a new file
c
IF(CFREHM_S_UNOBS .ne. '')THEN
nulinchr_unobs=760
inquire(file='./'//CFREHM_S_UNOBS, exist=lexist)
IERR=FNOM(nulinchr_unobs,CFREHM_S_UNOBS,'STD+RND',0)
ierr2 = fstouv(nulinchr_unobs,'RND')
if(lexist) then
write(nulout,*) 'file ', CFREHM_S_UNOBS, ' already exists!'
else
write(nulout,*) 'file ', CFREHM_S_UNOBS, ' is a new file!'
endif
IF ( ierr .EQ. 0 ) THEN
write(nulout,*) 'output HR INCREMENT - File for unobserved:'
write(nulout,*) cfrehm_s_unobs
write(nulout,*) ' is opened as file ',nulinchr_unobs
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFREHM_S_UNOBS
write(nulout,*)'open ', CFREHM_S_UNOBS, ' with fstouv = ' ,ierr2
ELSE
write(nulout,*) 'in ch_susplit, problem opening ',CFREHM_S_UNOBS
ENDIF
ELSE
nulinchr_unobs=nulinchr
write(nulout,*) 'output to original increment field ',nulinchr_unobs
ENDIF
c
c open the output analysis field for unobserved variables
C if the name is not specified, it is assued to use the file that is already
C opened in sufilnam.ftn. i.e output in the same anal file as the observed variables
C if the name is specifed but the file is not there, open a new file
c
IF(CFANLM_S_UNOBS .ne. '')THEN
nulstd_unobs=750
inquire(file='./'//CFANLM_S_UNOBS, exist=lexist)
IERR=FNOM(nulstd_unobs,CFANLM_S_UNOBS,'STD+RND',0)
ierr2 = fstouv(nulstd_unobs,'RND')
if(lexist) then
write(nulout,*) 'file ', CFANLM_S_UNOBS, ' already exists!'
else
write(nulout,*) 'file ', CFANLM_S_UNOBS, ' is a new file!'
endif
IF ( ierr .EQ. 0 ) THEN
write(nulout,*) 'output ANALYSIS - File for unobserved:'
write(nulout,*) cfanlm_s_unobs
write(nulout,*) ' is opened as file ',nulstd_unobs
c if (ierr .ne. 0) write(nulout,*) 'problem with fstouv for ', CFANLM_S_UNOBS
write(nulout,*)'open ', CFANLM_S_UNOBS, ' with fstouv = ' ,ierr2
ELSE
write(nulout,*) 'in ch_susplit, problem opening ',CFANLM_S_UNOBS
ENDIF
ELSE
nulstd_unobs=nulstd
write(nulout,*) 'output to original anal field ',nulstd_unobs
ENDIF
IF(mode .eq. 0) then
c
C off-line mode, call the splitting routine and pass the parameters
C
call ch_splitting
ENDIF
return
end