Changeset 3785 for palm/trunk/UTIL
- Timestamp:
- Mar 6, 2019 10:41:14 AM (6 years ago)
- Location:
- palm/trunk/UTIL/inifor
- Files:
-
- 21 edited
-
Makefile (modified) (2 diffs)
-
Makefile.gnu (modified) (2 diffs)
-
Makefile.ifort (modified) (2 diffs)
-
src/inifor.f90 (modified) (12 diffs)
-
src/inifor_control.f90 (modified) (2 diffs)
-
src/inifor_grid.f90 (modified) (31 diffs)
-
src/inifor_io.f90 (modified) (27 diffs)
-
src/inifor_transform.f90 (modified) (39 diffs)
-
src/inifor_util.f90 (modified) (3 diffs)
-
tests/Makefile (modified) (2 diffs)
-
tests/Makefile.gnu (modified) (2 diffs)
-
tests/Makefile.ifort (modified) (2 diffs)
-
tests/test-boundaries.f90 (modified) (2 diffs)
-
tests/test-centre-velocities.f90 (modified) (2 diffs)
-
tests/test-grid.f90 (modified) (4 diffs)
-
tests/test-input-files.f90 (modified) (4 diffs)
-
tests/test-interpolation.f90 (modified) (4 diffs)
-
tests/test-prototype.f90 (modified) (1 diff)
-
tests/test-stretching.f90 (modified) (1 diff)
-
tests/test-transform.f90 (modified) (1 diff)
-
tests/util.f90 (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/UTIL/inifor/Makefile
r3716 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3716 2019-02-05 17:02:38Z eckhard 27 31 # Added __netcdf preprocessor flag 28 32 # -
palm/trunk/UTIL/inifor/Makefile.gnu
r3716 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3716 2019-02-05 17:02:38Z eckhard 27 31 # Added __netcdf preprocessor flag 28 32 # -
palm/trunk/UTIL/inifor/Makefile.ifort
r3716 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3716 2019-02-05 17:02:38Z eckhard 27 31 # Added __netcdf preprocessor flag 28 32 # -
palm/trunk/UTIL/inifor/src/inifor.f90
r3779 r3785 130 130 131 131 LOGICAL, SAVE :: ug_vg_have_been_computed = .FALSE. !< flag for managing geostrophic wind allocation and computation 132 LOGICAL, SAVE :: debugging_output = .TRUE. !< flag controllging output of internal variables132 !LOGICAL, SAVE :: debugging_output = .TRUE. !< flag controllging output of internal variables 133 133 134 134 !> \mainpage About INIFOR … … 163 163 ! 164 164 !-- Add the output variables to the netCDF output file 165 CALL setup_netcdf_variables(output_file % name, output_var_table, & 166 cfg % debug) 165 CALL setup_netcdf_variables(output_file % name, output_var_table) 167 166 168 167 CALL setup_io_groups() … … 193 192 "' could not be preprocessed sucessfully." 194 193 CALL inifor_abort('main loop', message) 195 END 194 ENDIF 196 195 197 196 !------------------------------------------------------------------------------ … … 276 275 output_arr(0,0,:), rho_centre, & 277 276 output_var % averaging_grid) 278 END 279 280 END 277 ENDIF 278 279 ENDIF 281 280 CALL run_control('time', 'comp') 282 281 … … 349 348 input_buffer(output_var % input_id) % array(:,:,:),& 350 349 internal_arr(:), & 351 cosmo_grid, output_var % averaging_grid&350 output_var % averaging_grid & 352 351 ) 353 352 … … 363 362 ! ALLOCATE( output_arr(1,1,1:output_var % grid % nz) ) 364 363 ! output_arr(1,1,:) = internal_arr(:) 365 !END 364 !ENDIF 366 365 CALL run_control('time', 'comp') 367 366 … … 395 394 CALL interpolate_1d( vg_cosmo, vg_palm, & 396 395 output_var % grid ) 397 END 396 ENDIF 398 397 399 398 ug_vg_have_been_computed = .TRUE. 400 399 401 END 400 ENDIF 402 401 403 402 ! … … 467 466 output_file, cfg) 468 467 CALL run_control('time', 'write') 469 END 468 ENDIF 470 469 471 470 IF (ALLOCATED(output_arr)) DEALLOCATE(output_arr) 472 471 CALL run_control('time', 'alloc') 473 472 474 END 473 ENDIF 475 474 476 475 ! 477 476 !-- output variable loop 478 END 477 ENDDO 479 478 480 479 ug_vg_have_been_computed = .FALSE. … … 494 493 DEALLOCATE( p_east ) 495 494 DEALLOCATE( p_west ) 496 END 497 END 495 ENDIF 496 ENDIF 498 497 499 498 ! … … 505 504 CALL report('main loop', 'Deallocating input buffer', cfg % debug) 506 505 DEALLOCATE(input_buffer) 507 END 506 ENDIF 508 507 CALL run_control('time', 'alloc') 509 508 510 509 ! 511 510 !-- time steps / input files loop 512 END 511 ENDDO 513 512 514 513 IF (ALLOCATED(input_buffer)) THEN 515 514 CALL report('main loop', 'Deallocating input buffer', cfg % debug) 516 515 DEALLOCATE(input_buffer) 517 END 516 ENDIF 518 517 CALL run_control('time', 'alloc') 519 518 … … 524 523 message = TRIM(message) // " with input variable '" // & 525 524 TRIM(group % in_var_list(1) % name) // "'." 526 END 525 ENDIF 527 526 528 527 CALL report('main loop', message, cfg % debug) … … 530 529 ! 531 530 !-- IO group % to_be_processed conditional 532 END 531 ENDIF 533 532 534 533 ! 535 534 !-- IO groups loop 536 END 535 ENDDO 537 536 538 537 !------------------------------------------------------------------------------ -
palm/trunk/UTIL/inifor/src/inifor_control.f90
r3779 r3785 110 110 ELSE 111 111 OPEN( NEWUNIT=u, FILE='inifor.log', POSITION='append', STATUS='old' ) 112 END 112 ENDIF 113 113 114 114 … … 116 116 IF ( PRESENT(debug) ) THEN 117 117 IF ( .NOT. debug ) suppress_message = .TRUE. 118 END 118 ENDIF 119 119 120 120 IF ( .NOT. suppress_message ) THEN 121 121 PRINT *, "inifor: " // TRIM(message) // " [ " // TRIM(routine) // " ]" 122 122 WRITE(u, *) TRIM(message) // " [ " // TRIM(routine) // " ]" 123 END 123 ENDIF 124 124 125 125 CLOSE(u) -
palm/trunk/UTIL/inifor/src/inifor_grid.f90
r3779 r3785 440 440 "has not been implemented, yet." 441 441 CALL inifor_abort('setup_parameters', message) 442 END 442 ENDIF 443 443 444 444 ! … … 525 525 // TRIM(cfg % namelist_file) // "'" 526 526 527 END 527 ENDIF 528 528 origin_lon = origin_lon * TO_RADIANS 529 529 origin_lat = origin_lat * TO_RADIANS … … 566 566 hfl(:,:,k) = 0.5_dp * ( hhl(:,:,k) + & 567 567 hhl(:,:,k+1) ) 568 END 568 ENDDO 569 569 CALL run_control('time', 'comp') 570 570 … … 1041 1041 x0=x0, y0=y0, z0 = z0, & 1042 1042 nx = nx, ny = ny, nz = nlev - 1) 1043 END 1043 ENDIF 1044 1044 1045 1045 ! … … 1117 1117 CALL setup_interpolation(cosmo_grid, scalars_south_grid, scalars_south_intermediate, interp_mode) 1118 1118 CALL setup_interpolation(cosmo_grid, scalars_top_grid, scalars_top_intermediate, interp_mode) 1119 END 1119 ENDIF 1120 1120 1121 1121 interp_mode = 'u' … … 1127 1127 CALL setup_interpolation(cosmo_grid, u_south_grid, u_south_intermediate, interp_mode) 1128 1128 CALL setup_interpolation(cosmo_grid, u_top_grid, u_top_intermediate, interp_mode) 1129 END 1129 ENDIF 1130 1130 1131 1131 interp_mode = 'v' … … 1137 1137 CALL setup_interpolation(cosmo_grid, v_south_grid, v_south_intermediate, interp_mode) 1138 1138 CALL setup_interpolation(cosmo_grid, v_top_grid, v_top_intermediate, interp_mode) 1139 END 1139 ENDIF 1140 1140 1141 1141 interp_mode = 'w' … … 1147 1147 CALL setup_interpolation(cosmo_grid, w_south_grid, w_south_intermediate, interp_mode) 1148 1148 CALL setup_interpolation(cosmo_grid, w_top_grid, w_top_intermediate, interp_mode) 1149 END 1149 ENDIF 1150 1150 1151 1151 IF (TRIM(cfg % ic_mode) == 'profile') THEN 1152 1152 !TODO: remove this conditional if not needed. 1153 END 1153 ENDIF 1154 1154 1155 1155 … … 1241 1241 IF (PRESENT(ic_mode)) THEN 1242 1242 IF (TRIM(ic_mode) == 'profile') setup_volumetric = .FALSE. 1243 END 1243 ENDIF 1244 1244 1245 1245 IF (setup_volumetric) THEN … … 1254 1254 CALL interpolate_2d(cosmo_h, intermediate_grid % h, intermediate_grid) 1255 1255 CALL find_vertical_neighbours_and_weights_interp(grid, intermediate_grid) 1256 END 1256 ENDIF 1257 1257 1258 1258 END SUBROUTINE setup_interpolation … … 1317 1317 message = "z has not been passed but is required for 'boundary' grids" 1318 1318 CALL inifor_abort('init_grid_definition', message) 1319 END 1319 ENDIF 1320 1320 1321 1321 ALLOCATE( grid % x(0:nx) ) … … 1335 1335 ALLOCATE( grid % w_verti(0:nx, 0:ny, 1:nz, 2) ) 1336 1336 grid % w_verti(:,:,:,:) = 0.0_dp 1337 END 1337 ENDIF 1338 1338 1339 1339 CASE('boundary intermediate') … … 1374 1374 message = "z has not been passed but is required for 'palm' grids" 1375 1375 CALL inifor_abort('init_grid_definition', message) 1376 END 1376 ENDIF 1377 1377 1378 1378 IF (.NOT.PRESENT(zw)) THEN 1379 1379 message = "zw has not been passed but is required for 'palm' grids" 1380 1380 CALL inifor_abort('init_grid_definition', message) 1381 END 1381 ENDIF 1382 1382 1383 1383 grid % name(1) = 'x and lon' … … 1407 1407 ALLOCATE( grid % w_verti(0:nx, 0:ny, 1:nz, 2) ) 1408 1408 grid % w_verti(:,:,:,:) = 0.0_dp 1409 END 1409 ENDIF 1410 1410 1411 1411 CASE('palm intermediate') … … 1602 1602 avg_grid % iii, avg_grid % jjj) 1603 1603 1604 END 1604 ENDIF 1605 1605 1606 1606 ! … … 1674 1674 avg_grid % iii(l) = i 1675 1675 avg_grid % jjj(l) = j 1676 END 1677 END 1676 ENDDO 1677 ENDDO 1678 1678 1679 1679 END SUBROUTINE get_cosmo_averaging_region … … 2083 2083 DO k = 1, UBOUND(zw, 1) 2084 2084 zw(k) = 0.5_dp * (z(k-1) + z(k)) 2085 END 2085 ENDDO 2086 2086 2087 2087 END SUBROUTINE midpoints … … 2291 2291 ELSE 2292 2292 group % n_output_quantities = group % n_inputs 2293 END 2293 ENDIF 2294 2294 2295 2295 ALLOCATE(group % in_var_list(group % n_inputs)) … … 2347 2347 message = 'Simulation start date has not been set.' 2348 2348 CALL inifor_abort('setup_variable_tables', message) 2349 END 2349 ENDIF 2350 2350 2351 2351 nc_source_text = 'COSMO-DE analysis from ' // TRIM(cfg % start_date) … … 2491 2491 IF (TRIM(ic_mode) == 'profile') THEN 2492 2492 output_var_table(3) % averaging_grid => averaged_initial_scalar_profile 2493 END 2493 ENDIF 2494 2494 2495 2495 output_var_table(4) = init_nc_var( & … … 2567 2567 IF (TRIM(ic_mode) == 'profile') THEN 2568 2568 output_var_table(9) % averaging_grid => averaged_initial_scalar_profile 2569 END 2569 ENDIF 2570 2570 2571 2571 output_var_table(10) = init_nc_var( & … … 2643 2643 IF (TRIM(ic_mode) == 'profile') THEN 2644 2644 output_var_table(15) % averaging_grid => averaged_initial_scalar_profile 2645 END 2645 ENDIF 2646 2646 2647 2647 output_var_table(16) = init_nc_var( & … … 2719 2719 IF (TRIM(ic_mode) == 'profile') THEN 2720 2720 output_var_table(21) % averaging_grid => averaged_initial_scalar_profile 2721 END 2721 ENDIF 2722 2722 2723 2723 output_var_table(22) = init_nc_var( & … … 2795 2795 IF (TRIM(ic_mode) == 'profile') THEN 2796 2796 output_var_table(27) % averaging_grid => averaged_initial_w_profile 2797 END 2797 ENDIF 2798 2798 2799 2799 output_var_table(28) = init_nc_var( & … … 3315 3315 IF (PRESENT(is_profile)) THEN 3316 3316 IF (is_profile) out_var_kind = TRIM(kind) // ' profile' 3317 END 3317 ENDIF 3318 3318 3319 3319 var % name = name … … 3734 3734 u = input_buffer(1) % array(i,j,k), & 3735 3735 v = input_buffer(2) % array(i,j,k) ) 3736 END 3737 END 3738 END 3736 ENDDO 3737 ENDDO 3738 ENDDO 3739 3739 3740 3740 CASE DEFAULT … … 3788 3788 basic_state_pressure(:) 3789 3789 3790 END 3791 END 3790 ENDDO 3791 ENDDO 3792 3792 CALL run_control('time', 'comp') 3793 3793 … … 3797 3797 group % in_var_list(2) % name = 'P' 3798 3798 3799 END 3799 ENDIF 3800 3800 ! 3801 3801 !-- mark pressure as preprocessed … … 3875 3875 input_buffer(1) % array(i,j,k) = & 3876 3876 input_buffer(1) % array(i,j,k) * d_depth_rho_inv(k) 3877 END 3878 END 3879 END 3877 ENDDO 3878 ENDDO 3879 ENDDO 3880 3880 3881 3881 message = "Converted soil water from [kg/m^2] to [m^3/m^3]" … … 4054 4054 n_cells = n_cells + 1 4055 4055 column(:) = column(:) + array(ii,jj,:) 4056 END 4057 4058 END 4056 ENDIF 4057 4058 ENDDO 4059 4059 4060 4060 ! … … 4063 4063 array(i,j,:) = column(:) / n_cells 4064 4064 new_soiltyp(i,j) = 0 4065 END 4066 4067 END 4068 4069 END 4070 END 4065 ENDIF 4066 4067 ENDIF 4068 4069 ENDDO 4070 ENDDO 4071 4071 4072 4072 old_soiltyp(:,:) = new_soiltyp(:,:) 4073 4073 4074 END 4074 ENDDO 4075 4075 4076 4076 DEALLOCATE(old_soiltyp, new_soiltyp) -
palm/trunk/UTIL/inifor/src/inifor_io.f90
r3779 r3785 177 177 CALL inifor_abort('get_netcdf_variable', message) 178 178 179 END 179 ENDIF 180 180 181 181 CALL check(nf90_close(ncid)) … … 221 221 CALL inifor_abort('get_netcdf_variable', message) 222 222 223 END 223 ENDIF 224 224 225 225 CALL check(nf90_close(ncid)) … … 259 259 CALL inifor_abort('get_netcdf_dim_vector', message) 260 260 261 END 261 ENDIF 262 262 263 263 END SUBROUTINE get_netcdf_dim_vector … … 291 291 name = in_var % dimname(i), & 292 292 len = in_var % dimlen(i) )) 293 END 293 ENDDO 294 294 295 295 END SUBROUTINE get_input_dimensions … … 318 318 CALL inifor_abort('get_netcdf_start_and_count', message) 319 319 320 END 320 ENDIF 321 321 322 322 start = (/ 1, 1, 1 /) … … 329 329 !-- Start reading from second level, e.g. depth = 0.005 instead of 0.0 330 330 start(3) = 2 331 END 331 ENDIF 332 332 333 333 IF (in_var % ndim .EQ. 2) THEN … … 358 358 IF ( var % lod .GE. 0 ) THEN 359 359 CALL check(nf90_put_att(ncid, var % varid, "lod", var % lod)) 360 END 360 ENDIF 361 361 CALL check(nf90_put_att(ncid, var % varid, "source", var % source)) 362 362 CALL check(nf90_put_att(ncid, var % varid, "_FillValue", NF90_FILL_REAL)) … … 383 383 name = null, & 384 384 len = var % dimlen(i) ) ) 385 END 385 ENDDO 386 386 387 387 END SUBROUTINE netcdf_get_dimensions … … 538 538 i = i + 1 539 539 540 END 540 ENDDO 541 541 542 542 ELSE … … 545 545 CALL report('parse_command_line_arguments', message) 546 546 547 END 547 ENDIF 548 548 549 549 END SUBROUTINE parse_command_line_arguments … … 574 574 TRIM(date_string) // TRIM(suffix) // '.nc' 575 575 576 END 576 ENDDO 577 577 578 578 END SUBROUTINE get_datetime_file_list … … 594 594 LOGICAL, OPTIONAL, INTENT(IN) :: nocheck 595 595 596 INTEGER :: number_of_intervals, hour, i 597 CHARACTER(LEN=DATE) :: date_string 598 CHARACTER(LEN=PATH) :: file_name 599 LOGICAL :: check_files 596 INTEGER :: i 597 LOGICAL :: check_files 600 598 601 599 CALL get_datetime_file_list( start_date_string, start_hour, end_hour, & … … 606 604 IF ( PRESENT ( nocheck ) ) THEN 607 605 IF ( nocheck ) check_files = .FALSE. 608 END 606 ENDIF 609 607 610 608 IF ( check_files ) THEN … … 615 613 DO i = 1, SIZE(file_list) 616 614 CALL verify_file(file_list(i), 'input', tip) 617 END 618 619 END 615 ENDDO 616 617 ENDIF 620 618 621 619 END SUBROUTINE get_input_file_list … … 645 643 IF (PRESENT(tip)) THEN 646 644 message = TRIM(message) // " " // TRIM(tip) 647 END 648 649 END 645 ENDIF 646 647 ENDIF 650 648 651 649 CALL inifor_abort('verify_file', message) 652 650 653 END 651 ENDIF 654 652 655 653 message = "Set up input file name '" // TRIM(file_name) // "'" … … 691 689 IF (TRIM(cfg % static_driver_file) .NE. '') THEN 692 690 CALL verify_file(cfg % static_driver_file, 'static driver') 693 END 691 ENDIF 694 692 695 693 SELECT CASE( TRIM(cfg % ic_mode) ) … … 739 737 "wind. Please specify either both or none." 740 738 CALL inifor_abort( 'validate_config', message ) 741 END 739 ENDIF 742 740 743 741 END SUBROUTINE validate_config … … 958 956 !> Defines the netCDF variables to be written to the dynamic driver file 959 957 !------------------------------------------------------------------------------! 960 SUBROUTINE setup_netcdf_variables(filename, output_variable_table , debug)958 SUBROUTINE setup_netcdf_variables(filename, output_variable_table) 961 959 962 960 CHARACTER (LEN=*), INTENT(IN) :: filename 963 961 TYPE(nc_var), INTENT(INOUT), TARGET :: output_variable_table(:) 964 LOGICAL, INTENT(IN) :: debug965 962 966 963 TYPE(nc_var), POINTER :: var … … 988 985 CALL netcdf_define_variable(var, ncid) 989 986 CALL netcdf_get_dimensions(var, ncid) 990 END 987 ENDIF 991 988 992 END 989 ENDDO 993 990 994 991 CALL check(nf90_enddef(ncid)) … … 1043 1040 TRIM( str(SIZE(group % in_var_list)) ) // "." 1044 1041 CALL inifor_abort('read_input_variables | accumulation', message) 1045 END 1042 ENDIF 1046 1043 1047 1044 ! … … 1095 1092 input_var % name = TRIM( get_pressure_varname(input_file) ) 1096 1093 CALL run_control('time', 'read') 1097 END 1094 ENDIF 1098 1095 1099 1096 CALL get_netcdf_variable(input_file, input_var, buffer(ivar) % array) … … 1102 1099 CALL run_control('time', 'comp') 1103 1100 1104 END 1105 END 1101 ENDDO 1102 ENDIF 1106 1103 1107 1104 END SUBROUTINE read_input_variables … … 1159 1156 CALL inifor_abort('get_pressure_var', message) 1160 1157 1161 END 1158 ENDIF 1162 1159 1163 1160 CALL check(nf90_close(ncid)) … … 1189 1186 CALL inifor_abort('get_netcdf_attribute', message) 1190 1187 1191 END 1188 ENDIF 1192 1189 1193 1190 END FUNCTION get_netcdf_attribute … … 1252 1249 SIZE(array, 2), ")." 1253 1250 STOP 1254 END 1251 ENDIF 1255 1252 1256 1253 … … 1303 1300 start=start(1:ndim+1), & 1304 1301 count=count(1:ndim) ) ) 1305 END 1302 ENDIF 1306 1303 1307 1304 CASE ( 'large-scale scalar forcing', 'large-scale w forcing' ) … … 1336 1333 TRIM( nf90_strerror(status) ) 1337 1334 CALL inifor_abort('io.check', message) 1338 END 1335 ENDIF 1339 1336 1340 1337 END SUBROUTINE check -
palm/trunk/UTIL/inifor/src/inifor_transform.f90
r3779 r3785 121 121 REAL(dp), INTENT(OUT) :: out_arr(:) 122 122 123 INTEGER :: i, j,k, l, nz123 INTEGER :: k, l, nz 124 124 125 125 nz = UBOUND(out_arr, 1) … … 139 139 out_arr(k) = out_arr(k) + & 140 140 outgrid % w(1,k,l) * in_arr(outgrid % kkk(1,k,l) ) 141 END 142 END 143 END 141 ENDDO 142 ENDIF 143 ENDDO 144 144 145 145 END SUBROUTINE interpolate_1d … … 195 195 outgrid % w_verti(i,j,k,l) * & 196 196 in_arr(i,j,outgrid % kk(i,j,k, l) ) 197 END 198 END 199 END 200 END 201 END 197 ENDDO 198 ENDIF 199 ENDDO 200 ENDDO 201 ENDDO 202 202 END SUBROUTINE interpolate_1d_arr 203 203 … … 245 245 TRIM(str(UBOUND(invar, 3))) // ")." 246 246 CALL inifor_abort('interpolate_2d', message) 247 END 247 ENDIF 248 248 249 249 DO k = 0, UBOUND(outvar, 3) … … 257 257 outgrid % jj(i,j,l), & 258 258 k ) 259 END 260 END 261 END 262 END 259 ENDDO 260 ENDDO 261 ENDDO 262 ENDDO 263 263 264 264 END SUBROUTINE interpolate_2d … … 284 284 NEW_LINE(' ') // "jj has " // str(SIZE(jj)) // "." 285 285 CALL inifor_abort('average_2d', message) 286 END 286 ENDIF 287 287 288 288 IF (SIZE(ii) == 0) THEN … … 290 290 "size of index lists 'ii' and 'jj' is zero." 291 291 CALL inifor_abort('average_2d', message) 292 END 292 ENDIF 293 293 294 294 DO k = 0, UBOUND(out_arr, 1) … … 299 299 j = jj(l) 300 300 out_arr(k) = out_arr(k) + in_arr(i, j, k) 301 END 302 303 END 301 ENDDO 302 303 ENDDO 304 304 305 305 ni = 1.0_dp / SIZE(ii) … … 385 385 ! 386 386 !-- Loop over vertical interpolation neighbours m 387 END 387 ENDDO 388 388 389 389 ! 390 390 !-- Loop over PALM levels k_profile 391 END 391 ENDDO 392 392 393 393 ! 394 394 !-- Loop over horizontal neighbours l 395 END 395 ENDDO 396 396 397 397 ni_columns = 1.0_dp / avg_grid % n_columns … … 411 411 !> averaging grid 'avg_grid' and store the result in 'profile_array'. 412 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 413 SUBROUTINE average_profile( source_array, profile_array, avg_grid ) 414 415 TYPE(grid_definition), INTENT(IN) :: avg_grid 417 416 REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: source_array 418 417 REAL(dp), DIMENSION(:), INTENT(OUT) :: profile_array 419 418 420 INTEGER :: i_source, j_source, k_profile, k_source, l, m, nz, nlev421 422 REAL 419 INTEGER :: i_source, j_source, l, nz, nlev 420 421 REAL(dp) :: ni_columns 423 422 424 423 nlev = SIZE( source_array, 3 ) … … 442 441 + source_array(i_source, j_source, :) 443 442 444 END 443 ENDDO 445 444 446 445 ni_columns = 1.0_dp / avg_grid % n_columns … … 464 463 REAL(dp), DIMENSION(:), INTENT(OUT) :: profile_array 465 464 466 INTEGER :: i_source, j_source, k_profile, k_source, l, m, nz, nlev465 INTEGER :: i_source, j_source, l, nz, nlev 467 466 468 467 REAL(dp) :: ni_columns … … 497 496 ! 498 497 !-- Loop over horizontal neighbours l 499 END 498 ENDDO 500 499 501 500 DEALLOCATE( basic_state_pressure ) … … 554 553 p(k) = constant_density_pressure(p(k_min), zk, rhok, drhodz, & 555 554 avg_grid % z(k), G) 556 END 555 ENDDO 557 556 558 557 END SUBROUTINE extrapolate_pressure … … 706 705 IF (phi_c > 0.0_dp) THEN 707 706 lamc_to_lamn = lam_c - SIGN(PI, lam_c) 708 END 707 ENDIF 709 708 710 709 END FUNCTION lamc_to_lamn … … 731 730 ELSE 732 731 gamma_from_hemisphere = 0.0_dp 733 END 732 ENDIF 734 733 END FUNCTION gamma_from_hemisphere 735 734 … … 773 772 PRINT *, "inifor: rotate_to_cosmo: lam: ", SIZE(lam, 1), SIZE(lam, 2) 774 773 STOP 775 END 774 ENDIF 776 775 777 776 IF ( SIZE(phir) .NE. SIZE(phi, 2) .OR. & … … 781 780 PRINT *, "inifor: rotate_to_cosmo: lamr: ", SIZE(lamr), SIZE(phi, 1) 782 781 STOP 783 END 782 ENDIF 784 783 785 784 DO j = 0, UBOUND(phir, 1) … … 797 796 gam * TO_DEGREES) * TO_RADIANS 798 797 799 END 800 END 798 ENDDO 799 ENDDO 801 800 802 801 END SUBROUTINE rotate_to_cosmo … … 831 830 y(i) = v_rot(2) 832 831 833 END 832 ENDDO 834 833 835 834 END SUBROUTINE rotate_vector_field … … 941 940 ", PALM lat " // TRIM(real_to_str(palm_clat(i,j)*TO_DEGREES)) 942 941 CALL inifor_abort('find_horizontal_neighbours', message) 943 END 942 ENDIF 944 943 945 944 palm_ii(i,j,1) = FLOOR(lonpos) … … 952 951 palm_jj(i,j,3) = CEILING(latpos) 953 952 palm_jj(i,j,4) = FLOOR(latpos) 954 END 955 END 953 ENDDO 954 ENDDO 956 955 957 956 END SUBROUTINE find_horizontal_neighbours … … 1042 1041 current_height < h_top & 1043 1042 ) 1044 END 1043 ENDDO 1045 1044 1046 1045 IF (k_intermediate > nlev-1) THEN … … 1048 1047 " is above intermediate grid range." 1049 1048 CALL inifor_abort('find_vertical_neighbours', message) 1050 END 1049 ENDIF 1051 1050 1052 1051 palm_grid % kk(i,j,k,1) = k_intermediate … … 1058 1057 palm_grid % w_verti(i,j,k,1) = weight 1059 1058 palm_grid % w_verti(i,j,k,2) = 1.0_dp - weight 1060 END 1061 1062 END 1063 1064 END 1065 END 1059 ENDIF 1060 1061 ENDDO 1062 1063 ENDDO 1064 ENDDO 1066 1065 1067 1066 END SUBROUTINE find_vertical_neighbours_and_weights_interp … … 1103 1102 ELSE 1104 1103 cosmo_h => avg_grid % cosmo_h 1105 END 1104 ENDIF 1106 1105 1107 1106 ! … … 1115 1114 i = avg_grid % iii(l) 1116 1115 j = avg_grid % jjj(l) 1117 END 1116 ENDIF 1118 1117 1119 1118 column_base = cosmo_h(i,j,1) … … 1176 1175 current_height < h_top & 1177 1176 ) 1178 END 1177 ENDDO 1179 1178 1180 1179 ! … … 1185 1184 " is above intermediate grid range." 1186 1185 CALL inifor_abort('find_vertical_neighbours', message) 1187 END 1186 ENDIF 1188 1187 1189 1188 avg_grid % kkk(l,k_palm,1) = k_intermediate … … 1195 1194 avg_grid % w(l,k_palm,1) = weight 1196 1195 avg_grid % w(l,k_palm,2) = 1.0_dp - weight 1197 END 1196 ENDIF 1198 1197 1199 1198 ! 1200 1199 !-- Loop over PALM levels k 1201 END 1200 ENDDO 1202 1201 1203 1202 ! 1204 1203 !-- Loop over averaging columns l 1205 END 1204 ENDDO 1206 1205 1207 1206 END SUBROUTINE find_vertical_neighbours_and_weights_average … … 1283 1282 " is out bounds." 1284 1283 CALL inifor_abort('compute_horizontal_interp_weights', message) 1285 END 1284 ENDIF 1286 1285 IF (wp > 1.0_dp .OR. wp < 0.0_dp) THEN 1287 1286 message = "Horizontal weight wp = " // TRIM(real_to_str(wp)) // & 1288 1287 " is out bounds." 1289 1288 CALL inifor_abort('compute_horizontal_interp_weights', message) 1290 END 1289 ENDIF 1291 1290 1292 1291 palm_w_horiz(i,j,1) = wl * wp … … 1295 1294 palm_w_horiz(i,j,4) = 1.0_dp - SUM( palm_w_horiz(i,j,1:3) ) 1296 1295 1297 END 1298 END 1296 ENDDO 1297 ENDDO 1299 1298 1300 1299 END SUBROUTINE compute_horizontal_interp_weights … … 1352 1351 ELSE 1353 1352 zrlas = rlarot 1354 END 1353 ENDIF 1355 1354 zrlas = zrlas * TO_RADIANS 1356 1355 … … 1362 1361 ELSE 1363 1362 zarg = zcospol * COS (zphis) * COS (zrlas) + zsinpol * SIN (zphis) 1364 END 1363 ENDIF 1365 1364 1366 1365 phirot2phi = ASIN (zarg) * TO_DEGREES … … 1394 1393 ELSE 1395 1394 zrla1 = rla 1396 END 1395 ENDIF 1397 1396 zrla = zrla1 * TO_RADIANS 1398 1397 … … 1431 1430 ELSE 1432 1431 zrlas = rlarot 1433 END 1432 ENDIF 1434 1433 zrlas = TO_RADIANS * zrlas 1435 1434 … … 1452 1451 zcospol * SIN(zphis)) + & 1453 1452 SIN (zlampol) * SIN(zrlas) * COS(zphis) 1454 END 1453 ENDIF 1455 1454 1456 1455 IF (zarg2 == 0.0_dp) zarg2 = 1.0E-20_dp … … 1487 1486 ELSE 1488 1487 zrla1 = rla 1489 END 1488 ENDIF 1490 1489 zrla = zrla1 * TO_RADIANS 1491 1490 … … 1500 1499 rla2rlarot = polgam + rla2rlarot 1501 1500 IF (rla2rlarot > 180._dp) rla2rlarot = rla2rlarot - 360.0_dp 1502 END 1501 ENDIF 1503 1502 1504 1503 END FUNCTION rla2rlarot -
palm/trunk/UTIL/inifor/src/inifor_util.f90
r3779 r3785 250 250 DO i = 0, n 251 251 array(i) = start + REAL(i, dp) / n * (stop - start) 252 END 253 254 END 252 ENDDO 253 254 ENDIF 255 255 256 256 END SUBROUTINE linspace … … 366 366 ELSE 367 367 WRITE(real_to_str, '(E11.4)') val 368 END 368 ENDIF 369 369 real_to_str = ADJUSTL(real_to_str) 370 370 … … 416 416 IF (path(n:n) .NE. '/') THEN 417 417 path = TRIM(path) // '/' 418 END 418 ENDIF 419 419 420 420 END SUBROUTINE -
palm/trunk/UTIL/inifor/tests/Makefile
r3618 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3618 2018-12-10 13:25:22Z eckhard 27 31 # Prefixed INIFOR modules with inifor_ 28 32 # -
palm/trunk/UTIL/inifor/tests/Makefile.gnu
r3618 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3618 2018-12-10 13:25:22Z eckhard 27 31 # Prefixed INIFOR modules with inifor_ 28 32 # -
palm/trunk/UTIL/inifor/tests/Makefile.ifort
r3618 r3785 14 14 # PALM. If not, see <http://www.gnu.org/licenses/>. 15 15 # 16 # Copyright 2017-201 8Leibniz Universitaet Hannover17 # Copyright 2017-201 8Deutscher Wetterdienst Offenbach16 # Copyright 2017-2019 Leibniz Universitaet Hannover 17 # Copyright 2017-2019 Deutscher Wetterdienst Offenbach 18 18 #------------------------------------------------------------------------------# 19 19 # … … 25 25 # ----------------- 26 26 # $Id$ 27 # Updated copyright note 28 # 29 # 30 # 3618 2018-12-10 13:25:22Z eckhard 27 31 # Prefixed INIFOR modules with inifor_ 28 32 # -
palm/trunk/UTIL/inifor/tests/test-boundaries.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 104 104 105 105 CALL fini_grid_definition(boundary_grid) 106 END 106 ENDDO 107 107 108 108 CALL end_test(title, res) -
palm/trunk/UTIL/inifor/tests/test-centre-velocities.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 75 75 res = res .AND. assert_equal(u_centre(:,i,1), u_ref(:,i,1), 'centering u') 76 76 res = res .AND. assert_equal(v_centre(i,:,1), v_ref(i,:,1), 'centering v') 77 END 77 ENDDO 78 78 79 79 CALL end_test(title, res) -
palm/trunk/UTIL/inifor/tests/test-grid.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 74 74 xu(i) = real(i) / (nx+1) * lx 75 75 x(i) = 0.5*dx + xu(i) 76 END 76 ENDDO 77 77 78 78 dy = ly / (ny + 1) … … 80 80 yv(i) = real(i) / (ny+1) * ly 81 81 y(i) = 0.5*dy + yv(i) 82 END 82 ENDDO 83 83 84 84 dz(:) = lz / (nz + 1) … … 86 86 IF (i < nz) zw(i) = real(i) / (nz+1) * lz 87 87 z(i) = 0.5*dz(1) + zw(i) 88 END 88 ENDDO 89 89 90 90 ! Act -
palm/trunk/UTIL/inifor/tests/test-input-files.f90
r3681 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 90 90 DO i = 1, 6 91 91 res = res .AND. (TRIM(ref_list(i)) .EQ. TRIM(file_list(i))) 92 END 92 ENDDO 93 93 94 94 DEALLOCATE( ref_list, file_list ) … … 115 115 DO i = 1, 2 116 116 res = res .AND. (TRIM(ref_list(i)) .EQ. TRIM(file_list(i))) 117 END 117 ENDDO 118 118 119 119 DEALLOCATE( ref_list, file_list ) … … 145 145 DO i = 1, 2 146 146 res = res .AND. (TRIM(ref_list(i)) .EQ. TRIM(file_list(i))) 147 END 147 ENDDO 148 148 149 149 DEALLOCATE( ref_list, file_list ) -
palm/trunk/UTIL/inifor/tests/test-interpolation.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 146 146 PRINT *, "jj : ", palm_grid%jj(i,j,:) 147 147 PRINT *, "jj_ref : ", jj_ref(i,j,:), " indices match? ", res 148 END 149 END 148 ENDDO 149 ENDDO 150 150 151 151 CALL end_test(title, res) … … 180 180 DO i = 0, 1 181 181 PRINT *, "PALM lon, lat: ", palm_grid % clon(i,j) * TO_DEGREES, palm_grid % clat(i,j)*TO_DEGREES 182 END 183 END 182 ENDDO 183 ENDDO 184 184 185 185 ! Act … … 203 203 PRINT *, "jj : ", palm_grid%jj(i,j,:) 204 204 PRINT *, "jj_ref : ", jj_ref(i,j,:), " indices match? ", res 205 END 206 END 205 ENDDO 206 ENDDO 207 207 208 208 ! asserting that all four weights equal, 0.5, 0.25, 1./6., and 1./12., resp. -
palm/trunk/UTIL/inifor/tests/test-prototype.f90
r3183 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! -
palm/trunk/UTIL/inifor/tests/test-stretching.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! -
palm/trunk/UTIL/inifor/tests/test-transform.f90
r3618 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! -
palm/trunk/UTIL/inifor/tests/util.f90
r3183 r3785 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2017-201 8Leibniz Universitaet Hannover18 ! Copyright 2017-201 8Deutscher Wetterdienst Offenbach17 ! Copyright 2017-2019 Leibniz Universitaet Hannover 18 ! Copyright 2017-2019 Deutscher Wetterdienst Offenbach 19 19 !------------------------------------------------------------------------------! 20 20 ! … … 71 71 msg = 'failed.' 72 72 label = ' [XX]' 73 END 73 ENDIF 74 74 75 75 PRINT '(/A, A, A, A)', TRIM(label) // " Test '", TRIM(title), "' ", TRIM(msg) … … 87 87 ELSE 88 88 assert_equal = assert(a, b, 'eq') 89 END 89 ENDIF 90 90 91 91 IF (assert_equal .eqv. .TRUE.) THEN … … 94 94 PRINT *, "Equality assertion for ", msg, " failed. Maximum error is ", & 95 95 MAXVAL( ABS( a - b)) 96 END 96 ENDIF 97 97 98 98 END FUNCTION assert_equal … … 125 125 mag = MAX( ABS(a(i)), ABS(b(i)) ) 126 126 assert = assert .AND. (diff < mag * max_rel_diff ) 127 END 128 END 127 ENDDO 128 ENDIF 129 129 130 130 CASE DEFAULT
Note: See TracChangeset
for help on using the changeset viewer.
