source: palm/trunk/SOURCE/diffusion_e.f90 @ 1132

Last change on this file since 1132 was 1132, checked in by raasch, 9 years ago

r1028 documented

  • Property svn:keywords set to Id
File size: 21.6 KB
Line 
1 MODULE diffusion_e_mod
2
3!--------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2012  Leibniz University Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: diffusion_e.f90 1132 2013-04-12 14:35:30Z raasch $
27!
28! 1128 2013-04-12 06:19:32Z raasch
29! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
30! j_north
31!
32! 1065 2012-11-22 17:42:36Z hoffmann
33! Enabled the claculation of diss in case of turbulence = .TRUE. (parameterized
34! effects of turbulence on autoconversion and accretion in two-moments cloud
35! physics scheme).
36!
37! 1036 2012-10-22 13:43:42Z raasch
38! code put under GPL (PALM 3.9)
39!
40! 1015 2012-09-27 09:23:24Z raasch
41! accelerator version (*_acc) added,
42! adjustment of mixing length to the Prandtl mixing length at first grid point
43! above ground removed
44!
45! 1010 2012-09-20 07:59:54Z raasch
46! cpp switch __nopointer added for pointer free version
47!
48! 1001 2012-09-13 14:08:46Z raasch
49! most arrays comunicated by module instead of parameter list
50!
51! 825 2012-02-19 03:03:44Z raasch
52! wang_collision_kernel renamed wang_kernel
53!
54! 790 2011-11-29 03:11:20Z raasch
55! diss is also calculated in case that the Wang kernel is used
56!
57! 667 2010-12-23 12:06:00Z suehring/gryschka
58! nxl-1, nxr+1, nys-1, nyn+1 replaced by nxlg, nxrg, nysg, nyng
59!
60! 97 2007-06-21 08:23:15Z raasch
61! Adjustment of mixing length calculation for the ocean version. zw added to
62! argument list.
63! This is also a bugfix, because the height above the topography is now
64! used instead of the height above level k=0.
65! theta renamed var, dpt_dz renamed dvar_dz, +new argument var_reference
66! use_pt_reference renamed use_reference
67!
68! 65 2007-03-13 12:11:43Z raasch
69! Reference temperature pt_reference can be used in buoyancy term
70!
71! 20 2007-02-26 00:12:32Z raasch
72! Bugfix: ddzw dimensioned 1:nzt"+1"
73! Calculation extended for gridpoint nzt
74!
75! RCS Log replace by Id keyword, revision history cleaned up
76!
77! Revision 1.18  2006/08/04 14:29:43  raasch
78! dissipation is stored in extra array diss if needed later on for calculating
79! the sgs particle velocities
80!
81! Revision 1.1  1997/09/19 07:40:24  raasch
82! Initial revision
83!
84!
85! Description:
86! ------------
87! Diffusion- and dissipation terms for the TKE
88!------------------------------------------------------------------------------!
89
90    PRIVATE
91    PUBLIC diffusion_e, diffusion_e_acc
92   
93
94    INTERFACE diffusion_e
95       MODULE PROCEDURE diffusion_e
96       MODULE PROCEDURE diffusion_e_ij
97    END INTERFACE diffusion_e
98 
99    INTERFACE diffusion_e_acc
100       MODULE PROCEDURE diffusion_e_acc
101    END INTERFACE diffusion_e_acc
102
103 CONTAINS
104
105
106!------------------------------------------------------------------------------!
107! Call for all grid points
108!------------------------------------------------------------------------------!
109    SUBROUTINE diffusion_e( var, var_reference )
110
111       USE arrays_3d
112       USE control_parameters
113       USE grid_variables
114       USE indices
115       USE particle_attributes
116
117       IMPLICIT NONE
118
119       INTEGER ::  i, j, k
120       REAL    ::  dvar_dz, l_stable, var_reference
121
122#if defined( __nopointer )
123       REAL, DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var
124#else
125       REAL, DIMENSION(:,:,:), POINTER ::  var
126#endif
127       REAL, DIMENSION(nzb+1:nzt,nys:nyn) ::  dissipation, l, ll
128 
129
130!
131!--    This if clause must be outside the k-loop because otherwise
132!--    runtime errors occur with -C hopt on NEC
133       IF ( use_reference )  THEN
134
135          DO  i = nxl, nxr
136             DO  j = nys, nyn
137                DO  k = nzb_s_inner(j,i)+1, nzt
138!
139!--                Calculate the mixing length (for dissipation)
140                   dvar_dz = atmos_ocean_sign * &
141                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
142                   IF ( dvar_dz > 0.0 ) THEN
143                      l_stable = 0.76 * SQRT( e(k,j,i) ) / &
144                                 SQRT( g / var_reference * dvar_dz ) + 1E-5
145                   ELSE
146                      l_stable = l_grid(k)
147                   ENDIF
148!
149!--                Adjustment of the mixing length
150                   IF ( wall_adjustment )  THEN
151                      l(k,j)  = MIN( wall_adjustment_factor *          &
152                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
153                                     l_grid(k), l_stable )
154                      ll(k,j) = MIN( wall_adjustment_factor *          &
155                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
156                                     l_grid(k) )
157                   ELSE
158                      l(k,j)  = MIN( l_grid(k), l_stable )
159                      ll(k,j) = l_grid(k)
160                   ENDIF
161
162                ENDDO
163             ENDDO
164
165!
166!--          Calculate the tendency terms
167             DO  j = nys, nyn
168                DO  k = nzb_s_inner(j,i)+1, nzt
169
170                    dissipation(k,j) = ( 0.19 + 0.74 * l(k,j) / ll(k,j) ) * &
171                                       e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
172
173                    tend(k,j,i) = tend(k,j,i)                                  &
174                                        + (                                    &
175                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
176                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
177                                          ) * ddx2                             &
178                                        + (                                    &
179                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
180                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
181                                          ) * ddy2                             &
182                                        + (                                    &
183               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
184             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
185                                          ) * ddzw(k)                          &
186                             - dissipation(k,j)
187
188                ENDDO
189             ENDDO
190
191!
192!--          Store dissipation if needed for calculating the sgs particle
193!--          velocities
194             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
195                  turbulence )  THEN
196                DO  j = nys, nyn
197                   DO  k = nzb_s_inner(j,i)+1, nzt
198                      diss(k,j,i) = dissipation(k,j)
199                   ENDDO
200                ENDDO
201             ENDIF
202
203          ENDDO
204
205       ELSE
206
207          DO  i = nxl, nxr
208             DO  j = nys, nyn
209                DO  k = nzb_s_inner(j,i)+1, nzt
210!
211!--                Calculate the mixing length (for dissipation)
212                   dvar_dz = atmos_ocean_sign * &
213                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
214                   IF ( dvar_dz > 0.0 ) THEN
215                      l_stable = 0.76 * SQRT( e(k,j,i) ) / &
216                                        SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5
217                   ELSE
218                      l_stable = l_grid(k)
219                   ENDIF
220!
221!--                Adjustment of the mixing length
222                   IF ( wall_adjustment )  THEN
223                      l(k,j)  = MIN( wall_adjustment_factor *          &
224                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
225                                     l_grid(k), l_stable )
226                      ll(k,j) = MIN( wall_adjustment_factor *          &
227                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
228                                     l_grid(k) )
229                   ELSE
230                      l(k,j)  = MIN( l_grid(k), l_stable )
231                      ll(k,j) = l_grid(k)
232                   ENDIF
233
234                ENDDO
235             ENDDO
236
237!
238!--          Calculate the tendency terms
239             DO  j = nys, nyn
240                DO  k = nzb_s_inner(j,i)+1, nzt
241
242                    dissipation(k,j) = ( 0.19 + 0.74 * l(k,j) / ll(k,j) ) * &
243                                       e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
244
245                    tend(k,j,i) = tend(k,j,i)                                  &
246                                        + (                                    &
247                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
248                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
249                                          ) * ddx2                             &
250                                        + (                                    &
251                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
252                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
253                                          ) * ddy2                             &
254                                        + (                                    &
255               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
256             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
257                                          ) * ddzw(k)                          &
258                             - dissipation(k,j)
259
260                ENDDO
261             ENDDO
262
263!
264!--          Store dissipation if needed for calculating the sgs particle
265!--          velocities
266             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
267                  turbulence )  THEN
268                DO  j = nys, nyn
269                   DO  k = nzb_s_inner(j,i)+1, nzt
270                      diss(k,j,i) = dissipation(k,j)
271                   ENDDO
272                ENDDO
273             ENDIF
274
275          ENDDO
276
277       ENDIF
278
279!
280!--    Boundary condition for dissipation
281       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.  turbulence )  THEN
282          DO  i = nxl, nxr
283             DO  j = nys, nyn
284                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
285             ENDDO
286          ENDDO
287       ENDIF
288
289    END SUBROUTINE diffusion_e
290
291
292!------------------------------------------------------------------------------!
293! Call for all grid points - accelerator version
294!------------------------------------------------------------------------------!
295    SUBROUTINE diffusion_e_acc( var, var_reference )
296
297       USE arrays_3d
298       USE control_parameters
299       USE grid_variables
300       USE indices
301       USE particle_attributes
302
303       IMPLICIT NONE
304
305       INTEGER ::  i, j, k
306       REAL    ::  dissipation, dvar_dz, l, ll, l_stable, var_reference
307
308#if defined( __nopointer )
309       REAL, DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var
310#else
311       REAL, DIMENSION(:,:,:), POINTER ::  var
312#endif
313
314
315!
316!--    This if clause must be outside the k-loop because otherwise
317!--    runtime errors occur with -C hopt on NEC
318       IF ( use_reference )  THEN
319          STOP '+++ use_reference not implemented in diffusion_e_acc'
320!          DO  i = nxl, nxr
321!             DO  j = nys, nyn
322!                DO  k = nzb_s_inner(j,i)+1, nzt
323!
324!--                Calculate the mixing length (for dissipation)
325!                   dvar_dz = atmos_ocean_sign * &
326!                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
327!                   IF ( dvar_dz > 0.0 ) THEN
328!                      l_stable = 0.76 * SQRT( e(k,j,i) ) / &
329!                                 SQRT( g / var_reference * dvar_dz ) + 1E-5
330!                   ELSE
331!                      l_stable = l_grid(k)
332!                   ENDIF
333!
334!--                Adjustment of the mixing length
335!                   IF ( wall_adjustment )  THEN
336!                      l(k,j)  = MIN( wall_adjustment_factor *          &
337!                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
338!                                     l_grid(k), l_stable )
339!                      ll(k,j) = MIN( wall_adjustment_factor *          &
340!                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
341!                                     l_grid(k) )
342!                   ELSE
343!                      l(k,j)  = MIN( l_grid(k), l_stable )
344!                      ll(k,j) = l_grid(k)
345!                   ENDIF
346!
347!                ENDDO
348!             ENDDO
349!
350!
351!--          Calculate the tendency terms
352!             DO  j = nys, nyn
353!                DO  k = nzb_s_inner(j,i)+1, nzt
354!
355!                    dissipation(k,j) = ( 0.19 + 0.74 * l(k,j) / ll(k,j) ) * &
356!                                       e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
357!
358!                    tend(k,j,i) = tend(k,j,i)                                  &
359!                                        + (                                    &
360!                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
361!                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
362!                                          ) * ddx2                             &
363!                                        + (                                    &
364!                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
365!                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
366!                                          ) * ddy2                             &
367!                                        + (                                    &
368!               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
369!             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
370!                                          ) * ddzw(k)                          &
371!                             - dissipation(k,j)
372!
373!                ENDDO
374!             ENDDO
375!
376!
377!--          Store dissipation if needed for calculating the sgs particle
378!--          velocities
379!             IF ( use_sgs_for_particles  .OR.  wang_kernel )  THEN
380!                DO  j = nys, nyn
381!                   DO  k = nzb_s_inner(j,i)+1, nzt
382!                      diss(k,j,i) = dissipation(k,j)
383!                   ENDDO
384!                ENDDO
385!             ENDIF
386!
387!          ENDDO
388!
389       ELSE
390
391          !$acc kernels present( ddzu, ddzw, dd2zu, diss, e, km, l_grid ) &
392          !$acc         present( nzb_s_inner, rif, tend, var, zu, zw )
393          !$acc loop
394          DO  i = i_left, i_right
395             DO  j = j_south, j_north
396                !$acc loop vector( 32 )
397                DO  k = 1, nzt
398
399                   IF ( k > nzb_s_inner(j,i) )  THEN
400!
401!--                   Calculate the mixing length (for dissipation)
402                      dvar_dz = atmos_ocean_sign * &
403                                ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
404                      IF ( dvar_dz > 0.0 ) THEN
405                         l_stable = 0.76 * SQRT( e(k,j,i) ) / &
406                                           SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5
407                      ELSE
408                         l_stable = l_grid(k)
409                      ENDIF
410!
411!--                   Adjustment of the mixing length
412                      IF ( wall_adjustment )  THEN
413                         = MIN( wall_adjustment_factor *          &
414                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
415                                     l_grid(k), l_stable )
416                         ll = MIN( wall_adjustment_factor *          &
417                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
418                                   l_grid(k) )
419                      ELSE
420                         = MIN( l_grid(k), l_stable )
421                         ll = l_grid(k)
422                      ENDIF
423!
424!--                   Calculate the tendency terms
425                      dissipation = ( 0.19 + 0.74 * l / ll ) * &
426                                    e(k,j,i) * SQRT( e(k,j,i) ) / l
427
428                      tend(k,j,i) = tend(k,j,i)                                &
429                                        + (                                    &
430                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
431                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
432                                          ) * ddx2                             &
433                                        + (                                    &
434                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
435                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
436                                          ) * ddy2                             &
437                                        + (                                    &
438               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
439             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
440                                          ) * ddzw(k)                          &
441                             - dissipation
442
443!
444!--                   Store dissipation if needed for calculating the sgs
445!--                   particle  velocities
446                      IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.      &
447                           turbulence )  THEN
448                         diss(k,j,i) = dissipation
449                      ENDIF
450
451                   ENDIF
452
453                ENDDO
454             ENDDO
455          ENDDO
456          !$acc end kernels
457
458       ENDIF
459
460!
461!--    Boundary condition for dissipation
462       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.  turbulence )  THEN
463          !$acc kernels present( diss, nzb_s_inner )
464          !$acc loop
465          DO  i = i_left, i_right
466             !$acc loop vector( 32 )
467             DO  j = j_south, j_north
468                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
469             ENDDO
470          ENDDO
471          !$acc end kernels
472       ENDIF
473
474    END SUBROUTINE diffusion_e_acc
475
476
477!------------------------------------------------------------------------------!
478! Call for grid point i,j
479!------------------------------------------------------------------------------!
480    SUBROUTINE diffusion_e_ij( i, j, var, var_reference )
481
482       USE arrays_3d
483       USE control_parameters
484       USE grid_variables
485       USE indices
486       USE particle_attributes
487
488       IMPLICIT NONE
489
490       INTEGER ::  i, j, k
491       REAL    ::  dvar_dz, l_stable, var_reference
492
493#if defined( __nopointer )
494       REAL, DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var
495#else
496       REAL, DIMENSION(:,:,:), POINTER ::  var
497#endif
498       REAL, DIMENSION(nzb+1:nzt) ::  dissipation, l, ll
499
500
501!
502!--    Calculate the mixing length (for dissipation)
503       DO  k = nzb_s_inner(j,i)+1, nzt
504          dvar_dz = atmos_ocean_sign * &
505                    ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
506          IF ( dvar_dz > 0.0 ) THEN
507             IF ( use_reference )  THEN
508                l_stable = 0.76 * SQRT( e(k,j,i) ) / &
509                                  SQRT( g / var_reference * dvar_dz ) + 1E-5
510             ELSE
511                l_stable = 0.76 * SQRT( e(k,j,i) ) / &
512                                  SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5
513             ENDIF
514          ELSE
515             l_stable = l_grid(k)
516          ENDIF
517!
518!--       Adjustment of the mixing length
519          IF ( wall_adjustment )  THEN
520             l(k)  = MIN( wall_adjustment_factor *                     &
521                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k), &
522                          l_stable )
523             ll(k) = MIN( wall_adjustment_factor *                     &
524                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k) )
525          ELSE
526             l(k)  = MIN( l_grid(k), l_stable )
527             ll(k) = l_grid(k)
528          ENDIF
529!
530!--       Calculate the tendency term
531          dissipation(k) = ( 0.19 + 0.74 * l(k) / ll(k) ) * e(k,j,i) * &
532                           SQRT( e(k,j,i) ) / l(k)
533
534          tend(k,j,i) = tend(k,j,i)                                           &
535                                       + (                                    &
536                         ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
537                       - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
538                                         ) * ddx2                             &
539                                       + (                                    &
540                         ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
541                       - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
542                                         ) * ddy2                             &
543                                       + (                                    &
544              ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
545            - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
546                                         ) * ddzw(k)                          &
547                                       - dissipation(k)
548
549       ENDDO
550
551!
552!--    Store dissipation if needed for calculating the sgs particle velocities
553       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.  turbulence )  THEN
554          DO  k = nzb_s_inner(j,i)+1, nzt
555             diss(k,j,i) = dissipation(k)
556          ENDDO
557!
558!--       Boundary condition for dissipation
559          diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
560       ENDIF
561
562    END SUBROUTINE diffusion_e_ij
563
564 END MODULE diffusion_e_mod
Note: See TracBrowser for help on using the repository browser.