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

Last change on this file since 1310 was 1310, checked in by raasch, 7 years ago

update of GPL copyright

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