! $Header$

SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q &
#ifdef ISO      
               ,xt,d_xt &
#endif
          )
  USE dimphy
#ifdef ISO
    USE infotrac_phy, ONLY: ntraciso =>ntiso   
#ifdef ISOVERIF
  USE isotopes_mod, ONLY : iso_eau,iso_HDO
  USE isotopes_verif_mod, ONLY: iso_verif_egalite, &
        iso_verif_egalite_choix,iso_verif_noNaN,errmax,errmaxrel 
#ifdef ISOTRAC
  USE isotopes_verif_mod, ONLY: iso_verif_traceur,iso_verif_traceur_justmass
#endif
#endif
#endif
  USE yomcst_mod_h
IMPLICIT NONE
  ! ======================================================================
  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
  ! Objet: ajustement sec (adaptation du GCM du LMD)
  ! ======================================================================
  ! Arguments:
  ! t-------input-R- Temperature

  ! d_t-----output-R-Incrementation de la temperature
  ! ======================================================================

  REAL paprs(klon, klev+1), pplay(klon, klev)
  REAL t(klon, klev), q(klon, klev)
  REAL d_t(klon, klev), d_q(klon, klev)

  INTEGER limbas(klon), limhau ! les couches a ajuster

  LOGICAL mixq
  ! cc      PARAMETER (mixq=.TRUE.)
  PARAMETER (mixq=.FALSE.)

  REAL zh(klon, klev)
  REAL zho(klon, klev)
  REAL zq(klon, klev)
  REAL zpk(klon, klev)
  REAL zpkdp(klon, klev)
  REAL hm, sm, qm
  LOGICAL modif(klon), down
  INTEGER i, k, k1, k2
#ifdef ISO
      real xt(ntraciso,klon,klev)
      real d_xt(ntraciso,klon,klev)
      real zxt(ntraciso,klon,klev)
      real xtm(ntraciso)
      integer ixt
#endif


  ! Initialisation:

#ifdef ISO
#ifdef ISOVERIF
      do i=1,klon
         do k=1,klev         
           if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(q(i,k),xt(iso_eau,i,k), &
                 'ajsec 67',errmax,errmaxrel)
           endif !if (iso_eau.gt.0) then
         enddo !do k=limbas,limhau
      enddo !do i=1,klon
#endif
#endif


  ! ym
  limhau = klev

  DO k = 1, klev
    DO i = 1, klon
      d_t(i, k) = 0.0
      d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
    END DO
  END DO
  ! ------------------------------------- detection des profils a modifier
  DO k = 1, limhau
    DO i = 1, klon
      zpk(i, k) = pplay(i, k)**rkappa
      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
      zho(i, k) = zh(i, k)
      zq(i, k) = q(i, k)
#ifdef ISO
      do ixt=1,ntraciso
            zxt(ixt,i,k)=xt(ixt,i,k)
      enddo
#endif
    END DO
  END DO

  DO k = 1, limhau
    DO i = 1, klon
      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
    END DO
  END DO

  DO i = 1, klon
    modif(i) = .FALSE.
  END DO
  DO k = 2, limhau
    DO i = 1, klon
      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
      END IF
    END DO
  END DO
  ! ------------------------------------- correction des profils instables
  DO i = 1, klon
    IF (modif(i)) THEN
      k2 = limbas(i)
8000  CONTINUE
      k2 = k2 + 1
      IF (k2>limhau) GO TO 8001
      IF (zh(i,k2)<zh(i,k2-1)) THEN
        k1 = k2 - 1
        k = k1
        sm = zpkdp(i, k2)
        hm = zh(i, k2)
        qm = zq(i, k2)
#ifdef ISO
        do ixt=1,ntraciso
                 xtm(ixt)=zxt(ixt,i,k2)
        enddo    
#ifdef ISOVERIF
        if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(qm,xtm(iso_eau), &
                 'ajsec 126',errmax,errmaxrel)
        endif !if (iso_eau.gt.0) then      
#endif
#endif
8020    CONTINUE
        sm = sm + zpkdp(i, k)
        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
#ifdef ISO
        do ixt=1,ntraciso
                 xtm(ixt)=xtm(ixt) &
                    +zpkdp(i,k)*(zxt(ixt,i,k)-xtm(ixt))/sm
        enddo    
#ifdef ISOVERIF
        if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(qm,xtm(iso_eau), &
                 'ajsec 136',errmax,errmaxrel)
        endif !if (iso_eau.gt.0) then      
