source: LMDZ5/branches/testing/libf/dyn3dmem/qminimum_loc.F @ 4778

Last change on this file since 4778 was 2641, checked in by Laurent Fairhead, 8 years ago

Merged trunk changes r2593:2640 into testing branch
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 8.5 KB
RevLine 
[2298]1      SUBROUTINE qminimum_loc( q,nqtot,deltap )
[1864]2      USE parallel_lmdz
[2298]3      USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
[1632]4      IMPLICIT none
5c
6c  -- Objet : Traiter les valeurs trop petites (meme negatives)
7c             pour l'eau vapeur et l'eau liquide
8c
[2641]9      include "dimensions.h"
10      include "paramet.h"
[1632]11c
[2298]12      INTEGER nqtot ! CRisi: on remplace nq par nqtot
13      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
[1632]14c
15      INTEGER iq_vap, iq_liq
16      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
17      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
18      REAL seuil_vap, seuil_liq
19      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
20      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
21c
22c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
23c            parametres seuil_vap, seuil_liq soient pareilles a celles
24c            qui  sont utilisees dans la routine    ADDFI       )
25c     .................................................................
26c
27      INTEGER i, k, iq
28      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
[2298]29
30      real zx_defau_diag(ijb_u:ije_u,llm,2)
31      real q_follow(ijb_u:ije_u,llm,2)
[1632]32c
33      REAL SSUM
34      EXTERNAL SSUM
35c
36      INTEGER imprim
37      SAVE imprim
38      DATA imprim /0/
39c$OMP THREADPRIVATE(imprim)
40      INTEGER ijb,ije
41      INTEGER Index_pump(ij_end-ij_begin+1)
42      INTEGER nb_pump
[2298]43      INTEGER ixt
44      INTEGER iso_verif_noNaN_nostop
[1632]45c
46c Quand l'eau liquide est trop petite (ou negative), on prend
47c l'eau vapeur de la meme couche et la convertit en eau liquide
48c (sans changer la temperature !)
49c
50
[2298]51        !write(*,*) 'qminimum 52: entree'
52        if (ok_iso_verif) then
53           call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
54        endif !if (ok_iso_verif) then     
55
[1632]56      ijb=ij_begin
57      ije=ij_end
58
[2298]59      zx_defau_diag(ijb:ije,:,:)=0.0
60      q_follow(ijb:ije,:,1:2)=q(ijb:ije,:,1:2) 
61
62      !write(*,*) 'qminimum 57'
[1632]63c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
64      DO 1000 k = 1, llm
65      DO 1040 i = ijb, ije
66            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
[2298]67
68              if (ok_isotopes) then
69                 zx_defau_diag(i,k,iq_liq)=AMAX1
70     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
71              endif !if (ok_isotopes) then
72
[1632]73               q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
74               q(i,k,iq_liq) = seuil_liq
75            endif
76 1040 CONTINUE
77 1000 CONTINUE
78c$OMP END DO NOWAIT
79c$OMP BARRIER
80c --->  SYNCHRO OPENMP ICI
81
[2298]82
[1632]83c
84c Quand l'eau vapeur est trop faible (ou negative), on complete
85c le defaut en prennant de l'eau vapeur de la couche au-dessous.
86c
[2298]87      !write(*,*) 'qminimum 81'
[1632]88      iq = iq_vap
89c
90      DO k = llm, 2, -1
91ccc      zx_abc = dpres(k) / dpres(k-1)
92c$OMP DO SCHEDULE(STATIC)
93      DO i = ijb, ije
[2298]94
[1632]95         if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
[2298]96
97            if (ok_isotopes) then
98              zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
99            endif !if (ok_isotopes) then
100
[1632]101            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
102     &           deltap(i,k) / deltap(i,k-1)
103            q(i,k,iq)   =  seuil_vap 
[2298]104
[1632]105         endif
106      ENDDO
107c$OMP END DO NOWAIT
108      ENDDO
109c$OMP BARRIER
[2298]110
[1632]111c
112c Quand il s'agit de la premiere couche au-dessus du sol, on
113c doit imprimer un message d'avertissement (saturation possible).
114c
[2298]115      !write(*,*) 'qminimum 106'
[1632]116      nb_pump=0
117c$OMP DO SCHEDULE(STATIC)
118      DO i = ijb, ije
119         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
120         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
121         IF (zx_pump(i) > 0.0) THEN
122            nb_pump = nb_pump+1
123            Index_pump(nb_pump)=i
124         ENDIF
125      ENDDO
126c$OMP END DO 
127!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
128
129      IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN
130         PRINT *, 'ATT!:on pompe de l eau au sol'
131         DO i = 1, nb_pump
132               imprim = imprim + 1
133               PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
134         ENDDO
135      ENDIF
[2298]136
137      !write(*,*) 'qminimum 128'
138      if (ok_isotopes) then
139      ! CRisi: traiter de même les traceurs d'eau
140      ! Mais il faut les prendre à l'envers pour essayer de conserver la
141      ! masse.
142      ! 1) pompage dans le sol 
143      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
144      ! rien ici et on croise les doigts pour que ça ne soit pas trop
145      ! génant
146      DO i = ijb, ije
147        if (zx_pump(i).gt.0.0) then
148          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
149        endif !if (zx_pump(i).gt.0.0) then
150      enddo !DO i = ijb, ije 
151
152      ! 2) transfert de vap vers les couches plus hautes
153      !write(*,*) 'qminimum 139'
154      do k=2,llm
155        DO i = ijb, ije
156          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
157              ! on ajoute la vapeur en k             
158              do ixt=1,ntraciso
159               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
160     :              +zx_defau_diag(i,k,iq_vap)
161     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
162               
163              if (ok_iso_verif) then
164                if (iso_verif_noNaN_nostop(q(i,k,iqiso(ixt,iq_vap)),
165     :                   'qminimum 155').eq.1) then
166                   write(*,*) 'i,k,ixt=',i,k,ixt
167                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
168     :                   q_follow(i,k-1,iq_vap)
169                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
170     :                   q(i,k,iqiso(ixt,iq_vap))
171                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
172     :                   zx_defau_diag(i,k,iq_vap)
173                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
174     :                   q(i,k-1,iqiso(ixt,iq_vap))
175                   stop
176                endif
177              endif
178
179              ! et on la retranche en k-1
180               q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
181     :              -zx_defau_diag(i,k,iq_vap)
182     :              *deltap(i,k)/deltap(i,k-1)
183     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
184
185               if (ok_iso_verif) then
186                if (iso_verif_noNaN_nostop(q(i,k-1,iqiso(ixt,iq_vap)),
187     :                   'qminimum 175').eq.1) then
188                   write(*,*) 'k,i,ixt=',k,i,ixt
189                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
190     :                   q_follow(i,k-1,iq_vap)
191                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
192     :                   q(i,k,iqiso(ixt,iq_vap))
193                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
194     :                   zx_defau_diag(i,k,iq_vap)
195                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
196     :                   q(i,k-1,iqiso(ixt,iq_vap))
197                   stop
198                endif
199              endif
200
201              enddo !do ixt=1,niso
202              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
203     :               +zx_defau_diag(i,k,iq_vap)
204              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
205     :               -zx_defau_diag(i,k,iq_vap)
206     :              *deltap(i,k)/deltap(i,k-1)
207          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
208        enddo !DO i = 1, ip1jmp1       
209       enddo !do k=2,llm
210
211        if (ok_iso_verif) then
212           call check_isotopes(q,ijb,ije,'qminimum 168')
213        endif !if (ok_iso_verif) then
214       
215     
216        ! 3) transfert d'eau de la vapeur au liquide
217        !write(*,*) 'qminimum 164'
218        do k=1,llm
219        DO i = ijb, ije
220          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
221
222              ! on ajoute eau liquide en k en k             
223              do ixt=1,ntraciso
224               q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
225     :              +zx_defau_diag(i,k,iq_liq)
226     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
227              ! et on la retranche à la vapeur en k
228               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
229     :              -zx_defau_diag(i,k,iq_liq)
230     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
231              enddo !do ixt=1,niso
232              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
233     :               +zx_defau_diag(i,k,iq_liq)
234              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
235     :               -zx_defau_diag(i,k,iq_liq)
236          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
237        enddo !DO i = 1, ip1jmp1
238       enddo !do k=2,llm 
239
240        if (ok_iso_verif) then
241           call check_isotopes(q,ijb,ije,'qminimum 197')
242        endif !if (ok_iso_verif) then
243
244      endif !if (ok_isotopes) then
245      !write(*,*) 'qminimum 188'
[1632]246c
247      RETURN
248      END
Note: See TracBrowser for help on using the repository browser.