!-------------------------------------- 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 tovs_calc_jo(pjo,llprint,lobsSpaceData,dest_obs) 1,25
#if defined (doc)
!
!**s/r tovs_calc_jo - computation of jo and the residuals to the tovs observations
! (adapted from part of code of dobstovs)
!
!
!author : j. halle *cmda/aes december 14, 2004
!
!revision 001 : a. beaulne *cmda/smc june 2006
! -modifications for AIRS (codtyp 183)
!
!revision 002 : r. sarrazin cmda april 2008
! -modifications for CSR (codtyp 185)
!
!revision 003 : s. heilliette
! -modifications for IASI (codtyp 186)
!
!revision 004 : s. heilliette
! -modifications for RTTOV-10 (December 2010)
!
!revision 005 : s. macpherson
! -modifications for ATMS (codtyp 192)
! -modifications for CrIS (codtyp 193)
!revision 006 : s. macpherson nov 2012
! - remove #include "comtovst.cdk"
! -------------------
! purpose:
!
!arguments
! pjo: total value of jo for tovs
!
#endif
use rmatrix_mod
use tovs_nl_mod
use obsSpaceData_mod
implicit none
real(8) :: pjo
logical :: llprint
type(struct_obs) :: lobsSpaceData
integer, intent(in) :: dest_obs ! probably set to OBS_OMP or OBS_OMA
integer :: isens, indxchn, indxtovs
real*8 dlsum, zdtb, zjon,zgami,zqcarg
real*8 zjoch (0:jpchmax,jpnsatmax)
real*8 zavgnrm(0:jpchmax,jpnsatmax)
integer j, i, krtid, nchanperline, indxs, indxe
integer inobsjo, incanjo
integer idatyp
integer ichn, ichOBS_A, jl
integer inobsch(0:jpchmax,jpnsatmax)
integer lcanjo(jpchmax)
integer :: index_header, index_body
real (8) :: x(jpchmax),y(jpchmax)
integer :: list_chan(jpchmax)
integer :: count
integer isrcheq
external isrcheq
external abort3d
write(*,*) "Entering tovs_calc_jo subroutine"
if(NOBTOV.eq.0) return ! exit if there are not tovs data
! 1. Computation of (hx - z)/sigma for tovs data only
! ------------------------------------------------
dlsum = 0.D0
inobsjo = 0
do j = 1, nsensors
do i = 0, jpchmax
inobsch(i,j) = 0
zjoch (i,j) = 0.0D0
zavgnrm(i,j) = 0.0D0
enddo
enddo
! loop over all header indices of the 'TO' family
call obs_set_current_header_list(lobsSpaceData,'TO')
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
! 1.1 Extract general information for this observation point
! ------------------------------------------------------
! process only radiance data to be assimilated?
idatyp = obs_headElem_i(lobsSpaceData,OBS_ITY,index_header)
if ( .not. tvs_Is_idburp_tovs(idatyp) ) cycle HEADER
indxtovs = ltovsno(index_header)
if ( indxtovs .eq. 0 ) then
write(*,fmt=9203)
9203 format(' tovs_calc_jo: error with indxtovs')
call abort3d('tovs_calc_jo ')
endif
isens = lsensor(indxtovs)
! Set the body list
! (& start at the beginning of the list)
call obs_set_current_body_list(lobsSpaceData, index_header)
count=0
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0 ) then
if (count>0 .and. rmat_lnondiagr) then
call rmat_sqrtRm1(isens,count,x(1:count),y(1:count),list_chan(1:count),indxtovs)
dlsum = dlsum + 0.5d0*dot_product(y(1:count),y(1:count))
endif
exit BODY
endif
! Only consider if flagged for assimilation
if ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body).ne.1 ) cycle BODY
ichn = nint(obs_bodyElem_r(lobsSpaceData,OBS_PPP,index_body))
ichn = max(0,min(ichn,jpchmax+1))
ichOBS_A = max(0,min(ichn,jpchmax+1))
ichn=ichn-chanoffset(isens)
indxchn = isrcheq (ichan(:,isens),nchan(isens),ichn)
if ( indxchn .eq. 0 ) then
write(*,fmt=9202)
9202 format(' tovs_calc_jo: error with channel number')
call abort3d('tovs_calc_jo ')
endif
zdtb = obs_bodyElem_r(lobsSpaceData,OBS_PRM,index_body) - &
radiance_d (indxtovs) % bt(indxchn)
if ( ldbgtov ) then
write(*,'(a,i4,2f8.2,f6.2)') ' ichn,sim,obs,diff= ', &
ichn, radiance_d (indxtovs) % bt(indxchn), &
obs_bodyElem_r(lobsSpaceData,OBS_PRM,index_body), -zdtb
endif
call obs_bodySet_r(lobsSpaceData,dest_obs,index_body, zdtb)
! Comment out the modification of Jobs due to varqc for now, since this is probably
! only needed for use of nonlinear obs operator in minimization, which is not yet
! functional, but this interferes with doing ensemble of analyses (M. Buehner, Dec. 2013)
!if (.not. min_lvarqc .or. obs_bodyElem_r(lobsSpaceData,OBS_POB,index_body).eq.0.0d0) then
dlsum = dlsum &
+ (obs_bodyElem_r(lobsSpaceData,dest_obs,index_body)* &
obs_bodyElem_r(lobsSpaceData,dest_obs,index_body)) &
/ (2.D0 * obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body) &
* obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body))
!else
! compute contribution of data with varqc
! zgami = obs_bodyElem_r(lobsSpaceData,OBS_POB,index_body)
! zjon = (obs_bodyElem_r(lobsSpaceData,dest_obs,index_body)* &
! obs_bodyElem_r(lobsSpaceData,dest_obs,index_body))/2.D0
! zqcarg = zgami + exp(-1.0D0*zjon)
! dlsum= dlsum - log(zqcarg/(zgami+1.D0))
!endif
count=count+1
x(count)=zdtb
list_chan(count)=ichn
inobsjo = inobsjo + 1
inobsch(ichOBS_A,Isens) = inobsch(ichOBS_A,Isens) + 1
zjoch(ichOBS_A,Isens) = &
zjoch(ichOBS_A,Isens) &
+ obs_bodyElem_r(lobsSpaceData,dest_obs,index_body)* &
obs_bodyElem_r(lobsSpaceData,dest_obs,index_body) &
/ (obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body)* &
obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body))
zavgnrm(ichOBS_A,Isens) = &
zavgnrm(ichOBS_A,Isens) - &
obs_bodyElem_r(lobsSpaceData,dest_obs,index_body)/ &
obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body)
enddo BODY
enddo HEADER
! 2. Close up, print summary
! . -----------------------
pjo = dlsum
! printout of mean jo and normalized average for each sensor.
nchanperline = 18
if ( llprint .and. inobsjo .gt. 0 ) then
write(*,fmt=9000)
do krtid = 1, nsensors
do i = 1, jpchmax
inobsch(0,krtid) = inobsch(0,krtid) + &
inobsch(i,krtid)
zjoch(0,krtid) = zjoch(0,krtid) + &
zjoch(i,krtid)
zavgnrm(0,krtid) = zavgnrm(0,krtid) + &
zavgnrm(i,krtid)
enddo
enddo
do jl = 1, nsensors
incanjo = 0
do i = 0, jpchmax
if ( inobsch(i,jl) .ne. 0 ) then
incanjo = incanjo + 1
lcanjo(incanjo) = i
endif
enddo
if ( incanjo .ne. 0 ) then
write(*,'(/1x,"sensor #",i2,". platform: ",a, &
& "instrument: ",a)') &
jl, csatid(jl), cinstrumentid(jl)
do j = 1, incanjo, nchanperline
indxs = j
indxe = min(j+nchanperline-1,incanjo)
if ( j .eq. 1 ) then
write(*,'(1x,"channel",t13," all",17i6)') &
(lcanjo(i),i=indxs+1,indxe)
else
write(*,'(1x,"channel",t13,18i6)') &
(lcanjo(i),i=indxs,indxe)
endif
write(*,'(1x,"no. obs.",t13,18i6)') &
(inobsch(lcanjo(i),jl),i=indxs,indxe)
write(*,'(1x,"mean jo",t13,18f6.2)') &
(zjoch(lcanjo(i),jl)/max(1,inobsch(lcanjo(i),jl)) &
,i=indxs,indxe)
write(*,'(1x,"norm. bias",t13,18f6.2,/)') &
(zavgnrm(lcanjo(i),jl)/max(1,inobsch(lcanjo(i),jl)) &
,i=indxs,indxe)
enddo
endif
enddo
endif
9000 format(//,10x,"-tovs_calc_jo: computing jo and residuals to tovs" &
& ," observations")
end subroutine tovs_calc_jo