#endif
#endif
        down = .FALSE.
        IF (k1/=limbas(i)) THEN
          IF (hm<zh(i,k1-1)) down = .TRUE.
        END IF
        IF (down) THEN
          k1 = k1 - 1
          k = k1
        ELSE
          IF ((k2==limhau)) GO TO 8021
          IF ((zh(i,k2+1)>=hm)) GO TO 8021
          k2 = k2 + 1
          k = k2
        END IF
        GO TO 8020
8021    CONTINUE
        ! ------------ nouveau profil : constant (valeur moyenne)
        DO k = k1, k2
          zh(i, k) = hm
          zq(i, k) = qm
#ifdef ISO
                do ixt=1,ntraciso
                   zxt(ixt,i,k)=xtm(ixt)
                enddo
#endif
        END DO
        k2 = k2 + 1
      END IF
      GO TO 8000
8001  CONTINUE
    END IF
  END DO

#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i=1,klon
         do k=1,klev
           do ixt=1,ntraciso
             call iso_verif_noNaN(zxt(ixt,i,k),'ajsec 173')
           enddo !do ixt=1,niso           
           if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(zq(i,k),zxt(iso_eau,i,k), &
                 'ajsec 168',errmax,errmaxrel)
           endif !if (iso_eau.gt.0) then
#ifdef ISOTRAC      
           call iso_verif_traceur(zxt(1,i,k),'ajsec 181')
#endif           
         enddo !do k=limbas,limhau
      enddo !do i=1,klon
#endif
      ! end cam verif
#endif

  DO k = 1, limhau
    DO i = 1, klon
      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
      d_q(i, k) = zq(i, k) - q(i, k)
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=zxt(ixt,i,k)-xt(ixt,i,k)
         enddo
#endif
    END DO
  END DO

#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i = 1, klon
        do k = 1, limhau
         if (iso_eau.gt.0) then
          call iso_verif_egalite_choix(d_q(i,k),d_xt(iso_eau,i,k), &
                'ajsec 198',errmax,errmaxrel)
         endif
#ifdef ISOTRAC      
        call iso_verif_traceur_justmass(d_xt(1,i,k),'physiq 210')
#endif         
         enddo
      enddo
#endif
      ! end cam verif      
#endif

  ! FH : les d_q et d_t sont maintenant calcules de facon a valoir
  ! effectivement 0. si on ne fait rien.

  ! IF (limbas.GT.1) THEN
  ! DO k = 1, limbas-1
  ! DO i = 1, klon
  ! d_t(i,k) = 0.0
  ! d_q(i,k) = 0.0
  ! ENDDO
  ! ENDDO
  ! ENDIF

  ! IF (limhau.LT.klev) THEN
  ! DO k = limhau+1, klev
  ! DO i = 1, klon
  ! d_t(i,k) = 0.0
  ! d_q(i,k) = 0.0
  ! ENDDO
  ! ENDDO
  ! ENDIF

  IF (.NOT. mixq) THEN
    DO k = 1, klev
      DO i = 1, klon
        d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
      END DO
    END DO
  END IF

#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i = 1, klon
        do k = 1, klev
         if (iso_eau.gt.0) then
          call iso_verif_egalite(d_q(i,k),d_xt(iso_eau,i,k),'ajsec 270')
         endif
#ifdef ISOTRAC      
        call iso_verif_traceur_justmass(d_xt(1,i,k),'physiq 3045')
#endif         
         enddo
      enddo
#endif
      ! end cam verif
#endif


  RETURN
END SUBROUTINE ajsec

SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q &
#ifdef ISO
           ,xt,d_xt &     
#endif         
        )
  USE dimphy
#ifdef ISO
    USE infotrac_phy, ONLY: ntraciso=>ntiso    
#ifdef ISOVERIF
  USE isotopes_mod, ONLY : iso_eau,iso_HDO
  USE isotopes_verif_mod, ONLY: iso_verif_egalite, &
        iso_verif_egalite_choix,iso_verif_noNaN,errmax,errmaxrel
#ifdef ISOTRAC
  USE isotopes_verif_mod, ONLY: iso_verif_traceur,iso_verif_traceur_justmass
#endif
#endif
#endif
  USE yomcst_mod_h
