Changeset 3779 for palm/trunk/UTIL/inifor/src/inifor_transform.f90
 Timestamp:
 Mar 5, 2019 11:13:35 AM (4 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

palm/trunk/UTIL/inifor/src/inifor_transform.f90
r3716 r3779 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017201 8Leibniz Universitaet Hannover18 ! Copyright 2017201 8Deutscher Wetterdienst Offenbach17 ! Copyright 20172019 Leibniz Universitaet Hannover 18 ! Copyright 20172019 Deutscher Wetterdienst Offenbach 19 19 !! 20 20 ! … … 26 26 !  27 27 ! $Id$ 28 ! Remove basic state pressure before computing geostrophic wind 29 !  Introduced new levelbased profile averaging routine that does not rely on 30 ! external weights average_profile() 31 !  Renamed original weightsbased routine average_profile() > 32 ! interp_average_profile() 33 ! Average geostrophic wind components on coarse COSMO levels instead of fine PALM levels 34 !  Introduced new profile interpolation routine for interpolating single 35 ! profiles from COSMO to PALM levels 36 !  Renamed original array variant interpolate_1d() > interpolate_1d_arr() 37 ! 38 ! 39 ! 40 ! 3716 20190205 17:02:38Z eckhard 28 41 ! Include outofbounds error message in log 29 42 ! … … 93 106 USE inifor_control 94 107 USE inifor_defs, & 95 ONLY: G, TO_DEGREES, TO_RADIANS, PI, dp108 ONLY: BETA, dp, G, P_SL, PI, RD, T_SL, TO_DEGREES, TO_RADIANS 96 109 USE inifor_types 97 110 USE inifor_util, & 98 ONLY: real_to_str, str111 ONLY: get_basic_state, real_to_str, str 99 112 100 113 IMPLICIT NONE 101 114 102 115 CONTAINS 116 117 118 SUBROUTINE interpolate_1d(in_arr, out_arr, outgrid) 119 TYPE(grid_definition), INTENT(IN) :: outgrid 120 REAL(dp), INTENT(IN) :: in_arr(:) 121 REAL(dp), INTENT(OUT) :: out_arr(:) 122 123 INTEGER :: i, j, k, l, nz 124 125 nz = UBOUND(out_arr, 1) 126 127 DO k = nz, LBOUND(out_arr, 1), 1 128 129 ! 130 ! TODO: Remove IF clause and extrapolate based on a critical vertical 131 ! TODO: index marking the lower bound of COSMODE data coverage. 132 ! Check for negative interpolation weights indicating grid points 133 ! below COSMODE domain and extrapolate from the top in such cells. 134 IF (outgrid % w(1,k,1) < 1.0_dp .AND. k < nz) THEN 135 out_arr(k) = out_arr(k+1) 136 ELSE 137 out_arr(k) = 0.0_dp 138 DO l = 1, 2 139 out_arr(k) = out_arr(k) + & 140 outgrid % w(1,k,l) * in_arr(outgrid % kkk(1,k,l) ) 141 END DO 142 END IF 143 END DO 144 145 END SUBROUTINE interpolate_1d 146 103 147 104 148 !! … … 125 169 !> outvar : Array of interpolated data 126 170 !! 127 SUBROUTINE interpolate_1d (in_arr, out_arr, outgrid)171 SUBROUTINE interpolate_1d_arr(in_arr, out_arr, outgrid) 128 172 TYPE(grid_definition), INTENT(IN) :: outgrid 129 173 REAL(dp), INTENT(IN) :: in_arr(0:,0:,0:) … … 156 200 END DO 157 201 END DO 158 END SUBROUTINE interpolate_1d 202 END SUBROUTINE interpolate_1d_arr 159 203 160 204 … … 174 218 !> of PALM4U point (i,j,k) on the input grid corresponding to the source 175 219 !> data invar. (The outgrid carries the relationship with the ingrid in the 176 ! form of the interpo altion weights.)220 ! form of the interpolation weights.) 177 221 !> 178 222 !> outgrid % w_horiz: Array of weights for horizontal bilinear interpolation … … 298 342 ! Interpolate from intermediate grid to palm_grid grid, includes 299 343 ! extrapolation for cells below COSMO domain. 300 CALL interpolate_1d (intermediate_array, palm_array, palm_grid)344 CALL interpolate_1d_arr(intermediate_array, palm_array, palm_grid) 301 345 302 346 DEALLOCATE(intermediate_array) … … 311 355 !> averaging grid 'avg_grid' and store the result in 'profile_array'. 312 356 !! 313 SUBROUTINE average_profile(source_array, profile_array, avg_grid)357 SUBROUTINE interp_average_profile(source_array, profile_array, avg_grid) 314 358 TYPE(grid_definition), INTENT(IN) :: avg_grid 315 359 REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: source_array … … 358 402 profile_array(1:avg_grid % k_min1) = profile_array(avg_grid % k_min) 359 403 404 END SUBROUTINE interp_average_profile 405 406 407 !! 408 ! Description: 409 !  410 !> Average data horizontally from the source_array over the region given by the 411 !> averaging grid 'avg_grid' and store the result in 'profile_array'. 412 !! 413 SUBROUTINE average_profile( source_array, profile_array, & 414 source_grid, avg_grid ) 415 416 TYPE(grid_definition), INTENT(IN) :: source_grid, avg_grid 417 REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: source_array 418 REAL(dp), DIMENSION(:), INTENT(OUT) :: profile_array 419 420 INTEGER :: i_source, j_source, k_profile, k_source, l, m, nz, nlev 421 422 REAL :: ni_columns 423 424 nlev = SIZE( source_array, 3 ) 425 nz = SIZE( profile_array, 1 ) 426 427 IF ( nlev /= nz ) THEN 428 message = "Lengths of input and output profiles do not match: " // & 429 "cosmo_pressure(" // TRIM( str( nlev ) ) // & 430 "), profile_array(" // TRIM( str( nz ) ) // ")." 431 CALL inifor_abort('average_pressure_perturbation', message) 432 ENDIF 433 434 profile_array(:) = 0.0_dp 435 436 DO l = 1, avg_grid % n_columns 437 438 i_source = avg_grid % iii(l) 439 j_source = avg_grid % jjj(l) 440 441 profile_array(:) = profile_array(:) & 442 + source_array(i_source, j_source, :) 443 444 END DO 445 446 ni_columns = 1.0_dp / avg_grid % n_columns 447 profile_array(:) = profile_array(:) * ni_columns 448 360 449 END SUBROUTINE average_profile 450 451 452 !! 453 ! Description: 454 !  455 !> This is a sister routine to average_profile() and differes from it in that 456 !> it removes the COSMO basic state pressure from the input array before 457 !> averaging. 458 !! 459 SUBROUTINE average_pressure_perturbation( cosmo_pressure, profile_array, & 460 cosmo_grid, avg_grid ) 461 462 TYPE(grid_definition), INTENT(IN) :: cosmo_grid, avg_grid 463 REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: cosmo_pressure 464 REAL(dp), DIMENSION(:), INTENT(OUT) :: profile_array 465 466 INTEGER :: i_source, j_source, k_profile, k_source, l, m, nz, nlev 467 468 REAL(dp) :: ni_columns 469 REAL(dp), DIMENSION(:), ALLOCATABLE :: basic_state_pressure 470 471 nlev = SIZE( cosmo_pressure, 3 ) 472 nz = SIZE( profile_array, 1 ) 473 474 IF ( nlev /= nz ) THEN 475 message = "Lengths of input and output profiles do not match: " // & 476 "cosmo_pressure(" // TRIM( str( nlev ) ) // & 477 "), profile_array(" // TRIM( str( nz ) ) // ")." 478 CALL inifor_abort('average_pressure_perturbation', message) 479 ENDIF 480 481 ALLOCATE( basic_state_pressure(nz) ) 482 profile_array(:) = 0.0_dp 483 484 DO l = 1, avg_grid % n_columns 485 i_source = avg_grid % iii(l) 486 j_source = avg_grid % jjj(l) 487 488 ! 489 ! Compute pressure perturbation by removing COSMO basic state pressure 490 CALL get_basic_state( cosmo_grid % hfl(i_source,j_source,:), BETA, & 491 P_SL, T_SL, RD, G, basic_state_pressure ) 492 493 profile_array(:) = profile_array(:) & 494 + cosmo_pressure(i_source, j_source, :) & 495  basic_state_pressure(:) 496 497 ! 498 ! Loop over horizontal neighbours l 499 END DO 500 501 DEALLOCATE( basic_state_pressure ) 502 503 ni_columns = 1.0_dp / avg_grid % n_columns 504 profile_array(:) = profile_array(:) * ni_columns 505 506 END SUBROUTINE average_pressure_perturbation 507 508 361 509 362 510
Note: See TracChangeset
for help on using the changeset viewer.