SUBROUTINE oda_sumJo(PJO),5
use modmask, only : lmasksf_in,lmasksf_out,lmaskpp_in,lmaskpp_out
use modmask, only : lmaskto,lmaskgo,lmaskro,lmaskzp,lmask
use modmask, only : lmasktr, lmasktr_all
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 Y. Yang Feb. 2010
c - Added comnumbr.cdk due to dependencies on JPNBRELEM in cvcord.cdk
c Y. Yang Aug. 2010
c - Added storing of Jo's for each family for chi-2 test
c Y.J. Rochon May/Aug 2010
c - Added additional output IJOFM, CTRSTNID, NETR and module isumJo
c plus some other adjustment to the TR case.
c
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comdim.cdk"
#include "comchem.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "partov.cdk"
#include "comchi2test.cdk"
*
INTEGER IBEGIN,ILAST,ILASTOB,IBEGINOB,IDATEND
INTEGER J,JDATA,JO,IDATA,ITYP
LOGICAL LLOK
logical, dimension(ndata) :: llmask
real*8,target :: dljoraob,dljoairep,dljosatwind,dljosurfc,dljotov
real*8,target :: dljogoes,dljoprof,dljogpsro
real*8 :: dlsum1
real*8, pointer :: dlsum
REAL*8,target :: DLJOFM(NCMTMAX), DLJOALL_TR
integer jj, IJOFM(NCMTMAX)
C Compute the observation cost function value based on the sequence of
c the data array
pjo = pjo + sumJo
(1,ndata,lmask)
c
c Compute family contributions for diagnostic purposes
c The remaining of the code has no effect on the minimization
c
dljoraob = 0.d0
dljoairep = 0.d0
dljosatwind = 0.d0
dljosurfc = 0.d0
dljotov = 0.d0
dljogoes = 0.d0
dljogpsro = 0.d0
dljoprof = 0.d0
DLJOALL_TR= 0.d0
DLJOFM= 0.d0
IJOFM=0
DO J = 1,NFILES
IF (NBEGINTYP(J) .GT. 0)THEN
select case(CFAMTYP(J))
case('UA')
llmask = lmaskpp_in .or. lmaskpp_out
dlsum1 = sumJo
(nbegintyp(j),nendtyp(j),llmask)
dljoraob = dljoraob + dlsum1
c pjo = pjo + dlsum1
llmask = lmasksf_in .or. lmasksf_out
dlsum => dljosurfc
case('AI')
llmask = lmaskpp_in .or. lmaskpp_out
dlsum => dljoairep
case('SW')
llmask = lmaskpp_in .or. lmaskpp_out
dlsum => dljosatwind
case('SF','SC')
llmask = lmasksf_in .or. lmasksf_out
dlsum => dljosurfc
case('TO')
llmask = lmaskto
dlsum => dljotov
case('GO')
llmask = lmaskgo
dlsum => dljogoes
case('RO')
llmask = lmaskro
dlsum => dljogpsro
case('PR')
llmask = lmaskzp
dlsum => dljoprof
case('TR')
do JJ=1,NCMTASSI
llmask = lmasktr(JJ,:)
dlsum => DLJOFM(JJ)
dlsum = dlsum + sumJo
(nbegintyp(j),nendtyp(j),llmask)
ijofm(jj)=isumJo
(nbegintyp(j),nendtyp(j),llmask)
end do
llmask = lmasktr_all
dlsum => DLJOALL_TR
end select
dlsum1 = sumJo
(nbegintyp(j),nendtyp(j),llmask)
dlsum = dlsum + dlsum1
! pjo = pjo + dlsum1
endif
end do
write(nulout,'(a15,G23.16)') 'Jo(RAOB) = ',DLJORAOB
write(nulout,'(a15,G23.16)') 'Jo(AIREP) = ',DLJOAIREP
write(nulout,'(a15,G23.16)') 'Jo(SURFC) = ',DLJOSURFC
write(nulout,'(a15,G23.16)') 'Jo(ATOV) = ',DLJOTOV
write(nulout,'(a15,G23.16)') 'Jo(GOES) = ',DLJOGOES
write(nulout,'(a15,G23.16)') 'Jo(SATWIND)= ',DLJOSATWIND
write(nulout,'(a15,G23.16)') 'Jo(PROF) = ',DLJOPROF
write(nulout,'(a15,G23.16)') 'Jo(GPSRO) = ',DLJOGPSRO
if (NCMTASSI.GT.0) then
write(nulout,'(a15,G23.16)') 'Jo(TR) = ',DLJOALL_TR
do JJ=1,NCMTASSI
write(nulout,'(3x,a5,a4,a6,G23.16,2x,i10,a5,i7,1x,a9,)')
1 'Jo(',CNAMANAL(JJ),') = ',DLJOFM(JJ),IJOFM(JJ),
2 ' for ',NETR(JJ),CTRSTNID(JJ)
end do
end if
write(nulout,*)
!
cfamobs(1:JPFILES+1) = ''
cfamobs_tr(1:NCMTASSI) = ''
STJO(1:JPFILES+1)=0.0
!
! Fill in the family name for chi-2 test. Sequence in CFAMOBS does
! not necessarily follow that in CFAMTYP but those in NMBOBS_ASS
! and STJO have to be the same as in CFAMOBS, while those in
! NMBOBS_TR and STJO_TR have to be same as in CFAMOBS_TR.
!
CFAMOBS(1)='UA'
CFAMOBS(2)='AI'
CFAMOBS(3)='SW'
CFAMOBS(4)='SF'
CFAMOBS(5)='TO'
CFAMOBS(6)='GO'
CFAMOBS(7)='RO'
CFAMOBS(8)='PR'
CFAMOBS(9)='TR'
CFAMOBS(JPFILES+1)='ALL'
do JJ=1,NCMTASSI
CFAMOBS_TR(JJ)=CNAMANAL(JJ)
end do
!
! store Jo's for chi-2 test
! Jo's are stored for family type and for each species if applicable..
!
STJO(1)=DLJORAOB
STJO(2)=DLJOAIREP
STJO(3)=DLJOSATWIND
STJO(4)=DLJOSURFC
STJO(5)=DLJOTOV
STJO(6)=DLJOGOES
STJO(7)=DLJOGPSRO
STJO(8)=DLJOPROF
STJO(9)=DLJOALL_TR
STJO(JPFILES+1)=SUM(STJO(1:JPFILES))
do JJ=1,NCMTASSI
STJO_TR(JJ)=DLJOFM(JJ)
end do
contains
function sumJo(kbegin,klast,ll_mask) 4
*
real*8 :: sumJo
integer, intent(in) :: kbegin,klast
logical, intent(in), dimension(ndata) :: ll_mask
*
* Local variables
*
integer :: jdata
sumJo = 0.d0
DO JDATA=kbegin,klast
IF (ll_mask(jdata)) THEN
sumJo = sumJo + ROBDATA8(NCMOMI,JDATA)
ENDIF
END DO
return
END function sumJo
function isumJo(kbegin,klast,ll_mask) 1
*
integer :: isumJo
integer, intent(in) :: kbegin,klast
logical, intent(in), dimension(ndata) :: ll_mask
*
* Local variables
*
integer :: jdata
isumJo = 0
DO JDATA=kbegin,klast
IF (ll_mask(jdata)) THEN
isumJo = isumJo + 1
ENDIF
END DO
return
END function isumJo
end subroutine oda_sumJo