IMPLICIT NONE
  ! ======================================================================
  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
  ! Objet: ajustement sec (adaptation du GCM du LMD)
  ! ======================================================================
  ! Arguments:
  ! t-------input-R- Temperature

  ! d_t-----output-R-Incrementation de la temperature
  ! ======================================================================

  REAL paprs(klon, klev+1), pplay(klon, klev)
  REAL t(klon, klev), q(klon, klev)
  REAL d_t(klon, klev), d_q(klon, klev)

  INTEGER limbas, limhau ! les couches a ajuster
  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
  ! ym      PARAMETER (limbas=1, limhau=klev)

  LOGICAL mixq
  ! cc      PARAMETER (mixq=.TRUE.)
  PARAMETER (mixq=.FALSE.)

  REAL zh(klon, klev)
  REAL zq(klon, klev)
  REAL zpk(klon, klev)
  REAL zpkdp(klon, klev)
  REAL hm, sm, qm
  LOGICAL modif(klon), down
  INTEGER i, k, k1, k2

#ifdef ISO
      real xt(ntraciso,klon,klev)
      real d_xt(ntraciso,klon,klev)
      real zxt(ntraciso,klon,klev)
      real xtm(ntraciso)
      integer ixt
#endif


#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i=1,klon
         do k=1,klev
           do ixt=1,ntraciso
             call iso_verif_noNAN(xt(ixt,i,k),'ajsec 320')
           enddo !do ixt=1,niso           
           if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(q(i,k),xt(iso_eau,i,k), &
                 'ajsec 324',errmax,errmaxrel)
           endif !if (iso_eau.gt.0) then
#ifdef ISOTRAC      
           call iso_verif_traceur(xt(1,i,k),'ajsec 327')
#endif           
         enddo !do k=1,klev
      enddo !do i=1,klon
#endif
      ! end cam verif
#endif

  ! Initialisation:

  ! ym
  limbas = 1
  limhau = klev

  DO k = 1, klev
    DO i = 1, klon
      d_t(i, k) = 0.0
      d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
    END DO
  END DO
  ! ------------------------------------- detection des profils a modifier
  DO k = limbas, limhau
    DO i = 1, klon
      zpk(i, k) = pplay(i, k)**rkappa
      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
      zq(i, k) = q(i, k)
#ifdef ISO
         do ixt=1,ntraciso
            zxt(ixt,i,k)=xt(ixt,i,k)
         enddo
#endif

    END DO
  END DO

  DO k = limbas, limhau
    DO i = 1, klon
      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
    END DO
  END DO

  DO i = 1, klon
    modif(i) = .FALSE.
  END DO
  DO k = limbas + 1, limhau
    DO i = 1, klon
      IF (.NOT. modif(i)) THEN
        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
      END IF
    END DO
  END DO
  ! ------------------------------------- correction des profils instables
  DO i = 1, klon
    IF (modif(i)) THEN
      k2 = limbas
8000  CONTINUE
      k2 = k2 + 1
      IF (k2>limhau) GO TO 8001
      IF (zh(i,k2)<zh(i,k2-1)) THEN
        k1 = k2 - 1
        k = k1
        sm = zpkdp(i, k2)
        hm = zh(i, k2)
        qm = zq(i, k2)
#ifdef ISO
              do ixt=1,ntraciso
                 xtm(ixt)=zxt(ixt,i,k2)
              enddo
#endif
8020    CONTINUE
        sm = sm + zpkdp(i, k)
        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
#ifdef ISO
              do ixt=1,ntraciso
                 xtm(ixt)=xtm(ixt) &
                    +zpkdp(i,k)*(zxt(ixt,i,k)-xtm(ixt))/sm
              enddo
#endif
        down = .FALSE.
        IF (k1/=limbas) THEN
          IF (hm<zh(i,k1-1)) down = .TRUE.
        END IF
        IF (down) THEN
          k1 = k1 - 1
          k = k1
        ELSE
          IF ((k2==limhau)) GO TO 8021
          IF ((zh(i,k2+1)>=hm)) GO TO 8021
          k2 = k2 + 1
          k = k2
        END IF
        GO TO 8020
8021    CONTINUE
        ! ------------ nouveau profil : constant (valeur moyenne)
        DO k = k1, k2
          zh(i, k) = hm
          zq(i, k) = qm
#ifdef ISO
                do ixt=1,ntraciso
                   zxt(ixt,i,k)=xtm(ixt)
                enddo
#endif
        END DO
        k2 = k2 + 1
      END IF
      GO TO 8000
8001  CONTINUE
    END IF
  END DO

