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

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

Cleanup in the dynamics: turn temps.h into module temps_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
RevLine 
[1279]1!
2! $Id: fluxstokenc_p.F 2601 2016-07-24 09:51:55Z oboucher $
3!
[630]4      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
5     . time_step,itau )
[1403]6#ifdef CPP_IOIPSL
7! This routine is designed to work with ioipsl
[630]8
9       USE IOIPSL
[1823]10       USE parallel_lmdz
[630]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"
[1279]25#include "iniprint.h"
[630]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
[1000]32      REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
[630]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
[764]44      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
[630]45 
[1021]46      SAVE iadvtr, massem,irec
[630]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
[764]55c AC initialisations
[1454]56      pbarug(:,:)   = 0.
[764]57cym      pbarvg(:,:,:) = 0.
58cym      wg(:,:)       = 0.
59
[1000]60c$OMP MASTER
61
[630]62      if(first) then
63
64        CALL initfluxsto_p( 'fluxstoke',
65     .  time_step,istdyn* time_step,istdyn* time_step,
[1146]66     .  fluxid,fluxvid,fluxdid)
[630]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       
[1000]105        IF (pole_sud) ije=ij_end-iip1
[630]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
[1000]141c$OMP END MASTER
142c$OMP BARRIER
[630]143c   Test pour savoir si on advecte a ce pas de temps
144      IF ( iadvtr.EQ.istdyn ) THEN
[1000]145c$OMP MASTER
[630]146c    normalisation
147      ijb=ij_begin
148      ije=ij_end
149
150      DO l=1,llm
151         DO ij = ijb,ije
[1403]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)
[630]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
[1403]164            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
[630]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.
[1000]171c$OMP END MASTER
172c$OMP BARRIER
[630]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)
[1000]176c$OMP BARRIER
[630]177        call WaitRequest(Req)
[1000]178c$OMP BARRIER
179c$OMP MASTER
[630]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
[1403]201        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
[630]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
[1000]238c$OMP END MASTER
[630]239      ENDIF ! if iadvtr.EQ.istdyn
240
[1279]241#else
242      write(lunout,*)
[1403]243     & 'fluxstokenc: Needs IOIPSL to function'
[1279]244#endif
[1403]245! of #ifdef CPP_IOIPSL
[630]246      RETURN
247      END
Note: See TracBrowser for help on using the repository browser.