!-------------------------------------- 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,12
#if defined (DOC)
*
***s/r rebldnotag
*
*Author : Bin He *ARMA/MRB FEB., 2009
*
*Revision:
* Bin He *ARMA/MRB Feb. 2009
* . MPI version
* Bin He - ARMA/MRB - Oct. 2011,
* - 4Dvar optimization.
*Arguments: none
*
#endif
use modfgat
use mod4dv, only: l4dvar
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"
#include "cparamgoes.cdk"
#include "comgoes.cdk"
*
integer jobs, iobs,ig1obs, ig2obs, ig3obs, ig4obs, newdate
integer vezgdef, ierr,istepstamp,jstep,istat,ihdl,ihdl01
integer :: icode,jvar,getprofcode, ireslun
integer :: idate, itime, idata,idatend, jdata,itimeout,fnom
integer :: jo,istart,ifle,jj,istep,ifamid,ifile
character(len=2) :: cljx, cljy,cistep
integer :: istep1
integer :: maxnobs
real*8 zig1,zig2,zig3,zig4
*
real*8, allocatable, dimension(:,:) :: dlatfld, dlonfld
integer :: i,nobtotmax
integer,allocatable,dimension(:) :: allnobtot
logical :: llflag,lltimein
logical,dimension(nstepobs) :: lfirst
integer :: omp_get_max_threads
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(nobs(nstepobs))
nobs=0
allocate(nobsgid(nstepobs))
nobsgid=0
allocate(nstart(nstepobs,nfiles),stat=ierr)
nstart=0
allocate(nend(nstepobs,nfiles),stat=ierr)
nend=0
allocate(notag(nobtot,nstepobs))
notag=0
allocate(dlatfld(nobtot,nstepobs))
dlatfld=0.0d0
allocate(dlonfld(nobtot,nstepobs))
dlonfld=0.0d0
!
allocate(nobs_to(nstepobs),stat=ierr)
nobs_to=0
allocate(nobs_go(nstepobs),stat=ierr)
nobs_go=0
allocate(nobs_ro(nstepobs),stat=ierr)
nobs_ro=0
allocate(nobs_gp(nstepobs),stat=ierr)
nobs_gp=0
allocate(astepobs(nstepobs),stat=ierr)
do jj=1,nstepobs
astepobs(jj)=jj
enddo
!-----------
id_nonzero=0
!--------------------------------------------------------
! allocate mem to robdata8_loc
allocate(robdata8_loc(ndata),stat=ierr)
robdata8_loc=0.0D0
!-------------
numthreads=omp_get_max_threads()
!
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
!!IF(nobtot==0) RETURN
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
!! calculate the start and end index for each time step of a family
jj=0
nstart=0
nend=0
!! for O-P or O-A , skipping this block ...
if(nconf == 141) then
do ifile=1,Nfiles
do istep=1,nstepobs
lfirst(istep)=.true.
!!!bhe ** jj=0
do iobs=1,nobs(istep)
jobs=notag(iobs,istep)
ifamId = MOBHDR(NCMOEC,jobs)
istart=MOBHDR(NCMRLN,jobs)
idata=MOBHDR(NCMNLV,jobs)
CALL stepobs(ISTEPSTAMP,nbrpstamp,mobhdr(NCMDAT,jobs)
& ,mobhdr(NCMETM,jobs),dstepobs)
if(ifamId == ifile) then
if(nstamplist(istep) == ISTEPSTAMP ) then
IF(LFIRST(istep)) THEN
nstart(istep,ifile)=istart
jj=istart
Lfirst(istep)=.false.
ENDIF
jj=jj+idata
endif
endif
enddo
nend(istep,ifile)=jj-1
if(nstart(istep,ifile) == 0) nend(istep,ifile)=0
print*,'nstart(istep,ifile) nend(istep,ifile)= ',ifile,nstart(istep,ifile),nend(istep,ifile)
enddo
enddo
endif !! end of skipping for O-A or O-P ....
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
maxnobs=maxval(nobs)
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)
!! bhe.. for O-P or O-A skipping following block..
if(NCONF == 141 ) THEN
c
c Looking for the last step file containing observations
c ------------------------------------------------------
istepobs_first=1
do jstep = 1,nstepobs
if (nobs(jstep) .gt. 0) then
istepobs_first=jstep
exit
endif
enddo
!istepobs_last=0
do jstep = nstepobs,1,-1
if (nobs(jstep) .gt. 0) goto 999
enddo
999 continue
istepobs_last=jstep
c If no obs in any jstep, set istepobs_last = nstepobs
if (istepobs_last.eq.0) istepobs_last = nstepobs
write(nulout,*) 'ISTEPOBS_LAST containing observations = ',istepobs_last
istep1=istepobs_last-1
write(cljx,'(i2.2)') myidx
write(cljy,'(i2.2)') myidy
write(cistep,'(i2.2)') istep1
IF(l4dvar) TL_prof_file = trim(CEXC4DV) // '/' // cljx//'_'// cljy //'_'// cistep // '/dwyf_'//cljx//'_'//cljy//'_'//cistep//'.prof'
c
do ifile=1,NFILES
if(cfamtyp(ifile) == 'TO' .and. nbegintyp(ifile) >0 )then
allocate(nobtag_to(maxnobs,nstepobs),stat=ierr)
nobtag_to=0
CALL getFamilyTag('TO',nobtag_to,nobs_to)
else if(cfamtyp(ifile) == 'GO' .and. nbegintyp(ifile) >0 )then
allocate(nobtag_go(maxnobs,nstepobs),stat=ierr)
nobtag_go=0
CALL getFamilyTag('GO',nobtag_go,nobs_go)
else if(cfamtyp(ifile) == 'RO' .and. nbegintyp(ifile) >0 )then
allocate(nobtag_ro(maxnobs,nstepobs),stat=ierr)
nobtag_ro=0
CALL getFamilyTag('RO',nobtag_ro,nobs_ro)
else if(cfamtyp(ifile) == 'GP' .and. nbegintyp(ifile) >0 )then
allocate(nobtag_gp(maxnobs,nstepobs),stat=ierr)
nobtag_gp=0
CALL getFamilyTag('GP',nobtag_gp,nobs_gp)
endif
enddo
! find the processor id (id_nonzero) which has maximum number of observations.
allocate(allnobtot(nprocs))
allnobtot=0
!bhecall rpn_comm_allgather(nobtot,1,"MPI_INTEGER",allnobtot,1,"MPI_INTEGER","GRID",ierr)
call rpn_comm_gather(nobtot,1,"MPI_INTEGER",allnobtot,1,"MPI_INTEGER",0,"GRID",ierr)
call rpn_comm_bcast(allnobtot,nprocs,"MPI_INTEGER",0,"GRID",ierr)
nobtotmax=allnobtot(1)
id_nonzero=0
do i=1,nprocs-1
if(nobtotmax<allnobtot(i+1) ) then
nobtotmax=allnobtot(i+1)
id_nonzero=i
endif
enddo
write(nulout,*) 'Maximum number of obs. at the processor: ',id_nonzero
deallocate(allnobtot)
ENDIF !! End of skipping... for O-P and O-A...
write(nulout,*) ' '
write(nulout,*) '-------- END OF ReBldNobtag ---------'
write(nulout,*) ' '
c
contains
subroutine getFamilyTag(cfam,iobtag,sobs) 4
CHARACTER*2,intent(IN) :: cfam
integer,dimension(:,:),intent(INOUT) :: iobtag
integer,dimension(:),intent(INOUT) :: sobs
integer :: jf ,iobs ,istep
integer :: jj,jbegin,jlast,ibeginob,ilastob
integer :: idatyp, idata,idatend, isat ,ksat
logical :: assim
jj=0
DO jf=1,NFILES
IF(cfam .EQ. cfamtyp(jf))THEN
DO istep=1,nstepobs
jj=0
jbegin=nstart(istep,jf)
jlast=nend(istep,jf)
if(jbegin == 0 .and. jlast == 0) goto 88
ibeginob=MOBDATA(NCMOBS,jbegin)
ilastob=MOBDATA(NCMOBS,jlast)
do jo=ibeginob,ilastob
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
if(cfam == 'TO') then
IF ( IDATYP .EQ. 164 .OR.
+ IDATYP .EQ. 168 .OR.
+ IDATYP .EQ. 180 .OR.
+ IDATYP .EQ. 181 .OR.
+ IDATYP .EQ. 182 .OR.
+ IDATYP .EQ. 183 .OR.
+ IDATYP .EQ. 185 .OR.
+ IDATYP .EQ. 186) THEN
jj=jj+1
iobtag(jj,istep)=jo
endif
else if(cfam == 'GO') Then
DO ksat=1,NSATGO
IF ( IDATYP .EQ. 180 ) THEN
IDATA = MOBHDR(NCMRLN,JO)
IDATEND = MOBHDR(NCMNLV,JO) + IDATA - 1
ASSIM = .FALSE.
DO JDATA= IDATA, IDATEND
IF ( MOBDATA(NCMASS,JDATA).EQ.1 ) THEN
ASSIM = .TRUE.
ENDIF
ENDDO
ISAT = MOD(MOBHDR(NCMITY,JO)/1000,1000)
ISAT = ISAT - 244
IF ( ASSIM .AND. (ISAT .EQ. NIDSATGO(KSAT)) ) THEN
jj=jj+1
iobtag(jj,istep)=jo
ENDIF
ENDIF
ENDDO
else
jj=jj+1
iobtag(jj,istep)=jo
endif
enddo !! JO
88 sobs(istep)=jj
ENDDO ! istep
ENDIF
ENDDO
print*,'size of sobs(istep) =',sobs(1:nstepobs)
print*,'return getFamilyTag: ',cfam
end subroutine getFamilyTag
end subroutine rebldnotag