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