source: palm/trunk/SOURCE/init_1d_model.f90 @ 1697

Last change on this file since 1697 was 1697, checked in by raasch, 8 years ago

FORTRAN an OpenMP errors removed
misplaced cpp-directive fixed
small E- and F-FORMAT changes to avoid informative compiler messages about insufficient field width

  • Property svn:keywords set to Id
File size: 35.9 KB
Line 
1!> @file init_1d_model.f90
2!--------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms
6! of the GNU General Public License as published by the Free Software Foundation,
7! either version 3 of the License, or (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
10! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with
14! PALM. If not, see <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2015 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21! small E- and F-FORMAT changes to avoid informative compiler messages about
22! insufficient field width
23!
24! Former revisions:
25! -----------------
26! $Id: init_1d_model.f90 1697 2015-10-28 17:14:10Z raasch $
27!
28! 1691 2015-10-26 16:17:44Z maronga
29! Renamed prandtl_layer to constant_flux_layer. rif is replaced by ol and zeta.
30!
31! 1682 2015-10-07 23:56:08Z knoop
32! Code annotations made doxygen readable
33!
34! 1353 2014-04-08 15:21:23Z heinze
35! REAL constants provided with KIND-attribute
36!
37! 1346 2014-03-27 13:18:20Z heinze
38! Bugfix: REAL constants provided with KIND-attribute especially in call of
39! intrinsic function like MAX, MIN, SIGN
40!
41! 1322 2014-03-20 16:38:49Z raasch
42! REAL functions provided with KIND-attribute
43!
44! 1320 2014-03-20 08:40:49Z raasch
45! ONLY-attribute added to USE-statements,
46! kind-parameters added to all INTEGER and REAL declaration statements,
47! kinds are defined in new module kinds,
48! revision history before 2012 removed,
49! comment fields (!:) to be used for variable explanations added to
50! all variable declaration statements
51!
52! 1036 2012-10-22 13:43:42Z raasch
53! code put under GPL (PALM 3.9)
54!
55! 1015 2012-09-27 09:23:24Z raasch
56! adjustment of mixing length to the Prandtl mixing length at first grid point
57! above ground removed
58!
59! 1001 2012-09-13 14:08:46Z raasch
60! all actions concerning leapfrog scheme removed
61!
62! 996 2012-09-07 10:41:47Z raasch
63! little reformatting
64!
65! 978 2012-08-09 08:28:32Z fricke
66! roughness length for scalar quantities z0h1d added
67!
68! Revision 1.1  1998/03/09 16:22:10  raasch
69! Initial revision
70!
71!
72! Description:
73! ------------
74!> 1D-model to initialize the 3D-arrays.
75!> The temperature profile is set as steady and a corresponding steady solution
76!> of the wind profile is being computed.
77!> All subroutines required can be found within this file.
78!>
79!> @todo harmonize code with new surface_layer_fluxes module
80!------------------------------------------------------------------------------!
81 SUBROUTINE init_1d_model
82 
83
84    USE arrays_3d,                                                             &
85        ONLY:  l_grid, ug, u_init, vg, v_init, zu
86   
87    USE indices,                                                               &
88        ONLY:  nzb, nzt
89   
90    USE kinds
91   
92    USE model_1d,                                                              &
93        ONLY:  e1d, e1d_p, kh1d, km1d, l1d, l_black, qs1d, rif1d,              &
94               simulated_time_1d, te_e, te_em, te_u, te_um, te_v, te_vm, ts1d, &
95               u1d, u1d_p, us1d, usws1d, v1d, v1d_p, vsws1d, z01d, z0h1d
96   
97    USE control_parameters,                                                    &
98        ONLY:  constant_diffusion, constant_flux_layer, f, humidity, kappa,    &
99               km_constant, mixing_length_1d, passive_scalar, prandtl_number,  &
100               roughness_length, simulated_time_chr, z0h_factor
101
102    IMPLICIT NONE
103
104    CHARACTER (LEN=9) ::  time_to_string  !<
105   
106    INTEGER(iwp) ::  k  !<
107   
108    REAL(wp) ::  lambda !<
109
110!
111!-- Allocate required 1D-arrays
112    ALLOCATE( e1d(nzb:nzt+1),    e1d_p(nzb:nzt+1),                             &
113              kh1d(nzb:nzt+1),   km1d(nzb:nzt+1),                              &
114              l_black(nzb:nzt+1), l1d(nzb:nzt+1),                              &
115              rif1d(nzb:nzt+1),   te_e(nzb:nzt+1),                             &
116              te_em(nzb:nzt+1),  te_u(nzb:nzt+1),    te_um(nzb:nzt+1),         &
117              te_v(nzb:nzt+1),   te_vm(nzb:nzt+1),    u1d(nzb:nzt+1),          &
118              u1d_p(nzb:nzt+1),  v1d(nzb:nzt+1),                               &
119              v1d_p(nzb:nzt+1) )
120
121!
122!-- Initialize arrays
123    IF ( constant_diffusion )  THEN
124       km1d = km_constant
125       kh1d = km_constant / prandtl_number
126    ELSE
127       e1d = 0.0_wp; e1d_p = 0.0_wp
128       kh1d = 0.0_wp; km1d = 0.0_wp
129       rif1d = 0.0_wp
130!
131!--    Compute the mixing length
132       l_black(nzb) = 0.0_wp
133
134       IF ( TRIM( mixing_length_1d ) == 'blackadar' )  THEN
135!
136!--       Blackadar mixing length
137          IF ( f /= 0.0_wp )  THEN
138             lambda = 2.7E-4_wp * SQRT( ug(nzt+1)**2 + vg(nzt+1)**2 ) /        &
139                               ABS( f ) + 1E-10_wp
140          ELSE
141             lambda = 30.0_wp
142          ENDIF
143
144          DO  k = nzb+1, nzt+1
145             l_black(k) = kappa * zu(k) / ( 1.0_wp + kappa * zu(k) / lambda )
146          ENDDO
147
148       ELSEIF ( TRIM( mixing_length_1d ) == 'as_in_3d_model' )  THEN
149!
150!--       Use the same mixing length as in 3D model
151          l_black(1:nzt) = l_grid
152          l_black(nzt+1) = l_black(nzt)
153
154       ENDIF
155    ENDIF
156    l1d   = l_black
157    u1d   = u_init
158    u1d_p = u_init
159    v1d   = v_init
160    v1d_p = v_init
161
162!
163!-- Set initial horizontal velocities at the lowest grid levels to a very small
164!-- value in order to avoid too small time steps caused by the diffusion limit
165!-- in the initial phase of a run (at k=1, dz/2 occurs in the limiting formula!)
166    u1d(0:1)   = 0.1_wp
167    u1d_p(0:1) = 0.1_wp
168    v1d(0:1)   = 0.1_wp
169    v1d_p(0:1) = 0.1_wp
170
171!
172!-- For u*, theta* and the momentum fluxes plausible values are set
173    IF ( constant_flux_layer )  THEN
174       us1d = 0.1_wp   ! without initial friction the flow would not change
175    ELSE
176       e1d(nzb+1)  = 1.0_wp
177       km1d(nzb+1) = 1.0_wp
178       us1d = 0.0_wp
179    ENDIF
180    ts1d = 0.0_wp
181    usws1d = 0.0_wp
182    vsws1d = 0.0_wp
183    z01d  = roughness_length
184    z0h1d = z0h_factor * z01d 
185    IF ( humidity .OR. passive_scalar )  qs1d = 0.0_wp
186
187!
188!-- Tendencies must be preset in order to avoid runtime errors within the
189!-- first Runge-Kutta step
190    te_em = 0.0_wp
191    te_um = 0.0_wp
192    te_vm = 0.0_wp
193
194!
195!-- Set start time in hh:mm:ss - format
196    simulated_time_chr = time_to_string( simulated_time_1d )
197
198!
199!-- Integrate the 1D-model equations using the leap-frog scheme
200    CALL time_integration_1d
201
202
203 END SUBROUTINE init_1d_model
204
205
206
207!------------------------------------------------------------------------------!
208! Description:
209! ------------
210!> Leap-frog time differencing scheme for the 1D-model.
211!------------------------------------------------------------------------------!
212 
213 SUBROUTINE time_integration_1d
214
215
216    USE arrays_3d,                                                             &
217        ONLY:  dd2zu, ddzu, ddzw, l_grid, pt_init, q_init, ug, vg, zu
218       
219    USE control_parameters,                                                    &
220        ONLY:  constant_diffusion, constant_flux_layer, dissipation_1d,        &
221               humidity, intermediate_timestep_count,                          &
222               intermediate_timestep_count_max, f, g, ibc_e_b, kappa,          & 
223               mixing_length_1d, passive_scalar,                               &
224               simulated_time_chr, timestep_scheme, tsc, zeta_max, zeta_min
225               
226    USE indices,                                                               &
227        ONLY:  nzb, nzb_diff, nzt
228       
229    USE kinds
230   
231    USE model_1d,                                                              &
232        ONLY:  current_timestep_number_1d, damp_level_ind_1d, dt_1d,           &
233               dt_pr_1d, dt_run_control_1d, e1d, e1d_p, end_time_1d,           &
234               kh1d, km1d, l1d, l_black, qs1d, rif1d, simulated_time_1d,       &
235               stop_dt_1d, te_e, te_em, te_u, te_um, te_v, te_vm, time_pr_1d,  &
236               ts1d, time_run_control_1d, u1d, u1d_p, us1d, usws1d, v1d,       &
237               v1d_p, vsws1d, z01d, z0h1d
238       
239    USE pegrid
240
241    IMPLICIT NONE
242
243    CHARACTER (LEN=9) ::  time_to_string  !<
244   
245    INTEGER(iwp) ::  k  !<
246   
247    REAL(wp) ::  a            !<
248    REAL(wp) ::  b            !<
249    REAL(wp) ::  dissipation  !<
250    REAL(wp) ::  dpt_dz       !<
251    REAL(wp) ::  flux         !<
252    REAL(wp) ::  kmzm         !<
253    REAL(wp) ::  kmzp         !<
254    REAL(wp) ::  l_stable     !<
255    REAL(wp) ::  pt_0         !<
256    REAL(wp) ::  uv_total     !<
257
258!
259!-- Determine the time step at the start of a 1D-simulation and
260!-- determine and printout quantities used for run control
261    CALL timestep_1d
262    CALL run_control_1d
263
264!
265!-- Start of time loop
266    DO  WHILE ( simulated_time_1d < end_time_1d  .AND.  .NOT. stop_dt_1d )
267
268!
269!--    Depending on the timestep scheme, carry out one or more intermediate
270!--    timesteps
271
272       intermediate_timestep_count = 0
273       DO  WHILE ( intermediate_timestep_count < &
274                   intermediate_timestep_count_max )
275
276          intermediate_timestep_count = intermediate_timestep_count + 1
277
278          CALL timestep_scheme_steering
279
280!
281!--       Compute all tendency terms. If a Prandtl-layer is simulated, k starts
282!--       at nzb+2.
283          DO  k = nzb_diff, nzt
284
285             kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
286             kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
287!
288!--          u-component
289             te_u(k) =  f * ( v1d(k) - vg(k) ) + ( &
290                              kmzp * ( u1d(k+1) - u1d(k) ) * ddzu(k+1) &
291                            - kmzm * ( u1d(k) - u1d(k-1) ) * ddzu(k)   &
292                                                 ) * ddzw(k)
293!
294!--          v-component
295             te_v(k) = -f * ( u1d(k) - ug(k) ) + (                     &
296                              kmzp * ( v1d(k+1) - v1d(k) ) * ddzu(k+1) &
297                            - kmzm * ( v1d(k) - v1d(k-1) ) * ddzu(k)   &
298                                                 ) * ddzw(k)
299          ENDDO
300          IF ( .NOT. constant_diffusion )  THEN
301             DO  k = nzb_diff, nzt
302!
303!--             TKE
304                kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
305                kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
306                IF ( .NOT. humidity )  THEN
307                   pt_0 = pt_init(k)
308                   flux =  ( pt_init(k+1)-pt_init(k-1) ) * dd2zu(k)
309                ELSE
310                   pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
311                   flux = ( ( pt_init(k+1) - pt_init(k-1) ) +                  &
312                            0.61_wp * pt_init(k) *                             &
313                            ( q_init(k+1) - q_init(k-1) ) ) * dd2zu(k)
314                ENDIF
315
316                IF ( dissipation_1d == 'detering' )  THEN
317!
318!--                According to Detering, c_e=0.064
319                   dissipation = 0.064_wp * e1d(k) * SQRT( e1d(k) ) / l1d(k)
320                ELSEIF ( dissipation_1d == 'as_in_3d_model' )  THEN
321                   dissipation = ( 0.19_wp + 0.74_wp * l1d(k) / l_grid(k) )    &
322                                 * e1d(k) * SQRT( e1d(k) ) / l1d(k)
323                ENDIF
324
325                te_e(k) = km1d(k) * ( ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2&
326                                    + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2&
327                                    )                                          &
328                                    - g / pt_0 * kh1d(k) * flux                &
329                                    +            (                             &
330                                     kmzp * ( e1d(k+1) - e1d(k) ) * ddzu(k+1)  &
331                                   - kmzm * ( e1d(k) - e1d(k-1) ) * ddzu(k)    &
332                                                 ) * ddzw(k)                   &
333                                   - dissipation
334             ENDDO
335          ENDIF
336
337!
338!--       Tendency terms at the top of the Prandtl-layer.
339!--       Finite differences of the momentum fluxes are computed using half the
340!--       normal grid length (2.0*ddzw(k)) for the sake of enhanced accuracy
341          IF ( constant_flux_layer )  THEN
342
343             k = nzb+1
344             kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
345             kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
346             IF ( .NOT. humidity )  THEN
347                pt_0 = pt_init(k)
348                flux =  ( pt_init(k+1)-pt_init(k-1) ) * dd2zu(k)
349             ELSE
350                pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
351                flux = ( ( pt_init(k+1) - pt_init(k-1) ) +                     &
352                         0.61_wp * pt_init(k) * ( q_init(k+1) - q_init(k-1) )  &
353                       ) * dd2zu(k)
354             ENDIF
355
356             IF ( dissipation_1d == 'detering' )  THEN
357!
358!--             According to Detering, c_e=0.064
359                dissipation = 0.064_wp * e1d(k) * SQRT( e1d(k) ) / l1d(k)
360             ELSEIF ( dissipation_1d == 'as_in_3d_model' )  THEN
361                dissipation = ( 0.19_wp + 0.74_wp * l1d(k) / l_grid(k) )       &
362                              * e1d(k) * SQRT( e1d(k) ) / l1d(k)
363             ENDIF
364
365!
366!--          u-component
367             te_u(k) = f * ( v1d(k) - vg(k) ) + (                              &
368                       kmzp * ( u1d(k+1) - u1d(k) ) * ddzu(k+1) + usws1d       &
369                                                ) * 2.0_wp * ddzw(k)
370!
371!--          v-component
372             te_v(k) = -f * ( u1d(k) - ug(k) ) + (                             &
373                       kmzp * ( v1d(k+1) - v1d(k) ) * ddzu(k+1) + vsws1d       &
374                                                 ) * 2.0_wp * ddzw(k)
375!
376!--          TKE
377             te_e(k) = km1d(k) * ( ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2   &
378                                 + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2   &
379                                 )                                             &
380                                 - g / pt_0 * kh1d(k) * flux                   &
381                                 +           (                                 &
382                                  kmzp * ( e1d(k+1) - e1d(k) ) * ddzu(k+1)     &
383                                - kmzm * ( e1d(k) - e1d(k-1) ) * ddzu(k)       &
384                                              ) * ddzw(k)                      &
385                                - dissipation
386          ENDIF
387
388!
389!--       Prognostic equations for all 1D variables
390          DO  k = nzb+1, nzt
391
392             u1d_p(k) = u1d(k) + dt_1d * ( tsc(2) * te_u(k) + &
393                                           tsc(3) * te_um(k) )
394             v1d_p(k) = v1d(k) + dt_1d * ( tsc(2) * te_v(k) + &
395                                           tsc(3) * te_vm(k) )
396
397          ENDDO
398          IF ( .NOT. constant_diffusion )  THEN
399             DO  k = nzb+1, nzt
400
401                e1d_p(k) = e1d(k) + dt_1d * ( tsc(2) * te_e(k) + &
402                                              tsc(3) * te_em(k) )
403
404             ENDDO
405!
406!--          Eliminate negative TKE values, which can result from the
407!--          integration due to numerical inaccuracies. In such cases the TKE
408!--          value is reduced to 10 percent of its old value.
409             WHERE ( e1d_p < 0.0_wp )  e1d_p = 0.1_wp * e1d
410          ENDIF
411
412!
413!--       Calculate tendencies for the next Runge-Kutta step
414          IF ( timestep_scheme(1:5) == 'runge' ) THEN
415             IF ( intermediate_timestep_count == 1 )  THEN
416
417                DO  k = nzb+1, nzt
418                   te_um(k) = te_u(k)
419                   te_vm(k) = te_v(k)
420                ENDDO
421
422                IF ( .NOT. constant_diffusion )  THEN
423                   DO k = nzb+1, nzt
424                      te_em(k) = te_e(k)
425                   ENDDO
426                ENDIF
427
428             ELSEIF ( intermediate_timestep_count < &
429                         intermediate_timestep_count_max )  THEN
430
431                DO  k = nzb+1, nzt
432                   te_um(k) = -9.5625_wp * te_u(k) + 5.3125_wp * te_um(k)
433                   te_vm(k) = -9.5625_wp * te_v(k) + 5.3125_wp * te_vm(k)
434                ENDDO
435
436                IF ( .NOT. constant_diffusion )  THEN
437                   DO k = nzb+1, nzt
438                      te_em(k) = -9.5625_wp * te_e(k) + 5.3125_wp * te_em(k)
439                   ENDDO
440                ENDIF
441
442             ENDIF
443          ENDIF
444
445
446!
447!--       Boundary conditions for the prognostic variables.
448!--       At the top boundary (nzt+1) u,v and e keep their initial values
449!--       (ug(nzt+1), vg(nzt+1), 0), at the bottom boundary the mirror
450!--       boundary condition applies to u and v.
451!--       The boundary condition for e is set further below ( (u*/cm)**2 ).
452         ! u1d_p(nzb) = -u1d_p(nzb+1)
453         ! v1d_p(nzb) = -v1d_p(nzb+1)
454
455          u1d_p(nzb) = 0.0_wp
456          v1d_p(nzb) = 0.0_wp
457
458!
459!--       Swap the time levels in preparation for the next time step.
460          u1d  = u1d_p
461          v1d  = v1d_p
462          IF ( .NOT. constant_diffusion )  THEN
463             e1d  = e1d_p
464          ENDIF
465
466!
467!--       Compute diffusion quantities
468          IF ( .NOT. constant_diffusion )  THEN
469
470!
471!--          First compute the vertical fluxes in the Prandtl-layer
472             IF ( constant_flux_layer )  THEN
473!
474!--             Compute theta* using Rif numbers of the previous time step
475                IF ( rif1d(1) >= 0.0_wp )  THEN
476!
477!--                Stable stratification
478                   ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /          &
479                          ( LOG( zu(nzb+1) / z0h1d ) + 5.0_wp * rif1d(nzb+1) * &
480                                          ( zu(nzb+1) - z0h1d ) / zu(nzb+1)    &
481                          )
482                ELSE
483!
484!--                Unstable stratification
485                   a = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) )
486                   b = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /                 &
487                       zu(nzb+1) * z0h1d )
488!
489!--                In the borderline case the formula for stable stratification
490!--                must be applied, because otherwise a zero division would
491!--                occur in the argument of the logarithm.
492                   IF ( a == 0.0_wp  .OR.  b == 0.0_wp )  THEN
493                      ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /       &
494                             ( LOG( zu(nzb+1) / z0h1d ) +                      &
495                               5.0_wp * rif1d(nzb+1) *                         &
496                               ( zu(nzb+1) - z0h1d ) / zu(nzb+1)               &
497                             )
498                   ELSE
499                      ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /       &
500                             LOG( (a-1.0_wp) / (a+1.0_wp) *                    &
501                                  (b+1.0_wp) / (b-1.0_wp) )
502                   ENDIF
503                ENDIF
504
505             ENDIF    ! constant_flux_layer
506
507!
508!--          Compute the Richardson-flux numbers,
509!--          first at the top of the Prandtl-layer using u* of the previous
510!--          time step (+1E-30, if u* = 0), then in the remaining area. There
511!--          the rif-numbers of the previous time step are used.
512
513             IF ( constant_flux_layer )  THEN
514                IF ( .NOT. humidity )  THEN
515                   pt_0 = pt_init(nzb+1)
516                   flux = ts1d
517                ELSE
518                   pt_0 = pt_init(nzb+1) * ( 1.0_wp + 0.61_wp * q_init(nzb+1) )
519                   flux = ts1d + 0.61_wp * pt_init(k) * qs1d
520                ENDIF
521                rif1d(nzb+1) = zu(nzb+1) * kappa * g * flux / &
522                               ( pt_0 * ( us1d**2 + 1E-30_wp ) )
523             ENDIF
524
525             DO  k = nzb_diff, nzt
526                IF ( .NOT. humidity )  THEN
527                   pt_0 = pt_init(k)
528                   flux = ( pt_init(k+1) - pt_init(k-1) ) * dd2zu(k)
529                ELSE
530                   pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
531                   flux = ( ( pt_init(k+1) - pt_init(k-1) )                    &
532                            + 0.61_wp * pt_init(k)                             &
533                            * ( q_init(k+1) - q_init(k-1) )                    &
534                          ) * dd2zu(k)
535                ENDIF
536                IF ( rif1d(k) >= 0.0_wp )  THEN
537                   rif1d(k) = g / pt_0 * flux /                                &
538                              (  ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2     &
539                               + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2     &
540                               + 1E-30_wp                                      &
541                              )
542                ELSE
543                   rif1d(k) = g / pt_0 * flux /                                &
544                              (  ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2     &
545                               + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2     &
546                               + 1E-30_wp                                      &
547                              ) * ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
548                ENDIF
549             ENDDO
550!
551!--          Richardson-numbers must remain restricted to a realistic value
552!--          range. It is exceeded excessively for very small velocities
553!--          (u,v --> 0).
554             WHERE ( rif1d < zeta_min )  rif1d = zeta_min
555             WHERE ( rif1d > zeta_max )  rif1d = zeta_max
556
557!
558!--          Compute u* from the absolute velocity value
559             IF ( constant_flux_layer )  THEN
560                uv_total = SQRT( u1d(nzb+1)**2 + v1d(nzb+1)**2 )
561
562                IF ( rif1d(nzb+1) >= 0.0_wp )  THEN
563!
564!--                Stable stratification
565                   us1d = kappa * uv_total / (                                 &
566                             LOG( zu(nzb+1) / z01d ) + 5.0_wp * rif1d(nzb+1) * &
567                                              ( zu(nzb+1) - z01d ) / zu(nzb+1) &
568                                             )
569                ELSE
570!
571!--                Unstable stratification
572                   a = 1.0_wp / SQRT( SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) ) )
573                   b = 1.0_wp / SQRT( SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /  &
574                                                     zu(nzb+1) * z01d ) )
575!
576!--                In the borderline case the formula for stable stratification
577!--                must be applied, because otherwise a zero division would
578!--                occur in the argument of the logarithm.
579                   IF ( a == 1.0_wp  .OR.  b == 1.0_wp )  THEN
580                      us1d = kappa * uv_total / (                              &
581                             LOG( zu(nzb+1) / z01d ) +                         &
582                             5.0_wp * rif1d(nzb+1) * ( zu(nzb+1) - z01d ) /    &
583                                                  zu(nzb+1) )
584                   ELSE
585                      us1d = kappa * uv_total / (                              &
586                                 LOG( (1.0_wp+b) / (1.0_wp-b) * (1.0_wp-a) /   &
587                                      (1.0_wp+a) ) +                           &
588                                 2.0_wp * ( ATAN( b ) - ATAN( a ) )            &
589                                                )
590                   ENDIF
591                ENDIF
592
593!
594!--             Compute the momentum fluxes for the diffusion terms
595                usws1d  = - u1d(nzb+1) / uv_total * us1d**2
596                vsws1d  = - v1d(nzb+1) / uv_total * us1d**2
597
598!
599!--             Boundary condition for the turbulent kinetic energy at the top
600!--             of the Prandtl-layer. c_m = 0.4 according to Detering.
601!--             Additional Neumann condition de/dz = 0 at nzb is set to ensure
602!--             compatibility with the 3D model.
603                IF ( ibc_e_b == 2 )  THEN
604                   e1d(nzb+1) = ( us1d / 0.1_wp )**2
605!                  e1d(nzb+1) = ( us1d / 0.4_wp )**2  !not used so far, see also
606                                                      !prandtl_fluxes
607                ENDIF
608                e1d(nzb) = e1d(nzb+1)
609
610                IF ( humidity .OR. passive_scalar ) THEN
611!
612!--                Compute q*
613                   IF ( rif1d(1) >= 0.0_wp )  THEN
614!
615!--                Stable stratification
616                   qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /            &
617                          ( LOG( zu(nzb+1) / z0h1d ) + 5.0_wp * rif1d(nzb+1) * &
618                                          ( zu(nzb+1) - z0h1d ) / zu(nzb+1)    &
619                          )
620                ELSE
621!
622!--                Unstable stratification
623                   a = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) )
624                   b = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /                 &
625                                      zu(nzb+1) * z0h1d )
626!
627!--                In the borderline case the formula for stable stratification
628!--                must be applied, because otherwise a zero division would
629!--                occur in the argument of the logarithm.
630                   IF ( a == 1.0_wp  .OR.  b == 1.0_wp )  THEN
631                      qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /         &
632                             ( LOG( zu(nzb+1) / z0h1d ) +                      &
633                               5.0_wp * rif1d(nzb+1) *                         &
634                               ( zu(nzb+1) - z0h1d ) / zu(nzb+1)               &
635                             )
636                   ELSE
637                      qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /         &
638                             LOG( (a-1.0_wp) / (a+1.0_wp) *                    &
639                                  (b+1.0_wp) / (b-1.0_wp) )
640                   ENDIF
641                ENDIF               
642                ELSE
643                   qs1d = 0.0_wp
644                ENDIF             
645
646             ENDIF   !  constant_flux_layer
647
648!
649!--          Compute the diabatic mixing length
650             IF ( mixing_length_1d == 'blackadar' )  THEN
651                DO  k = nzb+1, nzt
652                   IF ( rif1d(k) >= 0.0_wp )  THEN
653                      l1d(k) = l_black(k) / ( 1.0_wp + 5.0_wp * rif1d(k) )
654                   ELSE
655                      l1d(k) = l_black(k) *                                    &
656                               ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
657                   ENDIF
658                   l1d(k) = l_black(k)
659                ENDDO
660
661             ELSEIF ( mixing_length_1d == 'as_in_3d_model' )  THEN
662                DO  k = nzb+1, nzt
663                   dpt_dz = ( pt_init(k+1) - pt_init(k-1) ) * dd2zu(k)
664                   IF ( dpt_dz > 0.0_wp )  THEN
665                      l_stable = 0.76_wp * SQRT( e1d(k) ) /                    &
666                                     SQRT( g / pt_init(k) * dpt_dz ) + 1E-5_wp
667                   ELSE
668                      l_stable = l_grid(k)
669                   ENDIF
670                   l1d(k) = MIN( l_grid(k), l_stable )
671                ENDDO
672             ENDIF
673
674!
675!--          Compute the diffusion coefficients for momentum via the
676!--          corresponding Prandtl-layer relationship and according to
677!--          Prandtl-Kolmogorov, respectively. The unstable stratification is
678!--          computed via the adiabatic mixing length, for the unstability has
679!--          already been taken account of via the TKE (cf. also Diss.).
680             IF ( constant_flux_layer )  THEN
681                IF ( rif1d(nzb+1) >= 0.0_wp )  THEN
682                   km1d(nzb+1) = us1d * kappa * zu(nzb+1) /                    &
683                                 ( 1.0_wp + 5.0_wp * rif1d(nzb+1) )
684                ELSE
685                   km1d(nzb+1) = us1d * kappa * zu(nzb+1) *                    &
686                                 ( 1.0_wp - 16.0_wp * rif1d(nzb+1) )**0.25_wp
687                ENDIF
688             ENDIF
689             DO  k = nzb_diff, nzt
690!                km1d(k) = 0.4 * SQRT( e1d(k) ) !changed: adjustment to 3D-model
691                km1d(k) = 0.1_wp * SQRT( e1d(k) )
692                IF ( rif1d(k) >= 0.0_wp )  THEN
693                   km1d(k) = km1d(k) * l1d(k)
694                ELSE
695                   km1d(k) = km1d(k) * l_black(k)
696                ENDIF
697             ENDDO
698
699!
700!--          Add damping layer
701             DO  k = damp_level_ind_1d+1, nzt+1
702                km1d(k) = 1.1_wp * km1d(k-1)
703                km1d(k) = MIN( km1d(k), 10.0_wp )
704             ENDDO
705
706!
707!--          Compute the diffusion coefficient for heat via the relationship
708!--          kh = phim / phih * km
709             DO  k = nzb+1, nzt
710                IF ( rif1d(k) >= 0.0_wp )  THEN
711                   kh1d(k) = km1d(k)
712                ELSE
713                   kh1d(k) = km1d(k) * ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
714                ENDIF
715             ENDDO
716
717          ENDIF   ! .NOT. constant_diffusion
718
719       ENDDO   ! intermediate step loop
720
721!
722!--    Increment simulated time and output times
723       current_timestep_number_1d = current_timestep_number_1d + 1
724       simulated_time_1d          = simulated_time_1d + dt_1d
725       simulated_time_chr         = time_to_string( simulated_time_1d )
726       time_pr_1d                 = time_pr_1d          + dt_1d
727       time_run_control_1d        = time_run_control_1d + dt_1d
728
729!
730!--    Determine and print out quantities for run control
731       IF ( time_run_control_1d >= dt_run_control_1d )  THEN
732          CALL run_control_1d
733          time_run_control_1d = time_run_control_1d - dt_run_control_1d
734       ENDIF
735
736!
737!--    Profile output on file
738       IF ( time_pr_1d >= dt_pr_1d )  THEN
739          CALL print_1d_model
740          time_pr_1d = time_pr_1d - dt_pr_1d
741       ENDIF
742
743!
744!--    Determine size of next time step
745       CALL timestep_1d
746
747    ENDDO   ! time loop
748
749
750 END SUBROUTINE time_integration_1d
751
752
753!------------------------------------------------------------------------------!
754! Description:
755! ------------
756!> Compute and print out quantities for run control of the 1D model.
757!------------------------------------------------------------------------------!
758 
759 SUBROUTINE run_control_1d
760
761
762    USE constants,                                                             &
763        ONLY:  pi
764       
765    USE indices,                                                               &
766        ONLY:  nzb, nzt
767       
768    USE kinds
769   
770    USE model_1d,                                                              &
771        ONLY:  current_timestep_number_1d, dt_1d, run_control_header_1d, u1d,  &
772               us1d, v1d
773   
774    USE pegrid
775   
776    USE control_parameters,                                                    &
777        ONLY:  simulated_time_chr
778
779    IMPLICIT NONE
780
781    INTEGER(iwp) ::  k  !<
782   
783    REAL(wp) ::  alpha 
784    REAL(wp) ::  energy 
785    REAL(wp) ::  umax
786    REAL(wp) ::  uv_total 
787    REAL(wp) ::  vmax
788
789!
790!-- Output
791    IF ( myid == 0 )  THEN
792!
793!--    If necessary, write header
794       IF ( .NOT. run_control_header_1d )  THEN
795          CALL check_open( 15 )
796          WRITE ( 15, 100 )
797          run_control_header_1d = .TRUE.
798       ENDIF
799
800!
801!--    Compute control quantities
802!--    grid level nzp is excluded due to mirror boundary condition
803       umax = 0.0_wp; vmax = 0.0_wp; energy = 0.0_wp
804       DO  k = nzb+1, nzt+1
805          umax = MAX( ABS( umax ), ABS( u1d(k) ) )
806          vmax = MAX( ABS( vmax ), ABS( v1d(k) ) )
807          energy = energy + 0.5_wp * ( u1d(k)**2 + v1d(k)**2 )
808       ENDDO
809       energy = energy / REAL( nzt - nzb + 1, KIND=wp )
810
811       uv_total = SQRT( u1d(nzb+1)**2 + v1d(nzb+1)**2 )
812       IF ( ABS( v1d(nzb+1) ) < 1.0E-5_wp )  THEN
813          alpha = ACOS( SIGN( 1.0_wp , u1d(nzb+1) ) )
814       ELSE
815          alpha = ACOS( u1d(nzb+1) / uv_total )
816          IF ( v1d(nzb+1) <= 0.0_wp )  alpha = 2.0_wp * pi - alpha
817       ENDIF
818       alpha = alpha / ( 2.0_wp * pi ) * 360.0_wp
819
820       WRITE ( 15, 101 )  current_timestep_number_1d, simulated_time_chr, &
821                          dt_1d, umax, vmax, us1d, alpha, energy
822!
823!--    Write buffer contents to disc immediately
824       CALL local_flush( 15 )
825
826    ENDIF
827
828!
829!-- formats
830100 FORMAT (///'1D-Zeitschrittkontrollausgaben:'/ &
831              &'------------------------------'// &
832           &'ITER.  HH:MM:SS    DT      UMAX   VMAX    U*   ALPHA   ENERG.'/ &
833           &'-------------------------------------------------------------')
834101 FORMAT (I5,2X,A9,1X,F6.2,2X,F6.2,1X,F6.2,1X,F6.3,2X,F5.1,2X,F7.2)
835
836
837 END SUBROUTINE run_control_1d
838
839
840
841!------------------------------------------------------------------------------!
842! Description:
843! ------------
844!> Compute the time step w.r.t. the diffusion criterion
845!------------------------------------------------------------------------------!
846 
847 SUBROUTINE timestep_1d
848
849
850    USE arrays_3d,                                                             &
851        ONLY:  dzu, zu
852       
853    USE indices,                                                               &
854        ONLY:  nzb, nzt
855   
856    USE kinds
857   
858    USE model_1d,                                                              &
859        ONLY:  dt_1d, dt_max_1d, km1d, old_dt_1d, stop_dt_1d
860   
861    USE pegrid
862   
863    USE control_parameters,                                                              &
864        ONLY:  message_string
865
866    IMPLICIT NONE
867
868    INTEGER(iwp) ::  k !<
869   
870    REAL(wp) ::  div      !<
871    REAL(wp) ::  dt_diff  !<
872    REAL(wp) ::  fac      !<
873    REAL(wp) ::  value    !<
874
875
876!
877!-- Compute the currently feasible time step according to the diffusion
878!-- criterion. At nzb+1 the half grid length is used.
879    fac = 0.35_wp
880    dt_diff = dt_max_1d
881    DO  k = nzb+2, nzt
882       value   = fac * dzu(k) * dzu(k) / ( km1d(k) + 1E-20_wp )
883       dt_diff = MIN( value, dt_diff )
884    ENDDO
885    value   = fac * zu(nzb+1) * zu(nzb+1) / ( km1d(nzb+1) + 1E-20_wp )
886    dt_1d = MIN( value, dt_diff )
887
888!
889!-- Set flag when the time step becomes too small
890    IF ( dt_1d < ( 0.00001_wp * dt_max_1d ) )  THEN
891       stop_dt_1d = .TRUE.
892
893       WRITE( message_string, * ) 'timestep has exceeded the lower limit &', &
894                                  'dt_1d = ',dt_1d,' s   simulation stopped!'
895       CALL message( 'timestep_1d', 'PA0192', 1, 2, 0, 6, 0 )
896       
897    ENDIF
898
899!
900!-- A more or less simple new time step value is obtained taking only the
901!-- first two significant digits
902    div = 1000.0_wp
903    DO  WHILE ( dt_1d < div )
904       div = div / 10.0_wp
905    ENDDO
906    dt_1d = NINT( dt_1d * 100.0_wp / div ) * div / 100.0_wp
907
908    old_dt_1d = dt_1d
909
910
911 END SUBROUTINE timestep_1d
912
913
914
915!------------------------------------------------------------------------------!
916! Description:
917! ------------
918!> List output of profiles from the 1D-model
919!------------------------------------------------------------------------------!
920 
921 SUBROUTINE print_1d_model
922
923
924    USE arrays_3d,                                                             &
925        ONLY:  pt_init, zu
926       
927    USE indices,                                                               &
928        ONLY:  nzb, nzt
929       
930    USE kinds
931   
932    USE model_1d,                                                              &
933        ONLY:  e1d, kh1d, km1d, l1d, rif1d, u1d, v1d
934   
935    USE pegrid
936   
937    USE control_parameters,                                                    &
938        ONLY:  run_description_header, simulated_time_chr
939
940    IMPLICIT NONE
941
942
943    INTEGER(iwp) ::  k  !<
944
945
946    IF ( myid == 0 )  THEN
947!
948!--    Open list output file for profiles from the 1D-model
949       CALL check_open( 17 )
950
951!
952!--    Write Header
953       WRITE ( 17, 100 )  TRIM( run_description_header ), &
954                          TRIM( simulated_time_chr )
955       WRITE ( 17, 101 )
956
957!
958!--    Write the values
959       WRITE ( 17, 102 )
960       WRITE ( 17, 101 )
961       DO  k = nzt+1, nzb, -1
962          WRITE ( 17, 103)  k, zu(k), u1d(k), v1d(k), pt_init(k), e1d(k), &
963                            rif1d(k), km1d(k), kh1d(k), l1d(k), zu(k), k
964       ENDDO
965       WRITE ( 17, 101 )
966       WRITE ( 17, 102 )
967       WRITE ( 17, 101 )
968
969!
970!--    Write buffer contents to disc immediately
971       CALL local_flush( 17 )
972
973    ENDIF
974
975!
976!-- Formats
977100 FORMAT (//1X,A/1X,10('-')/' 1d-model profiles'/ &
978            ' Time: ',A)
979101 FORMAT (1X,79('-'))
980102 FORMAT ('   k     zu      u      v     pt      e    rif    Km    Kh     ', &
981            'l      zu      k')
982103 FORMAT (1X,I4,1X,F7.1,1X,F6.2,1X,F6.2,1X,F6.2,1X,F6.2,1X,F5.2,1X,F5.2, &
983            1X,F5.2,1X,F6.2,1X,F7.1,2X,I4)
984
985
986 END SUBROUTINE print_1d_model
Note: See TracBrowser for help on using the repository browser.