source: palm/trunk/SOURCE/nudging.f90 @ 1320

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

ONLY-attribute added to USE-statements,
kind-parameters added to all INTEGER and REAL declaration statements,
kinds are defined in new module kinds,
old module precision_kind is removed,
revision history before 2012 removed,
comment fields (!:) to be used for variable explanations added to all variable declaration statements

  • Property svn:keywords set to Id
File size: 14.9 KB
Line 
1 MODULE nudge_mod
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! ONLY-attribute added to USE-statements,
23! kind-parameters added to all INTEGER and REAL declaration statements,
24! kinds are defined in new module kinds,
25! old module precision_kind is removed,
26! revision history before 2012 removed,
27! comment fields (!:) to be used for variable explanations added to
28! all variable declaration statements
29!
30! Former revisions:
31! -----------------
32! $Id: nudging.f90 1320 2014-03-20 08:40:49Z raasch $
33!
34! 1318 2014-03-17 13:35:16Z raasch
35! module interfaces removed
36!
37! 1268 2013-12-12 09:47:53Z heinze
38! bugfix: argument of calc_mean_profile corrected
39!
40! 1251 2013-11-07 08:14:30Z heinze
41! bugfix: calculate dtm and dtp also in vector version
42!
43! 1249 2013-11-06 10:45:47Z heinze
44! remove call of user module
45! reformatting
46!
47! 1241 2013-10-30 11:36:58Z heinze
48! Initial revision
49!
50! Description:
51! ------------
52! Nudges u, v, pt and q to given profiles on a relaxation timescale tnudge.
53! Profiles are read in from NUDGIN_DATA. Code is based on Neggers et al. (2012)
54! and also part of DALES and UCLA-LES.
55!--------------------------------------------------------------------------------!
56
57    PRIVATE
58    PUBLIC init_nudge, nudge
59    SAVE
60
61    INTERFACE nudge
62       MODULE PROCEDURE nudge
63       MODULE PROCEDURE nudge_ij
64    END INTERFACE nudge
65
66 CONTAINS
67
68    SUBROUTINE init_nudge
69
70       USE arrays_3d,                                                          &
71           ONLY:  ptnudge, qnudge, timenudge, tnudge, unudge, vnudge, wnudge,  &
72                  zu
73
74       USE control_parameters,                                                 &
75           ONLY:  dt_3d, lptnudge, lqnudge, lunudge, lvnudge, lwnudge,         &
76                   message_string, ntnudge
77
78       USE indices,                                                            &
79           ONLY:  nzb, nzt
80
81       USE kinds
82
83       IMPLICIT NONE
84
85
86       INTEGER(iwp) ::  finput = 90  !:
87       INTEGER(iwp) ::  ierrn        !:
88       INTEGER(iwp) ::  k            !:
89       INTEGER(iwp) ::  t            !:
90
91       CHARACTER(1) ::  hash     !:
92
93       REAL(wp) ::  highheight   !:
94       REAL(wp) ::  highqnudge   !:
95       REAL(wp) ::  highptnudge  !:
96       REAL(wp) ::  highunudge   !:
97       REAL(wp) ::  highvnudge   !:
98       REAL(wp) ::  highwnudge   !:
99       REAL(wp) ::  hightnudge   !:
100
101       REAL(wp) ::  lowheight    !:
102       REAL(wp) ::  lowqnudge    !:
103       REAL(wp) ::  lowptnudge   !:
104       REAL(wp) ::  lowunudge    !:
105       REAL(wp) ::  lowvnudge    !:
106       REAL(wp) ::  lowwnudge    !:
107       REAL(wp) ::  lowtnudge    !:
108
109       REAL(wp) ::  fac          !:
110
111       ALLOCATE( ptnudge(nzb:nzt+1,1:ntnudge), qnudge(nzb:nzt+1,1:ntnudge), &
112                 tnudge(nzb:nzt+1,1:ntnudge), unudge(nzb:nzt+1,1:ntnudge),  &
113                 vnudge(nzb:nzt+1,1:ntnudge), wnudge(nzb:nzt+1,1:ntnudge)  )
114
115       ALLOCATE( timenudge(0:ntnudge) )
116
117
118       ptnudge = 0.0; qnudge = 0.0; tnudge = 0.0; unudge = 0.0
119       vnudge = 0.0; wnudge = 0.0; timenudge = 0.0
120
121       t = 0
122       OPEN ( finput, FILE='NUDGING_DATA', STATUS='OLD', &
123              FORM='FORMATTED', IOSTAT=ierrn )
124
125       IF ( ierrn /= 0 )  THEN
126          message_string = 'file NUDGING_DATA does not exist'
127          CALL message( 'nudging', 'PA0365', 1, 2, 0, 6, 0 )
128       ENDIF
129
130       ierrn = 0
131
132 rloop:DO
133          t = t + 1
134          hash = "#"
135          ierrn = 1 ! not zero
136!
137!--       Search for the next line consisting of "# time",
138!--       from there onwards the profiles will be read
139          DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) ) 
140         
141            READ ( finput, *, IOSTAT=ierrn ) hash, timenudge(t)
142            IF ( ierrn < 0 )  EXIT rloop
143
144          ENDDO
145
146          ierrn = 0
147          READ ( finput, *, IOSTAT=ierrn ) lowheight, lowtnudge, lowunudge,   &
148                                           lowvnudge, lowwnudge , lowptnudge, &
149                                           lowqnudge
150
151          IF ( ierrn /= 0 )  THEN
152             message_string = 'errors in file NUDGING_DATA'
153             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
154          ENDIF
155
156          ierrn = 0
157          READ ( finput, *, IOSTAT=ierrn ) highheight, hightnudge, highunudge,   &
158                                           highvnudge, highwnudge , highptnudge, &
159                                           highqnudge
160
161          IF ( ierrn /= 0 )  THEN
162             message_string = 'errors in file NUDGING_DATA'
163             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
164          ENDIF
165
166          DO  k = nzb, nzt+1
167             IF ( highheight < zu(k) )  THEN
168                lowheight  = highheight
169                lowtnudge  = hightnudge
170                lowunudge  = highunudge
171                lowvnudge  = highvnudge
172                lowwnudge  = highwnudge
173                lowptnudge = highptnudge
174                lowqnudge  = highqnudge
175 
176                ierrn = 0
177                READ ( finput, *, IOSTAT=ierrn )  highheight , hightnudge , &
178                                                  highunudge , highvnudge , &
179                                                  highwnudge , highptnudge, &
180                                                  highqnudge
181                IF (ierrn /= 0 )  THEN
182                   message_string = 'errors in file NUDGING_DATA'
183                   CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
184                ENDIF
185             ENDIF
186
187!
188!--          Interpolation of prescribed profiles in space
189
190             fac = ( highheight - zu(k) ) / ( highheight - lowheight )
191
192             tnudge(k,t)  = fac * lowtnudge + ( 1.0 - fac ) * hightnudge
193             unudge(k,t)  = fac * lowunudge + ( 1.0 - fac ) * highunudge
194             vnudge(k,t)  = fac * lowvnudge + ( 1.0 - fac ) * highvnudge
195             wnudge(k,t)  = fac * lowwnudge + ( 1.0 - fac ) * highwnudge
196             ptnudge(k,t) = fac * lowptnudge + ( 1.0 - fac ) * highptnudge
197             qnudge(k,t)  = fac * lowqnudge + ( 1.0 - fac ) * highqnudge
198          ENDDO
199
200       ENDDO rloop
201
202       CLOSE ( finput )
203
204!
205!--    Prevent nudging if nudging profiles exhibt too small values
206!--    not used so far
207       lptnudge  = ANY( ABS( ptnudge ) > 1e-8 )
208       lqnudge   = ANY( ABS( qnudge ) > 1e-8 )
209       lunudge   = ANY( ABS( unudge ) > 1e-8 )
210       lvnudge   = ANY( ABS( vnudge ) > 1e-8 )
211       lwnudge   = ANY( ABS( wnudge ) > 1e-8 )
212
213    END SUBROUTINE init_nudge
214
215!------------------------------------------------------------------------------!
216! Call for all grid points
217!------------------------------------------------------------------------------!
218    SUBROUTINE nudge ( time, prog_var )
219
220       USE arrays_3d,                                                          &
221           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tnudge, u, unudge,  &
222                  v, vnudge
223
224       USE buoyancy_mod,                                                       &
225           ONLY:  calc_mean_profile
226
227       USE control_parameters,                                                 &
228           ONLY:  dt_3d, message_string
229
230       USE indices,                                                            &
231           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
232
233       USE kinds,                                                              &
234           ONLY:  iwp, wp
235
236       USE statistics,                                                         &
237           ONLY:  hom
238
239       IMPLICIT NONE
240
241       CHARACTER (LEN=*) ::  prog_var  !:
242
243       REAL(wp) ::  currtnudge  !:
244       REAL(wp) ::  dtm         !:
245       REAL(wp) ::  dtp         !:
246       REAL(wp) ::  time        !:
247
248       INTEGER(iwp) ::  i  !:
249       INTEGER(iwp) ::  j  !:
250       INTEGER(iwp) ::  k  !:
251       INTEGER(iwp) ::  t  !:
252
253
254       t = 1
255       DO WHILE ( time > timenudge(t) )
256         t = t+1
257       ENDDO
258       IF ( time /= timenudge(1) ) THEN
259         t = t-1
260       ENDIF
261
262       dtm = ( time - timenudge(t) ) / ( timenudge(t+1) - timenudge(t) )
263       dtp = ( timenudge(t+1) - time ) / ( timenudge(t+1) - timenudge(t) )
264
265       SELECT CASE ( prog_var )
266
267          CASE ( 'u' )
268
269             CALL calc_mean_profile( u, 1, 'nudging' )
270
271             DO  i = nxl, nxr
272                DO  j = nys, nyn
273                   DO  k = nzb_u_inner(j,i)+1, nzt
274
275                      currtnudge = MAX( dt_3d, tnudge(k,t) * dtp +  &
276                                               tnudge(k,t+1) * dtm )
277
278
279                      tend(k,j,i) = tend(k,j,i) - ( hom(k,1,1,0) - &
280                                    ( unudge(k,t) * dtp + &
281                                       unudge(k,t+1) * dtm ) ) / currtnudge
282                   ENDDO
283                ENDDO
284            ENDDO
285
286          CASE ( 'v' )
287
288             CALL calc_mean_profile( v, 2, 'nudging' )
289
290             DO  i = nxl, nxr
291                DO  j = nys, nyn
292                   DO  k = nzb_u_inner(j,i)+1, nzt
293
294                      currtnudge = MAX( dt_3d, tnudge(k,t) * dtp +  &
295                                               tnudge(k,t+1) * dtm )
296
297
298                      tend(k,j,i) = tend(k,j,i) - ( hom(k,1,2,0) - &
299                                    ( vnudge(k,t) * dtp + &
300                                       vnudge(k,t+1) * dtm ) ) / currtnudge
301                   ENDDO
302                ENDDO
303            ENDDO
304
305          CASE ( 'pt' )
306
307             CALL calc_mean_profile( pt, 4, 'nudging' )
308
309             DO  i = nxl, nxr
310                DO  j = nys, nyn
311                   DO  k = nzb_u_inner(j,i)+1, nzt
312
313                      currtnudge = MAX( dt_3d, tnudge(k,t) * dtp +  &
314                                               tnudge(k,t+1) * dtm )
315
316
317                      tend(k,j,i) = tend(k,j,i) - ( hom(k,1,4,0) - &
318                                    ( ptnudge(k,t) * dtp + &
319                                       ptnudge(k,t+1) * dtm ) ) / currtnudge
320                   ENDDO
321                ENDDO
322            ENDDO
323
324          CASE ( 'q' )
325
326             CALL calc_mean_profile( q, 41, 'nudging' )
327
328             DO  i = nxl, nxr
329                DO  j = nys, nyn
330                   DO  k = nzb_u_inner(j,i)+1, nzt
331
332                      currtnudge = MAX( dt_3d, tnudge(k,t) * dtp +  &
333                                               tnudge(k,t+1) * dtm )
334
335
336                      tend(k,j,i) = tend(k,j,i) - ( hom(k,1,41,0) - &
337                                    ( qnudge(k,t) * dtp + &
338                                       qnudge(k,t+1) * dtm ) ) / currtnudge
339                   ENDDO
340                ENDDO
341            ENDDO
342
343          CASE DEFAULT
344             message_string = 'unknown prognostic variable "' // prog_var // '"'
345             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
346
347       END SELECT
348
349    END SUBROUTINE nudge
350
351
352!------------------------------------------------------------------------------!
353! Call for grid point i,j
354!------------------------------------------------------------------------------!
355
356    SUBROUTINE nudge_ij( i, j, time, prog_var )
357
358       USE arrays_3d,                                                          &
359           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tnudge, u, unudge,  &
360                  v, vnudge
361
362       USE buoyancy_mod,                                                       &
363           ONLY:  calc_mean_profile
364
365       USE control_parameters,                                                 &
366           ONLY:  dt_3d, message_string
367
368       USE indices,                                                            &
369           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
370
371       USE kinds,                                                              &
372           ONLY:  iwp, wp
373
374       USE statistics,                                                         &
375           ONLY:  hom
376
377       IMPLICIT NONE
378
379
380       CHARACTER (LEN=*) ::  prog_var  !:
381
382       REAL(wp) ::  currtnudge  !:
383       REAL(wp) ::  dtm         !:
384       REAL(wp) ::  dtp         !:
385       REAL(wp) ::  time        !:
386
387       INTEGER(iwp) ::  i  !:
388       INTEGER(iwp) ::  j  !:
389       INTEGER(iwp) ::  k  !:
390       INTEGER(iwp) ::  t  !:
391
392
393       t = 1
394       DO WHILE ( time > timenudge(t) )
395         t = t+1
396       ENDDO
397       IF ( time /= timenudge(1) )  THEN
398         t = t-1
399       ENDIF
400
401       dtm = ( time - timenudge(t) ) / ( timenudge(t+1) - timenudge(t) )
402       dtp = ( timenudge(t+1) - time ) / ( timenudge(t+1) - timenudge(t) )
403
404       SELECT CASE ( prog_var )
405
406          CASE ( 'u' )
407
408             CALL calc_mean_profile( u, 1, 'nudging' )
409
410             DO  k = nzb_u_inner(j,i)+1, nzt
411
412                currtnudge = MAX( dt_3d, tnudge(k,t) * dtp + tnudge(k,t+1) * dtm )
413
414                tend(k,j,i) = tend(k,j,i) - ( hom(k,1,1,0) - &
415                               ( unudge(k,t) * dtp + &
416                                 unudge(k,t+1) * dtm ) ) / currtnudge
417             ENDDO
418
419          CASE ( 'v' )
420
421             CALL calc_mean_profile( v, 2, 'nudging' )
422
423             DO  k = nzb_u_inner(j,i)+1, nzt
424
425                currtnudge = MAX( dt_3d, tnudge(k,t) * dtp + tnudge(k,t+1) * dtm )
426
427                tend(k,j,i) = tend(k,j,i) - ( hom(k,1,2,0) - &
428                               ( vnudge(k,t) * dtp + &
429                                 vnudge(k,t+1) * dtm ) ) / currtnudge
430             ENDDO
431
432
433          CASE ( 'pt' )
434
435             CALL calc_mean_profile( pt, 4, 'nudging' )
436
437             DO  k = nzb_u_inner(j,i)+1, nzt
438
439                currtnudge = MAX( dt_3d, tnudge(k,t) * dtp + tnudge(k,t+1) * dtm )
440
441                tend(k,j,i) = tend(k,j,i) - ( hom(k,1,4,0) - &
442                               ( ptnudge(k,t) * dtp + &
443                                 ptnudge(k,t+1) * dtm ) ) / currtnudge
444             ENDDO
445
446
447          CASE ( 'q' )
448
449             CALL calc_mean_profile( q, 41, 'nudging' )
450
451             DO  k = nzb_u_inner(j,i)+1, nzt
452
453                currtnudge = MAX( dt_3d, tnudge(k,t) * dtp + tnudge(k,t+1) * dtm )
454
455                tend(k,j,i) = tend(k,j,i) - ( hom(k,1,41,0) - &
456                               ( qnudge(k,t) * dtp + &
457                                 qnudge(k,t+1) * dtm ) ) / currtnudge
458             ENDDO
459
460          CASE DEFAULT
461             message_string = 'unknown prognostic variable "' // prog_var // '"'
462             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
463
464       END SELECT
465
466
467    END SUBROUTINE nudge_ij
468
469 END MODULE nudge_mod
Note: See TracBrowser for help on using the repository browser.