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