My Project
 All Classes Files Functions Variables Macros
integrd_loc.F
Go to the documentation of this file.
1 !
2 ! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
3 !
4  SUBROUTINE integrd_loc
5  $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1,
6  $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
7  USE parallel
8  USE control_mod
9  USE mod_filtreg_p
10  USE write_field_loc
11  USE write_field
12  USE integrd_mod
13  IMPLICIT NONE
14 
15 
16 c=======================================================================
17 c
18 c Auteur: P. Le Van
19 c -------
20 c
21 c objet:
22 c ------
23 c
24 c Incrementation des tendances dynamiques
25 c
26 c=======================================================================
27 c-----------------------------------------------------------------------
28 c Declarations:
29 c -------------
30 
31 #include "dimensions.h"
32 #include "paramet.h"
33 #include "comconst.h"
34 #include "comgeom.h"
35 #include "comvert.h"
36 #include "logic.h"
37 #include "temps.h"
38 #include "serre.h"
39 #include "iniprint.h"
40 ! include 'mpif.h'
41 
42 c Arguments:
43 c ----------
44 
45  INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
46 
47  REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
48  REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
49  REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
50  REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
51  REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
52  REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
53  REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
54  ! values at previous time step
55  REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
56  REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
57  REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
58  REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
59  REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
60  ! the tendencies to add
61  REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
62  REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
63  REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
64  REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
65  REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
66 ! REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
67 
68 c Local:
69 c ------
70 
71  REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
72  REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
73  REAL massescr( ijb_u:ije_u,llm )
74 ! REAL finvmasse(ijb_u:ije_u,llm)
75  REAL tpn,tps,tppn(iim),tpps(iim)
76  REAL qpn,qps,qppn(iim),qpps(iim)
77 
78  INTEGER l,ij,iq,i,j
79 
80  REAL ssum
81  EXTERNAL ssum
82  INTEGER ijb,ije,jjb,jje
83  LOGICAL :: checksum
84  LOGICAL,SAVE :: checksum_all=.true.
85  INTEGER :: stop_it
86  INTEGER :: ierr
87 
88 c-----------------------------------------------------------------------
89 c$OMP BARRIER
90  if (pole_nord) THEN
91 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
92  DO l = 1,llm
93  DO ij = 1,iip1
94  ucov( ij , l) = 0.
95  uscr( ij ) = 0.
96  ENDDO
97  ENDDO
98 c$OMP END DO NOWAIT
99  ENDIF
100 
101  if (pole_sud) THEN
102 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
103  DO l = 1,llm
104  DO ij = 1,iip1
105  ucov( ij +ip1jm, l) = 0.
106  uscr( ij +ip1jm ) = 0.
107  ENDDO
108  ENDDO
109 c$OMP END DO NOWAIT
110  ENDIF
111 
112 c ............ integration de ps ..............
113 
114 c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
115 
116  ijb=ij_begin
117  ije=ij_end
118 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
119  DO l = 1,llm
120  massescr(ijb:ije,l)=masse(ijb:ije,l)
121  ENDDO
122 c$OMP END DO NOWAIT
123 
124 c$OMP DO SCHEDULE(STATIC)
125  DO 2 ij = ijb,ije
126  pscr(ij) = ps0(ij)
127  ps(ij) = psm1(ij) + dt * dp(ij)
128  2 CONTINUE
129 c$OMP END DO
130 c$OMP BARRIER
131 c --> ici synchro OPENMP pour ps
132 
133  checksum=.true.
134  stop_it=0
135 
136 c$OMP MASTER
137 !c$OMP DO SCHEDULE(STATIC)
138  DO ij = ijb,ije
139  IF( ps(ij).LT.0. ) THEN
140  IF (checksum) stop_it=ij
141  checksum=.false.
142  ENDIF
143  ENDDO
144 !c$OMP END DO NOWAIT
145 
146 ! CALL MPI_ALLREDUCE(checksum,checksum_all,1,
147 ! & MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
148  IF( .NOT. checksum ) THEN
149  write(lunout,*) "integrd: negative surface pressure ",
150  & ps(stop_it)
151  write(lunout,*) " at node ij =", stop_it
152  ! since ij=j+(i-1)*jjp1 , we have
153 ! j=modulo(stop_it,jjp1)
154 ! i=1+(stop_it-j)/jjp1
155 ! write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
156 ! & " lat = ",rlatu(j)*180./pi, " deg"
157  ENDIF
158 
159 c$OMP END MASTER
160 c$OMP BARRIER
161  IF (.NOT. checksum_all) THEN
162  call writefield_v('int_vcov',vcov)
163  call writefield_u('int_ucov',ucov)
164  call writefield_u('int_teta',teta)
165  call writefield_u('int_ps0',ps0)
166  call writefield_u('int_masse',masse)
167  call writefield_u('int_phis',phis)
168  call writefield_v('int_vcovm1',vcovm1)
169  call writefield_u('int_ucovm1',ucovm1)
170  call writefield_u('int_tetam1',tetam1)
171  call writefield_u('int_psm1',psm1)
172  call writefield_u('int_massem1',massem1)
173 
174  call writefield_v('int_dv',dv)
175  call writefield_u('int_du',du)
176  call writefield_u('int_dteta',dteta)
177  call writefield_u('int_dp',dp)
178 ! call WriteField_u('int_finvmaold',finvmaold)
179  do j=1,nq
180  call writefield_u('int_q'//trim(int2str(j)),
181  . q(:,:,j))
182  call writefield_u('int_dq'//trim(int2str(j)),
183  . dq(:,:,j))
184  enddo
185  stop
186  ENDIF
187 
188 
189 c
190 C$OMP MASTER
191  if (pole_nord) THEN
192 
193  DO ij = 1, iim
194  tppn(ij) = aire( ij ) * ps( ij )
195  ENDDO
196  tpn = ssum(iim,tppn,1)/apoln
197  DO ij = 1, iip1
198  ps( ij ) = tpn
199  ENDDO
200 
201  ENDIF
202 
203  if (pole_sud) THEN
204 
205  DO ij = 1, iim
206  tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
207  ENDDO
208  tps = ssum(iim,tpps,1)/apols
209  DO ij = 1, iip1
210  ps(ij+ip1jm) = tps
211  ENDDO
212 
213  ENDIF
214 c$OMP END MASTER
215 c$OMP BARRIER
216 c
217 c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ...
218 c
219 
220  CALL pression_loc( ip1jmp1, ap, bp, ps, p )
221 c$OMP BARRIER
222  CALL massdair_loc( p , masse )
223 
224 ! Ehouarn : we don't use/need finvmaold and finvmasse,
225 ! so might as well not compute them
226 !c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 )
227 ! ijb=ij_begin
228 ! ije=ij_end
229 !
230 !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
231 ! DO l = 1,llm
232 ! finvmasse(ijb:ije,l)=masse(ijb:ije,l)
233 ! ENDDO
234 !c$OMP END DO NOWAIT
235 
236 ! jjb=jj_begin
237 ! jje=jj_end
238 ! CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
239 ! & -2, 2, .TRUE., 1 )
240 c
241 
242 c ............ integration de ucov, vcov, h ..............
243 
244 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
245  DO 10 l = 1,llm
246 
247  ijb=ij_begin
248  ije=ij_end
249  if (pole_nord) ijb=ij_begin+iip1
250  if (pole_sud) ije=ij_end-iip1
251 
252  DO 4 ij = ijb,ije
253  uscr( ij ) = ucov( ij,l )
254  ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
255  4 CONTINUE
256 
257  ijb=ij_begin
258  ije=ij_end
259  if (pole_sud) ije=ij_end-iip1
260 
261  DO 5 ij = ijb,ije
262  vscr( ij ) = vcov( ij,l )
263  vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
264  5 CONTINUE
265 
266  ijb=ij_begin
267  ije=ij_end
268 
269  DO 6 ij = ijb,ije
270  hscr( ij ) = teta(ij,l)
271  teta( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l)
272  $ + dt * dteta(ij,l) / masse(ij,l)
273  6 CONTINUE
274 
275 c .... Calcul de la valeur moyenne, unique aux poles pour teta ......
276 c
277 c
278  IF (pole_nord) THEN
279 
280  DO ij = 1, iim
281  tppn(ij) = aire( ij ) * teta( ij ,l)
282  ENDDO
283  tpn = ssum(iim,tppn,1)/apoln
284 
285  DO ij = 1, iip1
286  teta( ij ,l) = tpn
287  ENDDO
288 
289  ENDIF
290 
291  IF (pole_sud) THEN
292 
293  DO ij = 1, iim
294  tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
295  ENDDO
296  tps = ssum(iim,tpps,1)/apols
297 
298  DO ij = 1, iip1
299  teta(ij+ip1jm,l) = tps
300  ENDDO
301 
302  ENDIF
303 c
304 
305  IF(leapf) THEN
306 c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
307 c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
308 c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
309  ijb=ij_begin
310  ije=ij_end
311  ucovm1(ijb:ije,l)=uscr(ijb:ije)
312  tetam1(ijb:ije,l)=hscr(ijb:ije)
313  if (pole_sud) ije=ij_end-iip1
314  vcovm1(ijb:ije,l)=vscr(ijb:ije)
315 
316  END IF
317 
318  10 CONTINUE
319 c$OMP END DO NOWAIT
320 
321 c
322 c ....... integration de q ......
323 c
324  ijb=ij_begin
325  ije=ij_end
326 
327  if (planet_type.eq."earth") then
328 ! Earth-specific treatment of first 2 tracers (water)
329 c$OMP BARRIER
330 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
331  DO l = 1, llm
332  DO ij = ijb, ije
333  deltap(ij,l) = p(ij,l) - p(ij,l+1)
334  ENDDO
335  ENDDO
336 c$OMP END DO NOWAIT
337 c$OMP BARRIER
338 
339  CALL qminimum_loc( q, nq, deltap )
340 c
341 c ..... Calcul de la valeur moyenne, unique aux poles pour q .....
342 c
343 c$OMP BARRIER
344  IF (pole_nord) THEN
345 
346  DO iq = 1, nq
347 
348 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
349  DO l = 1, llm
350 
351  DO ij = 1, iim
352  qppn(ij) = aire( ij ) * q( ij ,l,iq)
353  ENDDO
354  qpn = ssum(iim,qppn,1)/apoln
355 
356  DO ij = 1, iip1
357  q( ij ,l,iq) = qpn
358  ENDDO
359 
360  ENDDO
361 c$OMP END DO NOWAIT
362 
363  ENDDO
364 
365  ENDIF
366 
367  IF (pole_sud) THEN
368 
369  DO iq = 1, nq
370 
371 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
372  DO l = 1, llm
373 
374  DO ij = 1, iim
375  qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
376  ENDDO
377  qps = ssum(iim,qpps,1)/apols
378 
379  DO ij = 1, iip1
380  q(ij+ip1jm,l,iq) = qps
381  ENDDO
382 
383  ENDDO
384 c$OMP END DO NOWAIT
385 
386  ENDDO
387 
388  ENDIF
389 
390 ! Ehouarn: forget about finvmaold
391 !c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
392 
393 !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
394 ! DO l = 1, llm
395 ! finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
396 ! ENDDO
397 !c$OMP END DO NOWAIT
398 
399  endif ! of if (planet_type.eq."earth")
400 
401 c
402 c
403 c ..... FIN de l'integration de q .......
404 
405 15 continue
406 
407 c$OMP DO SCHEDULE(STATIC)
408  DO ij=ijb,ije
409  ps0(ij)=ps(ij)
410  ENDDO
411 c$OMP END DO NOWAIT
412 
413 c .................................................................
414 
415 
416  IF( leapf ) THEN
417 c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 )
418 c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 )
419 c$OMP DO SCHEDULE(STATIC)
420  DO ij=ijb,ije
421  psm1(ij)=pscr(ij)
422  ENDDO
423 c$OMP END DO NOWAIT
424 
425 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
426  DO l = 1, llm
427  massem1(ijb:ije,l)=massescr(ijb:ije,l)
428  ENDDO
429 c$OMP END DO NOWAIT
430  END IF
431 c$OMP BARRIER
432  RETURN
433  END