source: LMDZ5/branches/LMDZ5-DOFOCO/libf/dyn3dmem/dissip_loc.F @ 4785

Last change on this file since 4785 was 1632, checked in by Laurent Fairhead, 12 years ago

Import initial du répertoire dyn3dmem

Attention! ceci n'est qu'une version préliminaire du code "basse mémoire":
le code contenu dans ce répertoire est basé sur la r1320 et a donc besoin
d'être mis à jour par rapport à la dynamique parallèle d'aujourd'hui.
Ce code est toutefois mis à disposition pour circonvenir à des problèmes
de mémoire que certaines configurations du modèle pourraient rencontrer.
Dans l'état, il compile et tourne sur vargas et au CCRT


Initial import of dyn3dmem

Warning! this is just a preliminary version of the memory light code:
it is based on r1320 of the code and thus needs to be updated before
it can replace the present dyn3dpar code. It is nevertheless put at your
disposal to circumvent some memory problems some LMDZ configurations may
encounter. In its present state, it will compile and run on vargas and CCRT

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