qminimum.f90 Source File

!
! $Header$
!
SUBROUTINE qminimum( q,nqtot,deltap )

  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase
  USE strings_mod, ONLY: strIdx
  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
USE paramet_mod_h
IMPLICIT none
  !
  !  -- Objet : Traiter les valeurs trop petites (meme negatives)
  !         pour l'eau vapeur et l'eau liquide
  !


  !
  INTEGER :: nqtot
  REAL :: q(ip1jmp1,llm,nqtot), deltap(ip1jmp1,llm)
  !
  LOGICAL, SAVE :: first=.TRUE.
  INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
  REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
  REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
  !
  !  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
  !        parametres seuil_vap, seuil_liq soient pareilles a celles
  !        qui  sont utilisees dans la routine    ADDFI       )
  ! .................................................................
  !
  !DC iq_val and iq_liq are usable for q only, NOT for q_follow
  !   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
  !   water at hardcoded indices 1/2 in these variables
  INTEGER :: i, k, iq
  REAL :: zx_defau, zx_abc, zx_pump(ip1jmp1), pompe

  real :: zx_defau_diag(ip1jmp1,llm,2)
  real :: q_follow(ip1jmp1,llm,2)
  !
  REAL :: SSUM
  !
  INTEGER :: imprim
  SAVE imprim
  DATA imprim /0/
  ! !INTEGER ijb,ije
  ! !INTEGER Index_pump(ij_end-ij_begin+1)
  ! !INTEGER nb_pump
  INTEGER :: ixt

  IF(first) THEN
     iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
     iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
     first = .FALSE.
  END IF
  !
  ! Quand l'eau liquide est trop petite (ou negative), on prend
  ! l'eau vapeur de la meme couche et la convertit en eau liquide
  ! (sans changer la temperature !)
  !

  call check_isotopes_seq(q,ip1jmp1,'qminimum 52')

  zx_defau_diag(:,:,:)=0.0
  q_follow(:,:,1)=q(:,:,iq_vap)
  q_follow(:,:,2)=q(:,:,iq_liq)
  DO k = 1, llm
    DO i = 1, ip1jmp1
      if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then

        if (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
              ( seuil_liq - q(i,k,iq_liq), 0.0 )

        q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
        q(i,k,iq_liq) = seuil_liq
      endif
    ENDDO
  ENDDO
  !
  ! Quand l'eau vapeur est trop faible (ou negative), on complete
  ! le defaut en prennant de l'eau vapeur de la couche au-dessous.
  !
  DO k = llm, 2, -1
  !cc      zx_abc = dpres(k) / dpres(k-1)
    DO i = 1, ip1jmp1
      if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then

        if (niso > 0) zx_defau_diag(i,k,1) &
              = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )

        q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap &
              -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
        q(i,k,iq_vap)   =  seuil_vap

      endif
    ENDDO
  ENDDO

  !
  ! Quand il s'agit de la premiere couche au-dessus du sol, on
  ! doit imprimer un message d'avertissement (saturation possible).
  !
  DO i = 1, ip1jmp1
     zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
     q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
  ENDDO
  pompe = SSUM(ip1jmp1,zx_pump,1)
  IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN
     WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
     DO i = 1, ip1jmp1
        IF (zx_pump(i).GT.0.0) THEN
           imprim = imprim + 1
           PRINT*,'QMINIMUM:  en ',i,zx_pump(i)
        ENDIF
     ENDDO
  ENDIF

  ! !write(*,*) 'qminimum 128'
  if (niso > 0) then
  ! ! CRisi: traiter de même les traceurs d'eau
  ! ! Mais il faut les prendre à l'envers pour essayer de conserver la
  ! ! masse.
  ! ! 1) pompage dans le sol
  ! ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
  ! ! rien ici et on croise les doigts pour que ça ne soit pas trop
  ! ! génant
  DO i = 1,ip1jmp1
    if (zx_pump(i).gt.0.0) then
      q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
    endif !if (zx_pump(i).gt.0.0) then
  enddo !DO i = 1,ip1jmp1

  ! ! 2) transfert de vap vers les couches plus hautes
  ! !write(*,*) 'qminimum 139'
  do k=2,llm
    DO i = 1,ip1jmp1
      if (zx_defau_diag(i,k,1).gt.0.0) then
          ! ! on ajoute la vapeur en k
          do ixt=1,ntiso
           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
                 +zx_defau_diag(i,k,1) &
                 *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)

          ! ! et on la retranche en k-1
           q(i,k-1,iqIsoPha(ixt,iq_vap))= &
                 q(i,k-1,iqIsoPha(ixt,iq_vap)) &
                 -zx_defau_diag(i,k,1) &
                 *deltap(i,k)/deltap(i,k-1) &
                 *q(i,k-1,iqIsoPha(ixt,iq_vap)) &
                 /q_follow(i,k-1,1)

          enddo !do ixt=1,niso
          q_follow(i,k,1)=   q_follow(i,k,1) &
                +zx_defau_diag(i,k,1)
          q_follow(i,k-1,1)=   q_follow(i,k-1,1) &
                -zx_defau_diag(i,k,1) &
                *deltap(i,k)/deltap(i,k-1)
      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
    enddo !DO i = 1, ip1jmp1
   enddo !do k=2,llm

   call check_isotopes_seq(q,ip1jmp1,'qminimum 168')


    ! ! 3) transfert d'eau de la vapeur au liquide
    ! !write(*,*) 'qminimum 164'
    do k=1,llm
    DO i = 1,ip1jmp1
      if (zx_defau_diag(i,k,2).gt.0.0) then

          ! ! on ajoute eau liquide en k en k
          do ixt=1,ntiso
           q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq)) &
                 +zx_defau_diag(i,k,2) &
                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
          ! ! et on la retranche à la vapeur en k
           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
                 -zx_defau_diag(i,k,2) &
                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
          enddo !do ixt=1,niso
          q_follow(i,k,2)=   q_follow(i,k,2) &
                +zx_defau_diag(i,k,2)
          q_follow(i,k,1)=   q_follow(i,k,1) &
                -zx_defau_diag(i,k,2)
      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
    enddo !DO i = 1, ip1jmp1
   enddo !do k=2,llm

   call check_isotopes_seq(q,ip1jmp1,'qminimum 197')

  endif !if (niso > 0) then
  ! !write(*,*) 'qminimum 188'

  !
  RETURN
END SUBROUTINE qminimum