source: LMDZ5/trunk/libf/dyn3dpar/flumass_p.F @ 4735

Last change on this file since 4735 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

  • 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
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.3 KB
Line 
1      SUBROUTINE flumass_p(massebx,masseby, vcont, ucont, pbaru, pbarv)
2      USE parallel_lmdz
3      IMPLICIT NONE
4
5c=======================================================================
6c
7c   Auteurs:  P. Le Van, F. Hourdin  .
8c   -------
9c
10c   Objet:
11c   ------
12c
13c *********************************************************************
14c     .... calcul du flux de masse  aux niveaux s ......
15c *********************************************************************
16c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
17c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
18c
19c=======================================================================
20
21
22#include "dimensions.h"
23#include "paramet.h"
24#include "comgeom.h"
25
26      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
27     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
28     * pbarv( ip1jm,llm )
29
30      REAL apbarun( iip1 ),apbarus( iip1 )
31
32      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
33      INTEGER  l,ij,i
34      INTEGER ijb,ije
35     
36      EXTERNAL   SSUM
37      REAL       SSUM
38     
39c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
40      DO  5 l = 1,llm
41
42        ijb=ij_begin
43        ije=ij_end+iip1
44     
45        if (pole_nord) ijb=ij_begin+iip1
46        if (pole_sud)  ije=ij_end-iip1
47       
48        DO  1 ij = ijb,ije
49          pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
50   1    CONTINUE
51
52        ijb=ij_begin-iip1
53        ije=ij_end+iip1
54     
55        if (pole_nord) ijb=ij_begin
56        if (pole_sud)  ije=ij_end-iip1
57       
58        DO 3 ij = ijb,ije
59          pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
60   3    CONTINUE
61
62   5  CONTINUE
63c$OMP END DO NOWAIT
64c    ................................................................
65c     calcul de la composante du flux de masse en x aux poles .......
66c    ................................................................
67c     par la resolution d'1 systeme de 2 equations .
68
69c     la premiere equat.decrivant le calcul de la divergence en 1 point i
70c     du pole,ce calcul etant itere de i=1 a i=im .
71c                 c.a.d   ,
72c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
73c                                           - somme de ( pbarv(n) )/aire pole
74
75c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
76c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
77
78c     on en revient ainsi a determiner la constante additive commune aux pbaru
79c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
80c     i=1 .
81c     i variant de 1 a im
82c     n variant de 1 a im
83
84      IF (pole_nord) THEN
85     
86        sairen = SSUM( iim,  aire(   1     ), 1 )
87        saireun= SSUM( iim, aireu(   1     ), 1 )
88
89c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
90        DO l = 1,llm
91 
92          ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
93     
94          pbaru(1,l)=pbarv(1,l) - ctn * aire(1)
95       
96          DO i = 2,iim
97            pbaru(i,l) = pbaru(i- 1,l )    +
98     *                   pbarv(i,l) - ctn * aire(i )
99          ENDDO
100       
101          DO i = 1,iim
102            apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
103          ENDDO
104     
105          ctn0 = -SSUM( iim,apbarun,1 )/saireun
106       
107          DO i = 1,iim
108            pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
109          ENDDO
110       
111          pbaru(   iip1 ,l ) = pbaru(    1    ,l )
112       
113        ENDDO
114c$OMP END DO NOWAIT             
115
116      ENDIF
117
118     
119      IF (pole_sud) THEN
120 
121        saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
122        saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
123
124c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
125        DO  l = 1,llm
126 
127          cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
128          pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1)
129   
130          DO i = 2,iim
131            pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l)    -
132     *                          pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
133          ENDDO
134       
135          DO i = 1,iim
136            apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
137          ENDDO
138
139          cts0 = -SSUM( iim,apbarus,1 )/saireus
140
141          DO i = 1,iim
142            pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
143          ENDDO
144
145          pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
146       
147        ENDDO
148c$OMP END DO NOWAIT         
149      ENDIF
150     
151      RETURN
152      END
Note: See TracBrowser for help on using the repository browser.