subroutine suobsgid 1
use modfgat, only : nstamplist, nobsgid, nobs, notag, nstepobs
use mod4dv, only : mvar, l4dvar
#if defined (DOC)
*
***s/r suobsgid initialize observation Y grid handle.
*
*Author : S. Pellerin *ARMA/AES Nov., 1999
*
*Revision:
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
* S. Pellerin *ARMA/SMC Nov. 2001
* . Management of first guess at appropriate time
* S. Pellerin *ARMA/SMC Feb. 2002
* . Writing of PRM_STOB in lalo.prof file
* M. Buehner *ARMA/SMC Aug. 2002
* . Changed filename from lalo.prof to init.prof
* . Added simulation number to init.prof (for restart)
* . Write numseg for SV job
* Y. Yang - Oct. 2004
* . Added include "comnumbr.cdk"
* due to the dependence of the "cvcord.cdk" on JPNBRELEM
*Arguments: none
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comgdpar.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comfilt.cdk"
#include "comct0.cdk"
#include "comvfiles.cdk"
#include "comsv.cdk"
#include "comcva.cdk"
*
include 'prof_f.h'
*
integer jobs, ig1obs, ig2obs, ig3obs, ig4obs, newdate
integer vezgdef, ierr,istepstamp,jstep,istat,ihdl
integer :: prof_wrrec,icode,jvar,getprofcode, istepobs, ireslun
integer :: idate, itime, idata,idatend, jdata,itimeout,iobs,fnom
integer :: fclos
real*8 zig1,zig2,zig3,zig4
*
real*8, allocatable, dimension(:,:) :: dlatfld, dlonfld
character (len=128) :: clprof
logical llflag,lltimein
*
write(nulout,*) ' '
write(nulout,*) '-------- ENTERING SUOBSGID ---------'
write(nulout,*) ' '
write(nulout,*) 'SUOBSGID: Step obs : ',dstepobs,' hours'
* Compute the number of step obs over a 6 hours assimilation window
nstepobs = 2*nint((3.d0 - dstepobs/2.d0)/dstepobs) + 1
write(nulout,*) 'SUOBSGID: Number of step obs : ',nstepobs
allocate(nstamplist(nstepobs))
allocate(nobs(nstepobs))
allocate(nobsgid(nstepobs))
allocate(notag(nobtot,nstepobs),stat=ierr)
allocate(dlatfld(nobtot,nstepobs))
allocate(dlonfld(nobtot,nstepobs))
call getstamplist(NSTAMPLIST,nstepobs,nbrpstamp,dstepobs)
* Find lower and upper assimilation window index in nstamplist
if (nlwrbin == -1) nlwrbin = 1
if (nuprbin == -1) nuprbin = nstepobs
! CMC date time stamp of the step obs time
do jstep = 1, jpfiles
ntimeout(jstep) = 0
enddo
do jstep = 1, nstepobs
nobs(jstep) = 0
enddo
do jobs=1, nobtot
C
! return the step stamp associated whit date and time of the observation
C
call stepobs(ISTEPSTAMP,nbrpstamp,mobhdr(ncmdat,jobs)
& ,mobhdr(ncmetm,jobs),dstepobs)
C
! building the list of step stamp and counting number of obs in each step
C
lltimein = .false.
step : do jstep = nlwrbin,nuprbin
if (nstamplist(jstep) == istepstamp) then
nobs(jstep) = nobs(jstep) + 1
lltimein = .true.
exit step
endif
enddo step
if (.not. lltimein) then
ntimeout(mobhdr(ncmotp,jobs))=ntimeout(mobhdr(ncmotp,jobs))+1
C write(nulout,*) 'Report time for obs no. ',jobs
C & ,' out of range : ', mobhdr(ncmdat,jobs),
C & mobhdr(ncmetm,jobs)
C
! Put put the wrong data in the central bin
C
jstep = (nstepobs + 1) / 2
nobs(jstep) = nobs(jstep) + 1
C
! .. flag it as out of (time) domain (bit #5 of header flag
! .. and turn off its assimilation flag
C
idata = mobhdr(ncmrln,jobs)
idatend = mobhdr(ncmnlv,jobs) + idata -1
do jdata = idata, idatend
MOBDATA(NCMASS,JDATA) = 0
enddo
mobhdr(ncmst1,jobs)= ibset( mobhdr(ncmst1,jobs) , 05)
endif
C
! building the lat, long and tag vectors for each step
C
dlatfld(nobs(jstep),jstep) = robhdr(ncmlat,jobs)
dlonfld(nobs(jstep),jstep) = robhdr(ncmlon,jobs)
notag(nobs(jstep),jstep) = jobs
C
! Converting lat long to radian units
C
if(dlonfld(nobs(jstep),jstep).lt.0)
& dlonfld(nobs(jstep),jstep) = dlonfld(nobs(jstep),jstep) +
& 2*rpi
if(dlonfld(nobs(jstep),jstep).ge.2.*rpi)
& dlonfld(nobs(jstep),jstep) =dlonfld(nobs(jstep),jstep) -
& 2*rpi
dlatfld(nobs(jstep),jstep)=dlatfld(nobs(jstep),jstep)*180./rpi
dlonfld(nobs(jstep),jstep)=dlonfld(nobs(jstep),jstep)*180./rpi
enddo
itimeout = 0
do jstep = 1,nfiles
itimeout = ntimeout(jstep) + itimeout
enddo
if(itimeout > 0) then
write(nulout,*) 'Number of reports with time out of range :',
& itimeout
write(nulout,*) ' FAMILY No. of reports'
do jstep = 1,nfiles
write(nulout,'(4x,a2,11x,i5)') CFAMTYP(jstep),ntimeout(jstep)
enddo
endif
zig1 = 0.0D0
zig2 = 0.0D0
zig3 = 1.0D0
zig4 = 1.0D0
call vcxgaig('L',ig1obs, ig2obs, ig3obs, ig4obs,
. zig1, zig2, zig3, zig4)
c
write(nulout,*) 'STEP OBS NO. - DATE - TIME - Nbr. of obs.'
do jstep = 1,nstepobs
if (jstep == (nstepobs+1)/2) then
iobs = nobs(jstep) - itimeout
else
iobs = nobs(jstep)
endif
ierr = newdate(nstamplist(jstep),idate,itime,-3)
write(nulout,'(6x,i2,5x,i10,2x,i4.4,5x,i5)') jstep,idate,itime
& /10000,iobs
if (nobs(jstep) .gt. 0) then
nobsgid(jstep) = vezgdef(nobs(jstep),1,'Y','L',ig1obs,ig2obs,
& ig3obs,ig4obs,dlonfld(1:nobs(jstep),jstep)
& ,dlatfld(1:nobs(jstep),jstep))
else
nobsgid(jstep) = -999
endif
enddo
c
c Write lalo prof file:
c
mvar = 0
do jvar=1, nfstvar2d
icode = getprofcode(cfstvar2d(jvar))
mvar = ibset(mvar,icode)
enddo
c mvar = ibset(mvar,v3d_pres)
c mvar = ibset(mvar,v2d_geop) ! Geopotential at surface
c mvar = ibset(mvar,v2d_ptop) ! Pressure at model top
do jvar=1, nfstvar
icode = getprofcode(cfstvar(jvar))
mvar = ibset(mvar,icode)
enddo
if (l4dvar) then
*
istepobs = nint(dstepobs * 60.)
clprof = trim(CEXC4DV) // '/init.prof'
ihdl = prof_open(clprof,'WRITE','FILE')
c
c Get simulation number if this is a restart job
c
if(niterjob /= -1 .and. lrestart) then
ireslun=0
ierr = fnom(ireslun,crestart,'FTN+SEQ+UNF+OLD+R/O',0)
read(ireslun) nsim3d
ierr = fclos(ireslun)
else
nsim3d = 0
endif
c
if(NCONF.eq.601.or.NCONF.eq.605) then
C
c For SV job only write out number of segments and simulation number in init file
C
istat = prof_pvar(ihdl,numseg,prm_stob)
istat = prof_pvar(ihdl,nsim3d,prm_rstr)
istat = prof_wrrec(ihdl)
C
c For all other jobs write out lat/lon and other info for obs
C
else
do jstep = 1,nstepobs
if(nobs(jstep) /= 0) then
istat = prof_pvar(ihdl,istepobs,prm_stob)
istat = prof_pvar(ihdl,nstamplist(jstep),prm_dtst)
istat = prof_pvar(ihdl,nsim3d,prm_rstr)
istat = prof_pvar(ihdl,mvar,prm_mvar)
istat = prof_pvar(ihdl,notag(1:nobs(jstep),jstep),v2d_otag)
istat = prof_pvar(ihdl,dlatfld(1:nobs(jstep),jstep),
& v2d_lati)
istat = prof_pvar(ihdl,dlonfld(1:nobs(jstep),jstep),
& v2d_long)
istat = prof_wrrec(ihdl)
endif
enddo
endif
istat = prof_close(ihdl)
endif
deallocate(dlatfld)
deallocate(dlonfld)
c
write(nulout,*) ' '
write(nulout,*) '-------- END OF SUOBSGID ---------'
write(nulout,*) ' '
c
return
end