!-------------------------------------- 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 oda_sumJo(PJO) 1,9
use modmask
USE obstag
USE procs_topo
implicit none
real*8 pjo ! Total observation cost function
c
c Purpose:
c Compute the sum of Jo contributions saved in ROBDATA8(NCMOMI,*)
c Also, compute contribution of each family of observation (for
c diagnostic purposes)
c
c Author : S. Pellerin *ARMA/MRB January 2009
c
c Revision:
c L. Fillion, ARMA/EC, 5 Jun 2009. Introduce 1 Obs experiment.
c
c S. Macpherson, ARMA 14 Sep 2009. Add ground-based GPS (ZTD).
C Bin He *ARMA/MRB Oct. 2009
C -- Implement MPI to 3DVAR
c L. Fillion, ARMA/EC, 11 May 2010. Limit printout to processor 0.
c L. Fillion, ARMA/EC, 20 May 2010. Relocate call to restore_robdata8
C and correct bug ROBDATA8(NCMOMI,JDATA)
#include "comdim.cdk"
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "cvcord.cdk"
#include "comcva.cdk"
*
INTEGER IBEGIN,ILAST,ILASTOB,IBEGINOB,IDATEND
INTEGER J,JDATA,JO,IDATA,ITYP,indata
LOGICAL LLOK
logical, pointer,dimension(:) :: llmask
real*8,target :: dljoraob,dljoairep,dljosatwind,dljosurfc,dljotov
real*8,target :: dljogoes,dljoprof,dljogpsro,dljogpsztd
real*8 :: dlsum1
real*8, pointer :: dlsum
C
!logical,allocatable, dimension(:) :: lmask_g
real*8,allocatable, dimension(:) :: ROBDATA8_g
integer :: ierr
C Compute the observation cost function value based on the sequence of
c the data array
C
ALLOCATE(ROBDATA8_g(ndatap),STAT=ierr)
IF(ierr /= 0 ) CALL ABORT3D(nulout,'Cannt Allocate Mem. to ROBDATA_g')
if(l1obs) then
pjo = ROBDATA8(NCMOMI,1)
else
CALL restore_robdata8(robdata8_g,ndatap)
pjo = pjo + sumJo(1,ndatap,lmask_g)
c
c Compute family contributions for diagnostic purposes
c The remaining of the code has no effect on the minimization
c
dljogpsztd = 0.d0
dljoraob = 0.d0
dljoairep = 0.d0
dljosatwind = 0.d0
dljosurfc = 0.d0
dljotov = 0.d0
dljogoes = 0.d0
dljogpsro = 0.d0
dljoprof = 0.d0
DO J = 1,NFILES
!bhe IF (NBEGINTYP(J) .GT. 0)THEN
select case(CFAMTYP(J))
case('UA')
! llmask = lmaskpp_in .or. lmaskpp_out
llmask => lmaskpp_inout_g(1:ndatap)
dlsum1 = sumJo(nbegintyp_g(j),nendtyp_g(j),llmask)
dljoraob = dljoraob + dlsum1
llmask => lmasksf_inout_g(1:ndatap)
dlsum => dljosurfc
case('AI')
llmask => lmaskpp_inout_g(1:ndatap)
dlsum => dljoairep
case('SW')
llmask => lmaskpp_inout_g(1:ndatap)
dlsum => dljosatwind
case('SF','SC')
llmask => lmasksf_inout_g(1:ndatap)
dlsum => dljosurfc
case('TO')
llmask => lmaskto_g(1:ndatap)
dlsum => dljotov
case('GO')
llmask => lmaskgo_g(1:ndatap)
dlsum => dljogoes
case('RO')
llmask => lmaskro_g(1:ndatap)
dlsum => dljogpsro
case('PR')
llmask => lmaskzp_g(1:ndatap)
dlsum => dljoprof
case('GP')
llmask => lmaskgp_g(1:ndatap)
dlsum1 = sumJo(nbegintyp_g(j),nendtyp_g(j),llmask)
dljogpsztd = dljogpsztd + dlsum1
llmask = lmasksf_inout_g(1:ndatap)
dlsum => dljosurfc
end select
dlsum1 = sumJo(nbegintyp_g(j),nendtyp_g(j),llmask)
dlsum = dlsum + dlsum1
end do
!
IF(myid == 0) THEN
write(nulout,'(a15,f23.16)') 'Jo(RAOB) = ',DLJORAOB
write(nulout,'(a15,f23.16)') 'Jo(AIREP) = ',DLJOAIREP
write(nulout,'(a15,f23.16)') 'Jo(SURFC) = ',DLJOSURFC
write(nulout,'(a15,f23.16)') 'Jo(ATOV) = ',DLJOTOV
write(nulout,'(a15,f23.16)') 'Jo(GOES) = ',DLJOGOES
write(nulout,'(a15,f23.16)') 'Jo(SATWIND)= ',DLJOSATWIND
write(nulout,'(a15,f23.16)') 'Jo(PROF) = ',DLJOPROF
write(nulout,'(a15,f23.16)') 'Jo(GPSRO) = ',DLJOGPSRO
write(nulout,'(a15,f23.16)') 'Jo(GPSZTD) = ',DLJOGPSZTD
endif
DEALLOCATE(robdata8_g)
!
endif
contains
function sumJo(kbegin,klast,ll_mask) 4
*
real*8 :: sumJo
integer, intent(in) :: kbegin,klast
logical, intent(in), dimension(ndatap) :: ll_mask
*
* Local variables
*
integer :: jdata
sumJo = 0.d0
DO JDATA=kbegin,klast
IF (ll_mask(jdata)) THEN
sumJo = sumJo + ROBDATA8_g(JDATA)
ENDIF
END DO
return
END function sumJo
SUBROUTINE restore_robdata8(robdata8_g,kdata) 1
INTEGER :: kdata
REAL*8 ,DIMENSION(kdata) :: robdata8_g
!ping
REAL*8 ,DIMENSION(kdata) :: robdata8_t
INTEGER :: i,ii,j ,iobs,idata,idataend,ierr
integer :: aaa ,bbb
ii=0
aaa=size(MOBHDR_G,1)
bbb=size(MOBHDR_G,2)
robdata8_g=0.0D0
!ping
robdata8_t=0.0D0
DO i=1,nobtot
iobs=locObsTag(i)
idata=MOBHDR_G(NCMRLN,iobs)
idataend=MOBHDR_G(NCMNLV,iobs)+idata -1
DO j=idata,idataend
ii=ii+1
robdata8_g(j)=robdata8(NCMOMI,ii)
ENDDO
ENDDO
!ping CALL rpn_comm_allreduce(ROBDATA8_g,ROBDATA8_g,kdata,"MPI_DOUBLE_PRECISION","MPI_SUM","GRID",ierr)
CALL rpn_comm_allreduce(ROBDATA8_g,ROBDATA8_t,kdata,
& "MPI_DOUBLE_PRECISION","MPI_SUM","GRID",ierr)
ROBDATA8_g = ROBDATA8_t
END SUBROUTINE restore_robdata8
end subroutine oda_sumJo