source: LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc.F @ 1745

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

Fin du phasage de la dynamique parallele localisee (petite memoire) avec le tronc LMDZ5 r1671
Il reste quelques routines a verifier (en particulier ce qui touche a l'etude des cas academiques)
et la validation a effectuer


End of the phasing of the localised (low memory) parallel dynamics package with the
LMDZ5 trunk (r1671)
Some routines still need some checking (in particular the academic cases) and some
validation is still required

File size: 5.7 KB
Line 
1!
2! $Id$
3!
4      SUBROUTINE  exner_milieu_loc ( ngrid, ps, p,beta, pks, pk, pkf )
5c
6c     Auteurs :  F. Forget , Y. Wanherdrick
7c P.Le Van  , Fr. Hourdin  .
8c    ..........
9c
10c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
11c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
12c
13c   ************************************************************************
14c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des
15c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
16c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
17c   ************************************************************************
18c    .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
19c    la pression et la fonction d'Exner  au  sol  .
20c
21c     WARNING : CECI est une version speciale de exner_hyb originale
22c               Utilise dans la version martienne pour pouvoir
23c               tourner avec des coordonnees verticales complexe
24c              => Il ne verifie PAS la condition la proportionalite en
25c              energie totale/ interne / potentielle (F.Forget 2001)
26c    ( voir note de Fr.Hourdin )  ,
27c
28      USE parallel
29      IMPLICIT NONE
30c
31#include "dimensions.h"
32#include "paramet.h"
33#include "comconst.h"
34#include "comgeom.h"
35#include "comvert.h"
36#include "serre.h"
37
38      INTEGER  ngrid
39      REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
40      REAL pkf(ijb_u:ije_u,llm)
41      REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
42      REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
43
44c    .... variables locales   ...
45
46      INTEGER l, ij
47      REAL dum1
48
49      REAL ppn(iim),pps(iim)
50      REAL xpn, xps
51      REAL SSUM
52      EXTERNAL SSUM
53      INTEGER ije,ijb,jje,jjb
54      logical,save :: firstcall=.true.
55!$OMP THREADPRIVATE(firstcall)
56      character(len=*),parameter :: modname="exner_milieu_loc"
57
58      ! Sanity check
59      if (firstcall) then
60       
61        ! sanity checks for Shallow Water case (1 vertical layer)
62        if (llm.eq.1) then
63          if (kappa.ne.1) then
64            call abort_gcm(modname,
65     &      "kappa!=1 , but running in Shallow Water mode!!",42)
66          endif
67          if (cpp.ne.r) then
68            call abort_gcm(modname,
69     &      "cpp!=r , but running in Shallow Water mode!!",42)
70          endif
71        endif ! of if (llm.eq.1)
72
73        firstcall=.false.
74      endif ! of if (firstcall)
75     
76c$OMP BARRIER
77
78! Specific behaviour for Shallow Water (1 vertical layer) case
79      if (llm.eq.1) then
80             
81        ! Compute pks(:),pk(:),pkf(:)
82        ijb=ij_begin
83        ije=ij_end
84!$OMP DO SCHEDULE(STATIC)
85        DO ij=ijb, ije
86          pks(ij)=(cpp/preff)*ps(ij)
87          pk(ij,1) = .5*pks(ij)
88          pkf(ij,1)=pk(ij,1)
89        ENDDO
90!$OMP ENDDO
91
92!$OMP MASTER
93      if (pole_nord) then
94        DO  ij   = 1, iim
95          ppn(ij) = aire(   ij   ) * pks(  ij     )
96        ENDDO
97        xpn      = SSUM(iim,ppn,1) /apoln
98 
99        DO ij   = 1, iip1
100          pks(   ij     )  =  xpn
101          pk(ij,1) = .5*pks(ij)
102          pkf(ij,1)=pk(ij,1)
103        ENDDO
104      endif
105     
106      if (pole_sud) then
107        DO  ij   = 1, iim
108          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
109        ENDDO
110        xps      = SSUM(iim,pps,1) /apols
111 
112        DO ij   = 1, iip1
113          pks( ij+ip1jm )  =  xps
114          pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
115          pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
116        ENDDO
117      endif
118!$OMP END MASTER
119!$OMP BARRIER
120        jjb=jj_begin
121        jje=jj_end
122        CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
123
124        ! our work is done, exit routine
125        return
126      endif ! of if (llm.eq.1)
127
128!!!! General case:
129
130c     -------------
131c     Calcul de pks
132c     -------------
133   
134      ijb=ij_begin
135      ije=ij_end
136
137c$OMP DO SCHEDULE(STATIC)
138      DO   ij  = ijb, ije
139        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
140      ENDDO
141c$OMP ENDDO
142c Synchro OPENMP ici
143
144c$OMP MASTER
145      if (pole_nord) then
146        DO  ij   = 1, iim
147          ppn(ij) = aire(   ij   ) * pks(  ij     )
148        ENDDO
149        xpn      = SSUM(iim,ppn,1) /apoln
150 
151        DO ij   = 1, iip1
152          pks(   ij     )  =  xpn
153        ENDDO
154      endif
155     
156      if (pole_sud) then
157        DO  ij   = 1, iim
158          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
159        ENDDO
160        xps      = SSUM(iim,pps,1) /apols
161 
162        DO ij   = 1, iip1
163          pks( ij+ip1jm )  =  xps
164        ENDDO
165      endif
166c$OMP END MASTER
167c$OMP BARRIER
168c
169c
170c    .... Calcul de pk  pour la couche l
171c    --------------------------------------------
172c
173      dum1 = cpp * (2*preff)**(-kappa)
174      DO l = 1, llm-1
175c$OMP DO SCHEDULE(STATIC)
176        DO   ij   = ijb, ije
177         pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
178        ENDDO
179c$OMP ENDDO NOWAIT       
180      ENDDO
181
182c    .... Calcul de pk  pour la couche l = llm ..
183c    (on met la meme distance (en log pression)  entre Pk(llm)
184c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
185
186c$OMP DO SCHEDULE(STATIC)
187      DO   ij   = ijb, ije
188         pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
189      ENDDO
190c$OMP ENDDO NOWAIT       
191
192
193c    calcul de pkf
194c    -------------
195c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
196      DO l = 1, llm
197c$OMP DO SCHEDULE(STATIC)
198         DO   ij   = ijb, ije
199           pkf(ij,l)=pk(ij,l)
200         ENDDO
201c$OMP ENDDO NOWAIT             
202      ENDDO
203
204c$OMP BARRIER
205     
206      jjb=jj_begin
207      jje=jj_end
208      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
209     
210c    EST-CE UTILE ?? : calcul de beta
211c    --------------------------------
212      DO l = 2, llm
213c$OMP DO SCHEDULE(STATIC)
214        DO   ij   = ijb, ije
215          beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
216        ENDDO
217c$OMP ENDDO NOWAIT             
218      ENDDO
219
220      RETURN
221      END
Note: See TracBrowser for help on using the repository browser.