source: trunk/LMDZ.COMMON/libf/dyn3dpar/fluxstokenc_p.F @ 3093

Last change on this file since 3093 was 1422, checked in by milmd, 10 years ago

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