#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i=1,klon
         do k=limbas,limhau
           do ixt=1,ntraciso
             call iso_verif_noNAN(zxt(ixt,i,k),'ajsec 428')
           enddo !do ixt=1,niso           
           if (iso_eau.gt.0) then
             call iso_verif_egalite_choix(zq(i,k),zxt(iso_eau,i,k), &
                 'ajsec 432',errmax,errmaxrel)
           endif !if (iso_eau.gt.0) then
#ifdef ISOTRAC      
           call iso_verif_traceur(zxt(1,i,k),'ajsec 436')
#endif           
         enddo !do k=limbas,limhau
      enddo !do i=1,klon
#endif
      ! end cam verif
#endif   


  DO k = limbas, limhau
    DO i = 1, klon
      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
      d_q(i, k) = zq(i, k) - q(i, k)
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=zxt(ixt,i,k)-xt(ixt,i,k)
         enddo
#endif
    END DO
  END DO

  IF (limbas>1) THEN
    DO k = 1, limbas - 1
      DO i = 1, klon
        d_t(i, k) = 0.0
        d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
      END DO
    END DO
  END IF

  IF (limhau<klev) THEN
    DO k = limhau + 1, klev
      DO i = 1, klon
        d_t(i, k) = 0.0
        d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
      END DO
    END DO
  END IF

  IF (.NOT. mixq) THEN
    DO k = 1, klev
      DO i = 1, klon
        d_q(i, k) = 0.0
#ifdef ISO
         do ixt=1,ntraciso
            d_xt(ixt,i,k)=0.0
         enddo
#endif
      END DO
    END DO
  END IF


#ifdef ISO
      ! cam verif
#ifdef ISOVERIF
      do i = 1, klon
        do k = limbas, limhau
         if (iso_eau.gt.0) then
          call iso_verif_egalite(d_q(i,k),d_xt(iso_eau,i,k),'ajsec 270')
         endif
#ifdef ISOTRAC      
        call iso_verif_traceur_justmass(d_xt(1,i,k),'physiq 3045')
#endif         
         enddo
      enddo
#endif
      ! end cam verif
#endif

  RETURN
END SUBROUTINE ajsec_convv2
SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
  USE dimphy
  USE yomcst_mod_h
IMPLICIT NONE
  ! ======================================================================
  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
  ! Objet: ajustement sec (adaptation du GCM du LMD)
  ! ======================================================================
  ! Arguments:
  ! t-------input-R- Temperature

  ! d_t-----output-R-Incrementation de la temperature
  ! ======================================================================

  REAL paprs(klon, klev+1), pplay(klon, klev)
  REAL t(klon, klev)
  REAL d_t(klon, klev)

  REAL local_h(klon, klev)
  REAL hm, sm
  LOGICAL modif(klon), down
  INTEGER i, l, l1, l2
  ! ------------------------------------- detection des profils a modifier
  DO i = 1, klon
    modif(i) = .FALSE.
  END DO

  DO l = 1, klev
    DO i = 1, klon
      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
    END DO
  END DO

  DO l = 2, klev
    DO i = 1, klon
      IF (local_h(i,l)<local_h(i,l-1)) THEN
        modif(i) = .TRUE.
      ELSE
        modif(i) = modif(i)
      END IF
    END DO
  END DO
  ! ------------------------------------- correction des profils instables
  DO i = 1, klon
    IF (modif(i)) THEN
      l2 = 1
8000  CONTINUE
      l2 = l2 + 1
      IF (l2>klev) GO TO 8001
      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
        l1 = l2 - 1
        l = l1
        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
        hm = local_h(i, l2)
8020    CONTINUE
        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
          -hm)/sm
        down = .FALSE.
        IF (l1/=1) THEN
          IF (hm<local_h(i,l1-1)) THEN
            down = .TRUE.
          END IF
        END IF
        IF (down) THEN
          l1 = l1 - 1
          l = l1
        ELSE
          IF ((l2==klev)) GO TO 8021
          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
          l2 = l2 + 1
          l = l2
        END IF
        GO TO 8020
8021    CONTINUE
        ! ------------ nouveau profil : constant (valeur moyenne)
        DO l = l1, l2
          local_h(i, l) = hm
        END DO
        l2 = l2 + 1
      END IF
      GO TO 8000
8001  CONTINUE
    END IF
  END DO

  DO l = 1, klev
    DO i = 1, klon
      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
    END DO
  END DO

  RETURN
END SUBROUTINE ajsec_old