!-------------------------------------- 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 --------------------------------------
!
C
C  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
C

      subroutine lbal2(pgdpsi,pgdchi,pvort,pdiv,ldhelm) 1,5
*
***s/r lbal2  - 
*
*
*Author  : Luc Fillion - 10 Mar 09 - Version nanalvar=4 of lbal.ftn
*
*     -------------------
**    Purpose: Used for LA-XD-Var analysis
*
*Arguments
*     none
*
      implicit none
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comcva.cdk"
#include "comgd0.cdk"
#include "compdg.cdk"
#include "comcorr.cdk"
#include "comsim.cdk"
#include "comfftla.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
!
      logical ldhelm
      real*8 zscalt
      real*8 pgdpsi(ni,nflev,nj)
      real*8 pgdchi(ni,nflev,nj)
      real*8 pvort(ni,nflev,nj)
      real*8 pdiv(ni,nflev,nj)
!
      real*8 zu(0:ni+1,nflev,0:nj+1)
      real*8 zv(0:ni+1,nflev,0:nj+1)
      real*8 ztt(ni,nflev,nj)
      real*8 ztt0(ni,nflev,nj)
      real*8 zq(ni,nflev,nj)
      real*8 zgdchib(ni,nflev,nj)
      real*8 zomega(ni,nflev,nj)
      real*8 zp(ni,nflev,nj)
      real*8 zps0(ni,nj)
      real*8 zsppb(nla,2,nflev)
      real*8 zsptb(nla,2,nflev)
      real*8 zspt0(nla,2,nflev)
      real*8 zsps0(nla,2)
!
      logical llmass,llchib,lladiab,llconv,llcond
      logical llfplane
      integer ji,jj,jk,nip1,njp1,jk1,jk2,jband,jm,ila
      integer ilen,ierr
*
**
      llmass=.true.
      llfplane=.true.
      llchib=.false.
      if(nflev.eq.1) llchib = .false.
!
      lladiab=.true. ! has no effect if llchib .false.
      llconv=.false. ! has no effect if llchib .false.
      llcond=.false. ! has no effect if llchib .false.
!
      call zero(ni*nj*nflev,zgdchib)
!
      if(llmass) then
! T = Tb + Tu
        call linbal_la(zp,pgdpsi,llfplane,.false.,'P')
!
        if(cptot.eq.'GD') then
          zscalt = 0.1
          if(lsw) then
            do jj=1,nj            ! Barotropic option
              do ji=1,ni
                tt0(ji,mk,jj)=tt0(ji,mk,jj)+     ! tt0 already contains Tu
     &                       zscalt*zp(ji,mk,jj)
              enddo
            enddo
          else
            do jj=1,nj            ! Baroclinic option
              do ji=1,ni
                do jk2=1,nflev
                  gps0(ji,1,jj)=gps0(ji,1,jj)+
     &              ptot(nflev+1,jk2,jj)*zp(ji,jk2,jj)
                enddo
              enddo
            enddo
          endif
        else if(cptot.eq.'SP') then
          zscalt = 0.1
          if(lsw) then
            do jj=1,nj            ! Barotropic option
              do ji=1,ni
                tt0(ji,mk,jj)=tt0(ji,mk,jj)+     ! tt0 already contains Tu
     &                       zscalt*zp(ji,mk,jj)
              enddo
            enddo
          else
! 
! Ps = Ps_b + Ps_u
!
            do jj=1,nj 
              do ji=1,ni
                zps0(ji,jj) = gps0(ji,1,jj)
              enddo
            enddo
            zsps0(:,:) = 0.0
            zsppb(:,:,:) = 0.0
            call re2spla(zsps0,zps0,1)
            call re2spla(zsppb,zp,nflev)
!
            do jband = 1, nband
              do jm = 1, mbandsp(jband)
                ila=mila(jm,jband)
                do jk2 = 1, nflev
                  zsps0(ila,1) = zsps0(ila,1) +
     &              sptot(nflev+1,jk2,jband)*zsppb(ila,1,jk2)
                enddo
              enddo ! end loop on jm
            enddo ! end loop on jband
!
            call sp2rela(zps0,zsps0,1)
!
            do jj=1,nj 
              do ji=1,ni
                gps0(ji,1,jj) = zps0(ji,jj)
              enddo
            enddo
!
! tt0 = T_b + t_u
!
            do jj=1,nj 
              do jk=1,nflev
                do ji=1,ni
                  tt0(ji,jk,jj)=coriol(ji,jj)*tb0(ji,jk,jj)+tt0(ji,jk,jj)
                enddo
              enddo
            enddo
!
          endif ! lsw
        endif   ! cptot
      endif   ! llmass
!
      return
      end