source: palm/trunk/UTIL/inifor/src/inifor_util.f90 @ 3698

Last change on this file since 3698 was 3680, checked in by knoop, 6 years ago

Added cpp-option netcdf to inifor

  • Property svn:keywords set to Id
File size: 14.8 KB
Line 
1!> @file src/inifor_util.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! 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 2017-2018 Leibniz Universitaet Hannover
18! Copyright 2017-2018 Deutscher Wetterdienst Offenbach
19!------------------------------------------------------------------------------!
20!
21! Current revisions:
22! -----------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: inifor_util.f90 3680 2019-01-18 14:54:12Z suehring $
28! Prefixed all INIFOR modules with inifor_
29!
30!
31! 3557 2018-11-22 16:01:22Z eckhard
32! Updated documentation
33!
34!
35! 3447 2018-10-29 15:52:54Z eckhard
36! Renamed source files for compatibilty with PALM build system
37!
38!
39! 3395 2018-10-22 17:32:49Z eckhard
40! New routines for computing potential temperature and moist air density
41! Increased number of digits in real-to-str conversion
42!
43! 3183 2018-07-27 14:25:55Z suehring
44! Improved real-to-string conversion
45!
46!
47! 3182 2018-07-27 13:36:03Z suehring
48! Initial revision
49!
50!
51!
52! Authors:
53! --------
54!> @author Eckhard Kadasch (Deutscher Wetterdienst, Offenbach)
55!
56! Description:
57! ------------
58!> The util module provides miscellaneous utility routines for INIFOR.
59!------------------------------------------------------------------------------!
60#if defined ( __netcdf )
61 MODULE inifor_util
62
63    USE inifor_defs,                                                           &
64        ONLY :  dp, PI, DATE, SNAME
65    USE inifor_types,                                                          &
66        ONLY :  grid_definition
67    USE, INTRINSIC :: ISO_C_BINDING,                                           &
68        ONLY :  C_CHAR, C_INT, C_PTR, C_SIZE_T
69
70    IMPLICIT NONE
71
72!------------------------------------------------------------------------------!
73! Description:
74! ------------
75!> Fortran implementation of C's struct tm for representing points in time
76!------------------------------------------------------------------------------!
77    TYPE, BIND(c) :: tm_struct
78       INTEGER(C_INT) :: tm_sec     !< seconds after the minute [0, 61]
79       INTEGER(C_INT) :: tm_min     !< minutes after the hour [0, 59]
80       INTEGER(C_INT) :: tm_hour    !< hours since midnight [0, 23]
81       INTEGER(C_INT) :: tm_mday    !< day of the month [1, 31]
82       INTEGER(C_INT) :: tm_mon     !< month since January [0, 11]
83       INTEGER(C_INT) :: tm_year    !< years since 1900
84       INTEGER(C_INT) :: tm_wday    !< days since Sunday [0, 6]
85       INTEGER(C_INT) :: tm_yday    !< days since January 1st [0, 356]
86       INTEGER(C_INT) :: tm_isdst   !< Daylight Saving Time flag
87    END TYPE
88
89    INTERFACE
90
91!------------------------------------------------------------------------------!
92! Description:
93! ------------
94!> Interface to C's strptime function, which converts a string to a tm
95!> structure.
96!------------------------------------------------------------------------------!
97       FUNCTION strptime(string, format, timeinfo) BIND(c, NAME='strptime')
98          IMPORT :: C_CHAR, C_SIZE_T, tm_struct
99
100          IMPLICIT NONE
101
102          CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(IN) ::  string, format
103          TYPE(tm_struct), INTENT(OUT)                     ::  timeinfo
104
105          INTEGER(C_SIZE_T)                                ::  strptime
106       END FUNCTION
107
108
109!------------------------------------------------------------------------------!
110! Description:
111! ------------
112!> Interface to C's strftime function, which converts the given 'timeinfo'
113!> structure to a string in the given 'format'.
114!------------------------------------------------------------------------------!
115       FUNCTION strftime(string, string_len, format, timeinfo) BIND(c, NAME='strftime')
116          IMPORT :: C_CHAR, C_SIZE_T, tm_struct
117
118          IMPLICIT NONE
119
120          CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(OUT) ::  string
121          CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(IN)  ::  format
122          INTEGER(C_SIZE_T), INTENT(IN)                     ::  string_len
123          TYPE(tm_struct), INTENT(IN)                       ::  timeinfo
124
125          INTEGER(C_SIZE_T)                                 ::  strftime
126       END FUNCTION
127
128
129!------------------------------------------------------------------------------!
130! Description:
131! ------------
132!> Interface to C's mktime function, which converts the given tm structure to
133!> Unix time (number of seconds since 0 UTC, 1st January 1970). INIFOR uses the
134!> side effect that a call to mktime noramlizes the given 'timeinfo' structure,
135!> e.g. increments the date if hours overfow 24.
136!------------------------------------------------------------------------------!
137       FUNCTION mktime(timeinfo) BIND(c, NAME='mktime')
138          IMPORT :: C_PTR, tm_struct
139
140          IMPLICIT NONE
141
142          TYPE(tm_struct), INTENT(IN) ::  timeinfo
143
144          TYPE(C_PTR)                 ::  mktime
145       END FUNCTION
146
147    END INTERFACE
148
149 CONTAINS
150
151!------------------------------------------------------------------------------!
152! Description:
153! ------------
154!> Takes a string of the form YYYYMMDDHH, adds the given number of hours to its
155!> tm structure representation, and returns the corresponding string in the same
156!> format
157!------------------------------------------------------------------------------!
158    CHARACTER(LEN=DATE) FUNCTION add_hours_to(date_string, hours)
159       CHARACTER(LEN=DATE), INTENT(IN)          ::  date_string
160       INTEGER, INTENT(IN)                      ::  hours
161
162       CHARACTER(KIND=C_CHAR, LEN=*), PARAMETER ::  format_string = "%Y%m%d%H"
163       CHARACTER(KIND=C_CHAR, LEN=DATE)         ::  c_date_string
164       TYPE(C_PTR)                              ::  c_pointer
165       TYPE(tm_struct)                          ::  time_info
166       INTEGER                                  ::  err
167
168       c_date_string = date_string
169
170       ! Convert C string to C tm struct
171       CALL init_tm(time_info)
172       err = strptime(c_date_string, format_string, time_info)
173   
174       ! Manipulate and normalize C tm struct
175       time_info % tm_hour = time_info % tm_hour + hours
176       c_pointer = mktime(time_info)
177
178       ! Convert back to C string
179       err = strftime(c_date_string, INT(DATE, KIND=C_SIZE_T),                 &
180                      format_string, time_info)
181
182       add_hours_to = c_date_string
183    END FUNCTION
184
185
186!------------------------------------------------------------------------------!
187! Description:
188! ------------
189!> Print all members of the given tm structure
190!------------------------------------------------------------------------------!
191    SUBROUTINE print_tm(timeinfo)
192       TYPE(tm_struct), INTENT(IN) :: timeinfo
193
194       PRINT *, "sec: ", timeinfo % tm_sec,  &  !< seconds after the minute [0, 61]
195                "min: ", timeinfo % tm_min,  &  !< minutes after the hour [0, 59]
196                "hr:  ", timeinfo % tm_hour, &  !< hours since midnight [0, 23]
197                "day: ", timeinfo % tm_mday, &  !< day of the month [1, 31]
198                "mon: ", timeinfo % tm_mon,  &  !< month since January [0, 11]
199                "yr:  ", timeinfo % tm_year, &  !< years since 1900
200                "wday:", timeinfo % tm_wday, &  !< days since Sunday [0, 6]
201                "yday:", timeinfo % tm_yday, &  !< days since January 1st [0, 356]
202                "dst: ", timeinfo % tm_isdst    !< Daylight Saving time flag
203    END SUBROUTINE print_tm
204
205   
206!------------------------------------------------------------------------------!
207! Description:
208! ------------
209!> Initialize the given tm structure with zero values
210!------------------------------------------------------------------------------!
211    SUBROUTINE init_tm(timeinfo)
212       TYPE(tm_struct), INTENT(INOUT) :: timeinfo
213
214       timeinfo % tm_sec   = 0
215       timeinfo % tm_min   = 0
216       timeinfo % tm_hour  = 0
217       timeinfo % tm_mday  = 0
218       timeinfo % tm_mon   = 0
219       timeinfo % tm_year  = 0
220       timeinfo % tm_wday  = 0
221       timeinfo % tm_yday  = 0
222
223       ! We use UTC times, so marking Daylight Saving Time (DST) 'not available'
224       ! (< 0). If this is set to 0, mktime will convert the timeinfo to DST and
225       ! add one hour.
226       timeinfo % tm_isdst = -1
227    END SUBROUTINE init_tm
228
229
230!------------------------------------------------------------------------------!
231! Description:
232! ------------
233!> Fill the given array with values equally spaced between and including start
234!> and stop
235!------------------------------------------------------------------------------!
236    SUBROUTINE linspace(start, stop, array)
237
238       REAL(dp), INTENT(IN)    ::  start, stop
239       REAL(dp), INTENT(INOUT) ::  array(0:)
240       INTEGER                 ::  i, n
241
242       n = UBOUND(array, 1)
243
244       IF (n .EQ. 0)  THEN
245
246          array(0) = start
247
248       ELSE
249
250          DO i = 0, n
251             array(i) = start + REAL(i, dp) / n * (stop - start)
252          END DO
253
254       END IF
255       
256    END SUBROUTINE linspace
257
258
259!------------------------------------------------------------------------------!
260! Description:
261! ------------
262!> Reverse the order of the third (vertical) array dimension from top-down
263!> (COSMO) to bottom-up (PALM)
264!------------------------------------------------------------------------------!
265    SUBROUTINE reverse(input_arr)
266
267       REAL(dp), INTENT(INOUT) ::  input_arr(:,:,:)
268
269       input_arr = input_arr(:,:,size(input_arr, 3):1:-1)
270
271    END SUBROUTINE reverse
272
273
274!------------------------------------------------------------------------------!
275! Description:
276! ------------
277!>
278!------------------------------------------------------------------------------!
279    SUBROUTINE deaverage(avg_1, t1, avg_2, t2, avg_3, t3)
280
281       REAL(dp), DIMENSION(:,:,:), INTENT(IN)  ::  avg_1, avg_2
282       REAL(dp), INTENT(IN)                    ::  t1, t2, t3
283       REAL(dp), DIMENSION(:,:,:), INTENT(OUT) ::  avg_3
284
285       REAL(dp)                                ::  ti
286 
287       ti = 1.0_dp / t3
288
289       avg_3(:,:,:) = ti * ( t2 * avg_2(:,:,:) - t1 * avg_1(:,:,:) )
290
291    END SUBROUTINE deaverage
292
293
294!------------------------------------------------------------------------------!
295! Description:
296! ------------
297!> Compute the COSMO-DE/-D2 basic state pressure profile
298!------------------------------------------------------------------------------!
299    SUBROUTINE get_basic_state(z, beta, p_sl, t_sl, rd, g, p0)
300
301       REAL(dp), INTENT(IN)  ::  z(1:)  !< height [m]
302       REAL(dp), INTENT(IN)  ::  beta   !< logarithmic lapse rate, dT / d ln(p) [K]
303       REAL(dp), INTENT(IN)  ::  p_sl   !< reference pressure [Pa]
304       REAL(dp), INTENT(IN)  ::  t_sl   !< reference tempereature [K]
305       REAL(dp), INTENT(IN)  ::  rd     !< ideal gas constant of dry air [J/kg/K]
306       REAL(dp), INTENT(IN)  ::  g      !< acceleration of Earth's gravity [m/s^2]
307       REAL(dp), INTENT(OUT) ::  p0(1:) !< COSMO basic state pressure [Pa]
308       REAL(dp) ::  root_frac, factor   !< precomputed factors
309
310       factor = - t_sl / beta
311       root_frac = (2.0_dp * beta * g) / (rd * t_sl*t_sl)
312
313       p0(:) = p_sl * EXP(                                                     &
314                  factor * ( 1.0_dp - SQRT( 1.0_dp - root_frac * z(:) ) )      &
315       )
316
317    END SUBROUTINE get_basic_state
318
319
320!------------------------------------------------------------------------------!
321! Description:
322! ------------
323!> Converts the absolute temperature to the potential temperature in place using
324!> the identity a^b = e^(b ln(a)).
325!>
326!>     theta = T * (p_ref/p)^(R/c_p) = T * e^( R/c_p * ln(p_ref/p) )
327!------------------------------------------------------------------------------!
328    SUBROUTINE potential_temperature(t, p, p_ref, r, cp)
329       REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) ::  t
330       REAL(dp), DIMENSION(:,:,:), INTENT(IN)    ::  p
331       REAL(dp), INTENT(IN)                      ::  p_ref, r, cp
332       REAL(dp)                                  ::  rcp
333
334       rcp = r/cp
335       t(:,:,:) =  t(:,:,:) * EXP( rcp * LOG(p_ref / p(:,:,:)) )
336
337    END SUBROUTINE potential_temperature
338
339
340!------------------------------------------------------------------------------!
341! Description:
342! ------------
343!> Compute the density in place of the given temperature (t_rho).
344!------------------------------------------------------------------------------!
345   SUBROUTINE moist_density(t_rho, p, qv, rd, rv)
346       REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) ::  t_rho
347       REAL(dp), DIMENSION(:,:,:), INTENT(IN)    ::  p, qv
348       REAL(dp), INTENT(IN)                      ::  rd, rv
349
350       t_rho(:,:,:) = p(:,:,:) / (                                             &
351          (rv * qv(:,:,:) + rd * (1.0_dp - qv(:,:,:))) * t_rho(:,:,:)          &
352       )
353
354    END SUBROUTINE moist_density
355
356
357    ! Convert a real number to a string in scientific notation
358    ! showing four significant digits.
359    CHARACTER(LEN=SNAME) FUNCTION real_to_str(val, format)
360
361        REAL(dp), INTENT(IN)                   ::  val
362        CHARACTER(LEN=*), OPTIONAL, INTENT(IN) ::  format
363
364        IF (PRESENT(format))  THEN
365           WRITE(real_to_str, format) val
366        ELSE
367           WRITE(real_to_str, '(E11.4)') val
368        END IF
369        real_to_str = ADJUSTL(real_to_str)
370
371    END FUNCTION real_to_str
372
373
374!------------------------------------------------------------------------------!
375! Description:
376! ------------
377!> Converts the given real value to a string
378!------------------------------------------------------------------------------!
379    CHARACTER(LEN=16) FUNCTION real_to_str_f(val)
380
381        REAL(dp), INTENT(IN) ::  val
382
383        WRITE(real_to_str_f, '(F16.8)') val
384        real_to_str_f = ADJUSTL(real_to_str_f)
385
386    END FUNCTION real_to_str_f
387
388
389!------------------------------------------------------------------------------!
390! Description:
391! ------------
392!> Converts the given integer value to a string
393!------------------------------------------------------------------------------!
394    CHARACTER(LEN=10) FUNCTION str(val)
395
396        INTEGER, INTENT(IN) ::  val
397
398        WRITE(str, '(i10)') val
399        str = ADJUSTL(str)
400
401    END FUNCTION str
402
403
404!------------------------------------------------------------------------------!
405! Description:
406! ------------
407!> If the given path is not conlcuded by a slash, add one.
408!------------------------------------------------------------------------------!
409    SUBROUTINE normalize_path(path)
410       
411        CHARACTER(LEN=*), INTENT(INOUT) ::  path
412        INTEGER ::  n
413
414        n = LEN_TRIM(path)
415
416        IF (path(n:n) .NE. '/')  THEN
417           path = TRIM(path) // '/'
418        END IF
419
420    END SUBROUTINE
421
422 END MODULE inifor_util
423#endif
424
Note: See TracBrowser for help on using the repository browser.