
! $Header$
!$gpum horizontal klon
MODULE ajsec_mod
  PRIVATE

  PUBLIC ajsec, ajsec_convv2, ajsec_old

  CONTAINS

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
    ENDDO
  ENDDO
  ! ------------------------------------- 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
    ENDDO
  ENDDO

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

  DO i = 1, klon
    modif(i) = .FALSE.
  ENDDO
  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.
      ENDIF
    ENDDO
  ENDDO
  ! ------------------------------------- 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.
        ENDIF
        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
        ENDIF
        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
        ENDDO
        k2 = k2 + 1
      ENDIF
      GO TO 8000
8001  CONTINUE
    ENDIF
  ENDDO

#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
    ENDDO
  ENDDO

#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
      ENDDO
    ENDDO
  ENDIF

#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
    ENDDO
  ENDDO
  ! ------------------------------------- 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
    ENDDO
  ENDDO

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

  DO i = 1, klon
    modif(i) = .FALSE.
  ENDDO
  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.
      ENDIF
    ENDDO
  ENDDO
  ! ------------------------------------- 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.
        ENDIF
        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
        ENDIF
        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
        ENDDO
        k2 = k2 + 1
      ENDIF
      GO TO 8000
8001  CONTINUE
    ENDIF
  ENDDO

#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
    ENDDO
  ENDDO

  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
      ENDDO
    ENDDO
  ENDIF

  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
      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
      ENDDO
    ENDDO
  ENDIF


#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

END MODULE ajsec_mod
