subroutine evaljo(pjo,kobs,kprt,louter) !$$$ subprogram documentation block ! . . . . ! subprogram: evaljo ! prgmmr: tremolet ! ! abstract: Computes and prints Jo components ! ! program history log: ! 2007-03-01 tremolet ! 2009-01-15 todling - quad precision for reproducibility ! 2009-08-14 lueken - update documentation ! ! input argument list: ! kprt - print level ! louter ! ! output argument list: ! kobs - Number of obs used in evaluating Jo ! pjo - Jo value ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block use kinds, only: r_kind,i_kind,r_quad use obsmod, only: nobs_type,cobstype,obsdiags,obsptr,obscounts use gsi_4dvar, only: nobs_bins use constants, only: izero,ione,zero_quad use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_integer,mype use jfunc, only: jiter use mpl_allreducemod, only: mpl_allreduce implicit none ! Declare passed variables real(r_quad) ,intent( out) :: pjo integer(i_kind),intent( out) :: kobs integer(i_kind),intent(in ) :: kprt logical ,intent(in ) :: louter ! Declare local variables integer(i_kind) :: ii,jj,ij,ilen integer(i_kind) :: iobs(nobs_type) real(r_quad) :: zjo,zz real(r_kind) :: zdep real(r_quad) :: zjo2(nobs_type,nobs_bins) real(r_quad) :: zjo1(nobs_type) real(r_quad) :: zprods(nobs_type*nobs_bins) integer(i_kind) :: iobsgrp(nobs_type,nobs_bins),iobsglb(nobs_type,nobs_bins) ! ---------------------------------------------------------- zprods(:)=zero_quad iobsgrp(:,:)=izero iobsglb(:,:)=izero ij=izero do ii=1,nobs_bins do jj=1,nobs_type ij=ij+ione obsptr => obsdiags(jj,ii)%head do while (associated(obsptr)) if (obsptr%luse.and.obsptr%muse(jiter)) then if (louter) then zdep=obsptr%nldepart(jiter) else zdep=obsptr%tldepart(jiter)-obsptr%nldepart(jiter) endif zprods(ij) = zprods(ij) + obsptr%wgtjo * zdep * zdep iobsgrp(jj,ii)=iobsgrp(jj,ii)+ione endif obsptr => obsptr%next enddo enddo enddo ! Sum Jo contributions call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods) ! Sum number of observations ilen=nobs_bins*nobs_type call mpi_allreduce(iobsgrp,iobsglb,ilen, & & mpi_integer,mpi_sum,mpi_comm_world,ierror) ! Gather Jo contributions ij=izero do ii=1,nobs_bins do jj=1,nobs_type ij=ij+ione zjo2(jj,ii)=zprods(ij) enddo enddo zjo1=zero_quad iobs=izero DO ii=1,nobs_bins zjo1(:)=zjo1(:)+zjo2(:,ii) iobs(:)=iobs(:)+iobsglb(:,ii) ENDDO zjo=zero_quad kobs=izero DO ii=1,nobs_type zjo=zjo+zjo1(ii) kobs=kobs+iobs(ii) ENDDO pjo=zjo ! Prints IF (kprt>=2_i_kind.and.mype==izero) THEN if (louter) then write(6,*)'Begin Jo table outer loop' else write(6,*)'Begin Jo table inner loop' endif IF (kprt>=3_i_kind.and.nobs_bins>ione) THEN write(6,400)'Observation Type','Bin','Nobs','Jo','Jo/n' DO ii=1,nobs_type DO jj=1,nobs_bins IF (iobsglb(ii,jj)>izero) THEN zz=zjo2(ii,jj)/iobsglb(ii,jj) write(6,100)cobstype(ii),jj,iobsglb(ii,jj),real(zjo2(ii,jj),r_kind),real(zz,r_kind) ENDIF ENDDO ENDDO ENDIF write(6,400)'Observation Type',' ','Nobs','Jo','Jo/n' DO ii=1,nobs_type IF (iobs(ii)>izero) THEN zz=zjo1(ii)/iobs(ii) write(6,200)cobstype(ii),iobs(ii),real(zjo1(ii),r_kind),real(zz,r_kind) ENDIF ENDDO IF (kobs>izero) THEN zz=zjo/kobs ELSE zz=-999.999_r_quad ENDIF write(6,400)' ',' ','Nobs','Jo','Jo/n' write(6,300)"Jo Global",kobs,real(zjo,r_kind),real(zz,r_kind) if (louter) then write(6,*)'End Jo table outer loop' else write(6,*)'End Jo table inner loop' endif ENDIF if (.not.allocated(obscounts)) then write(6,*)'evaljo: obscounts not allocated' call stop2(125) end if obscounts(:,:)=iobsglb(:,:) 100 format(a20,2x,i3,2x,i8,2x,es24.16,2x,f10.3) 200 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) 300 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) 400 format(a20,2x,a3,2x,a8,2x,a24,4x,a8) ! ---------------------------------------------------------- return end subroutine evaljo