!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
subroutine rebldnotag 1,6
use modfgat
, only : nstamplist, nobsgid, nobs, notag, nstepobs
#if defined (DOC)
*
***s/r rebldnotag
*
*Author : Bin He *ARMA/MRB FEB., 2009
*
*Revision:
* Bin He *ARMA/MRB Feb. 2009
* . MPI version
*Arguments: none
*
#endif
USE procs_topo
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 "cvcord.cdk"
#include "comfilt.cdk"
#include "comct0.cdk"
#include "comvfiles.cdk"
#include "comsv.cdk"
#include "comcva.cdk"
*
integer jobs, ig1obs, ig2obs, ig3obs, ig4obs, newdate
integer vezgdef, ierr,istepstamp,jstep,istat,ihdl,ihdl01
integer :: icode,jvar,getprofcode, istepobs, ireslun
integer :: idate, itime, idata,idatend, jdata,itimeout,iobs,fnom
real*8 zig1,zig2,zig3,zig4
*
real*8, allocatable, dimension(:,:) :: dlatfld, dlonfld
logical :: llflag,lltimein
write(nulout,*) 'ReBldNobtag: Step obs : ',dstepobs,' hours'
nstepobs = 2*nint((3.d0 - dstepobs/2.d0)/dstepobs) + 1
write(nulout,*) 'ReBldNobtag: 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)
do jstep = 1, jpfiles
ntimeout(jstep) = 0
enddo
do jstep = 1, nstepobs
nobs(jstep) = 0
enddo
write(*,*) 'NOBTOT= ',nobtot
do jobs=1, nobtot
! return the step stamp associated whit date and time of the observation
c spe : for normal use uncomment the call to stepobs and comment the
C following line (istepstamp = nstamplist(1))
call stepobs(ISTEPSTAMP,nbrpstamp,mobhdr(ncmdat,jobs)
& ,mobhdr(ncmetm,jobs),dstepobs)
c ISTEPSTAMP = nstamplist(1)
! building the list of step stamp and counting number of obs in each step
lltimein = .false.
step : do jstep = 1,nstepobs
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
write(nulout,*) 'Report time for obs no. ',jobs
& ,' out of range : ', mobhdr(ncmdat,jobs),
& mobhdr(ncmetm,jobs)
! Put put the wrong data in the central bin
jstep = (nstepobs + 1) / 2
nobs(jstep) = nobs(jstep) + 1
! .. flag it as out of (time) domain (bit #5 of header flag
! .. and turn off its assimilation flag
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
! building the lat, long and tag vectors for each step
dlatfld(nobs(jstep),jstep) = robhdr(ncmlat,jobs)
dlonfld(nobs(jstep),jstep) = robhdr(ncmlon,jobs)
notag(nobs(jstep),jstep) = jobs
! Converting lat long to radian units
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
deallocate(dlatfld)
deallocate(dlonfld)
c
write(nulout,*) ' '
write(nulout,*) '-------- END OF ReBldNobtag ---------'
write(nulout,*) ' '
c
return
end