source: LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90 @ 5300

Last change on this file since 5300 was 5285, checked in by abarral, 4 days ago

As discussed internally, remove generic ONLY: ... for new _mod_h modules
  • 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
File size: 6.5 KB
Line 
1!
2! $Header$
3!
4SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, &
5        du,dv,dteta)
6  USE comgeom_mod_h
7  USE parallel_lmdz
8  USE write_field_loc
9  USE advect_new_mod
10  USE comconst_mod, ONLY: daysec
11  USE logic_mod, ONLY: conser
12  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
13  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
14  USE paramet_mod_h
15IMPLICIT NONE
16  !=======================================================================
17  !
18  !   Auteurs:  P. Le Van , Fr. Hourdin  .
19  !   -------
20  !
21  !   Objet:
22  !   ------
23  !
24  !   *************************************************************
25  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
26  !   *************************************************************
27  !    ces termes sont ajoutes a du,dv,dteta et dq .
28  !  Modif F.Forget 03/94 : on retire q de advect
29  !
30  !=======================================================================
31  !-----------------------------------------------------------------------
32  !   Declarations:
33  !   -------------
34
35  !   Arguments:
36  !   ----------
37
38  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
39  REAL :: teta(ijb_u:ije_u,llm)
40  REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
41  REAL :: w(ijb_u:ije_u,llm)
42  REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
43  REAL :: dteta(ijb_u:ije_u,llm)
44  !   Local:
45  !   ------
46
47  REAL :: wsur2(ijb_u:ije_u)
48  REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
49  REAL :: deuxjour, ww, gt, uu, vv
50
51  INTEGER :: ij,l,ijb,ije
52  EXTERNAL  SSUM
53  REAL :: SSUM
54
55
56
57  !-----------------------------------------------------------------------
58  !   2. Calculs preliminaires:
59  !   -------------------------
60
61  IF (conser.AND.1==0)  THEN
62     deuxjour = 2. * daysec
63
64     DO  ij   = 1, ip1jmp1
65     unsaire2(ij) = unsaire(ij) * unsaire(ij)
66     END DO
67  END IF
68
69
70  !------------------  -yy ----------------------------------------------
71  !   .  Calcul de     u
72
73!$OMP MASTER
74  ijb=ij_begin
75  ije=ij_end
76  if (pole_nord) ijb=ijb+iip1
77  if (pole_sud)  ije=ije-iip1
78
79  DO ij=ijb,ije
80    du2(ij,1)=0.
81    du1(ij,llm)=0.
82  ENDDO
83
84  ijb=ij_begin
85  ije=ij_end
86  if (pole_sud)  ije=ij_end-iip1
87
88  DO ij=ijb,ije
89    dv2(ij,1)=0.
90    dv1(ij,llm)=0.
91  ENDDO
92
93  ijb=ij_begin
94  ije=ij_end
95
96  DO ij=ijb,ije
97    dteta2(ij,1)=0.
98    dteta1(ij,llm)=0.
99  ENDDO
100!$OMP END MASTER
101!$OMP BARRIER
102
103!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
104  DO  l=1,llm
105
106     ijb=ij_begin
107     ije=ij_end
108     if (pole_nord) ijb=ijb+iip1
109     if (pole_sud)  ije=ije-iip1
110
111      ! DO    ij     = iip2, ip1jmp1
112      !    uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
113      ! ENDDO
114
115      ! DO    ij     = iip2, ip1jm
116      !    uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
117      ! ENDDO
118
119     DO    ij     = ijb, ije
120
121       uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) &
122             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
123     ENDDO
124
125     if (pole_nord) then
126       DO      ij         = 1, iip1
127          uav(ij      ,l) = 0.
128       ENDDO
129     endif
130
131     if (pole_sud) then
132       DO      ij         = 1, iip1
133          uav(ip1jm+ij,l) = 0.
134       ENDDO
135     endif
136
137  ENDDO
138!$OMP END DO
139   ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
140
141  !------------------  -xx ----------------------------------------------
142  !   .  Calcul de     v
143
144  ijb=ij_begin
145  ije=ij_end
146  if (pole_sud)  ije=ij_end-iip1
147
148!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
149  DO  l=1,llm
150
151     DO    ij   = ijb+1, ije
152       vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
153     ENDDO
154
155     DO    ij   = ijb,ije,iip1
156      vav(ij,l) = vav(ij+iim,l)
157     ENDDO
158
159
160     DO    ij   = ijb, ije-1
161      vav(ij,l) = vav(ij,l) + vav(ij+1,l)
162     ENDDO
163
164     DO    ij       = ijb, ije, iip1
165      vav(ij+iim,l) = vav(ij,l)
166     ENDDO
167
168  ENDDO
169!$OMP END DO
170    ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
171
172  !-----------------------------------------------------------------------
173!$OMP BARRIER
174
175!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
176  DO l = 1, llmm1
177
178
179    ! ......   calcul de  - w/2.    au niveau  l+1   .......
180  ijb=ij_begin
181  ije=ij_end+iip1
182  if (pole_sud)  ije=ij_end
183
184  DO   ij   = ijb, ije
185  wsur2( ij ) = - 0.5 * w( ij,l+1 )
186  END DO
187
188
189  ! .....................     calcul pour  du     ..................
190
191  ijb=ij_begin
192  ije=ij_end
193  if (pole_nord) ijb=ijb+iip1
194  if (pole_sud)  ije=ije-iip1
195
196  DO ij = ijb ,ije-1
197  ww        = wsur2 (  ij  )     + wsur2( ij+1 )
198  uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
199  du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
200  du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
201  END DO
202
203  ! .................    calcul pour   dv      .....................
204  ijb=ij_begin
205  ije=ij_end
206  if (pole_sud)  ije=ij_end-iip1
207
208  DO ij = ijb, ije
209  ww        = wsur2( ij+iip1 )   + wsur2( ij )
210  vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
211  dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
212  dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
213  END DO
214
215  !
216
217  ! ............................................................
218  ! ...............    calcul pour   dh      ...................
219  ! ............................................................
220
221  !                   ---z
222  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
223  !               ...............
224    ijb=ij_begin
225    ije=ij_end
226
227    DO ij = ijb, ije
228     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
229     dteta1(ij, l ) =   ww
230     dteta2(ij,l+1) =   ww
231    END DO
232
233  ! ym ---> conser a voir plus tard
234
235   ! IF( conser)  THEN
236  !
237  !    DO 17 ij = 1,ip1jmp1
238  !    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
239  !  17    CONTINUE
240  !    gt       = SSUM( ip1jmp1,ge,1 )
241  !    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
242  !  END IF
243
244  END DO
245!$OMP END DO
246
247  ijb=ij_begin
248  ije=ij_end
249  if (pole_nord) ijb=ijb+iip1
250  if (pole_sud)  ije=ije-iip1
251IF (CPPKEY_DEBUGIO) THEN
252   CALL WriteField_u('du_bis',du)
253END IF
254!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
255  DO l=1,llm
256    DO ij=ijb,ije-1
257      du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
258    ENDDO
259
260    DO   ij   = ijb+iip1-1, ije, iip1
261     du( ij, l  ) = du( ij -iim, l  )
262    ENDDO
263  ENDDO
264!$OMP END DO NOWAIT
265IF (CPPKEY_DEBUGIO) THEN
266  CALL WriteField_u('du1',du1)
267  CALL WriteField_u('du2',du2)
268  CALL WriteField_u('du_bis',du)
269END IF
270  ijb=ij_begin
271  ije=ij_end
272  if (pole_sud)  ije=ij_end-iip1
273
274!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
275  DO l=1,llm
276    DO ij=ijb,ije
277      dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
278    ENDDO
279  ENDDO
280!$OMP END DO NOWAIT
281  ijb=ij_begin
282  ije=ij_end
283
284!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
285  DO l=1,llm
286    DO ij=ijb,ije
287      dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
288    ENDDO
289  ENDDO
290!$OMP END DO NOWAIT
291
292  RETURN
293END SUBROUTINE advect_new_loc
Note: See TracBrowser for help on using the repository browser.