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

Last change on this file since 1056 was 1037, checked in by raasch, 12 years ago

last commit documented

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