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

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

code has been put under the GNU General Public License (v3)

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