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

Last change on this file since 1609 was 1354, checked in by heinze, 11 years ago

last commit documented

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