source: LMDZ5/trunk/libf/dyn3dmem/dissip_loc.F @ 4643

Last change on this file since 4643 was 2597, checked in by Ehouarn Millour, 8 years ago

Cleanup in the dynamics: get rid of comconst.h, make it a module comconst_mod.
EM

  • 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: 5.5 KB
RevLine 
[1987]1!
2! $Id: $
3!
[1632]4      SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
5c
[1823]6      USE parallel_lmdz
[1632]7      USE write_field_loc
[1987]8      USE dissip_mod, ONLY: dissip_allocate
[2597]9      USE comconst_mod, ONLY: dtdiss
[1632]10      IMPLICIT NONE
11
12
13c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
14c                                 (  10/01/98  )
15
16c=======================================================================
17c
18c   Auteur:  P. Le Van
19c   -------
20c
21c   Objet:
22c   ------
23c
24c   Dissipation horizontale
25c
26c=======================================================================
27c-----------------------------------------------------------------------
28c   Declarations:
29c   -------------
30
[2597]31      include "dimensions.h"
32      include "paramet.h"
33      include "comgeom.h"
34      include "comdissnew.h"
35      include "comdissipn.h"
[1632]36
37c   Arguments:
38c   ----------
39
[1987]40      REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
41      REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
42      REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
43      REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
44      ! tendencies (.../s) on covariant winds and potential temperature
45      REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
46      REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
47      REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
[1632]48
49c   Local:
50c   ------
51
52      REAL gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
53      REAL grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
54      REAL te1dt(llm),te2dt(llm),te3dt(llm)
55      REAL deltapres(ijb_u:ije_u,llm)
56
57      INTEGER l,ij
58
59      REAL  SSUM
60      integer :: ijb,ije
61     
62      LOGICAl,SAVE :: first=.TRUE.
63!$OMP THREADPRIVATE(first)
64
65      IF (first) THEN
66        CALL dissip_allocate
67        first=.FALSE.
68      ENDIF
69c-----------------------------------------------------------------------
70c   initialisations:
71c   ----------------
72
73c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
74      DO l=1,llm
75         te1dt(l) = tetaudiv(l) * dtdiss
76         te2dt(l) = tetaurot(l) * dtdiss
77         te3dt(l) = tetah(l)    * dtdiss
78      ENDDO
79c$OMP END DO NOWAIT
80c      CALL initial0( ijp1llm, du )
81c      CALL initial0( ijmllm , dv )
82c      CALL initial0( ijp1llm, dh )
83     
84      ijb=ij_begin
85      ije=ij_end
86
87c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
88      DO l=1,llm
89        du(ijb:ije,l)=0
90        dh(ijb:ije,l)=0
91      ENDDO
92c$OMP END DO NOWAIT
93     
94      if (pole_sud) ije=ij_end-iip1
95
96c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
97      DO l=1,llm
98        dv(ijb:ije,l)=0
99      ENDDO
100c$OMP END DO NOWAIT
101     
102c-----------------------------------------------------------------------
103c   Calcul de la dissipation:
104c   -------------------------
105
106c   Calcul de la partie   grad  ( div ) :
107c   -------------------------------------
108     
109     
110     
111      IF(lstardis) THEN
112c      IF (.FALSE.) THEN
113         CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
114      ELSE
115!         CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
116      ENDIF
117
118#ifdef DEBUG_IO   
119      call WriteField_u('gdx',gdx)
120      call WriteField_v('gdy',gdy)
121#endif
122
123      ijb=ij_begin
124      ije=ij_end
125      if (pole_sud) ije=ij_end-iip1
126
127c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
128      DO l=1,llm
129         if (pole_nord) then
130           DO ij = 1, iip1
131              gdx(     ij ,l) = 0.
132           ENDDO
133         endif
134         
135         if (pole_sud) then
136           DO ij = 1, iip1
137              gdx(ij+ip1jm,l) = 0.
138           ENDDO
139         endif
140         
141         if (pole_nord) ijb=ij_begin+iip1
142         DO ij = ijb,ije
143            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
144         ENDDO
145
146         if (pole_nord) ijb=ij_begin
147         DO ij = ijb,ije
148            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
149         ENDDO
150
151       ENDDO
152c$OMP END DO NOWAIT
153c   calcul de la partie   n X grad ( rot ):
154c   ---------------------------------------
155
156      IF(lstardis) THEN
157c      IF (.FALSE.) THEN
158         CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
159      ELSE
160!         CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
161      ENDIF
162
163#ifdef DEBUG_IO   
164      call WriteField_u('grx',grx)
165      call WriteField_v('gry',gry)
166#endif
167
168
169      ijb=ij_begin
170      ije=ij_end
171      if (pole_sud) ije=ij_end-iip1
172
173c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
174      DO l=1,llm
175         
176         if (pole_nord) then
177           DO ij = 1, iip1
178              grx(ij,l) = 0.
179           ENDDO
180         endif
181         
182         if (pole_nord) ijb=ij_begin+iip1
183         DO ij = ijb,ije
184            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
185         ENDDO
186         
187         if (pole_nord) ijb=ij_begin
188         DO ij =  ijb, ije
189            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
190         ENDDO
191     
192      ENDDO
193c$OMP END DO NOWAIT
194
195c   calcul de la partie   div ( grad ):
196c   -----------------------------------
197
198       
199      IF(lstardis) THEN
200c      IF (.FALSE.) THEN
201   
202      ijb=ij_begin
203      ije=ij_end
204
205c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
206       DO l = 1, llm
207          DO ij = ijb, ije
208            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
209          ENDDO
210       ENDDO
211c$OMP END DO NOWAIT
212         CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
213      ELSE
214!         CALL divgrad_p ( llm,teta, niterh, gdx        )
215      ENDIF
216
217#ifdef DEBUG_IO   
218      call WriteField_u('gdx',gdx)
219#endif
220
221
222      ijb=ij_begin
223      ije=ij_end
224     
225c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
226      DO l = 1,llm
227         DO ij = ijb,ije
228            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
229         ENDDO
230      ENDDO
231c$OMP END DO NOWAIT
232
233      RETURN
234      END
Note: See TracBrowser for help on using the repository browser.