source: LMDZ5/trunk/libf/dyn3dpar/fluxstokenc_p.F @ 2600

Last change on this file since 2600 was 2600, checked in by Ehouarn Millour, 8 years ago

Cleanup in the dynamics: turn comvert.h into module comvert_mod.F90
EM
  • 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: 5.7 KB
Line 
1!
2! $Id: fluxstokenc_p.F 2600 2016-07-23 05:45:38Z emillour $
3!
4      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
5     . time_step,itau )
6#ifdef CPP_IOIPSL
7! This routine is designed to work with ioipsl
8
9       USE IOIPSL
10       USE parallel_lmdz
11       USE misc_mod
12       USE mod_hallo
13c
14c     Auteur :  F. Hourdin
15c
16c
17ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
18c
19      IMPLICIT NONE
20c
21#include "dimensions.h"
22#include "paramet.h"
23#include "comgeom.h"
24#include "tracstoke.h"
25#include "temps.h"
26#include "iniprint.h"
27
28      REAL time_step,t_wrt, t_ops
29      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
30      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
31      REAL phis(ip1jmp1)
32
33      REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
34      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
35
36      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
37
38      REAL pbarvst(iip1,jjp1,llm),zistdyn
39        real dtcum
40
41      INTEGER iadvtr,ndex(1)
42      integer nscal
43      real tst(1),ist(1),istp(1)
44      INTEGER ij,l,irec,i,j,itau
45      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
46 
47      SAVE iadvtr, massem,irec
48      SAVE phic,tetac
49      logical first
50      save first
51      data first/.true./
52      DATA iadvtr/0/
53      integer :: ijb,ije,jjb,jje,jjn
54      type(Request) :: Req
55
56c AC initialisations
57      pbarug(:,:)   = 0.
58cym      pbarvg(:,:,:) = 0.
59cym      wg(:,:)       = 0.
60
61c$OMP MASTER
62
63      if(first) then
64
65        CALL initfluxsto_p( 'fluxstoke',
66     .  time_step,istdyn* time_step,istdyn* time_step,
67     .  fluxid,fluxvid,fluxdid)
68       
69        ijb=ij_begin
70        ije=ij_end
71        jjn=jj_nb
72
73        ndex(1) = 0
74        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
75     .                 iip1*jjn, ndex)
76        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
77     .                 iip1*jjn, ndex)
78       
79        ndex(1) = 0
80        nscal = 1
81       
82        if (mpi_rank==0) then
83          tst(1) = time_step
84          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
85          ist(1)=istdyn
86          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
87          istp(1)= istphy
88          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
89        endif
90        first = .false.
91
92      endif
93
94
95      IF(iadvtr.EQ.0) THEN
96cym         CALL initial0(ijp1llm,phic)
97cym        CALL initial0(ijp1llm,tetac)
98cym         CALL initial0(ijp1llm,pbaruc)
99cym         CALL initial0(ijmllm,pbarvc)
100        ijb=ij_begin
101        ije=ij_end
102        phic(ijb:ije,1:llm)=0
103        tetac(ijb:ije,1:llm)=0
104        pbaruc(ijb:ije,1:llm)=0
105       
106        IF (pole_sud) ije=ij_end-iip1
107        pbarvc(ijb:ije,1:llm)=0
108      ENDIF
109
110c   accumulation des flux de masse horizontaux
111      ijb=ij_begin
112      ije=ij_end
113     
114      DO l=1,llm
115         DO ij = ijb,ije
116            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
117            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
118            phic(ij,l) = phic(ij,l) + phi(ij,l)
119         ENDDO
120       ENDDO
121     
122      ijb=ij_begin
123      ije=ij_end
124      if (pole_sud) ije=ij_end-iip1
125       
126      DO l=1,llm
127         DO ij = ijb,ije
128            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
129         ENDDO
130      ENDDO
131
132c   selection de la masse instantannee des mailles avant le transport.
133      IF(iadvtr.EQ.0) THEN
134cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
135        ijb=ij_begin
136        ije=ij_end
137        massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
138      ENDIF
139
140      iadvtr   = iadvtr+1
141
142c$OMP END MASTER
143c$OMP BARRIER
144c   Test pour savoir si on advecte a ce pas de temps
145      IF ( iadvtr.EQ.istdyn ) THEN
146c$OMP MASTER
147c    normalisation
148      ijb=ij_begin
149      ije=ij_end
150
151      DO l=1,llm
152         DO ij = ijb,ije
153            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
154            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
155            phic(ij,l) = phic(ij,l)/REAL(istdyn)
156         ENDDO
157      ENDDO
158
159      ijb=ij_begin
160      ije=ij_end
161      if (pole_sud) ije=ij_end-iip1     
162     
163      DO l=1,llm
164          DO ij = ijb,ije
165            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
166         ENDDO
167      ENDDO
168
169c   traitement des flux de masse avant advection.
170c     1. calcul de w
171c     2. groupement des mailles pres du pole.
172c$OMP END MASTER
173c$OMP BARRIER
174        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
175        call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
176        call SendRequest(Req)
177c$OMP BARRIER
178        call WaitRequest(Req)
179c$OMP BARRIER
180c$OMP MASTER
181        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
182       
183        jjb=jj_begin
184        jje=jj_end
185        if (pole_sud) jje=jj_end-1
186       
187        do l=1,llm
188           do j=jjb,jje
189              do i=1,iip1
190                 pbarvst(i,j,l)=pbarvg(i,j,l)
191              enddo
192           enddo
193         enddo
194         
195         if (pole_sud) then
196           do i=1,iip1
197              pbarvst(i,jjp1,l)=0.
198           enddo
199        endif
200     
201         iadvtr=0
202        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
203       
204        ijb=ij_begin
205        ije=ij_end
206        jjn=jj_nb
207       
208        call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
209     .               iip1*jjn*llm, ndex)
210       
211        call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
212     .               iip1*jjn*llm, ndex)
213       
214        jjb=jj_begin
215        jje=jj_end
216        jjn=jj_nb
217        if (pole_sud) then
218          jje=jj_end-1
219          jjn=jj_nb-1
220        endif
221       
222        call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
223     .               iip1*jjn*llm, ndex)
224       
225        ijb=ij_begin
226        ije=ij_end
227        jjn=jj_nb
228       
229        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:),
230     .             iip1*jjn*llm, ndex)
231       
232        call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:),
233     .             iip1*jjn*llm, ndex)
234       
235        call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:),
236     .             iip1*jjn*llm, ndex)
237       
238C
239c$OMP END MASTER
240      ENDIF ! if iadvtr.EQ.istdyn
241
242#else
243      write(lunout,*)
244     & 'fluxstokenc: Needs IOIPSL to function'
245#endif
246! of #ifdef CPP_IOIPSL
247      RETURN
248      END
Note: See TracBrowser for help on using the repository browser.