SUBROUTINE DOTEUCL(CDCTL,KULOUT)
#if defined (DOC)
!
! **s/r DOTEUCL - Evaluation of the euclidean inner product
!
!
! Author : P. Gauthier *ARMA/AES June 9, 1992
! Revision:
! L. Fillion *RPN/AES Feb 93 - Observation space option added.
! P. Gauthier *ARMA/AES May 25,1993: -Treatment of specific humidity
! and surface pressure (for all options)
! L. Fillion *RPN/AES Dec 93 - Barotropic energy norm option added.
! S. Pellerin *ARMA/AES Sept 97.
! - Control of the different model state of the 3Dvar
! through COMSTATE, COMSTATEC and COMSTNUM common
! blocks variables (comstate.cdk).
! J. Halle *CMDA/AES Oct 99.
! - Added ground temperature (TG) to the model state.
! P. Gauthier *ARMA/MSC February 2003
! - Added include "comchem.cdk" for chemistry
! - Added extra loop for chemical species
! . Y. Yang Oct. 2003*
! Introduction of the total energy norm
!
! -------------------
! * Purpose: to evaluate the euclidean inner product in either
! . spectral or physical space.(FOR MODEL STATES ONLY)
! . Used to test the adjoint of the spectral transforms
!
! Arguments
! i- CDCTL = 'G' inner product evaluated in PHYSICAL space
! . Implicit input: COMGD and COMGD1
! i- CDCTL = 'S' inner product evaluated in SPECTRAL space
! . Implicit input: COMSP and COMSP1
! i- CDCTL = 'E' energy inner product evaluated in SPECTRAL space
! . Implicit input: COMSP and COMSP1
! i- CDCTL = 'M' inner product evaluated in OBSERVATION space
! . Implicit input: COMMVO and COMMVO1
! i- KULOUT: logical unit for printing
!
#endif
use modstag, only: rwt_s,level2_staggrid
IMPLICIT NONE
! implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comcst.cdk"
#include "comleg.cdk"
#include "comgem.cdk"
#include "comchem.cdk"
#include "comgd0.cdk"
#include "comgd1.cdk"
#include "comsp.cdk"
#include "comsp1.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "comstate.cdk"
!
!
INTEGER KULOUT
CHARACTER*1 CDCTL
REAL*8 :: DLTOTU, DLTOTV, DLTOTG, DLTOTDIV, DLTOTVOR
S , DLTOTQ, DLTOTPS, DLTOTTG, DLTOTO, DLTOTR,dltott
!
! Select type of inner product
!
real*8 :: DLENER_rot(nflev), dlener_div(nflev), dlener_ape(nflev)
REAL*8 :: DLTMPU, DLTMPV,DLTMPG, DLTMPQ, DLKINE, dltotal_energy
REAL*8 :: DLTMPO, DLTMPR,dltmpt, ztref, zpref, dlwt_v(njbeg:njend)
real*8 :: dldel_eta(1:nflev)
INTEGER :: JLEV, JLON, ILON, JGL, JLA, JOBS
INTEGER :: JJ, NLEV
! Select type of inner product
!
select case(cdctl)
!
case('G')
!
! 1. Inner product in physical space
! -------------------------------
!
WRITE(KULOUT,FMT=9100)
9100 FORMAT(//,40(' *'),/,5x,'DOTEUCL- Computation of the euclidean inner'
S ,' product in grid space',/,1x,'LEVEL'
S ,5x,'U-part',9x,'V-part',9x
S ,5X,'Total U + V ',5x,'TT-part',5x,'Q-part'
! & ,9x,'OZ-part',9x,'TR-part','GZ-part'
S )
!
dlwt_v(:) = rwt(:)
if(level2_staggrid) then
dlwt_v(:) = rwt_s(:)
end if
DO JLEV = 1, NFLEV
DLTOTU = 0.
DLTOTV = 0.
DLTOTG = 0.
DLTOTQ = 0.
DLTOTT = 0.
DLTOTO = 0.
DLTOTR = 0.
DO JGL = 1, NJ
DLTMPU = 0.
DLTMPV = 0.
DLTMPG = 0.
DLTMPT = 0.
DLTMPQ = 0.
DLTMPO = 0.
DLTMPR = 0.
ILON = NILON(JGL)
!
IF(NGEXIST(NGUU) .EQ. 1) THEN
DO JLON = 1,ILON
DLTMPU = DLTMPU + UT0(JLON,JLEV,JGL)*UT1(JLON,JLEV,JGL)
END DO
ENDIF
IF(NGEXIST(NGVV) .EQ. 1) THEN
DO JLON = 1,ILON
DLTMPV = DLTMPV + VT0(JLON,JLEV,JGL)*VT1(JLON,JLEV,JGL)
END DO
ENDIF
IF(NGEXIST(NGGZ) .EQ. 1) THEN
DO JLON = 1,ILON
DLTMPG = DLTMPG + GZ0(JLON,JLEV,JGL)*GZ1(JLON,JLEV,JGL)
END DO
ENDIF
IF(NGEXIST(NGQ) .EQ. 1) THEN
DO JLON = 1,ILON
DLTMPQ = DLTMPQ + Q0(JLON,JLEV,JGL)*Q1(JLON,JLEV,JGL)
END DO
ENDIF
IF(NGEXIST(NGTT) .EQ. 1) THEN
DO JLON = 1,ILON
DLTMPT = DLTMPT + TT0(JLON,JLEV,JGL)*TT1(JLON,JLEV,JGL)
END DO
ENDIF
DO JJ = 1, NGCMT
IF(NGEXIST(NGTR(JJ)) .EQ. 1) THEN
NLEV = (JJ-1)*NFLEV + JLEV
DO JLON = 1,ILON
DLTMPR = DLTMPR +
S GTR0(JLON,NLEV,JGL)*GTR1(JLON,NLEV,JGL)
END DO
ENDIF
ENDDO
!
DLTOTU = DLTOTU + RWT(JGL)*DLTMPU/FLOAT(ILON)
DLTOTV = DLTOTV + DLWT_V(JGL)*DLTMPV/FLOAT(ILON)
DLTOTG = DLTOTG + RWT(JGL)*DLTMPG/FLOAT(ILON)
DLTOTQ = DLTOTQ + RWT(JGL)*DLTMPQ/FLOAT(ILON)
DLTOTT = DLTOTT + RWT(JGL)*DLTMPT/FLOAT(ILON)
DLTOTO = DLTOTO + RWT(JGL)*DLTMPO/FLOAT(ILON)
DLTOTR = DLTOTR + RWT(JGL)*DLTMPR/FLOAT(ILON)
end do
DLKINE = DLTOTU + DLTOTV
!
! * . 1.1 Specific humidity
!
WRITE(KULOUT,9500)JLEV,DLTOTU,DLTOTV,DLKINE,DLTOTT,DLTOTQ
! & ,DLTOTO,DLTOTR,DLTOTG
! WRITE(KULOUT,9501)
! S JLEV,DLTOTU,DLTOTV
! WRITE(KULOUT,9502) DLTOTG,DLKINE,DLTOTQ
!
end do
!
! * . 1.2 Surface pressure
!
IF(NGEXIST(ngps).eq.1) THEN
DLTOTPS = 0.
DO JGL = 1, NJ
ILON = NILON(JGL)
DLTMPQ = 0.
DO JLON = 1, ILON
DLTMPQ = DLTMPQ + GPS0(JLON,1,JGL)*GPS1(JLON,1,JGL)
end do
!
DLTOTPS = DLTOTPS + RWT(JGL)*DLTMPQ/FLOAT(ILON)
end do
WRITE(KULOUT,FMT='(8X,"SURFACE PRESSURE:",4X,G12.6)')DLTOTPS
END IF
!
! * . 1.3 Ground temperature
!
IF(NGEXIST(ngtg).eq.1) THEN
DLTOTTG = 0.
DO JGL = 1, NJ
ILON = NILON(JGL)
DLTMPQ = 0.
DO JLON = 1, ILON
DLTMPQ = DLTMPQ + GTG0(JLON,1,JGL)*GTG1(JLON,1,JGL)
end do
DLTOTTG = DLTOTTG + RWT(JGL)*DLTMPQ/FLOAT(ILON)
end do
WRITE(KULOUT,FMT='(8X,"GROUND TEMPERATURE:",4X,G12.6)') DLTOTTG
END IF
case('S')
!
! 2. Inner product in spectral space
! -------------------------------
!
!
WRITE(KULOUT,FMT=9200)
9200 FORMAT(//,40(' *'),/,5x,'Computation of inner product in spectral space'
S ,/,1x,'LEVEL'
S ,5x,'VOR-part',8x,' DIV-part'
S ,5x,'Total wind part',8x,'TT-part',5x,'Q-part'
! & ,9x,'OZ-part',9x,'TR-part',8x,'GZ-part'
S )
!
DO JLEV = 1, NFLEV
DLTOTDIV = 0.
DLTOTVOR = 0.
DLTOTG = 0.
DLTOTQ = 0.
DLTOTT = 0.
DLTOTO = 0.
DLTOTR = 0.
if (nsexist(nsvor) .eq. 1) then
DO JLA = NTRUNC+2, NLA
DLTOTVOR = DLTOTVOR + SPVOR1(JLA,1,JLEV)*SPVOR(JLA,1,JLEV) + SPVOR1(JLA,2,JLEV)*SPVOR(JLA,2,JLEV)
end do
endif
if (nsexist(nsdiv) .eq. 1) then
DO JLA = NTRUNC+2, NLA
DLTOTDIV = DLTOTDIV + SPDIV1(JLA,1,JLEV)*SPDIV(JLA,1,JLEV) + SPDIV1(JLA,2,JLEV)*SPDIV(JLA,2,JLEV)
end do
endif
if (nsexist(nsgz) .eq. 1) then
DO JLA = NTRUNC+2, NLA
DLTOTG = DLTOTG + SPGZ1(JLA,1,JLEV)*SPGZ(JLA,1,JLEV) + SPGZ1(JLA,2,JLEV)*SPGZ(JLA,2,JLEV)
end do
endif
if (nsexist(nsq) .eq. 1) then
DO JLA = NTRUNC+2, NLA
DLTOTQ = DLTOTQ + SPQ1(JLA,1,JLEV)*SPQ(JLA,1,JLEV)+ SPQ1(JLA,2,JLEV)*SPQ(JLA,2,JLEV)
end do
endif
if (nsexist(nstt) .eq. 1) then
DO JLA = NTRUNC+2, NLA
DLTOTT = DLTOTT + SPTT1(JLA,1,JLEV)*SPTT(JLA,1,JLEV)+ SPTT1(JLA,2,JLEV)*SPTT(JLA,2,JLEV)
end do
endif
do jj = 1, nscmt
if (nsexist(nstr(jj)) .eq. 1) then
NLEV = (JJ-1)*NFLEV + JLEV
DO JLA = NTRUNC+2, NLA
DLTOTR = DLTOTR
S + SPTR1(JLA,1,NLEV)*SPTR(JLA,1,NLEV)
S + SPTR1(JLA,2,NLEV)*SPTR(JLA,2,NLEV)
end do
endif
enddo
!
DLTOTVOR = 2.D0*DLTOTVOR
DLTOTDIV = 2.D0*DLTOTDIV
DLTOTG = 2.D0*DLTOTG
DLTOTT = 2.D0*DLTOTT
DLTOTQ = 2.D0*DLTOTQ
DLTOTO = 2.D0*DLTOTO
DLTOTR = 2.D0*DLTOTR
!
if (nsexist(nsvor) .eq. 1) then
DO JLA = 1, NTRUNC + 1
DLTOTVOR = DLTOTVOR + SPVOR1(JLA,1,JLEV)*SPVOR(JLA,1,JLEV)
end do
endif
if (nsexist(nsdiv) .eq. 1) then
DO JLA = 1, NTRUNC + 1
DLTOTDIV = DLTOTDIV + SPDIV1(JLA,1,JLEV)*SPDIV(JLA,1,JLEV)
end do
endif
if (nsexist(nsgz) .eq. 1) then
DO JLA = 1, NTRUNC + 1
DLTOTG = DLTOTG + SPGZ1(JLA,1,JLEV)*SPGZ(JLA,1,JLEV)
end do
endif
if (nsexist(nsq) .eq. 1) then
DO JLA = 1, NTRUNC + 1
DLTOTQ = DLTOTQ + SPQ1(JLA,1,JLEV)*SPQ(JLA,1,JLEV)
end do
endif
if (nsexist(nstt) .eq. 1) then
DO JLA = 1, NTRUNC + 1
DLTOTT = DLTOTT + SPTT1(JLA,1,JLEV)*SPTT(JLA,1,JLEV)
end do
endif
do jj = 1, nscmt
if (nsexist(nstr(jj)) .eq. 1) then
NLEV = (JJ-1) *NFLEV +JLEV
DO JLA = 1, NTRUNC + 1
DLTOTR = DLTOTR
S + SPTR1(JLA,1,NLEV)*SPTR(JLA,1,NLEV)
enddo
endif
end do
!
DLKINE = DLTOTVOR + DLTOTDIV
!
WRITE(KULOUT,9500) JLEV,DLTOTVOR,DLTOTDIV,DLKINE,DLTOTT,DLTOTQ
! & ,DLTOTO,DLTOTR,DLTOTG
!
end do
!
! * . 2.2 Surface pressure
! . ----------------
!
IF(NSEXIST(nsps).eq.1) THEN
DLTOTPS = 0.
DO JLA = NTRUNC+2, NLA
DLTOTPS = DLTOTPS + SPPS1(JLA,1,1)*SPPS(JLA,1,1) + SPPS1(JLA,2,1)*SPPS(JLA,2,1)
end do
DLTOTPS = 2.D0*DLTOTPS
DO JLA = 1, NTRUNC + 1
DLTOTPS = DLTOTPS + SPPS1(JLA,1,1)*SPPS(JLA,1,1)
end do
!
WRITE(KULOUT,FMT='(8X,"SURFACE PRESSURE:",4X,G12.6)')DLTOTPS
END IF
!
! * . 2.3 Ground temperature
! . ------------------
!
IF(NSEXIST(nstg).eq.1) THEN
DLTOTTG = 0.
DO JLA = NTRUNC+2, NLA
DLTOTTG = DLTOTTG + SPTG1(JLA,1,1)*SPTG(JLA,1,1) + SPTG1(JLA,2,1)*SPTG(JLA,2,1)
end do
DLTOTTG = 2.D0*DLTOTTG
DO JLA = 1, NTRUNC + 1
DLTOTTG = DLTOTTG + SPTG1(JLA,1,1)*SPTG(JLA,1,1)
end do
WRITE(KULOUT,FMT='(8X,"GROUND TEMPERATURE:",4X,G12.6)') DLTOTTG
END IF
!
!
case('M')
!
! 3. Inner product in observation space
! ----------------------------------
!
!
WRITE(KULOUT,FMT=9300)
9300 FORMAT(40(' *'),/,5x,'Computation of the euclidean inner',
S ' product in observation space',/,1x,'LEVEL',
S 5x,'U-part',9x,'V-part'
S ,5X,'Kinetic Energy',5x,'TT-part',5x,'Q-part'
! & ,9x,'OZ-part',9x,'TR-part',9x,'GZ-part'
S )
!
DO JLEV = 1, NFLEV
DLTOTU = 0.
DLTOTV = 0.
DLTOTG = 0.
DLTOTQ = 0.
DLTOTT = 0.
DLTOTO = 0.
DLTOTR = 0.
if (nmvoexist(nouu) .eq. 1) then
DO JOBS = 1, NOBTOT
DLTOTU = DLTOTU + GOMU(JLEV,JOBS)*GOMU1(JLEV,JOBS)
END DO
endif
if (nmvoexist(novv) .eq. 1) then
DO JOBS = 1, NOBTOT
DLTOTV = DLTOTV + GOMV(JLEV,JOBS)*GOMV1(JLEV,JOBS)
END DO
endif
if (nmvoexist(nogz) .eq. 1) then
DO JOBS = 1, NOBTOT
DLTOTG = DLTOTG + GOMGZ(JLEV,JOBS)*GOMGZ1(JLEV,JOBS)
END DO
endif
if (nmvoexist(nott) .eq. 1) then
DO JOBS = 1, NOBTOT
DLTOTT = DLTOTT + GOMT(JLEV,JOBS)*GOMT1(JLEV,JOBS)
END DO
endif
if (nmvoexist(noq) .eq. 1) then
DO JOBS = 1, NOBTOT
DLTOTQ = DLTOTQ + GOMQ(JLEV,JOBS)*GOMQ1(JLEV,JOBS)
END DO
endif
do jj = 1, nocmt
if (nmvoexist(notr(jj)) .eq. 1) then
NLEV = (JJ-1)*NFLEV + JLEV
DO JOBS = 1, NOBTOT
DLTOTR = DLTOTR +
S GOMTR(NLEV,JOBS)*GOMTR1(NLEV,JOBS)
END DO
endif
enddo
!
DLKINE = DLTOTU + DLTOTV
!
WRITE(KULOUT,9500)JLEV,DLTOTU,DLTOTV,DLKINE,dltott,DLTOTQ
end do
!
! * . 3.2 Surface pressure
! . ----------------
!
IF(nmvoexist(nops).eq.1) THEN
DLTOTPS = 0.
DO JOBS = 1, NOBTOT
DLTOTPS = DLTOTPS + GOMPS(1,JOBS)*GOMPS1(1,JOBS)
end do
WRITE(KULOUT,FMT='(8X,"SURFACE PRESSURE:",4X,G12.6)') DLTOTPS
END IF
!
! * . 3.3 Ground temperature
! . ------------------
!
IF(nmvoexist(notg).eq.1) THEN
DLTOTTG = 0.
DO JOBS = 1, NOBTOT
DLTOTTG = DLTOTTG + GOMTGR(1,JOBS)*GOMTGR1(1,JOBS)
end do
WRITE(KULOUT,FMT='(8X,"GROUND TEMPERATURE:",4X,G12.6)')DLTOTTG
END IF
!
case('E') ! 4. Computing the energy norm in spectral space
!
IF(NSEXIST(NSVOR).NE.1.OR.NSEXIST(NSDIV).NE.1.OR.NSEXIST(NSTT)
S .NE.1.OR.NSEXIST(NSPS).NE.1)THEN
WRITE(KULOUT,FMT='(//4X,A)')'DOTEUCL: ENERGY NORM CANNOT BE COMPUTED'
RETURN
END IF
!
! COMPUTATION OF THICKNESS OF LAYERS FOR THE VERTICAL INTEGRATION
!
ZPREF = 100000.
ZTREF = 300.
DO JLEV = 2, NFLEV-1
DLDEL_ETA(JLEV) = VLEV(JLEV+1) - VLEV(JLEV-1)
END DO
DLDEL_ETA(1) = VLEV(2) - VLEV(1)
DLDEL_ETA(NFLEV) = VLEV(NFLEV) - VLEV(NFLEV-1)
DLDEL_ETA(:) = ZPREF*DLDEL_ETA(:)
write(kulout,*)'DOTEUCL: energy norm'
!
DLENER_ROT(:) = 0.
DLENER_DIV(:) = 0.
DLENER_APE(:) = 0.
!
write(kulout,fmt='(16x,A,4x,A,7x,A,6x,A,12x,A,4(4x,A))')'Level','p(hPa)'
S ,'Rotational','Divergent','Kinetic','Potential'
LEVELS: DO JLEV = 1, NFLEV
DO JLA = NTRUNC+2, NLA
DLENER_ROT(JLEV) = DLENER_ROT(JLEV) - R1SNP1(JLA)*(SPVOR1(JLA,1,JLEV)*SPVOR(JLA,1,JLEV)
S + SPVOR1(JLA,2,JLEV)*SPVOR(JLA,2,JLEV))*DLDEL_ETA(JLEV)
DLENER_DIV(JLEV) = DLENER_DIV(JLEV) - R1SNP1(JLA)*(SPDIV1(JLA,1,JLEV)*SPDIV(JLA,1,JLEV)
S + SPDIV1(JLA,2,JLEV)*SPDIV(JLA,2,JLEV))*DLDEL_ETA(JLEV)
DLENER_APE(JLEV) = DLENER_APE(JLEV) + (SPTT1(JLA,1,JLEV)*SPTT(JLA,1,JLEV)
S + SPTT1(JLA,2,JLEV)*SPTT(JLA,2,JLEV))*DLDEL_ETA(JLEV)
END DO
!
DLENER_ROT(JLEV) = 2.D0*DLENER_ROT(JLEV)
DLENER_DIV(JLEV) = 2.D0*DLENER_DIV(JLEV)
DLENER_APE(JLEV) = 2.D0*DLENER_APE(JLEV)
!
DO JLA = 1, NTRUNC + 1
DLENER_ROT(JLEV) = DLENER_ROT(JLEV) + R1SNP1(JLA)*SPVOR1(JLA,1,JLEV)*SPVOR(JLA,1,JLEV)*DLDEL_ETA(JLEV)
DLENER_DIV(JLEV) = DLENER_DIV(JLEV) + R1SNP1(JLA)*SPDIV1(JLA,1,JLEV)*SPDIV(JLA,1,JLEV)*DLDEL_ETA(JLEV)
DLENER_APE(JLEV) = DLENER_APE(JLEV) + SPTT1(JLA,1,JLEV)*SPTT(JLA,1,JLEV)*DLDEL_ETA(JLEV)
END DO
!
!
DLENER_ROT(JLEV) = DLENER_ROT(JLEV)*RA*RA/2.
DLENER_DIV(JLEV) = DLENER_DIV(JLEV)*RA*RA/2.
DLKINE = (DLENER_ROT(JLEV) + DLENER_DIV(JLEV))
DLENER_APE(JLEV) = (RCPD/ZTREF)*DLENER_APE(JLEV)
!
WRITE(KULOUT,fmt='(1X,A,I3,A,G10.2,3x,4(3X,G14.6))')'ENERGY AT LEVEL'
S , JLEV,': ',vlev(jlev)*zpref/100.
S ,DLENER_ROT(JLEV),DLENER_DIV(JLEV),DLKINE,DLENER_APE(JLEV)
END DO LEVELS
!
! CONTRIBUTION FROM SURFACE PRESSURE
!
DLTOTPS = 0.
DO JLA = NTRUNC+2, NLA
DLTOTPS = DLTOTPS + SPPS1(JLA,1,1)*SPPS(JLA,1,1) + SPPS1(JLA,2,1)*SPPS(JLA,2,1)
END DO
DLTOTPS = 2.D0*DLTOTPS
DO JLA = 1, NTRUNC + 1
DLTOTPS = DLTOTPS + SPPS1(JLA,1,1)*SPPS(JLA,1,1)
END DO
DLTOTPS = DLTOTPS*RD*ZTREF/ZPREF
!
dltotvor = sum(dlener_rot(1:nflev))
dltotdiv = sum(dlener_div(1:nflev))
dltott = sum(dlener_ape(1:nflev))
dltotal_energy = dltotvor + dltotdiv + dltott + dltotps
!
WRITE(KULOUT,FMT='(8X,"SURFACE PRESSURE:",4X,G12.6)')DLTOTPS
write(kulout,fmt='(23x,A,10x,A,8x,A,8x,A,8x,A)')'Rotational'
S ,'Divergent','Potential','Surf. Press','Total'
WRITE(KULOUT,fmt='(1X,A,3x,5(3X,G14.6))')'Total Energy: '
S ,dltotvor, dltotdiv, dltott, dltotps, dltotal_energy
!
case default ! Default case
!
!
WRITE(KULOUT,fmt ='(//,12x,A,A)')'Wrong value of control in DOTEUCL. CDCTL = ',CDCTL
END select
!
9500 format(1X,I4,3x,5(3X,G20.12))
9501 format(1X,I4,3X,G20.12,4X,G20.12,8X)
9502 format(1X,G20.12,8X,G20.12,8X,G20.12)
!
END subroutine doteucl