diff --git a/Registry/registry.var b/Registry/registry.var index 516239f451..a168f94c61 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -264,9 +264,10 @@ rconfig integer report_end namelist,wrfvar5 1 10000000 - "rep rconfig integer tovs_start namelist,wrfvar5 1 1 - "tovs_start" "" "" rconfig integer tovs_end namelist,wrfvar5 1 10000000 - "tovs_end" "" "" rconfig logical gpsref_thinning namelist,wrfvar5 1 .false. - "gpsref_thinning" "" "" -rconfig logical outer_loop_restart namelist,wrfvar6 1 .false. - "outer_loop_restart" "" "" rconfig integer max_ext_its namelist,wrfvar6 1 1 - "max_ext_its" "" "" rconfig integer ntmax namelist,wrfvar6 max_outer_iterations 75 - "ntmax" "" "" +rconfig logical use_inverse_squarerootb namelist,wrfvar6 1 .false. - "use_inverse_squarerootb" "" "" +rconfig logical use_interpolate_cvt namelist,wrfvar6 1 .false. - "use_interpolate_cvt" "" "" rconfig integer nsave namelist,wrfvar6 1 4 - "nsave" "" "" rconfig integer write_interval namelist,wrfvar6 1 5 - "write_interval" "" "" rconfig real eps namelist,wrfvar6 max_outer_iterations 0.01 - "eps" "" "" diff --git a/phys/module_radiation_driver.F b/phys/module_radiation_driver.F index b8a6b06820..93243461a9 100644 --- a/phys/module_radiation_driver.F +++ b/phys/module_radiation_driver.F @@ -3765,6 +3765,17 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & qvs(k) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+35.) endif + if (modify_qvapor) then + if (qc(k).gt.1.E-8) then + qv(k) = MAX(qv(k), qvsw) + qvs(k) = qvsw + endif + if (qc(k).le.1.E-8 .and. qi(k).ge.1.E-9) then + qv(k) = MAX(qv(k), qvsi*1.005) !..To ensure a tiny bit ice supersaturation + qvs(k) = qvsi + endif + endif + rh(k) = MAX(0.01, qv(k)/qvs(k)) rhoa(k) = p(k)/(287.0*t(k)) ENDDO @@ -3779,14 +3790,13 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.65 + SQRT(1./(25.0+gridkm*gridkm*delz*0.01)) - RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*delz*0.01)) + RH_00L = 0.53 + MIN(0.46,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.86 + MIN(0.13,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).gt.1.E-7 .or. qi(k).ge.1.E-7 & - & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then + if (qc(k).gt.1.E-6 .or. qi(k).ge.1.E-6 & + & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 - qvs(k) = qv(k) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -3798,36 +3808,36 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & tc = t(k) - 273.15 if (tc .lt. -12.0) RH_00 = RH_00L - if (tc .ge. 20.0) then + if (tc .ge. 29.0) then CLDFRA(K) = 0.0 elseif (tc .ge. -12.0) then RHUM = MIN(rh(k), 1.0) - CLDFRA(K) = MAX(0., 1.0-SQRT((1.005-RHUM)/(1.005-RH_00))) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.001-RHUM)/(1.001-RH_00))) else if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then !..For HRRR model, the following look OK. RHUM = MIN(rh(k), 1.45) - RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+100.) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) if (RH_00 .ge. 1.5) then WRITE (dbg_msg,*) ' FATAL: RH_00 too large (1.5): ', RH_00, RH_00L, tc CALL wrf_error_fatal (dbg_msg) endif - CLDFRA(K) = MAX(0., 1.0-SQRT((1.5-RHUM)/(1.5-RH_00))) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) else !..but for the GFS model, RH is way lower. RHUM = MIN(rh(k), 1.05) - RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+100.) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) if (RH_00 .ge. 1.05) then WRITE (dbg_msg,*) ' FATAL: RH_00 too large (1.05): ', RH_00, RH_00L, tc CALL wrf_error_fatal (dbg_msg) endif - CLDFRA(K) = MAX(0., 1.0-SQRT((1.05-RHUM)/(1.05-RH_00))) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) endif endif - if (CLDFRA(K).gt.0.) CLDFRA(K) = MAX(0.01, MIN(CLDFRA(K),0.9)) + if (CLDFRA(K).gt.0.) CLDFRA(K) = MAX(0.01, MIN(CLDFRA(K),0.95)) if (debug_flag) then - WRITE (dbg_msg,*) 'DEBUG-GT: cloud fraction: ', RH_00, RHUM, CLDFRA(K) + WRITE (dbg_msg,*) 'DEBUG-GT: cloud fraction (k,RH_00, RHUM, CF): ',k,RH_00,RHUM,CLDFRA(K) CALL wrf_debug (150, dbg_msg) endif @@ -3847,8 +3857,8 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds' CALL wrf_debug (150, dbg_msg) do k = kte, kts, -1 - write(dbg_msg,'(f7.2, 2x, f7.2, 2x, f6.4, 2x, f7.3, 2x, f15.7, 2x, f15.7)') & - & T(k)-273.15, P(k)*0.01, rh(k), cldfra(k)*100., qc(k)*1000.,qi(k)*1000. + write(dbg_msg,'(f7.2,2x,f7.2,2x,f6.4,2x,f7.3,x,f15.7,x,f15.7,x,f15.7)') & + & T(k)-273.15, P(k)*0.01, rh(k), cldfra(k)*100., qc(k)*1000.,qi(k)*1000., qs(k)*1000. CALL wrf_debug (150, dbg_msg) enddo endif @@ -3857,7 +3867,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (modify_qvapor) then DO k = kts,kte if (cldfra(k).gt.0.20 .and. cldfra(k).lt.1.0) then - qv(k) = qvs(k) + qv(k) = MAX(qv(k),qvs(k)) endif ENDDO endif @@ -3884,16 +3894,18 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& !..Local vars. REAL, DIMENSION(kts:kte):: theta REAL:: theta1, theta2, delz - INTEGER:: k, k2, k_tropo, k_m12C, k_cldb, k_cldt, kbot + INTEGER:: k, k2, k_tropo, k_m12C, k_cldb, k_cldt, kbot, k_p150 LOGICAL:: in_cloud character*512 dbg_msg !+---+ k_m12C = 0 + k_p150 = 0 DO k = kte, kts, -1 theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10100.0) k_m12C = MAX(k_m12C, k) + if (P1d(k).gt.14999.0 .and. k_p150.eq.0) k_p150 = k ENDDO if (k_m12C .le. kts) k_m12C = kts @@ -3917,18 +3929,25 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& !.. tropopause height, as would any other diagnostic, so ensure resulting !.. k_tropo level is above 700hPa. - DO k = kte-3, kts, -1 + if ( (kte-k_p150) .lt. 3) k_p150 = kte-3 + DO k = k_p150-2, kts, -1 theta1 = theta(k) theta2 = theta(k+2) - delz = dz1d(k) + dz1d(k+1) + dz1d(k+2) - if ( ((((theta2-theta1)/delz) .lt. 10./1500. ) .AND. & - & (P1d(k).gt.8500.)) .or. (P1d(k).gt.70000.) ) then - goto 86 - endif + delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2) + if ( (((theta2-theta1)/delz).lt.10./1500.) .OR. P1d(k).gt.70000.) EXIT ENDDO - 86 continue k_tropo = MAX(kts+2, MIN(k+2, kte-1)) + if (k_tropo .gt. k_p150) then + DO k = kte-3, k_p150-2, -1 + theta1 = theta(k) + theta2 = theta(k+2) + delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2) + if ( (((theta2-theta1)/delz).lt.10./1500.) .AND. P1d(k).gt.9500.) EXIT + ENDDO + k_tropo = MAX(k_p150-1, MIN(k+2, kte-1)) + endif + if (k_tropo.gt.kte-2) then WRITE (dbg_msg,*) 'DEBUG-GT: CAUTION, tropopause appears to be very high up: ', k_tropo CALL wrf_debug (150, dbg_msg) @@ -3948,19 +3967,20 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& endif ENDDO -!..We would like to prevent fractional clouds below LCL in idealized -!.. situation with deep well-mixed convective PBL, that otherwise is -!.. likely to get clouds in more realistic capping inversion layer. +!..Be a bit more conservative with lower cloud fraction in scenario with +!.. well-mixed convective boundary layer below LCL. - kbot = kts+2 + kbot = kts+1 DO k = kbot, k_m12C - if ( (theta(k)-theta(k-1)) .gt. 0.025E-3*Dz1d(k)) EXIT + if ( (theta(k)-theta(k-1)) .gt. 0.010E-3*Dz1d(k)) EXIT ENDDO kbot = MAX(kts+1, k-2) DO k = kts, kbot - if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) cfr1d(k) = 0. + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) cfr1d(k) = MAX(0.01,0.5*cfr1d(k)) + ENDDO + DO k = kts,k_tropo + if (cfr1d(k).gt.0.0) kbot = MIN(k,kbot) ENDDO - !..Starting below tropo height, if cloud fraction greater than 1 percent, !.. compute an approximate total layer depth of cloud, determine a total @@ -4001,16 +4021,16 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& CALL wrf_debug (150, dbg_msg) endif if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & - & qi1d(k_cldb)=0.05*qvs1d(k_cldb) + & qi1d(k_cldb)=qi1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb) k = k_cldb endif k = k - 1 ENDDO - k_cldb = k_m12C + 3 + k_cldb = k_m12C + 5 in_cloud = .false. - k = k_m12C + 2 + k = k_m12C + 4 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4037,7 +4057,7 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& k = k_cldb elseif ((k_cldt - k_cldb + 1) .eq. 1) then if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & - & qc1d(k_cldb)=0.05*qvs1d(k_cldb) + & qc1d(k_cldb)=qc1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb) k = k_cldb endif k = k - 1 @@ -4067,9 +4087,9 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) ! print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz do k = k1, k2 - max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) + max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) enddo - max_iwc = MIN(1.E-3, max_iwc) + max_iwc = MIN(2.E-3, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4079,7 +4099,7 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_iwc = max_iwc*this_dz/tdz - iwc = MAX(1.E-6, this_iwc*(1.-entr)) + iwc = MAX(5.E-6, this_iwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif @@ -4108,9 +4128,9 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 - max_lwc = MAX(1.E-6, max_lwc - qc(k)) + max_lwc = MAX(1.E-5, max_lwc - qc(k)) enddo - max_lwc = MIN(1.E-3, max_lwc) + max_lwc = MIN(2.E-3, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4120,7 +4140,7 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_lwc = max_lwc*this_dz/tdz - lwc = MAX(1.E-6, this_lwc*(1.-entr)) + lwc = MAX(5.E-6, this_lwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif @@ -4146,14 +4166,14 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) lwp = 0. iwp = 0. do k = kts, kte - if (cfr(k).gt.0.0) then + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then lwp = lwp + qc(k)*Rho(k)*dz(k) iwp = iwp + qi(k)*Rho(k)*dz(k) endif enddo - if (lwp .gt. 1.5) then - xfac = 1.5/lwp + if (lwp .gt. 1.0) then + xfac = 1.0/lwp do k = kts, kte if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then qc(k) = qc(k)*xfac @@ -4161,8 +4181,8 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) enddo endif - if (iwp .gt. 1.5) then - xfac = 1.5/iwp + if (iwp .gt. 1.0) then + xfac = 1.0/iwp do k = kts, kte if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then qi(k) = qi(k)*xfac diff --git a/var/build/depend.txt b/var/build/depend.txt index 1b733744e2..ad5275d2c4 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -132,7 +132,7 @@ da_module_couple_uv_ad.o : da_module_couple_uv_ad.f90 da_couple_ad.inc da_calc_m da_mtgirs.o : da_mtgirs.f90 da_calculate_grady_mtgirs.inc da_get_innov_vector_mtgirs.inc da_check_max_iv_mtgirs.inc da_transform_xtoy_mtgirs_adj.inc da_transform_xtoy_mtgirs.inc da_print_stats_mtgirs.inc da_oi_stats_mtgirs.inc da_residual_mtgirs.inc da_jo_mtgirs_uvtq.inc da_jo_and_grady_mtgirs.inc da_ao_stats_mtgirs.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_netcdf_interface.o : da_netcdf_interface.f90 da_atotime.inc da_get_bdytimestr_cdf.inc da_get_bdyfrq.inc da_put_att_cdf.inc da_get_att_cdf.inc da_put_var_2d_int_cdf.inc da_get_var_2d_int_cdf.inc da_put_var_2d_real_cdf.inc da_put_var_3d_real_cdf.inc da_get_var_2d_real_cdf.inc da_get_var_3d_real_cdf.inc da_get_gl_att_real_cdf.inc da_get_gl_att_int_cdf.inc da_get_dims_cdf.inc da_get_times_cdf.inc da_get_var_1d_real_cdf.inc da_obs.o : da_obs.f90 da_grid_definitions.o da_set_obs_missing.inc da_obs_sensitivity.inc da_count_filtered_obs.inc da_store_obs_grid_info_rad.inc da_store_obs_grid_info.inc da_random_omb_all.inc da_fill_obs_structures.inc da_fill_obs_structures_rain.inc da_fill_obs_structures_radar.inc da_check_missing.inc da_add_noise_to_ob.inc da_transform_xtoy_adj.inc da_transform_xtoy.inc da_obs_proc_station.inc module_dm.o da_tracing.o da_tools.o da_tools_serial.o da_synop.o da_ssmi.o da_tamdar.o da_mtgirs.o da_sound.o da_ships.o da_satem.o da_rttov.o da_reporting.o da_rain.o da_radar.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_pilot.o da_physics.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_crtm.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_domain.o da_define_structures.o da_gpseph.o -da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_wrf_interfaces.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc +da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_par_util.o : da_par_util.f90 da_proc_maxmin_combine.inc da_proc_stats_combine.inc da_system.inc da_y_facade_to_global.inc da_generic_boilerplate.inc da_deallocate_global_synop.inc da_deallocate_global_sound.inc da_deallocate_global_sonde_sfc.inc da_generic_methods.inc da_patch_to_global_3d.inc da_patch_to_global_dual_res.inc da_patch_to_global_2d.inc da_cv_to_global.inc da_transpose_y2x_v2.inc da_transpose_x2y_v2.inc da_transpose_z2y.inc da_transpose_y2z.inc da_transpose_x2z.inc da_transpose_z2x.inc da_transpose_y2x.inc da_transpose_x2y.inc da_unpack_count_obs.inc da_pack_count_obs.inc da_copy_tile_dims.inc da_copy_dims.inc da_alloc_and_copy_be_arrays.inc da_vv_to_cv.inc da_cv_to_vv.inc da_generic_typedefs.inc da_wrf_interfaces.o da_tracing.o da_reporting.o da_define_structures.o da_par_util1.o module_dm.o module_domain.o da_control.o da_par_util1.o : da_par_util1.f90 da_proc_sum_real.inc da_proc_sum_ints.inc da_proc_sum_int.inc da_control.o da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o @@ -146,14 +146,14 @@ da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_netcdf4ahi_geocat.inc da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o -da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o +da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_transform_through_rf_inv.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_recursive_filter_1d_inv.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_reporting.o : da_reporting.f90 da_message2.inc da_message.inc da_warning.inc da_error.inc da_control.o da_rf_cv3.o : da_rf_cv3.f90 da_mat_cv3.o da_rfz_cv3.o : da_rfz_cv3.f90 da_rsl_interfaces.o : da_rsl_interfaces.f90 da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o da_satem.o : da_satem.f90 da_calculate_grady_satem.inc da_get_innov_vector_satem.inc da_check_max_iv_satem.inc da_transform_xtoy_satem_adj.inc da_transform_xtoy_satem.inc da_print_stats_satem.inc da_oi_stats_satem.inc da_residual_satem.inc da_jo_and_grady_satem.inc da_ao_stats_satem.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o -da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_setup_flow_predictors_ep_format2.inc da_setup_flow_predictors_ep_format3.inc da_get_alpha_vertloc.inc +da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_setup_flow_predictors_ep_format2.inc da_setup_flow_predictors_ep_format3.inc da_get_alpha_vertloc.inc da_write_vp.inc da_ships.o : da_ships.f90 da_calculate_grady_ships.inc da_get_innov_vector_ships.inc da_check_max_iv_ships.inc da_transform_xtoy_ships_adj.inc da_transform_xtoy_ships.inc da_print_stats_ships.inc da_oi_stats_ships.inc da_residual_ships.inc da_jo_and_grady_ships.inc da_ao_stats_ships.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_sound.o : da_sound.f90 da_calculate_grady_sonde_sfc.inc da_check_max_iv_sonde_sfc.inc da_get_innov_vector_sonde_sfc.inc da_transform_xtoy_sonde_sfc_adj.inc da_transform_xtoy_sonde_sfc.inc da_print_stats_sonde_sfc.inc da_oi_stats_sonde_sfc.inc da_residual_sonde_sfc.inc da_jo_sonde_sfc_uvtq.inc da_jo_and_grady_sonde_sfc.inc da_ao_stats_sonde_sfc.inc da_check_buddy_sound.inc da_calculate_grady_sound.inc da_get_innov_vector_sound.inc da_check_max_iv_sound.inc da_transform_xtoy_sound_adj.inc da_transform_xtoy_sound.inc da_print_stats_sound.inc da_oi_stats_sound.inc da_residual_sound.inc da_jo_sound_uvtq.inc da_jo_and_grady_sound.inc da_ao_stats_sound.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_spectral.o : da_spectral.f90 da_apply_power.inc da_legtra_inv_adj.inc da_vtovv_spectral_adj.inc da_vv_to_v_spectral.inc da_vtovv_spectral.inc da_test_spectral.inc da_setlegpol.inc da_setlegpol_test.inc da_legtra.inc da_legtra_inv.inc da_initialize_h.inc da_get_reglats.inc da_get_gausslats.inc da_calc_power_spectrum.inc da_asslegpol.inc da_tracing.o da_tools_serial.o da_reporting.o da_par_util1.o da_define_structures.o da_control.o @@ -182,7 +182,7 @@ da_verif_tools.o : da_verif_tools.f90 da_verif_obs_control.o : da_verif_obs_control.f90 da_verif_obs_init.o : da_verif_obs_init.f90 da_verif_obs_control.o -da_vtox_transforms.o : da_vtox_transforms.f90 da_apply_be_adj.inc da_apply_be.inc da_transform_bal_adj.inc da_transform_bal.inc da_transform_vtovv_global_adj.inc da_transform_vtovv_global.inc da_get_aspoles.inc da_get_avpoles.inc da_get_spoles.inc da_get_vpoles.inc da_vertical_transform.inc da_transform_vptovv.inc da_transform_vvtovp_adj.inc da_transform_vvtovp.inc da_transform_vptox_adj.inc da_transform_vptox.inc da_transform_xtoxa_adj.inc da_transform_vtox_adj.inc da_transform_xtoxa.inc da_transform_vtox.inc da_transform_rescale.inc da_transform_vtovv_adj.inc da_transform_vtovv.inc da_check_eof_decomposition.inc da_add_flow_dependence_xa_adj.inc da_add_flow_dependence_xa.inc da_add_flow_dependence_vp_adj.inc da_add_flow_dependence_vp.inc da_transform_vvtovp_dual_res.inc da_transform_vvtovp_adj_dual_res.inc da_wavelet.o da_wrf_interfaces.o da_tracing.o da_tools.o da_ssmi.o da_spectral.o da_reporting.o da_recursive_filter.o da_par_util.o da_physics.o da_dynamics.o da_define_structures.o da_control.o module_domain.o module_comm_dm.o module_dm.o interp_fcn.o da_copy_xa.inc da_add_xa.inc da_calc_flow_dependence_xa_adj.inc da_calc_flow_dependence_xa.inc da_calc_flow_dependence_xa_dual_res.inc da_calc_flow_dependence_xa_adj_dual_res.inc da_transform_vpatox.inc da_transform_vpatox_adj.inc da_dual_res_c2n_ad.inc +da_vtox_transforms.o : da_vtox_transforms.f90 da_apply_be_adj.inc da_apply_be.inc da_transform_bal_adj.inc da_transform_bal.inc da_transform_vtovv_global_adj.inc da_transform_vtovv_global.inc da_get_aspoles.inc da_get_avpoles.inc da_get_spoles.inc da_get_vpoles.inc da_vertical_transform.inc da_transform_vptovv.inc da_transform_vvtovp_adj.inc da_transform_vvtovp.inc da_transform_vptox_adj.inc da_transform_vptox.inc da_transform_xtoxa_adj.inc da_transform_vtox_adj.inc da_transform_xtoxa.inc da_transform_vtox.inc da_transform_rescale.inc da_transform_vtovv_adj.inc da_transform_vtovv.inc da_check_eof_decomposition.inc da_add_flow_dependence_xa_adj.inc da_add_flow_dependence_xa.inc da_add_flow_dependence_vp_adj.inc da_add_flow_dependence_vp.inc da_transform_vvtovp_dual_res.inc da_transform_vvtovp_adj_dual_res.inc da_wavelet.o da_wrf_interfaces.o da_tracing.o da_tools.o da_ssmi.o da_spectral.o da_reporting.o da_recursive_filter.o da_par_util.o da_physics.o da_dynamics.o da_define_structures.o da_control.o module_domain.o module_comm_dm.o module_dm.o interp_fcn.o da_copy_xa.inc da_add_xa.inc da_calc_flow_dependence_xa_adj.inc da_calc_flow_dependence_xa.inc da_calc_flow_dependence_xa_dual_res.inc da_calc_flow_dependence_xa_adj_dual_res.inc da_transform_vpatox.inc da_transform_vpatox_adj.inc da_dual_res_c2n_ad.inc da_transform_vvtovp_inv.inc da_transform_vptox_inv.inc da_transform_vtox_inv.inc da_transform_vtovv_inv.inc diff --git a/var/da/da_main/da_solve.inc b/var/da/da_main/da_solve.inc index 65cb69669e..f0a74ecd97 100644 --- a/var/da/da_main/da_solve.inc +++ b/var/da/da_main/da_solve.inc @@ -45,6 +45,8 @@ type(x_type) :: shuffle real, allocatable :: grid_box_area(:,:), mapfac(:,:) + real, allocatable :: v1(:,:,:),v2(:,:,:),v3(:,:,:),v4(:,:,:),v5(:,:,:) + real, allocatable :: v6(:,:,:),v7(:,:,:),v8(:,:,:),v9(:,:,:),v10(:,:,:),v11(:,:,:) character (len=10) :: variable_name integer :: iwin, num_subtwindow @@ -53,8 +55,9 @@ real, external :: nest_loc_of_cg ! from share/interp_fcn.F integer, external :: compute_CGLL ! from share/interp_fcn.F - integer :: cvt_unit, iost - character(len=8) :: cvtfile + integer :: vp_unit, iost + character(len=13) :: vpfile ! vp_input.0001 + integer :: i1,i2,i3,i4,i5,i6 logical :: ex character(len=10) :: this_time @@ -630,42 +633,135 @@ ! Done with randomcv. ! Set the following to skip some code to get to the deallocation part. max_ext_its = 0 - outer_loop_restart = .false. end if !anal_type_randomcv - if ( outer_loop_restart ) then - !call da_get_unit(cvt_unit) - cvt_unit=600 +! mri-4dvar: if multi_inc /= 2: run normal 3D/4D-Var +!------------------------------------------------------------------------ + ! cvt is outer loop control variable, it is zero for the first outer loop, + ! but non-zero from the second outer loop in normal 3d/4dvar. + ! for MRI-4DVar, vp from the previous outer loop needs to be read in, + ! then perform the inverse transform to derive cvt + !----------------------------------------------------- + call da_initialize_cv (cv_size, cvt) + call da_zero_vp_type (grid%vp) + call da_zero_vp_type (grid%vv) + + if ( multi_inc == 2 ) then if ( max_ext_its > 1 ) then max_ext_its=1 - write(unit=message(1),fmt='(a)') "Re-set max_ext_its = 1 for outer_loop_restart" + write(unit=message(1),fmt='(a)') "Re-set max_ext_its = 1 for multi_inc==2" call da_message(message(1:1)) end if - write(unit=cvtfile,fmt='(a,i4.4)') 'cvt_',myproc - inquire(file=trim(cvtfile), exist=ex) + + ! read vp files for different PEs + !---------------------------------- + write(unit=vpfile,fmt='(a,i4.4)') 'vp_input.',myproc + inquire(file=trim(vpfile), exist=ex) if ( ex ) then - open(unit=cvt_unit,file=trim(cvtfile),iostat=iost,form='UNFORMATTED',status='OLD') + call da_get_unit(vp_unit) + open(unit=vp_unit,file=trim(vpfile),iostat=iost,form='UNFORMATTED',status='OLD') if (iost /= 0) then write(unit=message(1),fmt='(A,I5,A)') & - "Error ",iost," opening cvt file "//trim(cvtfile) + "Error ",iost," opening vp file "//trim(vpfile) call da_error(__FILE__,__LINE__,message(1:1)) end if - write(unit=message(1),fmt='(a)') 'Reading cvt from : '//trim(cvtfile) + if ( use_interpolate_cvt ) then ! works for CV3?, 3D RF + write(unit=message(1),fmt='(a)') 'Reading vv from : '//trim(vpfile) + elseif ( use_inverse_squarerootb ) then ! works for CV5,6,7, vertical EOF + write(unit=message(1),fmt='(a)') 'Reading vp from : '//trim(vpfile) + end if call da_message(message(1:1)) - read(cvt_unit) cvt - close(cvt_unit) + read(vp_unit) i1, i2, i3, i4, i5, i6 ! read dimension of patch for current processor + allocate( v1(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v2(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v3(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v4(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v5(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + if ( cloud_cv_options >= 2 ) then + allocate( v6(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v7(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v8(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v9(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + allocate( v10(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + end if + if ( use_cv_w ) allocate( v11(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) ) + + read(vp_unit) v1, v2, v3, v4, v5 + if ( cloud_cv_options >= 2 ) read(vp_unit) v6, v7, v8, v9, v10 + if ( use_cv_w ) read(vp_unit) v11 + + if ( use_interpolate_cvt ) then + grid%vv%v1(ips:ipe,jps:jpe,kps:kpe) = v1(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v2(ips:ipe,jps:jpe,kps:kpe) = v2(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v3(ips:ipe,jps:jpe,kps:kpe) = v3(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v4(ips:ipe,jps:jpe,kps:kpe) = v4(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v5(ips:ipe,jps:jpe,kps:kpe) = v5(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + if ( cloud_cv_options >= 2 ) then + grid%vv%v6(ips:ipe,jps:jpe,kps:kpe) = v6(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v7(ips:ipe,jps:jpe,kps:kpe) = v7(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v8(ips:ipe,jps:jpe,kps:kpe) = v8(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v9(ips:ipe,jps:jpe,kps:kpe) = v9(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vv%v10(ips:ipe,jps:jpe,kps:kpe) = v10(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + end if + if ( use_cv_w ) then + grid%vv%v11(ips:ipe,jps:jpe,kps:kpe) = v11(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + end if + call da_vv_to_cv( grid%vv, grid%xp, be%cv_mz, be%ncv_mz, cv_size, cvt ) + elseif ( use_inverse_squarerootb ) then + grid%vp%v1(ips:ipe,jps:jpe,kps:kpe) = v1(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v2(ips:ipe,jps:jpe,kps:kpe) = v2(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v3(ips:ipe,jps:jpe,kps:kpe) = v3(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v4(ips:ipe,jps:jpe,kps:kpe) = v4(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v5(ips:ipe,jps:jpe,kps:kpe) = v5(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + if ( cloud_cv_options >= 2 ) then + grid%vp%v6(ips:ipe,jps:jpe,kps:kpe) = v6(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v7(ips:ipe,jps:jpe,kps:kpe) = v7(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v8(ips:ipe,jps:jpe,kps:kpe) = v8(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v9(ips:ipe,jps:jpe,kps:kpe) = v9(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + grid%vp%v10(ips:ipe,jps:jpe,kps:kpe) = v10(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + end if + if ( use_cv_w ) then ! vertical stagging +1? + grid%vp%v11(ips:ipe,jps:jpe,kps:kpe) = v11(1:i2-i1+1, 1:i4-i3+1, 1:i6-i5+1) + end if + !call da_write_vp(grid,grid%vp,'vp_input.global ') ! to verify correctness + print '(/10X,"===> Use inverse transform of square-root B for outer-loop=",i2)', it + if ( cv_options == 3 ) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error: inverse U transform not for cv_options = 3" + call da_error(__FILE__,__LINE__,message(1:1)) + end if + call da_transform_vtox_inv (grid,be%cv%size_jb,xbx,be,grid%ep,cvt(1:be%cv%size_jb),grid%vv,grid%vp) + end if + + deallocate( v1 ) + deallocate( v2 ) + deallocate( v3 ) + deallocate( v4 ) + deallocate( v5 ) + if ( cloud_cv_options >= 2 ) then + deallocate( v6 ) + deallocate( v7 ) + deallocate( v8 ) + deallocate( v9 ) + deallocate( v10 ) + end if + if ( use_cv_w ) deallocate( v11 ) + + close(vp_unit) + call da_free_unit(vp_unit) + else - write(unit=message(1),fmt='(a)') "cvt file '"//trim(cvtfile)//"' does not exists, initializing cvt." + write(unit=message(1),fmt='(a)') "vp files '"//trim(vpfile)//"' does not exists, initiallizing cvt." call da_message(message(1:1)) - call da_initialize_cv (cv_size, cvt) + call da_initialize_cv (cv_size, cvt) ! perhaps better use da_error end if - else - call da_initialize_cv (cv_size, cvt) + + call da_zero_vp_type (grid%vv) + call da_zero_vp_type (grid%vp) + end if +! mri-4dvar ------------------------------------------- - call da_zero_vp_type (grid%vv) - call da_zero_vp_type (grid%vp) - if ( var4d ) then #ifdef VAR4D call da_zero_vp_type (grid%vv6) @@ -698,6 +794,24 @@ call da_initialize_cv (cv_size, xhat) +! mri-4dvar---------------------- +! Apply inverse transform of squareroot(B) for full-resolution non-stop Var +! from 2nd outer loop, this is to check correctness of inverse U transform +! does not apply this setting for real world application +!----------------------------- + if (multi_inc == 0 .and. it > 1 .and. use_inverse_squarerootb .and. cv_options /= 3) then + print '(/10X,"===> Use inverse transform of square-root B for outer-loop=",i2)', it + call da_transform_vtox_inv (grid,be%cv%size_jb,xbx,be,grid%ep,cvt(1:be%cv%size_jb),grid%vv,grid%vp) + endif + +! Reinitialize cvt=0 for full-resolution non-stop Var for each loop +!------another option not tested -------------- + if (multi_inc == 0 .and. it > 1 .and. use_interpolate_cvt) then + print '(/10X,"===> Reinitialize cvt as zeros for outer loop ",i2)', it + call da_initialize_cv (cv_size, cvt) + endif +! mri-4dvar------------------------ + ! [8.1] Calculate nonlinear model trajectory ! if (var4d .and. multi_inc /= 2 ) then @@ -869,18 +983,9 @@ ! Update outer-loop control variable cvt = cvt + xhat - if ( outer_loop_restart ) then - open(unit=cvt_unit,status='unknown',file=trim(cvtfile),iostat=iost,form='UNFORMATTED') - if (iost /= 0) then - write(unit=message(1),fmt='(A,I5,A)') & - "Error ",iost," opening cvt file "//trim(cvtfile) - call da_error(__FILE__,__LINE__,message(1:1)) - end if - write(unit=message(1),fmt='(a)') 'Writing cvt to : '//trim(cvtfile) - call da_message(message(1:1)) - write(cvt_unit) cvt - close(cvt_unit) - !call da_free_unit(cvt_unit) + if ( multi_inc == 2 .and. use_interpolate_cvt ) then ! obsolete option + call da_cv_to_vv( cv_size, cvt, be%cv_mz, be%ncv_mz, grid%vv ) + call da_write_vp(grid,grid%vv,'vp_output.global') ! wrtie vv to vp file end if !------------------------------------------------------------------------ @@ -905,6 +1010,13 @@ call da_transform_vtox (grid,be%cv%size_jb,xbx,be,grid%ep,xhat(1:be%cv%size_jb),grid%vv,grid%vp) call da_transform_vpatox (grid,be,grid%ep,grid%vp) endif + +! mri-4dvar-------------------------- + if (multi_inc == 2 .and. use_inverse_squarerootb) then + call da_write_vp(grid,grid%vp,'vp_output.global') ! write vp to vp file + end if +! mri-4dvar-------------------------- + call da_transform_xtoxa (grid) ! [8.6] Only when use_radarobs = .false. and calc_w_increment =.true., @@ -1105,11 +1217,5 @@ if (trace_use) call da_trace_exit ("da_solve") - -contains - -#include "da_solve_init.inc" -#include "da_solve_dual_res_init.inc" - end subroutine da_solve diff --git a/var/da/da_main/da_wrfvar_top.f90 b/var/da/da_main/da_wrfvar_top.f90 index 05b03b966b..6ca3d7560e 100644 --- a/var/da/da_main/da_wrfvar_top.f90 +++ b/var/da/da_main/da_wrfvar_top.f90 @@ -55,7 +55,8 @@ module da_wrfvar_top use da_obs, only : da_transform_xtoy_adj use da_obs_io, only : da_write_filtered_obs, da_write_obs, da_final_write_obs , & da_write_obs_etkf, da_write_modified_filtered_obs - use da_par_util, only : da_system,da_copy_tile_dims,da_copy_dims + use da_par_util, only : da_system,da_copy_tile_dims,da_copy_dims, & + da_vv_to_cv, da_cv_to_vv use da_physics, only : da_uvprho_to_w_lin #if defined (CRTM) || defined (RTTOV) use da_radiance, only : da_deallocate_radiance @@ -65,7 +66,7 @@ module da_wrfvar_top use da_varbc, only : da_varbc_init,da_varbc_update #endif use da_reporting, only : message, da_warning, da_error, da_message - use da_setup_structures, only : da_setup_obs_structures, & + use da_setup_structures, only : da_setup_obs_structures, da_write_vp, & da_setup_background_errors,da_setup_flow_predictors, & da_setup_cv, da_scale_background_errors, da_scale_background_errors_cv3 use da_setup_structures, only : da_setup_flow_predictors_para_read_opt1 @@ -76,7 +77,8 @@ module da_wrfvar_top use da_transfer_model, only : da_transfer_xatoanalysis,da_setup_firstguess, & da_transfer_wrftltoxa_adj use da_vtox_transforms, only : da_transform_vtox, da_transform_xtoxa, & - da_transform_xtoxa_adj, da_copy_xa, da_add_xa, da_transform_vpatox + da_transform_xtoxa_adj, da_copy_xa, da_add_xa, da_transform_vpatox, & + da_transform_vtox_inv use da_wrfvar_io, only : da_med_initialdata_input, da_update_firstguess use da_tools, only : da_set_randomcv, da_get_julian_time @@ -150,5 +152,7 @@ module da_wrfvar_top #include "da_wrfvar_interface.inc" #include "da_wrfvar_finalize.inc" #include "da_solve.inc" +#include "da_solve_init.inc" +#include "da_solve_dual_res_init.inc" end module da_wrfvar_top diff --git a/var/da/da_minimisation/da_get_innov_vector.inc b/var/da/da_minimisation/da_get_innov_vector.inc index 792c3856dd..490167203d 100644 --- a/var/da/da_minimisation/da_get_innov_vector.inc +++ b/var/da/da_minimisation/da_get_innov_vector.inc @@ -2,9 +2,9 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) !----------------------------------------------------------------------- - ! Purpose: TBD - ! Updated for Analysis on Arakawa-C grid - ! Author: Syed RH Rizvi, MMM/ESSL/NCAR, Date: 10/22/2008 + ! Purpose: driver routine for getting innovation vectors + ! History:$ + ! 10/22/2008 - Updated for Analysis on Arakawa-C grid (Syed RH Rizvi, NCAR) !----------------------------------------------------------------------- implicit none @@ -145,7 +145,7 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) call da_get_innov_vector_ssmt2 (it, num_qcstat_conv,grid, ob, iv) if (iv%info(satem)%nlocal > 0) & call da_get_innov_vector_satem (it, num_qcstat_conv,grid, ob, iv) - if (iv%info(radar)%nlocal > 0) & + if (iv%info(radar)%nlocal >= 0 .and. use_radarobs) & call da_get_innov_vector_radar (it, grid, ob, iv) if (iv%info(qscat)%nlocal > 0) & call da_get_innov_vector_qscat (it, num_qcstat_conv,grid, ob, iv) @@ -168,7 +168,7 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) end if if (iv%info(airsr)%nlocal > 0) & call da_get_innov_vector_airsr (it,num_qcstat_conv, grid, ob, iv) - + !---------------------------------------------- ! [5] write out iv in ascii format !----------------------------------------------- @@ -255,6 +255,18 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) call domain_clock_set (grid, time_step_seconds=time_step_seconds) call domain_clockprint(150, grid, 'get CurrTime from clock,') end if +#if defined(CRTM) || defined(RTTOV) + !---------------------------------------------- + ! write out or read in radiance iv for multi in binary format + !----------------------------------------------- + if (use_rad) then + if ( multi_inc == 1 ) then + call da_write_iv_rad_for_multi_inc(it,ob,iv) + elseif ( multi_inc == 2 ) then + call da_read_iv_rad_for_multi_inc(it,ob,iv) + end if + end if +#endif if ( multi_inc == 1 ) then #ifdef DM_PARALLEL diff --git a/var/da/da_minimisation/da_minimisation.f90 b/var/da/da_minimisation/da_minimisation.f90 index 248cc5906e..55d89a14c4 100644 --- a/var/da/da_minimisation/da_minimisation.f90 +++ b/var/da/da_minimisation/da_minimisation.f90 @@ -54,7 +54,7 @@ module da_minimisation use_satcv, sensitivity_option, print_detail_outerloop, adj_sens, filename_len, & ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe, fgat_rain_flags, var4d_bin_rain, freeze_varbc, & use_wpec, wpec_factor, use_4denvar, anal_type_hybrid_dual_res, alphacv_method, alphacv_method_xa, & - write_detail_grad_fn, pseudo_uvtpq, lanczos_ep_filename, use_divc, divc_factor, & + write_detail_grad_fn, pseudo_uvtpq, lanczos_ep_filename, use_divc, divc_factor, use_radarobs, & cloud_cv_options, use_cv_w, var_scaling6, var_scaling7, var_scaling8, var_scaling9, & var_scaling10, var_scaling11, & write_gts_omb_oma, write_unpert_obs, write_rej_obs_conv, pseudo_time, & @@ -121,6 +121,7 @@ module da_minimisation da_get_innov_vector_radiance, satinfo use da_radiance1, only : da_ao_stats_rad,da_oi_stats_rad, & da_write_iv_rad_ascii,da_residual_rad,da_jo_and_grady_rad, & + da_write_iv_rad_for_multi_inc,da_read_iv_rad_for_multi_inc, & da_biasprep, da_qc_rad #endif use da_radar, only : da_calculate_grady_radar, da_ao_stats_radar, & diff --git a/var/da/da_obs_io/da_obs_io.f90 b/var/da/da_obs_io/da_obs_io.f90 index 7d4a0ef68f..e9b0d2e99a 100644 --- a/var/da/da_obs_io/da_obs_io.f90 +++ b/var/da/da_obs_io/da_obs_io.f90 @@ -32,7 +32,7 @@ module da_obs_io thin_conv, thin_conv_ascii, lsac_nh_step, lsac_nv_step, lsac_nv_start, lsac_print_details, & lsac_use_u, lsac_use_v, lsac_use_t, lsac_use_q, lsac_u_error, lsac_v_error, lsac_t_error, lsac_q_error, & gpsro_drift, max_gpseph_input, use_gpsephobs, gpseph, gpseph_loadbalance, kds, kde, kts, kte, & - use_radar_rhv, use_radar_rqv + use_radar_rhv, use_radar_rqv, use_radar_rf, use_radar_rv, multi_inc use da_wrf_interfaces, only : wrf_dm_bcast_integer, wrf_dm_bcast_real use da_define_structures, only : iv_type, multi_level_type, multi_level_type_BUFR, & diff --git a/var/da/da_obs_io/da_read_iv_for_multi_inc.inc b/var/da/da_obs_io/da_read_iv_for_multi_inc.inc index d15162d110..f2ad1bd4b4 100644 --- a/var/da/da_obs_io/da_read_iv_for_multi_inc.inc +++ b/var/da/da_obs_io/da_read_iv_for_multi_inc.inc @@ -21,6 +21,12 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) integer :: n, gn logical :: found_flag + integer :: nobs_tot, nlev_max, k , iobs + integer :: nobs_in, nlev_in + logical :: has_rv, has_rf, has_rhv, has_rqv + real, allocatable :: data2d(:,:) + real, allocatable :: data3d(:,:,:) + if (trace_use) call da_trace_entry("da_read_iv_for_multi_inc") !------------------------------------------------------------------------- @@ -63,7 +69,6 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) ! [2] metar obs: if (iv%info(metar)%plocal(iv%time)-iv%info(metar)%plocal(iv%time-1) > 0) then - open(unit=unit_in,file=trim(filename)//'.metar',form='formatted',status='old',iostat=ios) if (ios /= 0) Then call da_error(__FILE__,__LINE__, & @@ -266,7 +271,6 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) ! [9] buoy obs: if (iv%info(buoy)%plocal(iv%time)-iv%info(buoy)%plocal(iv%time-1) > 0) then - open(unit=unit_in,file=trim(filename)//'.buoy',form='formatted',status='old',iostat=ios) if (ios /= 0) Then call da_error(__FILE__,__LINE__, & @@ -499,7 +503,6 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) ! [17] satem obs: if (iv%info(satem)%plocal(iv%time)-iv%info(satem)%plocal(iv%time-1) > 0) then - open(unit=unit_in,file=trim(filename)//'.satem',form='formatted',status='old',iostat=ios) if (ios /= 0) Then call da_error(__FILE__,__LINE__, & @@ -586,7 +589,6 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) ! [20] scatterometer obs: if (iv%info(qscat)%plocal(iv%time)-iv%info(qscat)%plocal(iv%time-1) > 0) then - open(unit=unit_in,file=trim(filename)//'.qscat',form='formatted',status='old',iostat=ios) if (ios /= 0) Then call da_error(__FILE__,__LINE__, & @@ -731,33 +733,96 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) ! [25] radar obs: - if (iv%info(radar)%plocal(iv%time)-iv%info(radar)%plocal(iv%time-1) > 0) then - - open(unit=unit_in,file=trim(filename)//'.radar',form='formatted',status='old',iostat=ios) - if (ios /= 0) Then - call da_error(__FILE__,__LINE__, & - (/"Cannot open file"//filename/)) - end if - - read(unit_in,'(a20,i8)', end = 999, err = 1000) ob_type_string,num_obs - if ( trim(adjustl(ob_type_string)) .ne. 'radar' ) & - call da_error(__FILE__,__LINE__, & - (/"Cannot find radar marker. "/)) - gn = 0 - do n = iv%info(radar)%plocal(iv%time-1) + 1, & - iv%info(radar)%plocal(iv%time) - call da_search_obs (ob_type_string, unit_in, num_obs, n, iv, found_flag) - if (found_flag .eqv. .false.) & - call da_error(__FILE__,__LINE__, & - (/"Cannot find radar obs. "/)) - gn = gn + 1 - end do - if (gn /= iv%info(radar)%plocal(iv%time)-iv%info(radar)%plocal(iv%time-1)) & - call da_error(__FILE__,__LINE__, & - (/"Unequal obs. found "/)) - close (unit_in) - end if - + nobs_tot = iv%info(radar)%ptotal(num_fgat_time) - iv%info(radar)%ptotal(0) + nlev_max = iv%info(radar)%max_lev + + if ( nobs_tot > 0 ) then + + write(unit=filename, fmt='(a,i3.3)') 'radar_innov_t', file_index + open(unit=unit_in,file=trim(filename),form='unformatted',status='old',iostat=ios) + if (ios /= 0) Then + call da_error(__FILE__,__LINE__, & + (/"Cannot open file "//trim(filename)/)) + end if + + read(unit_in) nobs_in, nlev_in, has_rv, has_rf, has_rhv, has_rqv + if ( nobs_in /= nobs_tot .or. nlev_in /= nlev_max ) then + call da_error(__FILE__,__LINE__, & + (/"Dimensions (nobs_tot or nlev_max) mismatch "/)) + end if + allocate ( data2d(nobs_tot, 2) ) + read(unit_in) data2d + do n = iv%info(radar)%n1, iv%info(radar)%n2 + iobs = iv%info(radar)%obs_global_index(n) +! iv%info(radar)%lat(1,n) = data2d(iobs, 1) +! iv%info(radar)%lon(1,n) = data2d(iobs, 2) + end do + deallocate ( data2d ) + + if ( use_radar_rv .and. has_rv ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + read(unit_in) data3d + do n = iv%info(radar)%n1, iv%info(radar)%n2 + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + iv%radar(n)%rv(k)%inv = data3d(iobs, k, 1) + iv%radar(n)%rv(k)%qc = int(data3d(iobs, k, 2)) + iv%radar(n)%rv(k)%error = data3d(iobs, k, 3) + end do + end do + deallocate( data3d ) + end if + + if ( use_radar_rf .and. has_rf ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + read(unit_in) data3d + do n = iv%info(radar)%n1, iv%info(radar)%n2 + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + iv%radar(n)%rf(k)%inv = data3d(iobs, k, 1) + iv%radar(n)%rf(k)%qc = int(data3d(iobs, k, 2)) + iv%radar(n)%rf(k)%error = data3d(iobs, k, 3) + end do + end do + deallocate( data3d ) + end if + + if ( use_radar_rhv .and. has_rhv ) then + allocate( data3d(nobs_tot, nlev_max, 9) ) + read(unit_in) data3d + do n = iv%info(radar)%n1, iv%info(radar)%n2 + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + iv%radar(n)%rrn(k)%inv = data3d(iobs, k, 1) + iv%radar(n)%rrn(k)%qc = int(data3d(iobs, k, 2)) + iv%radar(n)%rrn(k)%error = data3d(iobs, k, 3) + iv%radar(n)%rsn(k)%inv = data3d(iobs, k, 4) + iv%radar(n)%rsn(k)%qc = int(data3d(iobs, k, 5)) + iv%radar(n)%rsn(k)%error = data3d(iobs, k, 6) + iv%radar(n)%rgr(k)%inv = data3d(iobs, k, 7) + iv%radar(n)%rgr(k)%qc = int(data3d(iobs, k, 8)) + iv%radar(n)%rgr(k)%error = data3d(iobs, k, 9) + end do + end do + deallocate( data3d ) + end if + + if ( use_radar_rqv .and. has_rqv ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + read(unit_in) data3d + do n = iv%info(radar)%n1, iv%info(radar)%n2 + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + iv%radar(n)%rqv(k)%inv = data3d(iobs, k, 1) + iv%radar(n)%rqv(k)%qc = int(data3d(iobs, k, 2)) + iv%radar(n)%rqv(k)%error = data3d(iobs, k, 3) + end do + end do + deallocate( data3d ) + end if + + close (unit_in) + end if ! nobs_tot > 0 999 continue close (unit_in) diff --git a/var/da/da_obs_io/da_read_obs_radar.inc b/var/da/da_obs_io/da_read_obs_radar.inc index b2f7679a6f..e968e09554 100644 --- a/var/da/da_obs_io/da_read_obs_radar.inc +++ b/var/da/da_obs_io/da_read_obs_radar.inc @@ -219,7 +219,7 @@ subroutine da_read_obs_radar (iv, filename, grid) endif call da_llxy (platform%info, platform%loc, outside, outside_all) - if( outside_all ) then + if( outside_all .and. multi_inc == 0 ) then if (print_detail_radar) then write(unit=stdout, fmt='(a)') '*** Report is outside of domain:' write(unit=stdout, fmt='(2x,a,2(2x,f8.3),2x,a)') & diff --git a/var/da/da_obs_io/da_scan_obs_radar.inc b/var/da/da_obs_io/da_scan_obs_radar.inc index 5d30072dc8..f665c801ca 100644 --- a/var/da/da_obs_io/da_scan_obs_radar.inc +++ b/var/da/da_obs_io/da_scan_obs_radar.inc @@ -194,7 +194,7 @@ subroutine da_scan_obs_radar (iv, filename, grid) endif call da_llxy (platform%info, platform%loc, outside, outside_all) - if( outside_all ) cycle reports + if( outside_all .and. multi_inc == 0 ) cycle reports nlevels = platform%info%levels diff --git a/var/da/da_obs_io/da_search_obs.inc b/var/da/da_obs_io/da_search_obs.inc index 89d47b08f0..b664655497 100644 --- a/var/da/da_obs_io/da_search_obs.inc +++ b/var/da/da_obs_io/da_search_obs.inc @@ -359,7 +359,9 @@ subroutine da_search_obs (ob_type_string, unit_in, num_obs, nth, iv, found_flag) if (trace_use) call da_trace_exit("da_search_obs") return else - read(unit_in,*) + do k = 1, levels + read(unit_in,*) + enddo endif enddo !found_flag = .false. diff --git a/var/da/da_obs_io/da_write_iv_for_multi_inc.inc b/var/da/da_obs_io/da_write_iv_for_multi_inc.inc index 3fcde8bfe6..1d359c7f5f 100644 --- a/var/da/da_obs_io/da_write_iv_for_multi_inc.inc +++ b/var/da/da_obs_io/da_write_iv_for_multi_inc.inc @@ -13,6 +13,12 @@ subroutine da_write_iv_for_multi_inc(file_index, iv) integer :: ounit ! Output unit character(len=filename_len) :: filename + integer :: nobs_tot, nlev_max, iobs + real, allocatable :: data2d(:,:) + real, allocatable :: data3d(:,:,:) + real, allocatable :: data2d_g(:,:) + real, allocatable :: data3d_g(:,:,:) + if (trace_use) call da_trace_entry("da_write_iv_for_multi_inc") !------------------------------------------------------------------------- @@ -736,33 +742,153 @@ subroutine da_write_iv_for_multi_inc(file_index, iv) ! [25] radar obs: - if (iv%info(radar)%plocal(iv%time) - iv%info(radar)%plocal(iv%time-1) > 0) then + nobs_tot = iv%info(radar)%ptotal(num_fgat_time) - iv%info(radar)%ptotal(0) + nlev_max = iv%info(radar)%max_lev + + if ( nobs_tot > 0 ) then + if ( rootproc ) then + write(unit=filename, fmt='(a,i3.3,a)') 'radar_innov_t', file_index + open (unit=ounit,file=trim(filename),form='unformatted', & + status='replace', iostat=ios) + if (ios /= 0) then + call da_error(__FILE__,__LINE__, & + (/"Cannot open file "//trim(filename)/)) + end if + write(ounit) nobs_tot, nlev_max, use_radar_rv, use_radar_rf, use_radar_rhv, use_radar_rqv + end if ! root open ounit + + allocate( data2d(nobs_tot, 2) ) + data2d = 0.0 + do n = iv%info(radar)%n1, iv%info(radar)%n2 + if ( .not. iv%info(radar)%proc_domain(1,n) ) cycle + iobs = iv%info(radar)%obs_global_index(n) + data2d(iobs, 1) = iv%info(radar)%lat(1,n) + data2d(iobs, 2) = iv%info(radar)%lon(1,n) + end do - open (unit=ounit,file=trim(filename)//'.radar',form='formatted',status='replace', & - iostat=ios) - if (ios /= 0) then - call da_error(__FILE__,__LINE__, & - (/"Cannot open conventional observation omb file"//filename/)) + allocate( data2d_g(nobs_tot, 2) ) +#ifdef DM_PARALLEL + call mpi_reduce(data2d, data2d_g, nobs_tot*2, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data2d_g = data2d +#endif + deallocate( data2d ) + if ( rootproc ) then + write(ounit) data2d_g + end if + deallocate( data2d_g ) + + if ( use_radar_rv ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + data3d = 0.0 + do n = iv%info(radar)%n1, iv%info(radar)%n2 + if ( .not. iv%info(radar)%proc_domain(1,n) ) cycle + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + data3d(iobs, k, 1) = iv%radar(n)%rv(k)%inv + data3d(iobs, k, 2) = iv%radar(n)%rv(k)%qc * 1.0 !int to real + data3d(iobs, k, 3) = iv%radar(n)%rv(k)%error + end do + end do + allocate( data3d_g(nobs_tot, nlev_max, 3) ) +#ifdef DM_PARALLEL + call mpi_reduce(data3d, data3d_g, nobs_tot*nlev_max*3, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data3d_g = data3d +#endif + deallocate( data3d ) + if ( rootproc ) then + write(ounit) data3d_g + end if + deallocate( data3d_g ) + end if ! use_radar_rv + + if ( use_radar_rf ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + data3d = 0.0 + do n = iv%info(radar)%n1, iv%info(radar)%n2 + if ( .not. iv%info(radar)%proc_domain(1,n) ) cycle + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + data3d(iobs, k, 1) = iv%radar(n)%rf(k)%inv + data3d(iobs, k, 2) = iv%radar(n)%rf(k)%qc * 1.0 !int to real + data3d(iobs, k, 3) = iv%radar(n)%rf(k)%error + end do + end do + allocate( data3d_g(nobs_tot, nlev_max, 3) ) +#ifdef DM_PARALLEL + call mpi_reduce(data3d, data3d_g, nobs_tot*nlev_max*3, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data3d_g = data3d +#endif + deallocate( data3d ) + if ( rootproc ) then + write(ounit) data3d_g + end if + deallocate( data3d_g ) + end if ! use_radar_rf + + if ( use_radar_rhv ) then + allocate( data3d(nobs_tot, nlev_max, 9) ) + data3d = 0.0 + do n = iv%info(radar)%n1, iv%info(radar)%n2 + if ( .not. iv%info(radar)%proc_domain(1,n) ) cycle + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + data3d(iobs, k, 1) = iv%radar(n)%rrn(k)%inv + data3d(iobs, k, 2) = iv%radar(n)%rrn(k)%qc * 1.0 !int to real + data3d(iobs, k, 3) = iv%radar(n)%rrn(k)%error + data3d(iobs, k, 4) = iv%radar(n)%rsn(k)%inv + data3d(iobs, k, 5) = iv%radar(n)%rsn(k)%qc * 1.0 !int to real + data3d(iobs, k, 6) = iv%radar(n)%rsn(k)%error + data3d(iobs, k, 7) = iv%radar(n)%rgr(k)%inv + data3d(iobs, k, 8) = iv%radar(n)%rgr(k)%qc * 1.0 !int to real + data3d(iobs, k, 9) = iv%radar(n)%rgr(k)%error + end do + end do + allocate( data3d_g(nobs_tot, nlev_max, 9) ) +#ifdef DM_PARALLEL + call mpi_reduce(data3d, data3d_g, nobs_tot*nlev_max*9, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data3d_g = data3d +#endif + deallocate( data3d ) + if ( rootproc ) then + write(ounit) data3d_g + end if + deallocate( data3d_g ) end if - write(ounit,'(a20,i8)')'radar', iv%info(radar)%plocal(iv%time) - & - iv%info(radar)%plocal(iv%time-1) - do n = iv%info(radar)%plocal(iv%time-1) + 1, & - iv%info(radar)%plocal(iv%time) - write(ounit,'(2i8,2E22.13)')& - n, iv%info(radar)%levels(n), & - iv%info(radar)%lat(1,n), & ! Latitude - iv%info(radar)%lon(1,n) ! Longitude - do k = 1 , iv%info(radar)%levels(n) - write(ounit,'(E22.13,i8,3E22.13)')& - iv%radar(n)%rv(k) ! radar_rv - - enddo - end do - close (ounit) - end if - + if ( use_radar_rqv ) then + allocate( data3d(nobs_tot, nlev_max, 3) ) + data3d = 0.0 + do n = iv%info(radar)%n1, iv%info(radar)%n2 + if ( .not. iv%info(radar)%proc_domain(1,n) ) cycle + iobs = iv%info(radar)%obs_global_index(n) + do k = 1 , iv%info(radar)%levels(n) + data3d(iobs, k, 1) = iv%radar(n)%rqv(k)%inv + data3d(iobs, k, 2) = iv%radar(n)%rqv(k)%qc * 1.0 !int to real + data3d(iobs, k, 3) = iv%radar(n)%rqv(k)%error + end do + end do + allocate( data3d_g(nobs_tot, nlev_max, 3) ) +#ifdef DM_PARALLEL + call mpi_reduce(data3d, data3d_g, nobs_tot*nlev_max*3, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data3d_g = data3d +#endif + deallocate( data3d ) + if ( rootproc ) then + write(ounit) data3d_g + end if + deallocate( data3d_g ) + end if ! use_radar_rqv + + if ( rootproc ) then + close(ounit) + end if + end if ! nobs_tot > 0 !------------------------------------------------------------------------------- diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 441752d34d..e7ae1d0a22 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -42,6 +42,11 @@ module da_radiance1 use da_tracing, only : da_trace #endif +#ifdef DM_PARALLEL + use da_control, only : ierr,comm,root + use da_par_util1, only : true_mpi_real, mpi_sum,mpi_integer +#endif + implicit none type datalink_type @@ -243,6 +248,8 @@ module da_radiance1 #include "da_qc_ahi.inc" #include "da_qc_goesimg.inc" #include "da_write_iv_rad_ascii.inc" +#include "da_write_iv_rad_for_multi_inc.inc" +#include "da_read_iv_rad_for_multi_inc.inc" #include "da_write_oa_rad_ascii.inc" #include "da_detsurtyp.inc" #include "da_cld_eff_radius.inc" diff --git a/var/da/da_radiance/da_read_iv_rad_for_multi_inc.inc b/var/da/da_radiance/da_read_iv_rad_for_multi_inc.inc new file mode 100644 index 0000000000..90d9b2067f --- /dev/null +++ b/var/da/da_radiance/da_read_iv_rad_for_multi_inc.inc @@ -0,0 +1,121 @@ +subroutine da_read_iv_rad_for_multi_inc (it, ob, iv ) + + !--------------------------------------------------------------------------- + ! Purpose: read in innovation vector structure for radiance data. + !--------------------------------------------------------------------------- + + implicit none + + integer , intent(in) :: it ! outer loop count + type (y_type), intent(in) :: ob ! Observation structure. + type (iv_type), intent(inout) :: iv ! O-B structure. + + integer :: n ! Loop counter. + integer :: i, k, l, m, my,nobs_tot,nobs_in,iobs ! Index dimension. + + integer :: ios, innov_rad_unit_in + character(len=filename_len) :: filename + integer :: ndomain + logical :: amsr2,fexist + real, allocatable :: data2d(:,:) + real, allocatable :: data3d(:,:,:) + real, allocatable :: data2d_g(:,:) + real, allocatable :: data3d_g(:,:,:) + integer :: ndomain_local,ndomain_sum + integer, allocatable :: ndomain_global(:) + + real, allocatable :: lat(:),lon(:) + + if (trace_use) call da_trace_entry("da_read_iv_rad_for_multi_inc") + + write(unit=message(1),fmt='(A)') 'Reading binary radiance OMB for MRI-4DVar' + call da_message(message(1:1)) + +!no thinning for coarse res.(setup in namelist), keep all the obs: + do i = 1, iv%num_inst + amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 !jban 2020-08-22 + + nobs_tot = iv%info(radiance)%ptotal(num_fgat_time) - iv%info(radiance)%ptotal(0) + + do m=num_fgat_time,1,-1 + + iv%instid(i)%info%n1 = iv%instid(i)%info%plocal(m-1) + 1 + iv%instid(i)%info%n2 = iv%instid(i)%info%plocal(m) + ndomain_local = 0 + do n = iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) then + ndomain_local = ndomain_local + 1 + iv%instid(i)%tb_qc(:,n) = -1 + end if + end do + +#ifdef DM_PARALLEL + ! gather each tile's number of obs at one time slot into a global array + ! and distribute combined 'ndomain_global' to all processors + allocate (ndomain_global(0:num_procs-1)) + call mpi_allgather( ndomain_local, 1, mpi_integer, & + ndomain_global, 1, mpi_integer, comm, ierr ) + ndomain_sum = sum(ndomain_global) ! nobs over the entire domain in a time slot +#else + allocate (ndomain_global(1)) + ndomain_global = ndomain_local + ndomain_sum = sum(ndomain_global) +#endif + + if ( ndomain_sum > 0 ) then + write(unit=filename, fmt='(a,i3.3)') 'inv_'//trim(iv%instid(i)%rttovid_string)//'_',m + call da_get_unit(innov_rad_unit_in) + inquire (file=filename, exist=fexist) + if (.not. fexist) then + exit + else + open(unit=innov_rad_unit_in,file=trim(filename),form='unformatted',status='old',iostat=ios) + if (ios /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Cannot open innovation radiance file"//filename/)) + endif + write(unit=message(1),fmt='(A)') filename + call da_message(message(1:1)) + read(innov_rad_unit_in) nobs_in + + ndomain = 0 + + if ( amsr2 ) then + my=3 + else + my=2 + end if + + allocate( data2d(nobs_in, my) ) + read(innov_rad_unit_in) data2d + + allocate( data3d(nobs_in, iv%instid(i)%nchan, 3) ) + read(innov_rad_unit_in) data3d + + do n = iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) then + do iobs = 1, nobs_in + if (iv%instid(i)%info%lat(1,n)==data2d(iobs, 1) .and. & + iv%instid(i)%info%lon(1,n)==data2d(iobs, 2)) then + iv%instid(i)%tb_inv(:,n) = data3d (iobs,:,1) + iv%instid(i)%tb_error(:,n) = data3d (iobs,:,2) + iv%instid(i)%tb_qc(:,n) = int(data3d (iobs,:,3)) + end if + end do !if + end if !do + end do + + deallocate(data2d) + deallocate(data3d) + + call da_free_unit(innov_rad_unit_in) + end if ! fexist + end if ! ndomain_sum + deallocate(ndomain_global) + end do !num_fgat + end do ! end do instruments + +if (trace_use) call da_trace_exit("da_read_iv_rad_for_multi_inc") + +end subroutine da_read_iv_rad_for_multi_inc + diff --git a/var/da/da_radiance/da_write_iv_rad_for_multi_inc.inc b/var/da/da_radiance/da_write_iv_rad_for_multi_inc.inc new file mode 100644 index 0000000000..eb25f471b5 --- /dev/null +++ b/var/da/da_radiance/da_write_iv_rad_for_multi_inc.inc @@ -0,0 +1,168 @@ +subroutine da_write_iv_rad_for_multi_inc (it,ob, iv ) + + !--------------------------------------------------------------------------- + ! Purpose: write out innovation vector structure for radiance data. + !--------------------------------------------------------------------------- + + implicit none + + integer , intent(in) :: it ! outer loop count + type (y_type), intent(in) :: ob ! Observation structure. + type (iv_type), intent(in) :: iv ! O-B structure. + + integer :: n ! Loop counter. + integer :: i, k, l, m ! Index dimension. + integer :: my,iobs + integer :: ios, innov_rad_unit + character(len=filename_len) :: filename + integer :: ndomain_local,ndomain_sum + logical :: amsr2 + real, allocatable :: data2d(:,:) + real, allocatable :: data3d(:,:,:) + real, allocatable :: data2d_g(:,:) + real, allocatable :: data3d_g(:,:,:) + + integer, allocatable :: ndomain_global(:) + + if (trace_use) call da_trace_entry("da_write_iv_rad_for_multi_inc") + + write(unit=message(1),fmt='(A)') 'Writing radiance OMB binary files for multi_inc' + call da_message(message(1:1)) + + do i = 1, iv%num_inst + + amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + if ( amsr2 ) then ! write out clw + my=3 + else + my=2 + end if + + do m=num_fgat_time,1,-1 + + iv%instid(i)%info%n1 = iv%instid(i)%info%plocal(m-1) + 1 + iv%instid(i)%info%n2 = iv%instid(i)%info%plocal(m) + ndomain_local = 0 + do n = iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) then + ndomain_local = ndomain_local + 1 + end if + end do + +#ifdef DM_PARALLEL + ! gather each tile's number of obs at one time slot into a global array + ! and distribute combined 'ndomain_global' to all processors + allocate (ndomain_global(0:num_procs-1)) + call mpi_allgather( ndomain_local, 1, mpi_integer, & + ndomain_global, 1, mpi_integer, comm, ierr ) + ndomain_sum = sum(ndomain_global) ! nobs over the entire domain in a time slot +#else + allocate (ndomain_global(1)) + ndomain_global = ndomain_local + ndomain_sum = sum(ndomain_global) +#endif + + if ( ndomain_sum > 0 ) then + write(unit=message(1),fmt='(A)') 'Begin to write binary radiance omb file for MRI-4DVar' + call da_message(message(1:1)) + + if (rootproc) then + call da_get_unit(innov_rad_unit) ! one file per time slot + write(unit=filename, fmt='(a,i3.3)') 'inv_'//trim(iv%instid(i)%rttovid_string)//'_',m + + open(unit=innov_rad_unit,file=trim(filename),form='unformatted',status='replace',iostat=ios) + if (ios /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Cannot open innovation radiance file"//filename/)) + endif + write(innov_rad_unit) ndomain_sum + end if ! root open ounit + + allocate( data2d(ndomain_sum, my) ) + data2d = 0.0 + + if (myproc == 0) then ! global index of obs at each processor + iobs = 0 + else + iobs = sum (ndomain_global (0:myproc-1)) + end if + + do n = iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) then + iobs = iobs+1 ! global index + ! fill in global array with each processor's local array + ! note: data2d exists in each processor, initialized with zero + ! so only current processor is filled with non-zero values. + if ( amsr2 ) then ! write out clw + data2d(iobs, 1) = iv%instid(i)%info%lat(1,n) + data2d(iobs, 2) = iv%instid(i)%info%lon(1,n) + data2d(iobs, 3) = iv%instid(i)%clw(n) + else ! no clw info + data2d(iobs, 1) = iv%instid(i)%info%lat(1,n) + data2d(iobs, 2) = iv%instid(i)%info%lon(1,n) + end if + end if + end do !n1,n2 + + write(unit=message(1),fmt='(A)') 'begin to write data2d' + call da_message(message(1:1)) + + allocate( data2d_g(ndomain_sum, my) ) +#ifdef DM_PARALLEL + ! sum of data2d from each processor into rootprocessor's data2d_g (other processors' data2d has zeros) + call mpi_reduce(data2d, data2d_g, ndomain_sum*my, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data2d_g = data2d +#endif + deallocate( data2d ) + + if (rootproc) then + write(innov_rad_unit) data2d_g + end if + deallocate( data2d_g ) + + if (myproc == 0) then + iobs = 0 + else + iobs = sum (ndomain_global (0:myproc-1)) + end if + + allocate( data3d(ndomain_sum, iv%instid(i)%nchan, 3) ) + data3d = 0.0 + do n = iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) then + iobs = iobs + 1 + data3d(iobs,:, 1)=iv%instid(i)%tb_inv(:,n) + data3d(iobs,:, 2)=iv%instid(i)%tb_error(:,n) + data3d(iobs,:, 3)=iv%instid(i)%tb_qc(:,n) * 1.0 + end if + end do + allocate( data3d_g(ndomain_sum, iv%instid(i)%nchan, 3) ) +#ifdef DM_PARALLEL + call mpi_reduce(data3d, data3d_g, ndomain_sum*iv%instid(i)%nchan*3, true_mpi_real, mpi_sum, root, comm, ierr) +#else + data3d_g = data3d +#endif + deallocate( data3d ) + + write(unit=message(1),fmt='(A)') 'begin to write data3d_g' + call da_message(message(1:1)) + + if (rootproc) then + write(innov_rad_unit) data3d_g + end if + deallocate( data3d_g ) + + if (rootproc) then + close(unit=innov_rad_unit) + call da_free_unit(innov_rad_unit) !jban + end if + end if ! ndomain_sum > 0 + deallocate (ndomain_global) + end do !num_fgat + end do ! end do instruments + +if (trace_use) call da_trace_exit("da_write_iv_rad_for_multi_inc") + +end subroutine da_write_iv_rad_for_multi_inc + diff --git a/var/da/da_recursive_filter/da_recursive_filter.f90 b/var/da/da_recursive_filter/da_recursive_filter.f90 index 12798251c6..54eae7ce6f 100644 --- a/var/da/da_recursive_filter/da_recursive_filter.f90 +++ b/var/da/da_recursive_filter/da_recursive_filter.f90 @@ -31,8 +31,10 @@ module da_recursive_filter #include "da_calculate_rf_factors.inc" #include "da_recursive_filter_1d.inc" #include "da_recursive_filter_1d_adj.inc" +#include "da_recursive_filter_1d_inv.inc" #include "da_transform_through_rf.inc" #include "da_transform_through_rf_adj.inc" +#include "da_transform_through_rf_inv.inc" #include "da_apply_rf_1v.inc" #include "da_apply_rf_1v_adj.inc" diff --git a/var/da/da_recursive_filter/da_recursive_filter_1d_inv.inc b/var/da/da_recursive_filter/da_recursive_filter_1d_inv.inc new file mode 100644 index 0000000000..cbc175bb5b --- /dev/null +++ b/var/da/da_recursive_filter/da_recursive_filter_1d_inv.inc @@ -0,0 +1,88 @@ +subroutine da_recursive_filter_1d_inv(pass, alpha, field, n) + + !--------------------------------------------------------------------------- + ! Purpose: Perform one pass of inverse of recursive filter on 1D array. + ! + ! Method: Inverse filter is non-recursive. References: + ! + ! Lorenc, A. (1992), Iterative Analysis Using Covariance Functions and Filters. + ! Q.J.R. Meteorol. Soc., 118: 569-591. Equation (A2) + ! + ! Christopher M. Hayden and R. James Purser, 1995: Recursive Filter Objective Analysis of + ! Meteorological Fields: Applications to NESDIS Operational Processing. + ! J. Appl. Meteor., 34, 3-15. + ! + ! Dale Barker etal., 2004, A 3DVAR data assimilation system for use with MM5, + ! NCAR Tech Note 393. + ! + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + !--------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: pass ! Current pass of filter. + real*8, intent(in) :: alpha ! Alpha coefficient for RF. + real*8, intent(inout) :: field(:) ! Array to be filtered. + integer, intent(in) :: n ! Size of field array. + + integer :: j ! Loop counter. + real :: one_alpha ! 1 - alpha. + real :: a(1:n) ! Input field. + real :: b(1:n) ! Field after left-right pass. + real :: c(1:n) ! Field after right-left pass. + + if (trace_use_dull) call da_trace_entry("da_recursive_filter_1d_inv") + + !------------------------------------------------------------------------- + ! [1.0] Initialise: + !------------------------------------------------------------------------- + + one_alpha = 1.0 - alpha + + c(1:n) = field(1:n) + + !------------------------------------------------------------------------- + ! [2.0] Perform non-recursive inverse filter: + !------------------------------------------------------------------------- + + ! Follow the appendix Eq. (A2) of Lorenc (1992): + + do j = 2, n-1 + a(j) = c(j) - (alpha/one_alpha**2) * (c(j-1)-2.0*c(j)+c(j+1)) + end do + + !------------------------------------------------------------------------- + ! [3.0] Perform inverse filter at boundary points 1 & n: + !------------------------------------------------------------------------- + + ! use turning conditions as in the appendix of Hayden & Purser (1995): + ! also see Barker etal., 2004, chapter 5a. + + if (pass == 1) then + b(1) = (c(1)-alpha*c(2))/one_alpha + a(1) = b(1)/one_alpha + + b(n-1) = (c(n-1)-alpha*c(n))/one_alpha + b(n) = c(n)*(1.0+alpha) + a(n) = (b(n) - alpha*b(n-1))/one_alpha + else if ( pass == 2) then + b(1) = (c(1)-alpha*c(2))/one_alpha + a(1) = b(1)*(1.0+alpha) + + b(n-1) = (c(n-1)-alpha*c(n))/one_alpha + b(n) = c(n)*(1.0-alpha**2)**2/one_alpha+alpha**3*b(n-1) + a(n) = (b(n) - alpha*b(n-1))/one_alpha + else + b(1) = (c(1)-alpha*c(2))/one_alpha + a(1) = b(1)*(1.0-alpha**2)**2/one_alpha+alpha**3*a(2) + + b(n-1) = (c(n-1)-alpha*c(n))/one_alpha + b(n) = c(n)*(1.0-alpha**2)**2/one_alpha+alpha**3*b(n-1) + a(n) = (b(n) - alpha*b(n-1))/one_alpha + end if + + field(1:n) = a(1:n) + + if (trace_use_dull) call da_trace_exit("da_recursive_filter_1d_inv") + +end subroutine da_recursive_filter_1d_inv diff --git a/var/da/da_recursive_filter/da_transform_through_rf.inc b/var/da/da_recursive_filter/da_transform_through_rf.inc index 71af24539a..fa2cd76d99 100644 --- a/var/da/da_recursive_filter/da_transform_through_rf.inc +++ b/var/da/da_recursive_filter/da_transform_through_rf.inc @@ -79,7 +79,8 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field, scaling) !------------------------------------------------------------------------- ! [2.1] Apply (i',j',k -> i,j',k') (grid%xp%v1z -> grid%xp%v1x) - ! convert from vertical column to x-stripe + ! convert from z-strip to x-stripe (i.e., no decomposition in x-dir) + ! Liuz NOTE: in order to do global recursive filter in x-direction call da_transpose_z2x (grid) @@ -108,7 +109,7 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field, scaling) !------------------------------------------------------------------------- ! [3.1] Apply (i, j' ,k' -> i', j ,k') (grid%xp%v1x -> grid%xp%v1y) - ! convert from vertical column to y-stripe + ! convert from x-strip to y-stripe call da_transpose_x2y (grid) @@ -133,11 +134,11 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field, scaling) !$OMP END PARALLEL DO !------------------------------------------------------------------------- - ! [4.0]: Perform 1D recursive filter in y-direction: + ! [4.0]: convert back from y-trip to normal z-strip: !------------------------------------------------------------------------- ! [4.1] Apply (i',j,k' -> i',j',k) (grid%xp%v1y -> grid%xp%v1z) - ! convert from y-stripe to vertical column. + ! convert from y-stripe to z-strip. call da_transpose_y2z (grid) diff --git a/var/da/da_recursive_filter/da_transform_through_rf_inv.inc b/var/da/da_recursive_filter/da_transform_through_rf_inv.inc new file mode 100644 index 0000000000..5576f66203 --- /dev/null +++ b/var/da/da_recursive_filter/da_transform_through_rf_inv.inc @@ -0,0 +1,189 @@ +subroutine da_transform_through_rf_inv(grid, mz,rf_alpha, val, field, scaling) + + !--------------------------------------------------------------------------- + ! Purpose: Inverse transform of the recursive filter. + ! Based on da_transform_through_rf_adj + ! + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + ! + ! Method: 1) Apply inverse filter first in y-direction. + ! 2) then apply inverse filter in x-direction + !--------------------------------------------------------------------------- + + implicit none + + type(domain), intent(inout) :: grid + integer, intent(in) :: mz ! Vertical truncation. + real*8, intent(in) :: rf_alpha(mz) ! RF scale parameter. + real*8, intent(in) :: val(jds:jde,mz) ! Error standard deviation. + real, intent(inout) :: field(ims:ime,jms:jme,kms:kme) ! Field to be transformed. + + integer :: rf_passes_over_two ! rf_passes / 2 + integer :: i, j, m, n, pass, ij ! Loop counters. + real :: p_x(ims:ime,jms:jme) ! sqrt(Grid box area). + real*8 :: val_j(grid%xp%jtsy:grid%xp%jtey) + real*8 :: val_i(grid%xp%itsx:grid%xp%itex) + + logical, optional, intent(in) :: scaling + + !------------------------------------------------------------------------- + ! [1.0]: Initialise: + !------------------------------------------------------------------------- + + if (trace_use_dull) call da_trace_entry("da_transform_through_rf_inv") + + write (*,*) 'mz= ', mz + !write (*,*) 'rf_alpha= ', rf_alpha + !write (*,*) 'eigval= ', val + !write (*,*) 'vert_corr=', vert_corr, ' vert_corr_1=', vert_corr_1 + + + rf_passes_over_two = rf_passes / 2 + + ! [1.1] Define inner product (square root of grid box area): + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, i, j) + do ij = 1 , grid%num_tiles + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + p_x(i,j) = sqrt(grid%xb%grid_box_area(i,j)) + end do + end do + end do + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, i, j ) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xp%v1z(i,j,m) = 0.0 + end do + end do + end do + end do + !$OMP END PARALLEL DO + + !------------------------------------------------------------------------- + ! [4.0]: Perform 1D recursive filter in y-direction: + !------------------------------------------------------------------------- + + ! [4.3] Optionally scale by background error: + ! be_s % val = Gridpoint standard deviation - only required for + ! vert_corr = vert_corr_1 as scaling is performed in vertical transform + ! for vert_corr = vert_corr_2: + + if (vert_corr == vert_corr_1 .or. (present(scaling))) then + if (scaling .or. vert_corr == vert_corr_1) then + do m = 1, mz + do i = its, ite + field(i,jts:jte,m) = field(i,jts:jte,m) / val(jts:jte,m) + end do + end do + end if + end if + + ! [4.2] Transform filtered field to dimensional space: + + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij ,m, j, i) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xp%v1z(i,j,m) = field(i,j,m) / p_x(i,j) + end do + end do + end do + end do + !$OMP END PARALLEL DO + + ! [4.1] Apply (i',j',k -> i',j,k') (grid%xp%v1z -> grid%xp%v1y) + ! convert z-strip to y-stripe + + call da_transpose_z2y (grid) + + !------------------------------------------------------------------------- + ! [3.0]: Perform 1D recursive filter in y-direction: + !------------------------------------------------------------------------- + + ! [3.2] Apply 1D filter in y direction: + + n=grid%xp%jtey-grid%xp%jtsy+1 + !$OMP PARALLEL DO & + !$OMP PRIVATE (m, i, val_j, pass, j) + do m = grid%xp%ktsy, min(grid%xp%ktey, mz) + do i = grid%xp%itsy, grid%xp%itey + do j = grid%xp%jtsy, grid%xp%jtey + val_j(j) = grid%xp%v1y(i,j,m) + end do + do pass = rf_passes_over_two, 1, -1 + call da_recursive_filter_1d_inv(pass, rf_alpha(m), val_j, n) + end do + do j = grid%xp%jtsy, grid%xp%jtey + grid%xp%v1y(i,j,m) = val_j(j) + end do + end do + end do + !$OMP END PARALLEL DO + + ! [3.1] Apply (i',j,k' -> i,j',k') (grid%xp%v1y -> grid%xp%v1x) + ! convert from y-stripe to x-stripe + + call da_transpose_y2x (grid) + + !------------------------------------------------------------------------- + ! [2.0]: Perform 1D recursive filter in x-direction: + !------------------------------------------------------------------------- + + ! [2.2] Apply 1D filter in x direction: + + n = grid%xp%itex-grid%xp%itsx+1 + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( m, j, pass, i, val_i) + do m = grid%xp%ktsx, min(grid%xp%ktex,mz) + do j = grid%xp%jtsx, grid%xp%jtex + do i = grid%xp%itsx, grid%xp%itex + val_i(i) = grid%xp%v1x(i,j,m) + end do + do pass = rf_passes_over_two, 1, -1 + call da_recursive_filter_1d_inv(pass, rf_alpha(m), val_i, n) + end do + do i = grid%xp%itsx, grid%xp%itex + grid%xp%v1x(i,j,m) = val_i(i) + end do + end do + end do + !$OMP END PARALLEL DO + + ! [2.1] Apply (i,j',k' -> i',j',k) (grid%xp%v1x -> grid%xp%v1z) + ! convert from x-stripe to normal z-strip + + call da_transpose_x2z (grid) + + !------------------------------------------------------------------------- + ! [1.0]: Initialise: + !------------------------------------------------------------------------- + + ! [1.2] Transform to nondimensional v_hat space: + + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij ,m, i, j) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + field(i,j,m) = grid%xp%v1z(i,j,m) * p_x(i,j) + end do + end do + end do + end do + !$OMP END PARALLEL DO + + if (trace_use_dull) call da_trace_exit("da_transform_through_rf_inv") + +end subroutine da_transform_through_rf_inv + + diff --git a/var/da/da_setup_structures/da_setup_structures.f90 b/var/da/da_setup_structures/da_setup_structures.f90 index 41631ad457..3d68bb7393 100644 --- a/var/da/da_setup_structures/da_setup_structures.f90 +++ b/var/da/da_setup_structures/da_setup_structures.f90 @@ -5,7 +5,7 @@ module da_setup_structures !--------------------------------------------------------------------------- use da_wavelet, only: lf,namw,nb,nij,ws - use module_domain, only : xb_type, ep_type, domain + use module_domain, only : xb_type, ep_type, domain, vp_type use da_define_structures, only : xbx_type,be_subtype, be_type, y_type, j_type, & iv_type,da_allocate_background_errors,da_allocate_observations, & @@ -143,6 +143,7 @@ module da_setup_structures #include "da_lcl.inc" #include "da_cumulus.inc" #include "da_qfrmrh.inc" +#include "da_write_vp.inc" #include "da_write_increments.inc" #include "da_write_increments_for_wrf_nmm_regional.inc" #include "da_write_kma_increments.inc" diff --git a/var/da/da_setup_structures/da_write_vp.inc b/var/da/da_setup_structures/da_write_vp.inc new file mode 100644 index 0000000000..75bcf4d42f --- /dev/null +++ b/var/da/da_setup_structures/da_write_vp.inc @@ -0,0 +1,195 @@ +subroutine da_write_vp (grid,vp,filename) + + !---------------------------------------------------------------------- + ! Purpose: Write vp, full varibles after balance transform Up + ! will be interpolated into higher resolution by offline program + ! Method: based on da_write_increments.inc + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + ! add cloud and w variables, 2017-07 + !---------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + type(vp_type), intent(in) :: vp + character(len=16), intent(in) :: filename + + ! Arrays for write out increments: + integer :: ix, jy, kz +#ifdef DM_PARALLEL + !real, dimension(1:grid%xb%mix,1:grid%xb%mjy) :: gbuf_2d + !real, dimension(1:grid%xb%mix+1,1:grid%xb%mjy+1) :: gbuf_2dd + real, dimension(1:grid%xb%mix,1:grid%xb%mjy,1:grid%xb%mkz) :: gbuf + + !real, dimension(1:grid%xb%mix,1:grid%xb%mjy,1:grid%xb%mkz+1) :: wgbuf + real, dimension(:,:,:), allocatable :: v1_global, v2_global, & + v3_global, v4_global, v5_global + real, dimension(:,:,:), allocatable :: v6_global, v7_global, & + v8_global, v9_global, v10_global, v11_global +#endif + + integer :: vp_unit, vp_local_unit + character(len=7) :: vpfile + + if (trace_use) call da_trace_entry("da_write_vp") + + + ! Dimension of the domain (unstagered): + ix = grid%xb%mix + jy = grid%xb%mjy + kz = grid%xb%mkz + +#ifdef DM_PARALLEL + + ! 3-d and 2-d increments: + + allocate ( v1_global (1:ix,1:jy,1:kz)) + allocate ( v2_global (1:ix,1:jy,1:kz)) + allocate ( v3_global (1:ix,1:jy,1:kz)) + allocate ( v4_global (1:ix,1:jy,1:kz)) + allocate ( v5_global (1:ix,1:jy,1:kz)) + if ( cloud_cv_options >= 2 ) then + allocate ( v6_global (1:ix,1:jy,1:kz)) + allocate ( v7_global (1:ix,1:jy,1:kz)) + allocate ( v8_global (1:ix,1:jy,1:kz)) + allocate ( v9_global (1:ix,1:jy,1:kz)) + allocate ( v10_global (1:ix,1:jy,1:kz)) + end if + if ( use_cv_w ) then + allocate ( v11_global (1:ix,1:jy,1:kz)) + end if + + call da_patch_to_global(grid, vp % v1, gbuf) ! psi or u + if (rootproc) then + v1_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v2, gbuf) ! chi_u or v + if (rootproc) then + v2_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v3, gbuf) ! t_u or t + if (rootproc) then + v3_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v4, gbuf) ! q/qs + if (rootproc) then + v4_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + !print *, "local size v5: ", size(vp % v5,1),size(vp % v5,2),size(vp % v5,3) + call da_patch_to_global(grid, vp % v5, gbuf) ! Ps (:,:,1) + if (rootproc) then + v5_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + if ( cloud_cv_options >= 2 ) then + call da_patch_to_global(grid, vp % v6, gbuf) ! qcloud + if (rootproc) then + v6_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v7, gbuf) ! qrain + if (rootproc) then + v7_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v8, gbuf) ! qice + if (rootproc) then + v8_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v9, gbuf) ! qsnow + if (rootproc) then + v9_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + + call da_patch_to_global(grid, vp % v10, gbuf) ! qgraupel + if (rootproc) then + v10_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + end if ! cloud_cv_options + + if ( use_cv_w ) then + call da_patch_to_global(grid, vp % v11, gbuf) ! w + if (rootproc) then + v11_global(1:ix,1:jy,1:kz) = gbuf(1:ix,1:jy,1:kz) + end if + end if + + !write(unit=vpfile,fmt='(a,i4.4)') 'vp_',myproc + !call da_get_unit(vp_local_unit) + !open(unit=vp_local_unit, file=trim(vpfile), form='unformatted') + + !print *, "local: ips,ipe,jps,jpe,kps,kpe=", ips,ipe,jps,jpe,kps,kpe + !print *, "local: ims,ime,jms,jme,kms,kme=", ims,ime,jms,jme,kms,kme + !print *, "local: dimx, dimy, dimz=", size(vp%v5,1),size(vp%v5,2),size(vp%v5,3) + + !write (unit=vp_local_unit) ips,ipe,jps,jpe,kps,kpe, & + ! ims,ime,jms,jme,kms,kme, & + ! size(vp%v5,1),size(vp%v5,2),size(vp%v5,3) + + !write (unit=vp_local_unit) vp%v1, vp%v2, & + ! vp%v3, vp%v4, vp%v5 + + !close(vp_local_unit) + !call da_free_unit(vp_local_unit) + + +#endif + + if (rootproc) then + call da_get_unit(vp_unit) + open(unit=vp_unit, file=trim(filename), form='unformatted') + + !print *, "ANALYSIS_DATE= ", ANALYSIS_DATE + !write (unit=vp_unit) ANALYSIS_DATE + + print *, "write_vp: Global ix, jy, kz=", ix, jy, kz + write (unit=vp_unit) ix, jy, kz + +#ifdef DM_PARALLEL + + ! 3d- and 2d-increments in vp space: + write (unit=vp_unit) v1_global, v2_global, & + v3_global, v4_global, v5_global + + if ( cloud_cv_options >= 2 ) then + write (unit=vp_unit) v6_global, v7_global, & + v8_global, v9_global, v10_global + end if + if ( use_cv_w ) write (unit=vp_unit) v11_global + + close(vp_unit) + call da_free_unit(vp_unit) + +#else + + ! 3d- and 2d-increments: + write (unit=vp_unit) vp%v1(1:ix,1:jy,1:kz), & + vp%v2(1:ix,1:jy,1:kz), & + vp%v3(1:ix,1:jy,1:kz), & + vp%v4(1:ix,1:jy,1:kz), & + vp%v5(1:ix,1:jy,1) + if ( cloud_cv_options >= 2 ) then + write (unit=vp_unit) vp%v6(1:ix,1:jy,1:kz), & + vp%v7(1:ix,1:jy,1:kz), & + vp%v8(1:ix,1:jy,1:kz), & + vp%v9(1:ix,1:jy,1:kz), & + vp%v10(1:ix,1:jy,1:kz) + end if + if ( use_cv_w ) write (unit=vp_unit) vp%v11(1:ix,1:jy,1:kz) + + close(vp_unit) + call da_free_unit(vp_unit) +#endif + + end if + + if (trace_use) call da_trace_exit("da_write_vp") + +end subroutine da_write_vp + + diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 2b9f988b31..36a0d810a0 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -49,8 +49,8 @@ subroutine da_llxy (info, loc, outside, outside_all) outside_all = .false. ! Do not check for global options if (.not. global) then - if ((int(loc%x) < ids) .or. (int(loc%x) >= ide) .or. & - (int(loc%y) < jds) .or. (int(loc%y) >= jde)) then + if ((int(loc%x) < ids) .or. (int(loc%x) > ide) .or. & + (int(loc%y) < jds) .or. (int(loc%y) > jde)) then outside_all = .true. outside = .true. return diff --git a/var/da/da_vtox_transforms/da_transform_vptox.inc b/var/da/da_vtox_transforms/da_transform_vptox.inc index 35b75ceffd..a72d6faae5 100644 --- a/var/da/da_vtox_transforms/da_transform_vptox.inc +++ b/var/da/da_vtox_transforms/da_transform_vptox.inc @@ -9,6 +9,12 @@ subroutine da_transform_vptox(grid, vp, be, ep) ! ! Implementation of multi-variate BE for cv_options=6 ! Syed RH Rizvi, MMM/NESL/NCAR, Date: 02/01/2010 + !------------------------ + ! Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + ! re-order transforms to avoid local chi_u and store full variables in vp + ! full vp will be written out and used as input of inverse U transform + ! for multi-resolution incremental 4DVAR + ! order: v4 (rh), v3 (T), v5 (Ps), v2 (Chi_u -> Chi) !----------------------------------------------------------------------- implicit none @@ -21,7 +27,7 @@ subroutine da_transform_vptox(grid, vp, be, ep) ! integer, intent(in), optional :: nobwin integer :: i, k, j, k1, ij ! Loop counters. - real, allocatable :: chi_u(:,:,:) ! Unbalanced chi + !real, allocatable :: chi_u(:,:,:) ! Unbalanced chi if (trace_use) call da_trace_entry("da_transform_vptox") @@ -41,43 +47,38 @@ subroutine da_transform_vptox(grid, vp, be, ep) !$OMP PRIVATE ( ij, k1, k, j, i) do ij = 1 , grid%num_tiles + ! 2.1 Pseudo rh_u to Pseudo rh (only for cv6) + ! do moisture first to avoid local (chi_u,t_t,Ps_u) variables + !-------------------------------------------------------------- if ( cv_options == 6 ) then - allocate (chi_u(its:ite,grid%j_start(ij):grid%j_end(ij),kts:kte) ) - do k = kts, kte - do j = grid%j_start(ij), grid%j_end(ij) - do i = its, ite - chi_u(i,j,k) = vp%v2(i,j,k) + do k1 = kts, kte + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v4(i,j,k1) = vp%v4(i,j,k1) + be%reg_psi_rh(j,k1,k)*vp%v1(i,j,k) + & + be%reg_chi_u_rh(j,k1,k)*vp%v2(i,j,k) + be%reg_t_u_rh(j,k1,k)*vp%v3(i,j,k) + end do end do end do end do - end if - - ! Chi: - if (cv_options /= 7) then +! do k = kts, kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - vp%v2(i,j,k) = vp%v2(i,j,k) + be%reg_psi_chi(j,k)* vp%v1(i,j,k) + vp%v4(i,j,k) = vp%v4(i,j,k) + be%reg_ps_u_rh(j,k)*vp%v5(i,j,1) end do end do end do end if - - ! Temperature: - do k = kts, kte - do j = grid%j_start(ij), grid%j_end(ij) - do i = its, ite - grid%xa%t(i,j,k) = vp%v3(i,j,k) - end do - end do - end do + ! 2.2 t_u --> t, do this before chi_u --> chi + !---------------------------------------------- if (cv_options /= 7) then do k1 = kts, kte do k = kts, kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - grid%xa%t(i,j,k) = grid%xa%t(i,j,k) + be%reg_psi_t(j,k,k1)*vp%v1(i,j,k1) + vp%v3(i,j,k) = vp%v3(i,j,k) + be%reg_psi_t(j,k,k1)*vp%v1(i,j,k1) end do end do end do @@ -89,25 +90,28 @@ subroutine da_transform_vptox(grid, vp, be, ep) do k = kts, kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - grid%xa%t(i,j,k) = grid%xa%t(i,j,k) + be%reg_chi_u_t(j,k,k1)*chi_u(i,j,k1) + vp%v3(i,j,k) = vp%v3(i,j,k) + be%reg_chi_u_t(j,k,k1)*vp%v2(i,j,k1) end do end do end do end do end if - ! Surface Pressure - do j = grid%j_start(ij), grid%j_end(ij) - do i = its, ite - grid%xa%psfc(i,j) = vp%v5(i,j,1) + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%t(i,j,k) = vp%v3(i,j,k) + end do end do end do + ! 2.3 Ps_u --> Ps, do this before chi_u --> chi + !------------------------------------------------- if (cv_options /= 7) then do k = kts,kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - grid%xa%psfc(i,j) = grid%xa%psfc(i,j) + be%reg_psi_ps(j,k)*vp%v1(i,j,k) + vp%v5(i,j,1) = vp%v5(i,j,1) + be%reg_psi_ps(j,k)*vp%v1(i,j,k) end do end do end do @@ -117,36 +121,31 @@ subroutine da_transform_vptox(grid, vp, be, ep) do k = kts,kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - grid%xa%psfc(i,j) = grid%xa%psfc(i,j) + be%reg_chi_u_ps(j,k)*chi_u(i,j,k) + vp%v5(i,j,1) = vp%v5(i,j,1) + be%reg_chi_u_ps(j,k)*vp%v2(i,j,k) end do end do end do end if - ! Moisture - if ( cv_options == 6 ) then - do k1 = kts, kte - do k = kts, kte - do j = grid%j_start(ij), grid%j_end(ij) - do i = its, ite - vp%v4(i,j,k1) = vp%v4(i,j,k1) + be%reg_psi_rh(j,k1,k)*vp%v1(i,j,k) + & - be%reg_chi_u_rh(j,k1,k)*chi_u(i,j,k) + be%reg_t_u_rh(j,k1,k)*vp%v3(i,j,k) - end do - end do - end do + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%psfc(i,j) = vp%v5(i,j,1) end do -! + end do + + ! 2.4 Chi_u --> Chi, do this last + !----------------------------------- + if (cv_options /= 7) then do k = kts, kte do j = grid%j_start(ij), grid%j_end(ij) do i = its, ite - vp%v4(i,j,k) = vp%v4(i,j,k) + be%reg_ps_u_rh(j,k)*vp%v5(i,j,1) + vp%v2(i,j,k) = vp%v2(i,j,k) + be%reg_psi_chi(j,k)* vp%v1(i,j,k) end do end do end do end if - ! - if ( cv_options == 6 ) deallocate (chi_u ) +! if ( cv_options == 6 ) deallocate (chi_u ) end do !$OMP END PARALLEL DO diff --git a/var/da/da_vtox_transforms/da_transform_vptox_inv.inc b/var/da/da_vtox_transforms/da_transform_vptox_inv.inc new file mode 100644 index 0000000000..93649b675e --- /dev/null +++ b/var/da/da_vtox_transforms/da_transform_vptox_inv.inc @@ -0,0 +1,174 @@ +subroutine da_transform_vptox_inv(grid, vp, be, ep) + + !----------------------------------------------------------------------- + ! Purpose: Inverse of balance (physical) transform of increment + ! + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-9 + !----------------------------------------------------------------------- + + implicit none + + type (domain), intent(inout) :: grid + + type (vp_type), intent(inout) :: vp ! input: full variables + ! output: unbalanced variables on model grid + type (be_type), intent(in), optional :: be ! Background errors. + type (ep_type), intent(in), optional :: ep ! Ensemble perturbations. + + integer :: i, k, j, k1, ij ! Loop counters. + real, allocatable :: chi_u(:,:,:) ! Unbalanced chi + + if (trace_use) call da_trace_entry("da_transform_vptox_inv") + + !--------------------------------------------------------------------------- + ! [1] Add flow-dependent increments in control variable space (vp): + !--------------------------------------------------------------------------- + + !if (be % ne > 0 .and. alphacv_method == alphacv_method_vp) then + ! call da_add_flow_dependence_vp(be % ne, ep, vp, its,ite, jts,jte, kts,kte) + ! call da_add_flow_dependence_vp_inv !!! ?? + !end if + + !-------------------------------------------------------------------------- + ! [2] Impose statistical balance constraints: + ! Assume input vp%* is full variable, out vp% is unbalanced variables + ! to avoid (Psi,Chi) -> (U,V) transform, which has no exact inverse, + ! we need to store full variables at vp%* after each outloop. + ! da_transform_vptox.inc is also modified for this purpose. + ! + ! for cv7, control variables are all full variables w/o multi-variate correlation. + ! so there is no need for balance transform and its inverse. + !-------------------------------------------------------------------------- + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k1, k, j, i) + do ij = 1 , grid%num_tiles + + ! 2.1 Psi, Chi --> Psi, Chi_u + !------------------------- + ! there is no need for Psi --> Psi transform + + ! Chi --> Chi_u + !-------------------- + if (cv_options /= 7) then + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v2(i,j,k) = vp%v2(i,j,k) - be%reg_psi_chi(j,k)* vp%v1(i,j,k) + end do + end do + end do + end if + + ! 2.2 T --> T_u + !------------------- + if (cv_options /= 7) then ! - balance contri. from psi + do k1 = kts, kte + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + !vp%v3(i,j,k) = grid%xa%t(i,j,k) - be%reg_psi_t(j,k,k1)*vp%v1(i,j,k1) + vp%v3(i,j,k) = vp%v3(i,j,k) - be%reg_psi_t(j,k,k1)*vp%v1(i,j,k1) + end do + end do + end do + end do + end if + + if ( cv_options == 6 ) then ! - balance contri. from Chi_u + do k1 = kts, kte + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v3(i,j,k) = vp%v3(i,j,k) - be%reg_chi_u_t(j,k,k1)*vp%v2(i,j,k1) + end do + end do + end do + end do + end if + + ! 2.3 Ps --> Ps_u + !------------------------ + !do j = grid%j_start(ij), grid%j_end(ij) + ! do i = its, ite + ! grid%xa%psfc(i,j) = vp%v5(i,j,1) + ! end do + !end do + + if (cv_options /= 7) then ! - balance contri. from psi + do k = kts,kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + !vp%v5(i,j,1) = grid%xa%psfc(i,j) - be%reg_psi_ps(j,k)*vp%v1(i,j,k) + vp%v5(i,j,1) = vp%v5(i,j,1) - be%reg_psi_ps(j,k)*vp%v1(i,j,k) + end do + end do + end do + end if + + if ( cv_options == 6 ) then ! - balance contri. from Chi_u + do k = kts,kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v5(i,j,1) = vp%v5(i,j,1) - be%reg_chi_u_ps(j,k)*vp%v2(i,j,k) + end do + end do + end do + end if + + ! 2.4 q --> pseudo rh=q/qs(background) + !---------------------------- + ! if cv5 or cv7, no need for pseudo rh transform + + !do k = kts, kte + ! do j = grid%j_start(ij), grid%j_end(ij) + ! do i = its, ite + ! vp%v4(i,j,k) = grid%xa % q(i,j,k) / grid%xb%qs(i,j,k) + ! enddo + ! enddo + !enddo + + if ( cv_options == 6 ) then + do k1 = kts, kte + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v4(i,j,k1) = vp%v4(i,j,k1) - & + be%reg_psi_rh(j,k1,k)*vp%v1(i,j,k) - & + be%reg_chi_u_rh(j,k1,k)*vp%v2(i,j,k) - & + be%reg_t_u_rh(j,k1,k)*vp%v3(i,j,k) + end do + end do + end do + end do +! + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v4(i,j,k) = vp%v4(i,j,k) - be%reg_ps_u_rh(j,k)*vp%v5(i,j,1) + end do + end do + end do + end if + + end do + + !--------------------------------------------------------------------------- + ! [4] Add flow-dependent increments in model space (grid%xa): + !--------------------------------------------------------------------------- + +! if (be % ne > 0 .and. alphacv_method == alphacv_method_xa) then +! call da_add_flow_dependence_xa(grid, be % ne, ep, vp) +! end if +! if (be % ne > 0 .and. alphacv_method == alphacv_method_xa) then +! if ( anal_type_hybrid_dual_res ) then +! call da_add_flow_dependence_xa_dual_res(grid, be % ne, ep, vp) +! else +! call da_add_flow_dependence_xa(grid, be % ne, ep, vp) +! endif +! end if + + if (trace_use) call da_trace_exit("da_transform_vptox_inv") + +end subroutine da_transform_vptox_inv + diff --git a/var/da/da_vtox_transforms/da_transform_vtovv_inv.inc b/var/da/da_vtox_transforms/da_transform_vtovv_inv.inc new file mode 100644 index 0000000000..3350e3940a --- /dev/null +++ b/var/da/da_vtox_transforms/da_transform_vtovv_inv.inc @@ -0,0 +1,229 @@ +subroutine da_transform_vtovv_inv(grid, cv_size, be, cv, vv) + + !----------------------------------------------------------------------- + ! Purpose: perform inverse transform of horizontal recursive filter + ! + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + !----------------------------------------------------------------------- + + implicit none + + type(domain), intent(inout) :: grid + integer, intent(in) :: cv_size ! Size of cv array. + type(be_type), intent(in) :: be ! Background error structure. + real, intent(inout) :: cv(cv_size) ! control variables. + type(vp_type), intent(inout) :: vv ! Grid point/EOF control var. + + integer :: s(4) ! Index bounds into arrays. + integer :: n ! Loop counter. + integer :: mz ! Vertical truncation. + integer :: ne ! Ensemble size. + + logical :: scaling + + if (trace_use) call da_trace_entry("da_transform_vtovv_inv") + + if( .not. use_rf .or. do_normalize ) s(1:2)=1 + + + !------------------------------------------------------------------------- + ! [2.0] Perform inverse of VToVV Transform: + !------------------------------------------------------------------------- + + ! [2.1] Transform 1st control variable: + mz = be % v1 % mz + !s(3)=s(1)+mz-1 + !if( do_normalize )call da_transform_rescale(mz,be%sd(:,:,s(1):s(3)),vv%v1) + if( use_rf .and. mz > 0 .and. len_scaling1(1) /= 0.0) then + call da_transform_through_rf_inv(grid, mz, be % v1 % rf_alpha, be % v1 % val, vv % v1) + !elseif( mz > 0 ) then + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%wsd(:,:,s(1):s(3)),cv(s(2):s(4)),vv%v1) + ! s(2)=s(4)+1 + !else + ! !print'(a,": be%v1%mz=",I0)',__FILE__,mz + endif + !s(1)=s(3)+1 + + ! [2.2] Transform 2nd control variable: + + mz = be % v2 % mz + !s(3)=s(1)+mz-1 + !if( do_normalize )call da_transform_rescale(mz,be%sd(:,:,s(1):s(3)),vv%v2) + if( use_rf .and. mz > 0 .and. len_scaling2(1) /= 0.0) then + call da_transform_through_rf_inv(grid, mz, be % v2 % rf_alpha, be % v2 % val, vv % v2) + !elseif( mz > 0 ) then + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%wsd(:,:,s(1):s(3)),cv(s(2):s(4)),vv%v2) + ! s(2)=s(4)+1 + !else + ! !print'(a,": be%v2%mz=",I0)',__FILE__,mz + endif + !s(1)=s(3)+1 + + ! [2.3] Transform 3rd control variable + + mz = be % v3 % mz + !s(3)=s(1)+mz-1 + !if( do_normalize )call da_transform_rescale(mz,be%sd(:,:,s(1):s(3)),vv%v3) + if( use_rf .and. mz > 0 .and. len_scaling3(1) /= 0.0) then + call da_transform_through_rf_inv(grid, mz, be % v3 % rf_alpha, be % v3 % val, vv % v3) + !elseif( mz > 0 ) then + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%wsd(:,:,s(1):s(3)),cv(s(2):s(4)),vv%v3) + ! s(2)=s(4)+1 + !else + ! !print'(a,": be%v3%mz=",I0)',__FILE__,mz + endif + !s(1)=s(3)+1 + + ! [2.4] Transform 4th control variable + + mz = be % v4 % mz + !s(3)=s(1)+mz-1 + !if( do_normalize )call da_transform_rescale(mz,be%sd(:,:,s(1):s(3)),vv%v4) + if( use_rf .and. mz > 0 .and. len_scaling4(1) /= 0.0) then + call da_transform_through_rf_inv(grid, mz, be % v4 % rf_alpha, be % v4 % val, vv % v4) + !elseif( mz > 0 ) then + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%wsd(:,:,s(1):s(3)),cv(s(2):s(4)),vv%v4) + ! s(2)=s(4)+1 + !else + ! !print'(a,": be%v4%mz=",I0)',__FILE__,mz + endif + !s(1)=s(3)+1 + + ! [2.5] Transform 5th control variable + + mz = be % v5 % mz + !s(3)=s(1)+mz-1 + !if( do_normalize )call da_transform_rescale(mz,be%sd(:,:,s(1):s(3)),vv%v5) + if( use_rf .and. mz > 0 .and. len_scaling5(1) /= 0.0) then + call da_transform_through_rf_inv(grid, mz, be % v5 % rf_alpha, be % v5 % val, vv % v5) + !elseif( mz > 0 ) then + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%wsd(:,:,s(1):s(3)),cv(s(2):s(4)),vv%v5) + ! s(2)=s(4)+1 + !else + ! !print'(a,": be%v5%mz=",I0)',__FILE__,mz + endif + !s(1)=s(3)+1 + + if ( use_rf .and. cloud_cv_options <= 1 ) then + vv % v6 = 0.0 + vv % v7 = 0.0 + vv % v8 = 0.0 + vv % v9 = 0.0 + vv % v10 = 0.0 + vv % v11 = 0.0 + end if + + + ! [2.6] Transform 6th-10th cloud control variables + + if ( use_rf .and. cloud_cv_options >= 2 ) then + select case ( cloud_cv_options ) + case ( 2 ) +!hcl-check array index of len_scaling + mz = be % v6 % mz + if ( mz > 0 .and. len_scaling6(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v6 % rf_alpha, be % v6 % val, vv % v6) + end if + mz = be % v7 % mz + if ( mz > 0 .and. len_scaling7(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v7 % rf_alpha, be % v7 % val, vv % v7) + end if + mz = be % v8 % mz + if ( mz > 0 .and. len_scaling8(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v8 % rf_alpha, be % v8 % val, vv % v8) + end if + mz = be % v9 % mz + if ( mz > 0 .and. len_scaling9(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v9 % rf_alpha, be % v9 % val, vv % v9) + end if + mz = be % v10 % mz + if ( mz > 0 .and. len_scaling10(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v10 % rf_alpha, be % v10 % val, vv % v10) + end if + case ( 3 ) + scaling = .true. + mz = be % v6 % mz + if ( mz > 0 .and. len_scaling6(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v6 % rf_alpha, be % v6 % val, vv % v6, scaling) + end if + mz = be % v7 % mz + if ( mz > 0 .and. len_scaling7(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v7 % rf_alpha, be % v7 % val, vv % v7, scaling) + end if + mz = be % v8 % mz + if ( mz > 0 .and. len_scaling8(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v8 % rf_alpha, be % v8 % val, vv % v8, scaling) + end if + mz = be % v9 % mz + if ( mz > 0 .and. len_scaling9(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v9 % rf_alpha, be % v9 % val, vv % v9, scaling) + end if + mz = be % v10 % mz + if ( mz > 0 .and. len_scaling10(1) > 0.0 ) then + call da_transform_through_rf_inv(grid, mz, be % v10 % rf_alpha, be % v10 % val, vv % v10, scaling) + end if + end select + end if + + ! [2.7] Transform w control variable + + if ( use_rf ) then + if ( .not. use_cv_w ) then + vv % v11 = 0.0 + else + mz = be % v11 % mz + if ( mz > 0 .and. len_scaling11(1) > 0.0 ) then + if ( cloud_cv_options == 2 ) then + call da_transform_through_rf_inv(grid, mz, be % v11 % rf_alpha, be % v11 % val, vv % v11) + else if ( cloud_cv_options == 3 ) then + scaling = .true. + call da_transform_through_rf_inv(grid, mz, be % v11 % rf_alpha, be % v11 % val, vv % v11, scaling) + end if + end if + end if + end if + + + ! [2.8] Transform alpha control variable + + ne = be % ne + if (ne > 0) then + mz = be % alpha % mz + !if( do_normalize )then + ! do n = 1, ne + ! call da_transform_rescale(mz,be%alpha%sd,vv%alpha(:,:,:,n)) + ! end do + !endif + if( use_rf )then + do n = 1, ne + !if ( anal_type_hybrid_dual_res ) then + ! call da_transform_through_rf_inv_dual_res(grid % intermediate_grid, mz, be % alpha % rf_alpha, & + ! be % alpha % val, vv % alpha(:,:,:,n)) + !else + call da_transform_through_rf_inv(grid, mz, be % alpha % rf_alpha, be % alpha % val, vv % alpha(:,:,:,n)) + !endif + end do + !else + !do n = 1, ne + ! s(4)=s(2)+nij(0,0,2)*nij(0,1,2)*mz-1 + ! call da_transform_through_wavelet_inv(grid,mz,be%alpha%wsd,cv(s(2):s(4)),vv%alpha(:,:,:,n)) + ! s(2)=s(4)+1 + !end do + endif + endif + + if( use_rf )then + !------------------------------------------------------------------------- + ! [1.0] Fill 1D cv array from 3-dimensional vv arrays. + !------------------------------------------------------------------------- + call da_vv_to_cv( vv, grid%xp, be%cv_mz, be%ncv_mz, cv_size, cv) + endif + + if (trace_use) call da_trace_exit("da_transform_vtovv_inv") + +end subroutine da_transform_vtovv_inv diff --git a/var/da/da_vtox_transforms/da_transform_vtox_inv.inc b/var/da/da_vtox_transforms/da_transform_vtox_inv.inc new file mode 100644 index 0000000000..56c56c2433 --- /dev/null +++ b/var/da/da_vtox_transforms/da_transform_vtox_inv.inc @@ -0,0 +1,87 @@ +subroutine da_transform_vtox_inv(grid, cv_size, xbx, be, ep, cv, vv, vp) + + !-------------------------------------------------------------------------- + ! Purpose: Inverse control variable transform v = U^{-1} x'. + !-------------------------------------------------------------------------- + + implicit none + + type(domain), intent(inout) :: grid + integer, intent(in) :: cv_size ! Size of cv array. + type(xbx_type), intent(in) :: xbx ! For header & non-grid arrays. + type(be_type), intent(in) :: be ! background errors. + type(ep_type), intent(in) :: ep ! Ensemble perturbations. + real, intent(out) :: cv(1:cv_size) ! control variables. + type(vp_type), intent(out) :: vv ! grdipt/eof cv (local). + type(vp_type), intent(inout) :: vp ! grdipt/level cv (local). + + if (trace_use) call da_trace_entry("da_transform_vtox_inv") + + call da_zero_x (grid%xa) + + if (.not. use_background_errors) then + if (trace_use) call da_trace_exit("da_transform_vtox_inv") + return + end if + + !---------------------------------------------------------------------- + ! [1.0]: Perform inverse of balance tranform: vp = u_p^{-1} dx + !---------------------------------------------------------------------- + + if ( cv_options /= 7 ) call da_transform_vptox_inv(grid, vp, be, ep) + + !---------------------------------------------------------------------- + ! [2.0]: Perform inverse of vertical transform: vv = L^{-1/2} E^T vp + !---------------------------------------------------------------------- + + !if ( cv_options == 3 ) then + ! + ! call da_apply_be( be, cv, vp, grid) + ! call da_transform_bal( vp, be, grid) + ! + !else + + if (vert_corr == vert_corr_2) then + call da_vertical_transform(grid, 'u_inv', be, grid%xb % vertical_inner_product, vv, vp) + !call da_write_vp(grid,vv,'vv_afterUvTransf') + else + vv % v1(its:ite,jts:jte,kts:kte) = vp % v1(its:ite,jts:jte,kts:kte) + vv % v2(its:ite,jts:jte,kts:kte) = vp % v2(its:ite,jts:jte,kts:kte) + vv % v3(its:ite,jts:jte,kts:kte) = vp % v3(its:ite,jts:jte,kts:kte) + vv % v4(its:ite,jts:jte,kts:kte) = vp % v4(its:ite,jts:jte,kts:kte) + vv % v5(its:ite,jts:jte,kts:kte) = vp % v5(its:ite,jts:jte,kts:kte) + if ( cloud_cv_options >= 2 ) then + vv % v6(its:ite,jts:jte,kts:kte) = vp % v6(its:ite,jts:jte,kts:kte) + vv % v7(its:ite,jts:jte,kts:kte) = vp % v7(its:ite,jts:jte,kts:kte) + vv % v8(its:ite,jts:jte,kts:kte) = vp % v8(its:ite,jts:jte,kts:kte) + vv % v9(its:ite,jts:jte,kts:kte) = vp % v9(its:ite,jts:jte,kts:kte) + vv % v10(its:ite,jts:jte,kts:kte) = vp % v10(its:ite,jts:jte,kts:kte) + end if + if ( use_cv_w ) vv % v11(its:ite,jts:jte,kts:kte) = vp % v11(its:ite,jts:jte,kts:kte) + if (be % ne > 0) then +! vv % alpha(its:ite,jts:jte,kts:kte,1:be%ne) = vp%alpha(its:ite,jts:jte,kts:kte,1:be%ne) + vv % alpha(its_int:ite_int,jts_int:jte_int,kts_int:kte_int,1:be%ne) = & + vp%alpha(its_int:ite_int,jts_int:jte_int,kts_int:kte_int,1:be%ne) + end if + end if + + !---------------------------------------------------------------------- + ! [3.0]: Perform inverse of recursive filter: cv = u_h^{-1} vv + !---------------------------------------------------------------------- + + !if (global) then + ! call da_transform_vtovv_global(cv_size, xbx, be, cv, vv) + !else if ( (fg_format == fg_format_wrf_arw_regional .or. & + ! fg_format == fg_format_wrf_nmm_regional) .and. & + ! (.not. cv_options == 3) )then + + call da_transform_vtovv_inv(grid, cv_size, be, cv, vv) + + !end if + + !end if + + if (trace_use) call da_trace_exit("da_transform_vtox_inv") + +end subroutine da_transform_vtox_inv + diff --git a/var/da/da_vtox_transforms/da_transform_vvtovp.inc b/var/da/da_vtox_transforms/da_transform_vvtovp.inc index e4fa05d871..dfce751467 100644 --- a/var/da/da_vtox_transforms/da_transform_vvtovp.inc +++ b/var/da/da_vtox_transforms/da_transform_vvtovp.inc @@ -4,7 +4,15 @@ subroutine da_transform_vvtovp(grid, evec, eval, vertical_wgt, vv, vp, mz, level ! Purpose: Transform from fields on vertical EOFS to fields on vertical ! levels. ! - ! Method: Perform vp(i,j,k) = P E L^{1/2} vv(i,j,m) transform. + ! Method: Perform vp(i,j,k) = E L^{1/2} vv(i,j,m) transform. + ! + ! Zhiquan (Jake) liu's note: 2015-09 + !------------------------------------------------------------------------- + ! 1. evec/eval assumed to vary in y direction (jds:jde) though it may not + ! be true in BE file (e.g., likely domain-averaged BE with bin_type=5). + ! 2. evec/eval truncated to number of EOF mode mz<=levels + ! 3. eval here is in fact square root of eigen values (see da_allocate_background_errors) + ! 4. by default, vertical weight not calculated/used !--------------------------------------------------------------------------- implicit none diff --git a/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc b/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc index ad820375da..c615c01c15 100644 --- a/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc +++ b/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc @@ -31,7 +31,7 @@ subroutine da_transform_vvtovp_adj(grid, evec, eval, vertical_wgt, vp, vv, mz, l end if !------------------------------------------------------------------- - ! [2.0] Perform vp(i,j,k) = E L^{1/2} vv(i,j,m) transform: + ! [2.0] Perform vv(i,j,m) = L^{1/2} E^T vp(i,j,k) transform: !------------------------------------------------------------------- !$OMP PARALLEL DO & diff --git a/var/da/da_vtox_transforms/da_transform_vvtovp_inv.inc b/var/da/da_vtox_transforms/da_transform_vvtovp_inv.inc new file mode 100644 index 0000000000..fa620d7f61 --- /dev/null +++ b/var/da/da_vtox_transforms/da_transform_vvtovp_inv.inc @@ -0,0 +1,62 @@ +subroutine da_transform_vvtovp_inv(grid, evec, eval, vertical_wgt, vp, vv, mz, levels) + + !--------------------------------------------------------------------------- + ! Purpose: Inverse of da_transform_vvtovp. + ! based on da_transform_vvtovp_adj + ! + ! Author: Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + !--------------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + integer, intent(in) :: mz ! # vertical modes. + integer, intent(in) :: levels ! no. of vertical levels + + real*8, intent(in) :: evec(jds:jde,kds:kde,1:mz) ! Eigenvectors. + real*8, intent(in) :: eval(jds:jde,1:mz) ! Eigenvalues. + real, intent(in) :: vertical_wgt(ims:ime,jms:jme,kms:kme) ! Weighting. + real, intent(inout) :: vp(ims:ime,jms:jme,kms:kme)! CV in level space. + real, intent(out) :: vv(ims:ime,jms:jme,kms:kme)! CV in EOF space. + + integer :: i, j, m, k, ij ! Loop counters. + real :: temp + + if (trace_use_dull) call da_trace_entry("da_transform_vvtovp_inv") + + !------------------------------------------------------------------- + ! [1.0] Apply inner-product weighting if vertical_ip /= vertical_ip_0: + !------------------------------------------------------------------- + + if (vertical_ip /= vertical_ip_0) then + vp(its:ite,jts:jte,kts:levels) = vp(its:ite,jts:jte,kts:levels) * & + vertical_wgt(its:ite,jts:jte,kts:levels) + end if + + !------------------------------------------------------------------- + ! [2.0] Perform vv(i,j,m) = L^{-1/2} E^T vp(i,j,k) transform: + !------------------------------------------------------------------- + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, k, j, i, temp ) + do ij = 1 , grid%num_tiles + vv(:,grid%j_start(ij):grid%j_end(ij),:) = 0.0 + do m = 1, mz + do k = kts, levels + do j = grid%j_start(ij), grid%j_end(ij) + temp = evec(j,k,m) / eval(j,m) + + do i = its, ite + vv(i,j,m) = vv(i,j,m) + temp * vp(i,j,k) + end do + end do + end do + end do + end do + !$OMP END PARALLEL DO + + if (trace_use_dull) call da_trace_exit("da_transform_vvtovp_inv") + +end subroutine da_transform_vvtovp_inv + + diff --git a/var/da/da_vtox_transforms/da_vertical_transform.inc b/var/da/da_vtox_transforms/da_vertical_transform.inc index e709bd423a..2fa70c1d00 100644 --- a/var/da/da_vtox_transforms/da_vertical_transform.inc +++ b/var/da/da_vtox_transforms/da_vertical_transform.inc @@ -1,7 +1,13 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) !--------------------------------------------------------------------- - ! Purpose: TBD + ! Purpose: perform vertical transform Uv using eigenvector/eigenvalue + ! of vertical covariance + ! + ! Zhiquan (Jake) Liu, NCAR/MMM, 2015-09 + ! 1. add appropriate comments on transform and variables + ! 2. replace inverse transform da_transform_vptovv + ! by da_transform_vvtovp_inv !--------------------------------------------------------------------- implicit none @@ -30,28 +36,28 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) if (be % v1 % mz > 0) then call da_transform_vvtovp (grid, be % v1 % evec, be % v1 % val, vertical_wgt, & - vv % v1, vp % v1, be % v1 % mz, kte) + vv % v1, vp % v1, be % v1 % mz, kte) ! psi (stream function) or u (if cv7) else vp % v1(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v2 % mz > 0) then call da_transform_vvtovp (grid, be % v2 % evec, be % v2 % val, vertical_wgt, & - vv % v2, vp % v2, be % v2 % mz, kte) + vv % v2, vp % v2, be % v2 % mz, kte) ! chi_u (unbalanced chi) or v (if cv7) else vp % v2(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v3 % mz > 0) then call da_transform_vvtovp (grid, be % v3 % evec, be % v3 % val, vertical_wgt, & - vv % v3, vp % v3, be % v3 % mz, kte) + vv % v3, vp % v3, be % v3 % mz, kte) ! T_u (unbalanced T) or T (if cv7) else vp % v3(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v4 % mz > 0) then call da_transform_vvtovp (grid, be % v4 % evec, be % v4 % val, vertical_wgt, & - vv % v4, vp % v4, be % v4 % mz, kte) + vv % v4, vp % v4, be % v4 % mz, kte) ! pseudo rh=q/qs(background) else vp % v4(its:ite,jts:jte,kts:kte) = 0.0 end if @@ -61,19 +67,19 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) vp % v5(its:ite,jts:jte,1) = vv % v5(its:ite,jts:jte,1) else call da_transform_vvtovp (grid, be % v5 % evec, be % v5 % val, vertical_wgt, & - vv % v5, vp % v5, be % v5 % mz, kts) + vv % v5, vp % v5, be % v5 % mz, kts) ! Ps_u (unbalanced Ps) or Ps (if cv7) end if else vp % v5(its:ite,jts:jte,kts:kts) = 0.0 end if ! for cloud_cv_options<=1 and not use_cv_w - vp % v6 = 0.0 - vp % v7 = 0.0 - vp % v8 = 0.0 - vp % v9 = 0.0 - vp % v10 = 0.0 - vp % v11 = 0.0 + vp % v6 = 0.0 ! cloud water qcw + vp % v7 = 0.0 ! rain water qrain + vp % v8 = 0.0 ! cloud ice qice + vp % v9 = 0.0 ! snow qsnow + vp % v10 = 0.0 ! qgraupel + vp % v11 = 0.0 ! vertical velocity w if ( cloud_cv_options == 2 ) then if (be % v6 % mz > 0) then @@ -142,72 +148,62 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) case ('u_inv'); !------------------------------------------------------------------- - ! [2.0] Perform vv(i,j,m) = L^{-1/2} E^T vp(i,j,k) transform: + ! [2.0] Perform inverse transform: vv(i,j,m) = L^{-1/2} E^T vp(i,j,k) !------------------------------------------------------------------- if (be % v1 % mz > 0) then - call da_transform_vptovv (be % v1 % evec, be % v1 % val, vertical_wgt, & - vp % v1, vv % v1, be % v1 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v1 % evec, be % v1 % val, vertical_wgt, & + vp % v1, vv % v1, be % v1 % mz, kte) end if if (be % v2 % mz > 0) then - call da_transform_vptovv (be % v2 % evec, be % v2 % val, vertical_wgt, & - vp % v2, vv % v2, be % v2 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v2 % evec, be % v2 % val, vertical_wgt, & + vp % v2, vv % v2, be % v2 % mz, kte) end if if (be % v3 % mz > 0) then - call da_transform_vptovv (be % v3 % evec, be % v3 % val, vertical_wgt, & - vp % v3, vv % v3, be % v3 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v3 % evec, be % v3 % val, vertical_wgt, & + vp % v3, vv % v3, be % v3 % mz, kte) end if if (be % v4 % mz > 0) then - call da_transform_vptovv (be % v4 % evec, be % v4 % val, vertical_wgt, & - vp % v4, vv % v4, be % v4 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v4 % evec, be % v4 % val, vertical_wgt, & + vp % v4, vv % v4, be % v4 % mz, kte) end if if (be % v5 % mz > 0) then if (global) then vv % v5(its:ite,jts:jte,1) = vp % v5(its:ite,jts:jte,1) else - call da_transform_vptovv (be % v5 % evec, be % v5 % val, vertical_wgt, & - vp % v5, vv % v5, be % v5 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v5 % evec, be % v5 % val, vertical_wgt, & + vp % v5, vv % v5, be % v5 % mz, kts) end if end if if ( cloud_cv_options == 2 ) then if (be % v6 % mz > 0) then - call da_transform_vptovv (be % v6 % evec, be % v6 % val, vertical_wgt, & - vp % v6, vv % v6, be % v6 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v6 % evec, be % v6 % val, vertical_wgt, & + vp % v6, vv % v6, be % v6 % mz, kte) end if if (be % v7 % mz > 0) then - call da_transform_vptovv (be % v7 % evec, be % v7 % val, vertical_wgt, & - vp % v7, vv % v7, be % v7 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v7 % evec, be % v7 % val, vertical_wgt, & + vp % v7, vv % v7, be % v7 % mz, kte) end if if (be % v8 % mz > 0) then - call da_transform_vptovv (be % v8 % evec, be % v8 % val, vertical_wgt, & - vp % v8, vv % v8, be % v8 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v8 % evec, be % v8 % val, vertical_wgt, & + vp % v8, vv % v8, be % v8 % mz, kte) end if if (be % v9 % mz > 0) then - call da_transform_vptovv (be % v9 % evec, be % v9 % val, vertical_wgt, & - vp % v9, vv % v9, be % v9 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v9 % evec, be % v9 % val, vertical_wgt, & + vp % v9, vv % v9, be % v9 % mz, kte) end if if (be % v10 % mz > 0) then - call da_transform_vptovv (be % v10 % evec, be % v10 % val, vertical_wgt, & - vp % v10, vv % v10, be % v10 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v10 % evec, be % v10 % val, vertical_wgt, & + vp % v10, vv % v10, be % v10 % mz, kte) end if else if ( cloud_cv_options == 3 ) then @@ -236,9 +232,8 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) if ( use_cv_w ) then if (be % v11 % mz > 0) then if ( cloud_cv_options == 2 ) then - call da_transform_vptovv (be % v11 % evec, be % v11 % val, vertical_wgt, & - vp % v11, vv % v11, be % v11 % mz, kds,kde, ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) + call da_transform_vvtovp_inv (grid, be % v11 % evec, be % v11 % val, vertical_wgt, & + vp % v11, vv % v11, be % v11 % mz, kte) else if ( cloud_cv_options == 3 ) then vv % v11 = vp % v11 end if @@ -250,17 +245,21 @@ subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) ! call da_transform_vptovv (be % alpha % evec, be % alpha % val, vertical_wgt, & ! vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kds,kde, & ! ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte) - call da_transform_vptovv (be % alpha % evec, be % alpha % val, vertical_wgt, & - vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kds_int,kde_int, & - ims_int,ime_int, jms_int,jme_int, kms_int,kme_int, its_int,ite_int, & - jts_int,jte_int, kts_int,kte_int) +! call da_transform_vptovv (be % alpha % evec, be % alpha % val, vertical_wgt, & +! vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kds_int,kde_int, & +! ims_int,ime_int, jms_int,jme_int, kms_int,kme_int, its_int,ite_int, & +! jts_int,jte_int, kts_int,kte_int) + + call da_transform_vvtovp_inv (grid, be % alpha % evec, be % alpha % val, vertical_wgt, & + vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kte) + end do end if case ('u_adj'); !------------------------------------------------------------------- - ! [3.0] Perform vv_adj = U_{v}^{T} vp_adj transform: + ! [3.0] Perform adjoint transform: vv_adj = L^{1/2} E^T vp_adj !------------------------------------------------------------------- if (be % v1 % mz > 0) then diff --git a/var/da/da_vtox_transforms/da_vtox_transforms.f90 b/var/da/da_vtox_transforms/da_vtox_transforms.f90 index c82de1c652..316dc6e49b 100644 --- a/var/da/da_vtox_transforms/da_vtox_transforms.f90 +++ b/var/da/da_vtox_transforms/da_vtox_transforms.f90 @@ -65,6 +65,7 @@ module da_vtox_transforms use da_par_util, only : da_vv_to_cv, da_cv_to_vv use da_recursive_filter, only : da_transform_through_rf, & + da_transform_through_rf_inv, & da_transform_through_rf_adj, da_apply_rf, da_apply_rf_adj, & da_transform_through_rf_dual_res, da_transform_through_rf_adj_dual_res use da_reporting, only : da_error, message, da_warning, da_message @@ -86,16 +87,19 @@ module da_vtox_transforms #include "da_check_eof_decomposition.inc" #include "da_transform_vtovv.inc" #include "da_transform_vtovv_adj.inc" +#include "da_transform_vtovv_inv.inc" #include "da_transform_rescale.inc" #include "da_transform_vtox.inc" +#include "da_transform_vtox_inv.inc" #include "da_transform_xtoxa.inc" #include "da_transform_vtox_adj.inc" #include "da_transform_xtoxa_adj.inc" #include "da_transform_vptox.inc" #include "da_transform_vptox_adj.inc" +#include "da_transform_vptox_inv.inc" #include "da_transform_vvtovp.inc" #include "da_transform_vvtovp_adj.inc" -#include "da_transform_vptovv.inc" +#include "da_transform_vvtovp_inv.inc" #include "da_transform_vpatox.inc" #include "da_transform_vpatox_adj.inc" #include "da_vertical_transform.inc" diff --git a/var/mri4dvar/Makefile b/var/mri4dvar/Makefile new file mode 100644 index 0000000000..77cd279fa7 --- /dev/null +++ b/var/mri4dvar/Makefile @@ -0,0 +1,42 @@ +all: da_thin.exe da_bilin.exe da_bdy.exe da_vp_bilin.exe da_vp_split.exe + +include ../../configure.wrf +FCOPTION=$(FCFLAGS) $(PROMOTION) $(FCSUFFIX) +CCOPTION=$(CFLAGS) +LIB_EXTERNAL=-L${NETCDFPATH}/lib -lnetcdf -lnetcdff + +da_thin.exe: da_thin.o + $(SFC) -o $@ da_thin.o ${FCOPTION} $(LIB_EXTERNAL) + +da_thin.o: da_thin.f90 + $(SFC) -c ${FCOPTION} -I$(NETCDFPATH)/include $< -o $@ + +da_bilin.exe: da_bilin.o + $(SFC) -o $@ ${FCOPTION} da_bilin.o $(LIB_EXTERNAL) + +da_bilin.o: da_bilin.f90 + $(SFC) -c ${FCOPTION} -I$(NETCDFPATH)/include $< -o $@ + +da_vp_bilin.exe: da_vp_bilin.o + $(SFC) -o $@ ${FCOPTION} da_vp_bilin.o + +da_vp_bilin.o: da_vp_bilin.f90 + $(SFC) -c ${FCOPTION} $< -o $@ + +da_bdy.exe: da_bdy.o + $(SFC) -o $@ ${FCOPTION} da_bdy.o $(LIB_EXTERNAL) + +da_bdy.o: da_bdy.f90 + $(SFC) -c ${FCOPTION} -I$(NETCDFPATH)/include $< -o $@ + +task_for_point.o: task_for_point.c + $(DM_CC) -c ${CCOPTION} $< -o $@ + +da_vp_split.exe: da_vp_split.o task_for_point.o + $(DM_FC) -o $@ ${FCOPTION} da_vp_split.o task_for_point.o + +da_vp_split.o: da_vp_split.f90 + $(DM_FC) -c ${FCOPTION} $< -o $@ + +clean: + rm -rf *.o da_thin.exe da_bilin.exe da_bdy.exe da_vp_bilin.exe da_vp_split.exe diff --git a/var/mri4dvar/README.MRI-4DVar b/var/mri4dvar/README.MRI-4DVar new file mode 100644 index 0000000000..9ac858966d --- /dev/null +++ b/var/mri4dvar/README.MRI-4DVar @@ -0,0 +1,70 @@ + +This directory contains offline programs needed for multi-resolution incremental 4DVar (MRI-4DVar) +-------------- + +Liu, Z., J. Ban, J.-S, Hong, and Y.-H. Kuo, 2020: Multi-resolution incremental 4D-Var for WRF: +Implementation and application at convective scale, Q. J. R. Meteorol. Soc. , 1-14. + +da_bdy.f90 : + +da_bilin.f90 : bilinearly interpolate analysis increment + from low-resolution to high-resolution + +da_thin.f90 : thin wrfinput file + +da_vp_bilin.f90 : bilinearly interpolate control variable + from low-resolution to high-resolution + +da_vp_split.f90 : scatter global hires. control variables to different PEs + +1. To compile: +---------------- + (1) need to compile WRFDA first in 4DVAR mode, + cd your_WRFDA_dir + ./clean -a + ./configure 4dvar + ./compile all_wrfvar + (2) cd your_WRFDA_dir/var/mri4dvar + make + (3) make clean (to remove *.exe *.o files) + +da_bdy.exe +da_bilin.exe +da_thin.exe +da_vp_bilin.exe +da_vp_split.exe + +2. Domain size requirment +--------------------------- + +Only WRF input files at high resolution are required to run MRI-4DVAR. +WRF input files at low resolution are thinned from those at high resolution. +This requires that grid number at high/low resolutions to satify: + ( n - 1 ) mod m = 0 +where n is the grid number of high resolution in x or y direction, m is the +grid number of low resolution in x or y direction. + +The ratio of the high/low resolution must be odd, the default ration is 1:3. + +3. First guess files +----------------------- + +MRI-4DVAR run needs 2 time-level first guess files (fg & fg02), + +fg is at the analysis time + +fg02 is at the end of the analysis time window, or the 2nd time level of boundary +if boundary interval is less then analysis time window + +4. BE +-------- +MRI-4DVAR run only needs be.dat files at different inner loop resolutions. + +5. sample script for running 3-stage MRI-4DVar +---------------------------------------------- +wraper_mri3d4dvar.csh : wrapper script to configure MRI-4DVar +run_mri3d4dvar.csh_pbs : run 3-step MRI-4DVar with PBS job scheduler +run_mri3d4dvar.csh_lsf : run 3-step MRI-4DVar with LSF job scheduler +*.ncl: NCL scripts only for debugging purposes. + +No support can be provided for MRI-4DVar. diff --git a/var/mri4dvar/da_bdy.f90 b/var/mri4dvar/da_bdy.f90 new file mode 100644 index 0000000000..8567d04e2b --- /dev/null +++ b/var/mri4dvar/da_bdy.f90 @@ -0,0 +1,681 @@ +program da_bdy + +!---------------------------------------------------------------------- +! Purpose: Generates boundary file by using wrfinput +! +! Input : fg -- first time level wrfinput generated by real +! fg02 -- second time level wrfinput generated by real +! wrfbdy_ref -- reference boundary file generated by real +! +! Output : wrfbdy_out -- the output boundary file +! +! Notes : 1. variable name and attributes, dimension name, bdy_width +! come from wrfbdy. +! 2. domain size and time come from fg +! 3. boundary and tendency are calculated by using fg & fg02 +! 4. the output boundary file only contain the 1st time level +! +! jliu@ucar.edu , 2011-12-15 +!---------------------------------------------------------------------- + + use netcdf + + implicit none + + integer :: i, n, offset, bdyfrq, domainsize, fg_jd, fg02_jd + + integer :: ncid, ncidfg, ncidfg02, ncidwrfbdy, ncidvarbdy, varid, varid_out, status + integer :: nDims, nVars, nGlobalAtts, numsAtts + integer :: dLen, attLen, xtype, unlimDimID + integer :: bdy_width, varbdy_dimID, wrfbdy_dimID, fg_dimID, vTimes_ID, MSF_ID + integer :: MU_fgID, MU_fg02ID, MUB_fgID, MUB_fg02ID, fg_varid, fg02_varid, tenid + + integer, dimension(4) :: dsizes + integer, dimension(4), target :: start_u, start_v, start_mass + integer, dimension(4) :: cnt_4d, map_4d + integer, dimension(3) :: start_3d, cnt_3d, map_3d + integer, dimension(3), target :: start_msfu, start_msfv, cnt_msfu, cnt_msfv, map_msfu, map_msfv + integer, dimension(:), pointer :: start_msf, cnt_msf, map_msf, start_4d + + integer :: south_north, south_north_stag + integer :: west_east, west_east_stag + integer :: bottom_top, bottom_top_stag + + integer, dimension(nf90_max_var_dims) :: vDimIDs + integer, dimension(:), allocatable :: vdimsizes + integer, dimension(:,:,:,:), allocatable :: iVar + + real, dimension(:,:,:,:), allocatable :: fVar_fg, fVar_fg02, Tend + real, dimension(:,:,:), allocatable , target :: MU_fg, MU_fg02, MUB_fg, MUB_fg02, MSF + + real, dimension(:,:,:), pointer :: MU_fgptr, MU_fg02ptr, MUB_fgptr, MUB_fg02ptr, MSF_ptr + + character (len = 19), dimension(:), allocatable :: times + character (len = 19) :: fg_time, fg02_time + character (len = 5) :: tenname + character (len = NF90_MAX_NAME) :: vNam, dNam, attNam + character (len = 9) :: MSF_NAME + character (len = 255) :: err_msg="" + character (len=8) :: i_char + character (len=255) :: arg = "" + character (len=255) :: appname ="" + character (len=255) :: fg = "fg" + character (len=255) :: fg02 = "fg02" + character (len=255) :: wrfbdy = "wrfbdy_ref" + character (len=255) :: varbdy = "wrfbdy_out" + + logical :: reverse, couple, stag + + integer iargc + + call getarg(0, appname) + n=index(appname, '/', BACK=.true.) + appname = trim(appname(n+1:)) + + DO i = 1, iargc(), 2 + call getarg(i, arg) + select case ( trim(arg) ) + case ("-fg") + call getarg(i+1, arg) + fg=trim(arg) + case ("-fg02") + call getarg(i+1, arg) + fg02=trim(arg) + case ("-bdy") + call getarg(i+1, arg) + wrfbdy=trim(arg) + case ("-o") + call getarg(i+1, arg) + varbdy=trim(arg) + case default + Write(*,*) "Usage : "//trim(appname)//" [-fg filename] [-fg02 filename] [-bdy filename] [-o outputfile] [-h]" + Write(*,*) " -fg Optional, 1st time levle first guess file, default - fg" + Write(*,*) " -fg02 Optional, 2nd time levle first guess file, default - fg02" + Write(*,*) " -bdy Optional, reference boundary file comes from real, default - wrfbdy_ref" + Write(*,*) " -o Optional, output boundary file, default - varbdy_out" + Write(*,*) " -h Show this usage" + call exit(0) + end select + END DO + + + status = nf90_open(fg, NF90_NOWRITE, ncidfg) + if ( status /= nf90_noerr ) then + err_msg="Failed to open "//trim(fg) + call nf90_handle_err(status, err_msg) + endif + + status = nf90_open(fg02, NF90_NOWRITE, ncidfg02) + if ( status /= nf90_noerr ) then + err_msg="Failed to open "//trim(fg02) + call nf90_handle_err(status, err_msg) + endif + + status = nf90_inq_varid(ncidfg, "Times", vTimes_ID ) + if ( status /= nf90_noerr ) then + err_msg="Please make sure fg has a vaild Times variable" + call nf90_handle_err(status, err_msg) + endif + + status = nf90_get_var(ncidfg, vTimes_ID, fg_time) + if ( status /= nf90_noerr ) then + err_msg="Please make sure fg has a vaild Time value" + call nf90_handle_err(status, err_msg) + endif + + status = nf90_inq_varid(ncidfg02, "Times", vTimes_ID ) + if ( status /= nf90_noerr ) then + err_msg="Please make sure fg02 has a vaild Times variable" + call nf90_handle_err(status, err_msg) + endif + + status = nf90_get_var(ncidfg02, vTimes_ID, fg02_time) + if ( status /= nf90_noerr ) then + err_msg="Please make sure fg02 has a vaild Time value" + call nf90_handle_err(status, err_msg) + endif + + status = nf90_open(wrfbdy, NF90_NOWRITE, ncidwrfbdy) + if ( status /= nf90_noerr ) then + err_msg="Failed to open "//trim(wrfbdy) + call nf90_handle_err(status, err_msg) + endif + + status = nf90_create(varbdy, NF90_CLOBBER, ncidvarbdy) + if ( status /= nf90_noerr ) then + err_msg="Please make sure have write access" + call nf90_handle_err(status, err_msg) + endif + + bdyfrq = datediff(fg_time, fg02_time) + + select case ( bdyfrq ) + case ( 0 ) + bdyfrq = 1 + case ( : -1 ) + Write (*,*) "***WARNNING : time levle of fg is LATER then fg02's.***" + end select + + write(i_char, '(i8)') bdyfrq + + Write(*,*) " Input :" + Write(*,*) " fg "//fg_time + Write(*,*) " fg02 "//fg02_time + Write(*,*) " Reference bdy "//trim(wrfbdy) + Write(*,*) "Output : " + Write(*,*) " wrfbdy_out "//fg_time + Write(*,*) " bdyfrq ",adjustl(i_char) + + status = nf90_inquire(ncidfg, nAttributes=nGlobalAtts) + do i=1, nGlobalAtts + status = nf90_inq_attname(ncidfg, NF90_GLOBAL, i, attNam) + status = nf90_copy_att(ncidfg, NF90_GLOBAL, attNam, ncidvarbdy, NF90_GLOBAL) + end do + + status = nf90_inquire(ncidwrfbdy, nDims, nVars, nGlobalAtts, unlimDimID) + if ( status /= nf90_noerr ) then + err_msg="Please make sure have a valid wrf boundary file" + call nf90_handle_err(status, err_msg) + endif + + allocate (vdimsizes(nDims), stat=status) + + do i=1, nDims + + status = nf90_inquire_dimension(ncidwrfbdy, i, name=dNam, len = dLen) + + vdimsizes(i) = dLen + select case (trim(dNam)) + case ("south_north") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + south_north = vdimsizes(i) + case ("west_east") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + west_east = vdimsizes(i) + case ("south_north_stag") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + south_north_stag = vdimsizes(i) + case ("west_east_stag") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + west_east_stag = vdimsizes(i) + case ("bottom_top") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + bottom_top = vdimsizes(i) + case ("bottom_top_stag") + status = nf90_inq_dimid(ncidfg, dNam, fg_dimID) + status = nf90_inquire_dimension(ncidfg, fg_dimID, len=dLen) + vdimsizes(i) = dLen + bottom_top_stag = vdimsizes(i) + case ("Time") + vdimsizes(i) = 1 + allocate(times(vdimsizes(i)), stat=status) + case ("bdy_width") + bdy_width = dLen + end select + + if ( i == unlimDimID ) dLen = NF90_UNLIMITED + + status = nf90_def_dim(ncidvarbdy, dNam, dLen, varbdy_dimID) + + end do + + status = nf90_inq_varid(ncidfg , "MU" , MU_fgID ) + status = nf90_inq_varid(ncidfg , "MUB", MUB_fgID ) + status = nf90_inq_varid(ncidfg02, "MU" , MU_fg02ID ) + status = nf90_inq_varid(ncidfg02, "MUB", MUB_fg02ID) + + status = nf90_inq_varid(ncidfg, "Times", vTimes_ID ) + + do varid=1, nVars + + status = nf90_inquire_variable(ncidwrfbdy,varid,name=vNam,xtype=xtype,ndims=nDims,dimids=vDimIDs,natts=numsAtts) + status = nf90_def_var(ncidvarbdy, trim(vNam), xtype, vDimIDs(1:nDims), varid_out) + if ( status /= nf90_noerr ) then + err_msg="Failed to define variable : "//trim(vNam) + call nf90_handle_err(status, err_msg) + endif + + do i=1, numsAtts + status = nf90_inq_attname(ncidwrfbdy, varid, i, attNam) + status = nf90_copy_att(ncidwrfbdy, varid, trim(attNam), ncidvarbdy, varid_out) + if ( status /= nf90_noerr ) then + err_msg="Failed to copy att : "//trim(attNam) + call nf90_handle_err(status, err_msg) + endif + end do + + end do + + status = nf90_enddef(ncidvarbdy) + + do varid=1, nVars + + status = nf90_inquire_variable(ncidwrfbdy,varid,name=vNam,xtype=xtype,ndims=nDims,dimids=vDimIDs) + if ( status /= nf90_noerr ) then + err_msg="Failed to inquire varialbe '"//trim(vNam)//"' for wrfbdy" + call nf90_handle_err(status, err_msg) + endif + + dsizes = 1 + do i = 1 , nDims + dsizes(i) = vdimsizes(vDimIDs(i)) + end do + + offset = index(vNam, '_', BACK=.True.) + if ( offset <= 0 ) offset = Len(Trim(vNam)) + + ! fg + ! U (west_east_stag, south_north, bottom_top, time) + ! V (west_east, south_north_stag, bottom_top, time) + ! T, QVAPOR (west_east, south_north, bottom_top, time) + ! PH (west_east, south_north, bottom_top_stag, time) + ! MU (west_east, south_north, time) + ! MAPFAC_U (west_east_stag, south_north, time) + ! MAPFAC_V (west_east, south_north_stag, time) + ! bdy + ! west & east + ! U (south_north, bottom_top, bdy_width, time) + ! V (south_north_stag, bottom_top, bdy_width, time) + ! T, QVAPOR (south_north, bottom_top, bdy_width, time) + ! PH (south_north, bottom_top_stag, bdy_width, time) + ! MU (south_north, bdy_width, time) + ! north & south + ! U (west_east_stag, bottom_top, bdy_width, time) + ! V (west_east, bottom_top, bdy_width, time) + ! T, QVAPOR (west_east, bottom_top, bdy_width, time) + ! PH (west_east, bottom_top_stag, bdy_width, time) + ! MU (west_east, bdy_width, time) + + select case (Trim(vNam(offset:))) + case ("_BXS") ! West Boundary + start_u = (/1,1,1,1/) + start_v = (/1,1,1,1/) + start_mass = (/1,1,1,1/) + start_3d = (/1,1,1/) + start_msfu = (/1,1,1/) + start_msfv = (/1,1,1/) + + cnt_4d = (/dsizes(3),dsizes(1),dsizes(2),1/) + cnt_3d = (/bdy_width,south_north,1/) + cnt_msfu = (/bdy_width,south_north,1/) + cnt_msfv = (/bdy_width,south_north_stag,1/) + + map_4d = (/dsizes(1)*dsizes(2), 1, dsizes(1), dsizes(1)*dsizes(2)*dsizes(3)/) + map_3d = (/south_north, 1, bdy_width*south_north/) + map_msfu = (/south_north, 1, bdy_width*south_north/) + map_msfv = (/south_north_stag, 1, bdy_width*south_north_stag/) + + reverse = .False. + tenname = "_BTXS" + case ("_BXE") ! East Boundary + start_u = (/west_east_stag - bdy_width + 1, 1, 1, 1/) + start_v = (/west_east - bdy_width + 1, 1, 1, 1/) + start_mass = (/west_east - bdy_width + 1, 1, 1, 1/) + start_3d = (/west_east - bdy_width + 1, 1, 1/) + start_msfu = (/west_east_stag - bdy_width + 1, 1, 1/) + start_msfv = (/west_east - bdy_width + 1, 1, 1/) + + cnt_4d = (/dsizes(3),dsizes(1),dsizes(2),1/) + cnt_3d = (/bdy_width,south_north,1/) + cnt_msfu = (/bdy_width,south_north,1/) + cnt_msfv = (/bdy_width,south_north_stag,1/) + + map_4d = (/dsizes(1)*dsizes(2), 1, dsizes(1), dsizes(1)*dsizes(2)*dsizes(3)/) + map_3d = (/south_north, 1, bdy_width*south_north/) + map_msfu = (/south_north, 1, bdy_width*south_north/) + map_msfv = (/south_north_stag, 1, bdy_width*south_north_stag/) + + reverse = .True. + tenname = "_BTXE" + case ("_BYE") ! North Boundary + start_u = (/1, south_north - bdy_width + 1, 1, 1/) + start_v = (/1, south_north_stag - bdy_width + 1, 1, 1/) + start_mass = (/1, south_north - bdy_width + 1, 1, 1/) + start_3d = (/1, south_north - bdy_width + 1, 1/) + start_msfu = (/1, south_north - bdy_width + 1, 1/) + start_msfv = (/1, south_north_stag - bdy_width + 1, 1/) + + cnt_4d = (/dsizes(1),dsizes(3),dsizes(2),1/) + cnt_3d = (/west_east, bdy_width,1/) + cnt_msfu = (/west_east_stag, bdy_width,1/) + cnt_msfv = (/west_east, bdy_width,1/) + + map_4d = (/1, dsizes(1)*dsizes(2), dsizes(1), dsizes(3)*dsizes(1)*dsizes(2)/) + map_3d = (/1, west_east, west_east*bdy_width/) + map_msfu = (/1, west_east_stag, west_east_stag*bdy_width/) + map_msfv = (/1, west_east, west_east*bdy_width/) + + reverse = .True. + tenname = "_BTYE" + + case ("_BYS") ! South Boundary + start_u = (/1, 1, 1, 1/) + start_v = (/1, 1, 1, 1/) + start_mass = (/1, 1, 1, 1/) + start_3d = (/1, 1, 1/) + start_msfu = (/1, 1, 1/) + start_msfv = (/1, 1, 1/) + + cnt_4d = (/dsizes(1),dsizes(3),dsizes(2),1/) + cnt_3d = (/west_east, bdy_width,1/) + cnt_msfu = (/west_east_stag, bdy_width,1/) + cnt_msfv = (/west_east, bdy_width,1/) + + map_4d = (/1, dsizes(1)*dsizes(2), dsizes(1), dsizes(3)*dsizes(1)*dsizes(2)/) + map_3d = (/1, west_east, west_east*bdy_width/) + map_msfu = (/1, west_east_stag, west_east_stag*bdy_width/) + map_msfv = (/1, west_east, west_east*bdy_width/) + + reverse = .False. + tenname = "_BTYS" + + case ("_BTXS", "_BTXE","_BTYS","_BTYE") + cycle + end select + + select case (nDims) + case (2) + if (vNam(1:offset) == "Times") then + ncid = ncidfg + else + n = index(vNam, "bdytime") + if ( n <= 0 ) cycle + select case (vNam(n-4:n-1)) + case ("this") + ncid = ncidfg + case ("next") + ncid = ncidfg02 + case default + cycle + end select + end if + status = nf90_get_var(ncid, vTimes_ID, times) + status = nf90_put_var(ncidvarbdy, varid, times) + case (3,4) + + Write(*,*) "Processing for "//trim(vNam) + + couple = .true. + + allocate(MU_fg (dsizes(1),bdy_width,1), stat=status) + allocate(MU_fg02 (dsizes(1),bdy_width,1), stat=status) + allocate(MUB_fg (dsizes(1),bdy_width,1), stat=status) + allocate(MUB_fg02(dsizes(1),bdy_width,1), stat=status) + allocate(MSF (dsizes(1),bdy_width,1), stat=status) + + allocate(Tend(dsizes(1), dsizes(2), dsizes(3), dsizes(4)), stat=status) + + if ( dsizes(1) == west_east_stag .or. dsizes(1) == south_north_stag ) then + MU_fgptr => MU_fg (2:,:,:) + MU_fg02ptr => MU_fg02 (2:,:,:) + MUB_fgptr => MUB_fg (2:,:,:) + MUB_fg02ptr => MUB_fg02(2:,:,:) + stag = .True. + else + MU_fgptr => MU_fg + MU_fg02ptr => MU_fg02 + MUB_fgptr => MUB_fg + MUB_fg02ptr => MUB_fg02 + stag = .False. + end if + + err_msg="Failed to get variable : "//trim(vNam) + status = nf90_get_var(ncidfg, MU_fgID, MU_fgptr, start=start_3d, count=cnt_3d, map=map_3d) + if ( status /= nf90_noerr ) call nf90_handle_err(status, err_msg) + + status = nf90_get_var(ncidfg02, MU_fg02ID, MU_fg02ptr, start=start_3d,count=cnt_3d, map=map_3d) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + status = nf90_get_var(ncidfg, MUB_fgID, MUB_fgptr, start=start_3d, count=cnt_3d,map=map_3d) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + status = nf90_get_var(ncidfg02, MUB_fg02ID, MUB_fg02ptr, start=start_3d, count=cnt_3d, map=map_3d) + if(status /= nf90_noerr) call nf90_handle_err(status, err_msg) + + err_msg="Failed to inquire tendency id for "//trim(vNam)//" for output file" + status = nf90_inq_varid(ncidvarbdy, vNam(1:offset-1)//tenname, tenid) + if(status /= nf90_noerr) call nf90_handle_err(status, err_msg) + + if ( reverse ) then + MU_fg = MU_fg (:,bdy_width:1:-1,:) + MU_fg02 = MU_fg02 (:,bdy_width:1:-1,:) + MUB_fg = MUB_fg (:,bdy_width:1:-1,:) + MUB_fg02 = MUB_fg02(:,bdy_width:1:-1,:) + end if + + select case (vNam(1:offset)) + case ("U_", "V_") + if ( stag ) then + MU_fg (1,:,:) = MU_fg (2,:,:) + MU_fg02 (1,:,:) = MU_fg02 (2,:,:) + MUB_fg (1,:,:) = MUB_fg (2,:,:) + MUB_fg02(1,:,:) = MUB_fg02(2,:,:) + + MU_fg (2:dsizes(1)-1,:,:) = (MU_fg (2:dsizes(1)-1,:,:) + MU_fg (3:dsizes(1),:,:))*0.5 + MU_fg02 (2:dsizes(1)-1,:,:) = (MU_fg02 (2:dsizes(1)-1,:,:) + MU_fg02 (3:dsizes(1),:,:))*0.5 + MUB_fg (2:dsizes(1)-1,:,:) = (MUB_fg (2:dsizes(1)-1,:,:) + MUB_fg (3:dsizes(1),:,:))*0.5 + MUB_fg02(2:dsizes(1)-1,:,:) = (MUB_fg02(2:dsizes(1)-1,:,:) + MUB_fg02(3:dsizes(1),:,:))*0.5 + else + MU_fg (:,2:bdy_width,:) = (MU_fg (:,1:bdy_width-1,:) + MU_fg (:,2:bdy_width,:))*0.5 + MU_fg02 (:,2:bdy_width,:) = (MU_fg02 (:,1:bdy_width-1,:) + MU_fg02 (:,2:bdy_width,:))*0.5 + MUB_fg (:,2:bdy_width,:) = (MUB_fg (:,1:bdy_width-1,:) + MUB_fg (:,2:bdy_width,:))*0.5 + MUB_fg02(:,2:bdy_width,:) = (MUB_fg02(:,1:bdy_width-1,:) + MUB_fg02(:,2:bdy_width,:))*0.5 + end if + + if ( vNam(1:offset) == "U_" ) then + start_4d => start_u + start_msf => start_msfu + cnt_msf => cnt_msfu + map_msf => map_msfu + MSF_NAME = "MAPFAC_U" + else + start_4d => start_v + start_msf => start_msfv + cnt_msf => cnt_msfv + map_msf => map_msfv + MSF_NAME = "MAPFAC_V" + end if + + status = nf90_inq_varid(ncidfg , MSF_NAME , MSF_ID ) + err_msg="Failed to get varialbe MSF" + status = nf90_get_var(ncidfg, MSF_ID, MSF, start=start_msf, count=cnt_msf, map=map_msf) + if(status /= nf90_noerr) call nf90_handle_err(status, err_msg) + + if ( reverse ) MSF = MSF(:,bdy_width:1:-1,:) + + case ("T_","PH_","QVAPOR_") + MSF = 1.0 + start_4d => start_mass + case ("MU_") + status = nf90_inq_varid(ncidvarbdy, "MU"//tenname, tenid) + Tend(:,:,:,1) = ( MU_fg02 - MU_fg ) / bdyfrq + status = nf90_put_var(ncidvarbdy, varid, MU_fg) + !status = nf90_put_var(ncidvarbdy, varid, MU_fg02) + err_msg="Failed to put variable "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + status = nf90_put_var(ncidvarbdy, tenid, Tend(:,:,:,1)) + err_msg="Failed to put tendency for "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + couple = .false. + + case default + Tend = 0.0 + couple = .false. + select case (xtype) + case (nf90_float) + allocate(fVar_fg( dsizes(1), dsizes(2), dsizes(3), dsizes(4) ), stat=status) + fVar_fg = 0.0 + status = nf90_put_var(ncidvarbdy, varid, fVar_fg) + err_msg="Failed to put variable "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + status = nf90_put_var(ncidvarbdy, tenid, Tend) + err_msg="Failed to put tendency for "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + deallocate (fVar_fg) + case (nf90_int) + allocate(iVar( dsizes(1), dsizes(2), dsizes(3), dsizes(4) ), stat=status) + iVar = 0 + status = nf90_put_var(ncidvarbdy, varid, iVar) + err_msg="Failed to put variable "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + status = nf90_put_var(ncidvarbdy, tenid, Tend) + err_msg="Failed to put tendency for "//trim(vNam) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + deallocate (iVar) + end select ! end of xtype + + end select ! end of vNam + + if ( couple ) then + + allocate( fVar_fg(dsizes(1), dsizes(2), dsizes(3), dsizes(4)), stat=status) + allocate(fVar_fg02(dsizes(1), dsizes(2), dsizes(3), dsizes(4)), stat=status) + + err_msg="Failed to inquire variable id for "//vNam(1:offset-1)//" for fg" + status = nf90_inq_varid(ncidfg, vNam(1:offset-1), fg_varid) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + err_msg="Failed to inquire variable id for "//vNam(1:offset-1)//" for fg02" + status = nf90_inq_varid(ncidfg02, vNam(1:offset-1), fg02_varid) + if(status /= nf90_noerr) call nf90_handle_err(status, err_msg) + + err_msg="Failed to inquire tendency id for "//trim(vNam(1:offset-1))//" for output file" + status = nf90_inq_varid(ncidvarbdy, vNam(1:offset-1)//tenname, tenid) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + err_msg="Failed to get variable "//vNam(1:offset-1)//" from fg" + status = nf90_get_var(ncidfg, fg_varid, fVar_fg, start=start_4d, count=cnt_4d, map=map_4d) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + err_msg="Failed to get variable "//vNam(1:offset-1)//" from fg02" + status = nf90_get_var(ncidfg02, fg02_varid, fVar_fg02, start=start_4d, count=cnt_4d, map=map_4d) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + MU_fg = MU_fg + MUB_fg + MU_fg02 = MU_fg02 + MUB_fg + !MU_fg02 = MU_fg02 + MUB_fg02 + + if ( reverse ) then + fVar_fg = fVar_fg (:,:,bdy_width:1:-1,:) + fVar_fg02 = fVar_fg02(:,:,bdy_width:1:-1,:) + end if + + do i = 1, dsizes(2) + fVar_fg(:,i,:,:) = (fVar_fg (:,i,:,:) * MU_fg ) / MSF + fVar_fg02(:,i,:,:) = (fVar_fg02(:,i,:,:) * MU_fg02) / MSF + end do + + Tend = ( fVar_fg02 - fVar_fg ) / bdyfrq + + err_msg="Failed to put variable "//trim(vNam) + status = nf90_put_var(ncidvarbdy, varid, fVar_fg) + !status = nf90_put_var(ncidvarbdy, varid, fVar_fg02) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + err_msg="Failed to put tendency for "//trim(vNam) + status = nf90_put_var(ncidvarbdy, tenid, Tend) + if(status /= nf90_noerr) call nf90_handle_err(status,err_msg) + + deallocate (fVar_fg) + deallocate (fVar_fg02) + + end if + + NULLIFY (MU_fgptr) + NULLIFY (MU_fg02ptr) + NULLIFY (MUB_fgptr) + NULLIFY (MUB_fg02ptr) + NULLIFY (MSF_ptr) + + deallocate (Tend) + deallocate (MU_fg) + deallocate (MU_fg02) + deallocate (MUB_fg) + deallocate (MUB_fg02) + deallocate (MSF) + case default + cycle + end select ! end of nDims + + end do + + deallocate (times) + + status = nf90_close(ncidfg) + status = nf90_close(ncidfg02) + status = nf90_close(ncidwrfbdy) + status = nf90_close(ncidvarbdy) + + Write(*,*) "Boundary file generated successfully" + +contains + + subroutine nf90_handle_err(status, err_msg) + integer, intent (in) :: status + character (len=*), intent(in) :: err_msg + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + print *, trim(err_msg) + call exit(-1) + end if + end subroutine nf90_handle_err + + function jd(yyyy, mm, dd) result(ival) + + integer, intent(in) :: yyyy + integer, intent(in) :: mm + integer, intent(in) :: dd + integer :: ival + + ! DATE ROUTINE JD(YYYY, MM, DD) CONVERTS CALENDER DATE TO + ! JULIAN DATE. SEE CACM 1968 11(10):657, LETTER TO THE + ! EDITOR BY HENRY F. FLIEGEL AND THOMAS C. VAN FLANDERN. + ! EXAMPLE JD(1970, 1, 1) = 2440588 + + ival = dd - 32075 + 1461*(yyyy+4800+(mm-14)/12)/4 + & + 367*(mm-2-((mm-14)/12)*12)/12 - 3*((yyyy+4900+(mm-14)/12)/100)/4 + + return + end function jd + + function datediff(date_1, date_2) result(ival) + + character(len=*), intent(in) :: date_1 + character(len=*), intent(in) :: date_2 + integer :: ival + integer :: jd1, jd2 + integer :: yyyy,mm,dd + integer :: hh1,nn1,ss1 + integer :: hh2,nn2,ss2 + + + ! date string : yyyy-mm-dd_hh:mm:ss + ! calculate the difference between date_1 and date_2 in seconds + + read(date_1(1:19), '(i4,5(1x,i2))') & + yyyy, mm, dd, hh1, nn1, ss1 + + jd1=jd(yyyy,mm,dd) + + read(date_2(1:19), '(i4,5(1x,i2))') & + yyyy, mm, dd, hh2, nn2, ss2 + + jd2=jd(yyyy,mm,dd) + + ival=(jd2-jd1)*86400 + ( hh2-hh1)*3600 + (nn2-nn1)*60 + (ss2-ss1) + + return + end function datediff + +end program da_bdy diff --git a/var/mri4dvar/da_bilin.f90 b/var/mri4dvar/da_bilin.f90 new file mode 100644 index 0000000000..d80417c187 --- /dev/null +++ b/var/mri4dvar/da_bilin.f90 @@ -0,0 +1,369 @@ +program da_bilin + +!---------------------------------------------------------------------- +! Purpose: Regridding increment from low-resolution to high-resolution +! by using bilinear interpolation +! +! Input : fg -- low resolution first guess file +! wrfvar_output -- low resolution analysis file +! wrfinput_hires -- high resolution first guess file +! +! Output : wrfvar_output_hires -- regridded high resolution analysis +! +! Increment = an_lores - fg_lores +! wrfvar_output_hires = Increment + wrfinput_hires +! +! In order to keep the domain size, it needs to match ( n - 1 )*ns + 1 +! +! where n is the grid number in x or y +! ns is the refinement ratio between two resulotions +! +! Compile: +! +! pgf90 -o da_bilin.exe -I$NETCDF/include -L$NETCDF/lib -lnetcdf da_bilin.f90 +! +! Usage: +! +! da_bilin.exe [-h] [-fg_lores filename] [-an_lores filename] +! [-fg_hires filename] [-ns n ] [-o outputfile] +! +! -fg_lores Optional, low resulotion first guess file, default - fg" +! -an_lores Optional, low resulotion analysis file comes from wrfvar, default - wrfvar_output" +! -fg_hires Optional, high resultion first guess file, default - wrfinput_hires" +! -ns Optional, the refinement ratio between two resulotions, default - 3" +! -o Optional, output high resulotion analysis file, default - wrfvar_output_hires" +! -h Show this help" +! +! jliu@ucar.edu , 2011-12-15 +!---------------------------------------------------------------------- + + use netcdf + + implicit none + + !These variables' incremental will be regridded by default + character (len=6), dimension(1:19) :: vNam + + integer :: i, j, k, n, status + integer :: nLat, nLon, oLat, oLon + integer :: sLat, eLat, sLon, eLon + integer :: rLat, rLon + + integer :: ncidfg, ncidan, ncidout + integer :: varid, nDims, dLen, varid_fg, varid_an, dimid + integer :: regridsize, domainsize_out + + real, dimension(:,:,:,:), allocatable :: fg, an, increment, var_out + real, dimension(:,:), allocatable :: iVar, oVar + + integer, dimension(nf90_max_var_dims) :: vDimIDs + integer, dimension(4) :: vdimsizes + + character (len = 19), dimension(:), allocatable :: times + character (len = 255) :: appname = "" + character (len = 255) :: arg = "" + character (len = 255) :: fg_lores = "fg" + character (len = 255) :: an_lores = "wrfvar_output" + character (len = 255) :: fg_hires = "wrfinput_hires" + character (len = 255) :: f_out = "wrfvar_output_hires" + character (len = 255) :: errmsg = "" + character (len = 8) :: i_char = "" + + integer :: ns = 3 + !integer :: cloud_cv_options = 0 + !integer :: cv_w = 0 + + LOGICAL :: file_exists + + integer iargc + + !These variables' incremental will be regridded by default + + vNam(1)="U" + vNam(2)="V" + vNam(3)="T" + vNam(4)="QVAPOR" + vNam(5)="PH" + vNam(6)="P" + vNam(7)="MU" + vNam(8)="U10" + vNam(9)="V10" + vNam(10)="T2" + vNam(11)="Q2" + vNam(12)="PSFC" + vNam(13)="TH2" + + vNam(14)="QCLOUD" + vNam(15)="QRAIN" + vNam(16)="QICE" + vNam(17)="QSNOW" + vNam(18)="QGRAUP" + vNam(19)="W" + + call getarg(0, appname) + n=index(appname, '/', BACK=.true.) + appname = trim(appname(n+1:)) + + DO i = 1, iargc(), 2 + arg="" + call getarg(i, arg) + select case ( trim(arg) ) + case ("-fg_lores") + call getarg(i+1, arg) + fg_lores=trim(arg) + case ("-an_lores") + call getarg(i+1, arg) + an_lores=trim(arg) + case ("-fg_hires") + call getarg(i+1, arg) + fg_hires=trim(arg) + case ("-ns") + call getarg(i+1, arg) + read(arg, '(i3)') ns + case ("-o") + call getarg(i+1, arg) + f_out=trim(arg) + !case ("-cloud_cv_options") + ! call getarg(i+1, arg) + ! read(arg, '(i3)') cloud_cv_options + !case ("-cv_w") + ! call getarg(i+1, arg) + ! read(arg, '(i3)') cv_w + case default + call show_usage() + call exit(0) + end select + END DO + + write (i_char, '(i8)') ns + + inquire(FILE=trim(fg_hires), EXIST=file_exists) + + if ( .not. file_exists ) then + Write(*,*) "\nError: "//trim(fg_hires)//" not exists\n" + call show_usage() + call exit(-1) + endif + + call system("cp "//fg_hires//" "//f_out) + + status = nf90_open(fg_lores, NF90_NOWRITE, ncidfg) + errmsg = trim(fg_lores) + if ( status /= nf90_noerr ) call nf90_handle_err(status, errmsg) + + status = nf90_open(an_lores, NF90_NOWRITE, ncidan) + errmsg = trim(an_lores) + if ( status /= nf90_noerr ) call nf90_handle_err(status, errmsg) + + status = nf90_open(f_out, NF90_WRITE, ncidout) + errmsg= trim(f_out) + if ( status /= nf90_noerr ) call nf90_handle_err(status, errmsg) + + status = nf90_inq_dimid(ncidout, "west_east_stag", dimid) + status = nf90_inquire_dimension(ncidout, dimid, len=dLen) + domainsize_out = dLen + + status = nf90_inq_dimid(ncidout, "south_north_stag", dimid) + status = nf90_inquire_dimension(ncidout, dimid, len=dLen) + domainsize_out = domainsize_out * dLen + + status = nf90_inq_dimid(ncidfg, "west_east_stag", dimid) + status = nf90_inquire_dimension(ncidfg, dimid, len=dLen) + regridsize = (dLen-1)*ns+1 + + status = nf90_inq_dimid(ncidfg, "south_north_stag", dimid) + status = nf90_inquire_dimension(ncidfg, dimid, len=dLen) + regridsize = regridsize * ( (dLen-1)*ns+1 ) + + if ( regridsize /= domainsize_out ) then + Write(*,'(a,i2,a)') "Error : It needs to match m = (n-1)*",ns, & + "+1 where n is coarse grid number in x or y, "// & + "m is fine grid number in x or y." + call exit(-1) + end if + + write (i_char, '(i8)') ns + + Write(*,*) " Input :" + Write(*,*) " Low resolution first guess : "//trim(fg_lores) + Write(*,*) " Low resolution analysis : "//trim(an_lores) + Write(*,*) " High resolution first guess : "//trim(fg_hires) + Write(*,*) " ns : "//adjustl(i_char) + Write(*,*) "Output :" + Write(*,*) " High resolution analysis : "//trim(f_out) + + errmsg = "" + + n = ubound(vNam,1) + do i=1,n + + Write (*,*) "Regridding increment for "//trim(vNam(i)) + + status = nf90_inq_varid(ncidout, trim(vNam(i)), varid) + status = nf90_inquire_variable(ncidout, varid, ndims=nDims,dimids=vDimIDs) + + vdimsizes = 1 + do j=1, nDims + status = nf90_inquire_dimension(ncidout, vDimIDs(j), len = dLen ) + vdimsizes(j) = dLen + end do + + allocate(var_out(vdimsizes(1), vdimsizes(2), vdimsizes(3), vdimsizes(4)), stat=status) + + status = nf90_get_var(ncidout, varid, var_out) + + status = nf90_inq_varid(ncidfg, trim(vNam(i)), varid_fg) + status = nf90_inq_varid(ncidan, trim(vNam(i)), varid_an) + + status = nf90_inquire_variable(ncidfg, varid_fg, ndims=nDims,dimids=vDimIDs) + + vdimsizes = 1 + do j=1, nDims + status = nf90_inquire_dimension(ncidfg, vDimIDs(j), len = dLen ) + vdimsizes(j) = dLen + end do + + allocate(fg(vdimsizes(1), vdimsizes(2), vdimsizes(3), vdimsizes(4)), stat=status) + allocate(an(vdimsizes(1), vdimsizes(2), vdimsizes(3), vdimsizes(4)), stat=status) + allocate(increment(vdimsizes(1), vdimsizes(2), vdimsizes(3), vdimsizes(4)), stat=status) + + status = nf90_get_var(ncidfg, varid_fg, fg) + status = nf90_get_var(ncidan, varid_an, an) + + increment = an - fg + + nLon = vdimsizes(1) + nLat = vdimsizes(2) + + if ( trim(vNam(i) ) == "U" ) then + rLat = nLat * ns + rLon = (nLon-1) * ns + 1 + nLat = nLat + 2 + else + rLon = nLon * ns + rLat = (nLat-1) * ns + 1 + nLon = nLon + 2 + if ( trim(vNam(i)) /= "V" ) then + rLat = nLat * ns + nLat = nLat + 2 + endif + endif + + oLon = ( nLon - 1 ) * ns + 1 + oLat = ( nLat - 1 ) * ns + 1 + + elat = (oLat - rLat) / 2 + slat = oLat - rLat - elat + 1 + + elon = (oLon - rLon) / 2 + slon = oLon - rLon - elon + 1 + + allocate(iVar(nLon, nLat), stat=status) + allocate(oVar(oLon, oLat), stat=status) + + do j=1, vdimsizes(4) + do k=1, vdimsizes(3) + + iVar = 0 + oVar = 0 + + select case ( trim(vNam(i)) ) + case ("U") + iVar(:,2:nlat-1) = increment(:,:,k,j) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + case ("V") + iVar(2:nlon-1,:) = increment(:,:,k,j) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + case default + iVar(2:nlon-1,2:nlat-1) = increment(:,:,k,j) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + end select + + call bilin(iVar, nLon, nLat, ns, oVar, oLon, oLat) + + select case ( trim(vNam(i)) ) + case ("U") + var_out(:,:,k,j) = var_out(:,:,k,j) + oVar(:,slat:olat-elat) + case ("V") + var_out(:,:,k,j) = var_out(:,:,k,j) + oVar(slon:olon-elon,:) + case default + var_out(:,:,k,j) = var_out(:,:,k,j) + oVar(slon:olon-elon,slat:olat-elat) + end select + + end do + end do + + status = nf90_put_var(ncidout, varid, var_out) + + deallocate(var_out, stat=status) + deallocate(iVar, stat=status) + deallocate(oVar, stat=status) + deallocate(fg, stat=status) + deallocate(an, stat=status) + deallocate(increment, stat=status) + + end do + + status = nf90_close(ncidfg) + status = nf90_close(ncidan) + status = nf90_close(ncidout) + + Write(*,*) "Regridding increment completed successfully" + +contains + subroutine show_usage() + Write(*,*) 'Usage :'//trim(appname)// & + '[-h] [-fg_lores filename] [-an_lores filename] [-fg_hires filename] [-ns n ] [-o outputfile]' + Write(*,*) " -fg_lores Optional, low resulotion first guess file, default - fg" + Write(*,*) " -an_lores Optional, low resulotion analysis file comes from wrfvar, default - wrfvar_output" + Write(*,*) " -fg_hires Optional, high resultion first guess file, default - wrfinput_hires" + Write(*,*) " -ns Optional, the refinement ratio between two resulotions, default - 3" + Write(*,*) " -o Optional, output high resulotion analysis file, default - wrfvar_output_hires" + Write(*,*) " -h Show this help" + end subroutine show_usage + + subroutine nf90_handle_err(status, errmsg) + integer, intent(in) :: status + character(len=*), intent(in) :: errmsg + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status))//" : "//trim(errmsg) + Stop + end if + end subroutine nf90_handle_err + + subroutine bilin(old,xi,yi,ns,new,xo,yo) + + implicit none + + integer, intent(in) :: xi,yi,xo,yo + real, dimension(xi,yi), intent(in) :: old + integer, intent(in) :: ns + real, dimension(xo,yo), intent(out):: new + + real :: im(1:ns+1,2) + integer:: i,j,jm1,im1,ix1,ix2,iy1,iy2 + + forall(i=1:ns+1) im(i,2) = real(i-1)/ns + im(:,1) = 1 - im(:,2) + + do j=2,yi + jm1 = j - 1 + iy2 = jm1 * ns + 1 + iy1 = iy2 - ns + do i=2,xi + im1 = i - 1 + ix2 = im1 * ns + 1 + ix1 = ix2 - ns + new(ix1:ix2,iy1:iy2) = matmul(im,matmul(old(im1:i,jm1:j),transpose(im))) + end do + end do + + end subroutine bilin + +end program da_bilin diff --git a/var/mri4dvar/da_thin.f90 b/var/mri4dvar/da_thin.f90 new file mode 100644 index 0000000000..559eced218 --- /dev/null +++ b/var/mri4dvar/da_thin.f90 @@ -0,0 +1,277 @@ +program da_thin +!---------------------------------------------------------------------- +! Purpose: Thinning wrfinput by using decimation +! +! Input : wrfinput_hires -- High resolution wrfinput +! +! Output : wrfinput_lores -- Thinned wrfinput +! +! jliu@ucar.edu, 2011-12-15 +!---------------------------------------------------------------------- + + use netcdf + + implicit none + + integer :: i, n + + integer :: ncidin, ncidout, varid, varid_out, status + integer :: nDims, nVars, nGlobalAtts, numsAtts, nTimes + integer :: dLen, attLen, xtype, dID, unlimDimID, TID + integer :: divided_exactly, dimid + + integer :: dsizes(4), start(4), stride(4) + + integer, dimension(nf90_max_var_dims) :: vDimIDs + + integer, dimension(:), allocatable :: vdimsizes + + real :: fVal + + real, dimension(:,:,:,:), allocatable :: fVar + integer, dimension(:,:,:,:), allocatable :: iVar + character (len = 19), dimension(:), allocatable :: times + + character (len = 14 ) :: coordinates + character (len = NF90_MAX_NAME) :: vNam, dNam, attNam + + integer :: decimation_factor = 3 + integer :: offset = 2 + character (len=255) :: filin = "wrfinput_hires" + character (len=255) :: filout = "wrfinput_lores" + character (len=255) :: arg = "" + character (len=255) :: appname = "" + character(len=8) :: i_char ="" + + integer iargc + + call getarg(0, appname) + n=index(appname, '/', BACK=.true.) + appname = trim(appname(n+1:)) + + DO i = 1, iargc(), 2 + call getarg(i, arg) + select case ( trim(arg) ) + case ("-i") + call getarg(i+1, arg) + filin=trim(arg) + case ("-o") + call getarg(i+1, arg) + filout=trim(arg) + case ("-thin") + call getarg(i+1, arg) + read(arg, '(i3)') decimation_factor + case default + Write(*,*) "Usage : "//trim(appname)//" [-i inputfile] [-o outputfile] [-thin decimation_factor] [-h]" + Write(*,*) " -i Optional, input filename, default - wrfinput_hires" + Write(*,*) " -o Optional, output filename, default - wrfinput_lores" + Write(*,*) " -thin Optional, decimation factor, default - 3" + Write(*,*) " -h Shwo this usage" + call exit(0) + end select + END DO + + if ( mod(decimation_factor,2) == 0 ) then + Write(*,*) "\nError : decimation factor must be odd number\n" + call exit(-1) + endif + + status = nf90_open(filin, NF90_NOWRITE, ncidin) + if ( status /= nf90_noerr ) then + Write (*,*) "File open error. Please link the input file to "//trim(filin) + call exit(-1) + endif + + status = nf90_inq_dimid(ncidin, "west_east_stag", dimid) + status = nf90_inquire_dimension(ncidin, dimid, len=dLen) + divided_exactly = mod((dLen-1),decimation_factor) + + status = nf90_inq_dimid(ncidin, "south_north_stag", dimid) + status = nf90_inquire_dimension(ncidin, dimid, len=dLen) + divided_exactly = divided_exactly + mod((dLen-1),decimation_factor) + + if ( divided_exactly /= 0 ) then + Write (*,fmt='(a,i2,a)') "Failed to thinning. Grids need to match : ( n - 1 ) mod ",decimation_factor," = 0" + call exit(-1) + endif + + status = nf90_create(filout, NF90_CLOBBER, ncidout) + if ( status /= nf90_noerr) call nf90_handle_err(status) + + status = nf90_inquire(ncidin, nDims, nVars, nGlobalAtts, unlimDimID) + if ( status /= nf90_noerr ) call nf90_handle_err(status) + + write (i_char, '(i8)') decimation_factor + + Write (*,*) " Input file : "//trim(filin) + Write (*,*) " Output file : "//trim(filout) + Write (*,*) "decimation factor : "//adjustl(i_char) + + do i=1, nGlobalAtts + status = nf90_inq_attname(ncidin, NF90_GLOBAL, i, attNam) + select case (trim(attNam)) + case ( "WEST-EAST_GRID_DIMENSION", "SOUTH-NORTH_GRID_DIMENSION", & + "WEST-EAST_PATCH_END_UNSTAG", "WEST-EAST_PATCH_END_STAG", & + "SOUTH-NORTH_PATCH_END_UNSTAG", "SOUTH-NORTH_PATCH_END_STAG" ) + status = nf90_get_att(ncidin, NF90_GLOBAL, attNam, fVal) + status = nf90_put_att(ncidout, NF90_GLOBAL, attNam, int(( fVal - 1 ) / decimation_factor + 1) ) + case ("DX","DY", "DT" ) + status = nf90_get_att(ncidin, NF90_GLOBAL, attNam, fVal) + status = nf90_put_att(ncidout, NF90_GLOBAL, attNam, fVal * decimation_factor ) + case default + status = nf90_copy_att(ncidin, NF90_GLOBAL, attNam, ncidout, NF90_GLOBAL) + end select + end do + + allocate (vdimsizes(nDims), stat=status) + + do i=1, nDims + + status = nf90_inquire_dimension(ncidin, i, name=dNam, len = dLen) + + vdimsizes(i) = dLen + select case (trim(dNam)) + case ("south_north_stag", "west_east_stag") + vdimsizes(i) = (dLen - 1 ) / decimation_factor + 1 + case ("west_east", "south_north") + vdimsizes(i) = dLen / decimation_factor + case ("Time") + allocate(times(dLen), stat=status) + vdimsizes(i) = NF90_UNLIMITED + nTimes = dLen + TID = i + end select + + status = nf90_def_dim(ncidout, dNam, vdimsizes(i), dID) + + end do + + vdimsizes(TID) = nTimes + + do varid=1, nVars + status = nf90_inquire_variable(ncidin,varid,name=vNam,xtype=xtype,ndims=nDims,dimids=vDimIDs,natts=numsAtts) + status = nf90_def_var(ncidout, trim(vNam), xtype, vDimIDs(1:nDims), varid_out) + if(status /= nf90_NoErr) call nf90_handle_err(status) + do i=1, numsAtts + status = nf90_inq_attname(ncidin, varid, i, attNam) + status = nf90_copy_att(ncidin, varid, trim(attNam), ncidout, varid_out) + if(status /= nf90_NoErr) call nf90_handle_err(status) + end do + end do + + status = nf90_enddef(ncidout) + + offset = (decimation_factor + 1) / 2 + + do varid=1, nVars + + status = nf90_inquire_variable(ncidin,varid,name=vNam,xtype=xtype,ndims=nDims,dimids=vDimIDs) + + dsizes = 1 + do i = 1 , nDims + dsizes(i) = vdimsizes(vDimIDs(i)) + end do + + status = nf90_inquire_attribute(ncidin,varid,"coordinates") + + if ( status == nf90_noerr ) then + + Write(*,*) "Thinning for "//trim(vNam) + + coordinates=char(0) + status = nf90_get_att(ncidin, varid, "coordinates" , coordinates) + !print *, coordinates + + stride=(/decimation_factor,decimation_factor,1,1/) + + n = index(coordinates, char(0)) - 1 + if ( n < 0 ) n = len(coordinates) + + select case (trim(coordinates(1:n))) + case ("XLONG_V XLAT_V") + start=(/offset,1,1,1/) + case ("XLONG_U XLAT_U") + start=(/1,offset,1,1/) + case ("XLONG XLAT") + start=(/offset,offset,1,1/) + case ("XLONG XLAT XTI") + start=(/offset,offset,1,1/) + case default + print *, "Unkown coordinates : "//coordinates + call exit(-1) + end select + + else + + stride = 1 + start = 1 + + if ( trim(vNam) == 'XLONG' .or. trim(vNam) == 'XLAT' ) then + stride = (/decimation_factor,decimation_factor,1,1/) + start = (/offset,offset,1,1/) + endif + + endif + + select case (xtype) + case (nf90_float) + allocate(fVar( dsizes(1), dsizes(2), dsizes(3), dsizes(4) ), stat=status) + status = nf90_get_var(ncidin, varid, fVar, start=start, stride=stride) + if ( status == nf90_noerr ) then + if ( vNam == "RDX" .or. vNam == "RDY" ) then + status = nf90_put_var(ncidout, varid, fVar / decimation_factor) + else + status = nf90_put_var(ncidout, varid, fVar) + endif + if ( status /= nf90_noerr) call nf90_handle_err(status) + else + call nf90_handle_err(status) + endif + deallocate(fVar, stat=status) + case (nf90_int) + allocate(iVar( dsizes(1), dsizes(2), dsizes(3), dsizes(4) ), stat=status) + status = nf90_get_var(ncidin, varid, iVar, start=start, stride=stride) + if ( status == nf90_noerr ) then + status = nf90_put_var(ncidout, varid, iVar) + if ( status /= nf90_noerr) call nf90_handle_err(status) + else + call nf90_handle_err(status) + endif + deallocate(iVar, stat=status) + case (nf90_char) + if ( trim(vNam) == "Times") then + status = nf90_get_var(ncidin, varid, times) + if ( status == nf90_noerr ) then + status = nf90_put_var(ncidout, varid, times) + if ( status /= nf90_noerr) call nf90_handle_err(status) + else + call nf90_handle_err(status) + endif + deallocate(times, stat=status) + else + print *, "Unkown character variable :"//trim(vNam) + call exit(-1) + endif + case default + print *, "Unkown xtype : ", xtype + call exit(-1) + end select + end do + + status = nf90_close(ncidin) + status = nf90_close(ncidout) + + Write(*,*) "Completed thinning successfully" + +contains + + subroutine nf90_handle_err(status) + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + call exit(-1) + end if + end subroutine nf90_handle_err + +end program da_thin diff --git a/var/mri4dvar/da_vp_bilin.f90 b/var/mri4dvar/da_vp_bilin.f90 new file mode 100644 index 0000000000..3855e0f95f --- /dev/null +++ b/var/mri4dvar/da_vp_bilin.f90 @@ -0,0 +1,384 @@ +program da_vp_bilin + +!---------------------------------------------------------------------- +! Purpose: Regridding from low to high resolution in control variable space +! by using bilinear interpolation +! +! where n is the grid number in x or y +! ns is the refinement ratio between two resulotions +! +! Method: follow da_bilin.f90 +! +! Compile: +! +! pgf90 -o da_vp_bilin.exe da_vp_bilin.f90 +! +! liuz@ucar.edu , 2016-08, NCAR/MMM +!---------------------------------------------------------------------- + + !use netcdf + + implicit none + + !These variables' incremental will be regridded by default + character (len=6), dimension(1:19) :: vNam + + integer :: ix, jy, kz, k, status + integer :: ixh, jyh, kzh + integer :: nLat, nLon, oLat, oLon + integer :: sLat, eLat, sLon, eLon + integer :: rLat, rLon + + real, dimension(:,:,:), allocatable :: v1, v2, v3, v4, v5 + real, dimension(:,:,:), allocatable :: v6, v7, v8, v9, v10, v11 + real, dimension(:,:,:), allocatable :: v1h, v2h, v3h, v4h, v5h + real, dimension(:,:,:), allocatable :: v6h, v7h, v8h, v9h, v10h, v11h + real, dimension(:,:), allocatable :: iVar, oVar + + character (len = 255) :: appname = "" + character (len = 255) :: arg = "" + character (len = 19) :: analysis_date + character (len = 255) :: input_file= "vp_output.global" + character (len = 255) :: output_file= "vp_output.global_hires" + + integer, parameter :: vp_unit = 8 + integer, parameter :: vp_hires_unit = 9 + integer :: ratio ! resolution ratio + integer :: cloud_cv_options ! 2 or 3 with cloud cv variables + integer :: use_cv_w ! =1 for w control variable + integer :: io_status + integer iargc + + LOGICAL :: file_exists + + !These variables' incremental will be regridded by default + + !call getarg(0, appname) + !n=index(appname, '/', BACK=.true.) + !appname = trim(appname(n+1:)) + + call getarg(1, arg) + call getarg(2, arg) + read(arg, '(i3)') ratio + + call getarg(3, arg) + call getarg(4, arg) + read(arg, '(i3)') cloud_cv_options + + call getarg(5, arg) + call getarg(6, arg) + read(arg, '(i3)') use_cv_w + + + write (*, *) 'ratio = ', ratio, 'cloud_cv_options = ', cloud_cv_options, & + 'use_cv_w = ', use_cv_w + + +! read vp file +!-------------------- + inquire(FILE=trim(input_file), EXIST=file_exists) + + if ( .not. file_exists ) then + Write(*,*) "\nError: "//trim(input_file)//" not exists\n" + call exit(-1) + else + Write(*,*) "Found: "//trim(input_file) + endif + + open(unit=vp_unit,file=trim(input_file),iostat=io_status,form='UNFORMATTED',status='OLD') + if (io_status /= 0) then + write(*,*) "Error ",io_status," opening vp file "//trim(input_file) + call exit(-1) + end if + write(*,*) 'Reading vp from : '//trim(input_file) + !read(vp_unit) analysis_date + !print *, 'analysis_date = ', analysis_date + read(vp_unit) ix, jy, kz ! domain dimension (unstagered) + print *, "input file: ix, jy, kz = ", ix, jy, kz + + allocate ( v1 (1:ix,1:jy,1:kz)) + allocate ( v2 (1:ix,1:jy,1:kz)) + allocate ( v3 (1:ix,1:jy,1:kz)) + allocate ( v4 (1:ix,1:jy,1:kz)) + allocate ( v5 (1:ix,1:jy,1:kz)) + + read(vp_unit) v1, v2, v3, v4, v5 + + if ( cloud_cv_options >= 2 ) then + allocate ( v6 (1:ix,1:jy,1:kz)) + allocate ( v7 (1:ix,1:jy,1:kz)) + allocate ( v8 (1:ix,1:jy,1:kz)) + allocate ( v9 (1:ix,1:jy,1:kz)) + allocate ( v10 (1:ix,1:jy,1:kz)) + read(vp_unit) v6, v7, v8, v9, v10 + end if + + if ( use_cv_w == 1 ) then + allocate ( v11 (1:ix,1:jy,1:kz)) + read(vp_unit) v11 + end if + + write(*,*) 'End Reading vp from : '//trim(input_file) + close(vp_unit) +!----------------------------- +! end read vp file +!---------------------- + + nLon = ix + 2 ! 52 + nLat = jy + 2 ! 52 + + rLon = ix * ratio ! 150 + rLat = jy * ratio ! 150 + + oLon = ( nLon - 1 ) * ratio + 1 ! 154 + oLat = ( nLat - 1 ) * ratio + 1 + + elat = (oLat - rLat) / 2 ! 2 + slat = oLat - rLat - elat + 1 ! 3 + + elon = (oLon - rLon) / 2 + slon = oLon - rLon - elon + 1 + + allocate(iVar(nLon, nLat), stat=status) + allocate(oVar(oLon, oLat), stat=status) + + + ixh = ix*ratio + jyh = jy*ratio + + allocate ( v1h (1:ixh,1:jyh,1:kz)) + allocate ( v2h (1:ixh,1:jyh,1:kz)) + allocate ( v3h (1:ixh,1:jyh,1:kz)) + allocate ( v4h (1:ixh,1:jyh,1:kz)) + allocate ( v5h (1:ixh,1:jyh,1:kz)) + + if ( cloud_cv_options >= 2 ) then + allocate ( v6h (1:ixh,1:jyh,1:kz)) + allocate ( v7h (1:ixh,1:jyh,1:kz)) + allocate ( v8h (1:ixh,1:jyh,1:kz)) + allocate ( v9h (1:ixh,1:jyh,1:kz)) + allocate ( v10h (1:ixh,1:jyh,1:kz)) + end if + + if ( use_cv_w == 1 ) then + allocate ( v11h (1:ixh,1:jyh,1:kz)) + end if + + do k = 1, kz + iVar(2:nlon-1,2:nlat-1) = v1(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v1h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v2(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v2h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v3(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v3h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v4(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v4h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v5(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v5h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + if ( cloud_cv_options >= 2 ) then + iVar(2:nlon-1,2:nlat-1) = v6(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v6h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v7(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v7h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v8(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v8h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v9(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v9h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + + iVar(2:nlon-1,2:nlat-1) = v10(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v10h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + end if + + if ( use_cv_w == 1 ) then + iVar(2:nlon-1,2:nlat-1) = v11(:,:,k) + iVar(1,:) = iVar(2,:) + iVar(nlon,:) = iVar(nlon-1,:) + iVar(:,1) = iVar(:,2) + iVar(:,nlat) = iVar(:,nlat-1) + call bilin(iVar,nLon,nLat,ratio,oVar,oLon,oLat) + v11h(:,:,k) = oVar(slon:olon-elon,slat:olat-elat) + end if + enddo + + open(unit=vp_hires_unit,file=trim(output_file),iostat=io_status,form='UNFORMATTED',status='UNKNOWN') + if (io_status /= 0) then + write(*,*) "Error ",io_status," opening vp file "//trim(output_file) + call exit(-1) + end if + write(*,*) 'Writting vp on hires. to : '//trim(output_file) + + print *, 'output file: ixh, jyh, kz=', ixh, jyh, kz + write(vp_hires_unit) ixh, jyh, kz + write(vp_hires_unit) v1h,v2h,v3h,v4h,v5h + if ( cloud_cv_options >= 2 ) then + write(vp_hires_unit) v6h,v7h,v8h,v9h,v10h + end if + if ( use_cv_w == 1 ) then + write(vp_hires_unit) v11h + end if + + deallocate(v1, stat=status) + deallocate(v2, stat=status) + deallocate(v3, stat=status) + deallocate(v4, stat=status) + deallocate(v5, stat=status) + + deallocate(v1h, stat=status) + deallocate(v2h, stat=status) + deallocate(v3h, stat=status) + deallocate(v4h, stat=status) + deallocate(v5h, stat=status) + + if ( cloud_cv_options >= 2 ) then + deallocate(v6, stat=status) + deallocate(v7, stat=status) + deallocate(v8, stat=status) + deallocate(v9, stat=status) + deallocate(v10, stat=status) + + deallocate(v6h, stat=status) + deallocate(v7h, stat=status) + deallocate(v8h, stat=status) + deallocate(v9h, stat=status) + deallocate(v10h, stat=status) + end if + + if ( use_cv_w == 1 ) then + deallocate(v11, stat=status) + deallocate(v11h, stat=status) + end if + + Write(*,*) "Regridding increment completed successfully" + +contains + subroutine show_usage() + Write(*,*) 'Usage :'//trim(appname)// & + '[-h] [-fg_lores filename] [-an_lores filename] [-fg_hires filename] [-ns n ] [-o outputfile]' + Write(*,*) " -fg_lores Optional, low resulotion first guess file, default - fg" + Write(*,*) " -an_lores Optional, low resulotion analysis file comes from wrfvar, default - wrfvar_output" + Write(*,*) " -fg_hires Optional, high resultion first guess file, default - wrfinput_hires" + Write(*,*) " -ns Optional, the refinement ratio between two resulotions, default - 3" + Write(*,*) " -o Optional, output high resulotion analysis file, default - wrfvar_output_hires" + Write(*,*) " -h Show this help" + end subroutine show_usage + + !subroutine nf90_handle_err(status, errmsg) + ! integer, intent(in) :: status + ! character(len=*), intent(in) :: errmsg +! +! if(status /= nf90_noerr) then +! print *, trim(nf90_strerror(status))//" : "//trim(errmsg) +! Stop +! end if +! end subroutine nf90_handle_err + + subroutine bilin(old,xi,yi,ns,new,xo,yo) + +! assume: xo = (xi-1)*ns + 1, xi=50, xo=49*3+1=148 +! yo = (yi-1)*ns + 1 + + implicit none + + integer, intent(in) :: xi,yi,xo,yo + real, dimension(xi,yi), intent(in) :: old + integer, intent(in) :: ns + real, dimension(xo,yo), intent(out):: new + + real :: im(1:ns+1,2) +! real :: imm(1:ns+3,2) + integer:: i,j,jm1,im1,ix1,ix2,iy1,iy2 + + forall(i=1:ns+1) im(i,2) = real(i-1)/ns + im(:,1) = 1 - im(:,2) + + do j=2,yi + jm1 = j - 1 + iy2 = jm1 * ns + 1 + iy1 = iy2 - ns + do i=2,xi + im1 = i - 1 + ix2 = im1 * ns + 1 + ix1 = ix2 - ns + new(ix1:ix2,iy1:iy2) = matmul(im,matmul(old(im1:i,jm1:j),transpose(im))) + end do + end do + + + ! ns = ns + 2 + ! forall(i=1:ns+1) imm(i,2) = real(i-1)/ns + ! imm(:,1) = 1 - imm(:,2) +! +! j=yi +! jm1 = j - 1 +! iy2 = jm1 * ns + 1 +! iy1 = iy2 - ns +! +! i=xi +! im1 = i - 1 +! ix2 = im1 * ns + 1 +! ix1 = ix2 - ns +! new(ix1:ix2,iy1:iy2) = matmul(imm,matmul(old(im1:i,jm1:j),transpose(imm))) +! end do +! end do + + end subroutine bilin + +end program da_vp_bilin diff --git a/var/mri4dvar/da_vp_split.f90 b/var/mri4dvar/da_vp_split.f90 new file mode 100644 index 0000000000..0a3ab07a69 --- /dev/null +++ b/var/mri4dvar/da_vp_split.f90 @@ -0,0 +1,368 @@ +program da_vp_split + +!---------------------------------------------------------------------- +! Purpose: Scatter global hires. control variables to different PEs +! +! Input : vp_hires.bin -- high resolution global control variables +! +! Output : vp_XXXX -- high resolution local control variables +! +! In order to keep the domain size, it needs to match ( n - 1 )*ratio + 1 +! +! where n is the grid number in x or y +! ratio is the refinement ratio between two resulotions +! +! liuz@ucar.edu , 2016-05, NCAR/MMM +!---------------------------------------------------------------------- + + implicit none + + include 'mpif.h' + + integer :: i, j, k, n, status + + INTEGER :: ntasks_x, ntasks_y, mytask, mytask_x, mytask_y + INTEGER :: new_local_comm, local_communicator + INTEGER, DIMENSION(2) :: dims, coords + LOGICAL, DIMENSION(2) :: isperiodic + INTEGER :: ids, ide, jds, jde, kds, kde, & + ips, ipe, jps, jpe, kps, kpe + INTEGER :: minx, miny + integer :: ratio = 3 + + integer :: io_status + + character (len = 255) :: vp_hires + character (len = 255) :: arg = "" + integer, parameter :: vp_unit = 8 + + integer :: ix, jy, kz + + real, dimension(:,:,:), allocatable :: v1, v2, v3, v4, v5 + real, dimension(:,:,:), allocatable :: v6, v7, v8, v9, v10, v11 + real, dimension(:,:,:), allocatable :: v1l, v2l, v3l, v4l, v5l + real, dimension(:,:,:), allocatable :: v6l, v7l, v8l, v9l, v10l, v11l + + integer size, ierror + integer :: cloud_cv_options ! 2 or 3 with cloud cv variables + integer :: use_cv_w ! =1 for w control variable + + LOGICAL :: file_exists + + + !------------------------------ + ! read program arguments + !------------------------------ + call getarg(1, arg) + call getarg(2, arg) + read(arg, '(i3)') cloud_cv_options + + call getarg(3, arg) + call getarg(4, arg) + read(arg, '(i3)') use_cv_w + + write (*, *) 'cloud_cv_options = ', cloud_cv_options, & + 'use_cv_w = ', use_cv_w + + !--------------------------------------------------------------------- + ! MPI initialization + !--------------------------------------------------------------------- + call MPI_INIT(ierror) + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierror) + call MPI_COMM_RANK(MPI_COMM_WORLD, mytask, ierror) + + call MPASPECT( size, ntasks_x, ntasks_y, 1, 1 ) + if ( mytask == 0 ) WRITE( * , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y + + new_local_comm = MPI_COMM_WORLD + dims(1) = ntasks_y ! rows + dims(2) = ntasks_x ! columns + isperiodic(1) = .false. + isperiodic(2) = .false. + CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierror ) + CALL mpi_comm_rank( local_communicator, mytask, ierror ) + CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierror ) + mytask_x = coords(2) ! col task (x) + mytask_y = coords(1) ! row task (y) + !write (*,*) "The coords of task ",mytask, " is ",mytask_x,mytask_y + + io_status = 0 + + vp_hires='vp_output.global_hires' + inquire(FILE=trim(vp_hires), EXIST=file_exists) + + if ( .not. file_exists ) then + Write(*,*) "\nError: "//trim(vp_hires)//" not exists\n" + call exit(-1) + endif + + open(unit=vp_unit,file=trim(vp_hires),iostat=io_status,form='UNFORMATTED',status='OLD') + if (io_status /= 0) then + write(*,*) "Error ",io_status," opening vp file "//trim(vp_hires) + call exit(-1) + end if + if ( mytask == 0 ) write(*,*) 'Reading vp from : '//trim(vp_hires) + read(vp_unit) ide, jde, kde ! domain dimension (unstagered) + ide = ide + 1 ! WRF parallel decomposition is based on stagered grid + jde = jde + 1 + kde = kde + 1 + if ( mytask == 0 ) write(*,*) 'ide, jde, kde = ', ide, jde, kde + ids = 1 + jds = 1 + kds = 1 + + !--------------------------------------------------------------------- + ! Calculate the domain decomposition + !--------------------------------------------------------------------- + CALL compute_memory_dims_rsl_lite ( 0 , & + ids, ide, jds, jde, kds, kde, & + ips, ipe, jps, jpe, kps, kpe ) + ! convert to A-grid and middle levels on which control variables sit + if ( ipe == ide ) ipe = ipe - 1 + if ( jpe == jde ) jpe = jpe - 1 + if ( kpe == kde ) kpe = kpe - 1 + !WRITE(*,*)'*************************************' + !WRITE(90,*)'local ',ips,ipe,jps,jpe,kps,kpe + WRITE(*,*)'local ',ips,ipe,jps,jpe,kps,kpe + !WRITE(*,*)'*************************************' + + !--------------------------------------------------------------------- + ! allocate global vp variables (unstagered) + !--------------------------------------------------------------------- + allocate ( v1(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v2(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v3(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v4(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v5(ids:ide-1,jds:jde-1,kds:kde-1) ) + + if ( cloud_cv_options >= 2 ) then + allocate ( v6(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v7(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v8(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v9(ids:ide-1,jds:jde-1,kds:kde-1) ) + allocate ( v10(ids:ide-1,jds:jde-1,kds:kde-1) ) + end if + + if ( use_cv_w == 1 ) allocate ( v11(ids:ide-1,jds:jde-1,kds:kde-1) ) + + read(vp_unit) v1, v2, v3, v4, v5 + if ( cloud_cv_options >= 2 )read(vp_unit) v6, v7, v8, v9, v10 + if ( use_cv_w == 1 )read(vp_unit) v11 + close(vp_unit) + + call MPI_BARRIER(MPI_COMM_WORLD,ierror) + if ( mytask == 0 ) write(*,*) 'Reading vp from : '//trim(vp_hires)//' is completeed' + + !--------------------------------------------------------------------- + ! allocate local vp variables (unstagered) + !--------------------------------------------------------------------- + ix = ipe-ips+1 + jy = jpe-jps+1 + kz = kpe-kps+1 + + allocate ( v1l(1:ix,1:jy,1:kz) ) + allocate ( v2l(1:ix,1:jy,1:kz) ) + allocate ( v3l(1:ix,1:jy,1:kz) ) + allocate ( v4l(1:ix,1:jy,1:kz) ) + allocate ( v5l(1:ix,1:jy,1:kz) ) + + if ( cloud_cv_options >= 2 ) then + allocate ( v6l(1:ix,1:jy,1:kz) ) + allocate ( v7l(1:ix,1:jy,1:kz) ) + allocate ( v8l(1:ix,1:jy,1:kz) ) + allocate ( v9l(1:ix,1:jy,1:kz) ) + allocate ( v10l(1:ix,1:jy,1:kz) ) + end if + + if ( use_cv_w == 1 ) allocate ( v11l(1:ix,1:jy,1:kz) ) + + !--------------------------------------------------------------------- + ! Scatter vp to PEs + !--------------------------------------------------------------------- + + v1l(1:ix,1:jy,1:kz) = v1(ips:ipe,jps:jpe,kps:kpe) + v2l(1:ix,1:jy,1:kz) = v2(ips:ipe,jps:jpe,kps:kpe) + v3l(1:ix,1:jy,1:kz) = v3(ips:ipe,jps:jpe,kps:kpe) + v4l(1:ix,1:jy,1:kz) = v4(ips:ipe,jps:jpe,kps:kpe) + v5l(1:ix,1:jy,1:kz) = v5(ips:ipe,jps:jpe,kps:kpe) + + if ( cloud_cv_options >= 2 ) then + v6l(1:ix,1:jy,1:kz) = v6(ips:ipe,jps:jpe,kps:kpe) + v7l(1:ix,1:jy,1:kz) = v7(ips:ipe,jps:jpe,kps:kpe) + v8l(1:ix,1:jy,1:kz) = v8(ips:ipe,jps:jpe,kps:kpe) + v9l(1:ix,1:jy,1:kz) = v9(ips:ipe,jps:jpe,kps:kpe) + v10l(1:ix,1:jy,1:kz) = v10(ips:ipe,jps:jpe,kps:kpe) + end if + + if ( use_cv_w == 1 ) v11l(1:ix,1:jy,1:kz) = v11(ips:ipe,jps:jpe,kps:kpe) + + write (vp_hires,'(A,i4.4)') "vp_input.",mytask + + open(unit=vp_unit,file=trim(vp_hires),iostat=io_status,form='UNFORMATTED',status='UNKNOWN') + if (io_status /= 0) then + write(*,*) "Error ",io_status," opening vp file "//trim(vp_hires) + call exit(-1) + end if + write(*,*) 'Writting vp on hires to : '//trim(vp_hires) + write(vp_unit) ips, ipe, jps, jpe, kps, kpe + write(vp_unit) v1l, v2l, v3l, v4l, v5l + if ( cloud_cv_options >= 2 )write(vp_unit) v6l, v7l, v8l, v9l, v10l + if ( use_cv_w == 1 )write(vp_unit) v11l + !write(*,*) 'Sample of cvt :',mytask, maxval(cvt), minval(cvt) + close(vp_unit) + + !--------------------------------------------------------------------- + ! The end + !--------------------------------------------------------------------- + !if ( mytask == 0 ) then + deallocate (v1) + deallocate (v2) + deallocate (v3) + deallocate (v4) + deallocate (v5) + deallocate (v1l) + deallocate (v2l) + deallocate (v3l) + deallocate (v4l) + deallocate (v5l) + + if ( cloud_cv_options >= 2 ) then + deallocate (v6) + deallocate (v7) + deallocate (v8) + deallocate (v9) + deallocate (v10) + deallocate (v6l) + deallocate (v7l) + deallocate (v8l) + deallocate (v9l) + deallocate (v10l) + end if + + if ( use_cv_w == 1 ) then + deallocate (v11) + deallocate (v11l) + end if + !endif + + call MPI_BARRIER(MPI_COMM_WORLD,ierror) + if ( mytask == 0 ) Write(*,*) "Distributting control variables completed successfully" + call MPI_FINALIZE(ierror) + +contains + + SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N ) + IMPLICIT NONE + INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N, ierror + MINI = 2*P + MINM = 1 + MINN = P + DO M = 1, P + IF ( MOD( P, M ) .EQ. 0 ) THEN + N = P / M + IF ( ABS(M-N) .LT. MINI & + .AND. M .GE. PROCMIN_M & + .AND. N .GE. PROCMIN_N & + ) THEN + MINI = ABS(M-N) + MINM = M + MINN = N + ENDIF + ENDIF + ENDDO + IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN + WRITE( * , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH. STOPPING.' + WRITE( * , * )' PROCMIN_M ', PROCMIN_M + WRITE( * , * )' PROCMIN_N ', PROCMIN_N + WRITE( * , * )' P ', P + WRITE( * , * )' MINM ', MINM + WRITE( * , * )' MINN ', MINN + call MPI_FINALIZE(ierror) + stop + ENDIF + RETURN + END SUBROUTINE MPASPECT + + SUBROUTINE compute_memory_dims_rsl_lite ( & + shw , & + ids, ide, jds, jde, kds, kde, & + ips, ipe, jps, jpe, kps, kpe ) + + IMPLICIT NONE + INTEGER, INTENT(IN) :: shw + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde + INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe, kps, kpe + + INTEGER Px, Py, P, i, j, k, ierr + +! xy decomposition + + ips = -1 + j = jds + ierr = 0 + DO i = ids, ide + CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + minx, miny, ierr ) + IF ( ierr .NE. 0 ) stop 'error code returned by task_for_point ' + IF ( Px .EQ. mytask_x ) THEN + ipe = i + IF ( ips .EQ. -1 ) ips = i + ENDIF + ENDDO + ! handle setting the memory dimensions where there are no X elements assigned to this proc + IF (ips .EQ. -1 ) THEN + ipe = -1 + ips = 0 + ENDIF + jps = -1 + i = ids + ierr = 0 + DO j = jds, jde + CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + minx, miny, ierr ) + IF ( ierr .NE. 0 ) stop 'error code returned by task_for_point ' + IF ( Py .EQ. mytask_y ) THEN + jpe = j + IF ( jps .EQ. -1 ) jps = j + ENDIF + ENDDO + ! handle setting the memory dimensions where there are no Y elements assigned to this proc + IF (jps .EQ. -1 ) THEN + jpe = -1 + jps = 0 + ENDIF + +!begin: wig; 12-Mar-2008 +! This appears redundant with the conditionals above, but we get cases with only +! one of the directions being set to "missing" when turning off extra processors. +! This may break the handling of setting only one of nproc_x or nproc_y via the namelist. + IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN + ipe = -1 + ips = 0 + jpe = -1 + jps = 0 + ENDIF +!end: wig; 12-Mar-2008 + +! extend the patch dimensions out shw along edges of domain + IF ( ips < ipe .and. jps < jpe ) THEN !wig; 11-Mar-2008 + IF ( mytask_x .EQ. 0 ) THEN + ips = ips - shw + ENDIF + IF ( mytask_x .EQ. ntasks_x-1 ) THEN + ipe = ipe + shw + ENDIF + IF ( mytask_y .EQ. 0 ) THEN + jps = jps - shw + ENDIF + IF ( mytask_y .EQ. ntasks_y-1 ) THEN + jpe = jpe + shw + ENDIF + ENDIF !wig; 11-Mar-2008 + + kps = 1 + kpe = kde-kds+1 + + END SUBROUTINE compute_memory_dims_rsl_lite + +end program da_vp_split diff --git a/var/mri4dvar/nc_increment.ncl b/var/mri4dvar/nc_increment.ncl new file mode 100644 index 0000000000..f8eb0468a5 --- /dev/null +++ b/var/mri4dvar/nc_increment.ncl @@ -0,0 +1,56 @@ +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + + + filename = "analysis_increments" + + varnames = (/"psi","chi_u","t_u","rh","ps_u"/) + nvar = dimsizes(varnames) + + setfileoption("bin","ReadByteOrder","BigEndian") + dims = fbinrecread(filename,0,6,"integer") + ni=dims(1) ;;+ 1 + nj=dims(3) ;;+ 1 + nk=dims(5) ;;+ 1 + print("ni, nj, nk = "+ni+", "+nj+", "+nk) + + vv = fbinrecread(filename,1,(/4,nk,nj,ni/),"double") + + system("/bin/rm -f "+filename+".nc") ; remove any pre-existing file + ncdf = addfile(filename+".nc" ,"c") ; open output netCDF file + + ;=================================================================== + ; make time an UNLIMITED dimension; recommended for most applications + ;=================================================================== + ; filedimdef(ncdf,"time",-1,True) + + u = new((/nk, nj,ni/),double) + v = new((/nk, nj,ni/),double) + ;w = new((/nk, nj,ni/),double) + ;p = new((/nk, nj,ni/),double) + t = new((/nk, nj,ni/),double) + q = new((/nk, nj,ni/),double) + ;z = new((/nk, nj,ni/),double) + + u(:,:,:) = vv(0,:,:,:) + v(:,:,:) = vv(1,:,:,:) + ;w(:,:,:) = vv(2,:,:,:) + ;p(:,:,:) = vv(3,:,:,:) + t(:,:,:) = vv(2,:,:,:) + q(:,:,:) = vv(3,:,:,:) + ;z(:,:,:) = vv(6,:,:,:) + + + ncdf->u = u + ncdf->v = v + ;ncdf->w = w + ;ncdf->p = p + ncdf->t = t + ncdf->q = q + ;ncdf->z = z + +end + diff --git a/var/mri4dvar/nc_vpglobal.ncl b/var/mri4dvar/nc_vpglobal.ncl new file mode 100644 index 0000000000..981e8dd0d4 --- /dev/null +++ b/var/mri4dvar/nc_vpglobal.ncl @@ -0,0 +1,65 @@ +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + + + ;filename = "vv_input.global" + filename = "vv_afterUvTransf" + + varnames = (/"psi","chi_u","t_u","rh","ps_u"/) + nvar = dimsizes(varnames) + + setfileoption("bin","ReadByteOrder","BigEndian") + dims = fbinrecread(filename,0,3,"integer") + ni=dims(0) + nj=dims(1) + nk=dims(2) + print("ni, nj, nk = "+ni+", "+nj+", "+nk) + + vv = fbinrecread(filename,1,(/5,nk,nj,ni/),"double") + + system("/bin/rm -f "+filename+".nc") ; remove any pre-existing file + ncdf = addfile(filename+".nc" ,"c") ; open output netCDF file + + ;=================================================================== + ; make time an UNLIMITED dimension; recommended for most applications + ;=================================================================== + ; filedimdef(ncdf,"time",-1,True) + + u = new((/nk, nj,ni/),double) + v = new((/nk, nj,ni/),double) + t = new((/nk, nj,ni/),double) + rh = new((/nk, nj,ni/),double) + ps = new((/nk, nj,ni/),double) + + ;do k = 0, nk-1 + ;do j = 0, nj-1 + ;do i = 0, ni-1 + ; v1(k,j,i) = v(i,j,k,1) + ; v2(k,j,i) = v(i,j,k,2) + ; v3(k,j,i) = v(i,j,k,3) + ; v4(k,j,i) = v(i,j,k,4) + ; ;v5(k,j,i) = v(i,j,k,5) + ;end do + ;end do + ;end do + + u(:,:,:) = vv(0,:,:,:) + v(:,:,:) = vv(1,:,:,:) + t(:,:,:) = vv(2,:,:,:) + rh(:,:,:) = vv(3,:,:,:) + ps(:,:,:) = vv(4,:,:,:) + + ncdf->u = u + ncdf->v = v + ncdf->t = t + ncdf->rh = rh + ncdf->ps = ps + + ;************************************************ + ; end of reading be.dat data + ;************************************************ + +end diff --git a/var/mri4dvar/nc_vphires.ncl b/var/mri4dvar/nc_vphires.ncl new file mode 100644 index 0000000000..8cee26a0fd --- /dev/null +++ b/var/mri4dvar/nc_vphires.ncl @@ -0,0 +1,64 @@ +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + + + filename = "vp_output.global_hires" + + varnames = (/"psi","chi_u","t_u","rh","ps_u"/) + nvar = dimsizes(varnames) + + setfileoption("bin","ReadByteOrder","BigEndian") + dims = fbinrecread(filename,0,3,"integer") + ni=dims(0) + nj=dims(1) + nk=dims(2) + print("ni, nj, nk = "+ni+", "+nj+", "+nk) + + vv = fbinrecread(filename,1,(/5,nk,nj,ni/),"double") + + system("/bin/rm -f "+filename+".nc") ; remove any pre-existing file + ncdf = addfile(filename+".nc" ,"c") ; open output netCDF file + + ;=================================================================== + ; make time an UNLIMITED dimension; recommended for most applications + ;=================================================================== + ; filedimdef(ncdf,"time",-1,True) + + u = new((/nk, nj,ni/),double) + v = new((/nk, nj,ni/),double) + t = new((/nk, nj,ni/),double) + rh = new((/nk, nj,ni/),double) + ps = new((/nk, nj,ni/),double) + + ;do k = 0, nk-1 + ;do j = 0, nj-1 + ;do i = 0, ni-1 + ; v1(k,j,i) = v(i,j,k,1) + ; v2(k,j,i) = v(i,j,k,2) + ; v3(k,j,i) = v(i,j,k,3) + ; v4(k,j,i) = v(i,j,k,4) + ; ;v5(k,j,i) = v(i,j,k,5) + ;end do + ;end do + ;end do + + u(:,:,:) = vv(0,:,:,:) + v(:,:,:) = vv(1,:,:,:) + t(:,:,:) = vv(2,:,:,:) + rh(:,:,:) = vv(3,:,:,:) + ps(:,:,:) = vv(4,:,:,:) + + ncdf->u = u + ncdf->v = v + ncdf->t = t + ncdf->rh = rh + ncdf->ps = ps + + ;************************************************ + ; end of reading be.dat data + ;************************************************ + +end diff --git a/var/mri4dvar/nc_vpinput.ncl b/var/mri4dvar/nc_vpinput.ncl new file mode 100644 index 0000000000..2c743f81c2 --- /dev/null +++ b/var/mri4dvar/nc_vpinput.ncl @@ -0,0 +1,64 @@ +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + + + filename = "vp_input.0000" + + varnames = (/"psi","chi_u","t_u","rh","ps_u"/) + nvar = dimsizes(varnames) + + setfileoption("bin","ReadByteOrder","BigEndian") + dims = fbinrecread(filename,0,6,"integer") + ni=dims(1)-dims(0)+1 + nj=dims(3)-dims(2)+1 + nk=dims(5)-dims(4)+1 + print("ni, nj, nk = "+ni+", "+nj+", "+nk) + + vv = fbinrecread(filename,1,(/5,nk,nj,ni/),"double") + + system("/bin/rm -f "+filename+".nc") ; remove any pre-existing file + ncdf = addfile(filename+".nc" ,"c") ; open output netCDF file + + ;=================================================================== + ; make time an UNLIMITED dimension; recommended for most applications + ;=================================================================== + ; filedimdef(ncdf,"time",-1,True) + + u = new((/nk, nj,ni/),double) + v = new((/nk, nj,ni/),double) + t = new((/nk, nj,ni/),double) + rh = new((/nk, nj,ni/),double) + ps = new((/nk, nj,ni/),double) + + ;do k = 0, nk-1 + ;do j = 0, nj-1 + ;do i = 0, ni-1 + ; v1(k,j,i) = v(i,j,k,1) + ; v2(k,j,i) = v(i,j,k,2) + ; v3(k,j,i) = v(i,j,k,3) + ; v4(k,j,i) = v(i,j,k,4) + ; ;v5(k,j,i) = v(i,j,k,5) + ;end do + ;end do + ;end do + + u(:,:,:) = vv(0,:,:,:) + v(:,:,:) = vv(1,:,:,:) + t(:,:,:) = vv(2,:,:,:) + rh(:,:,:) = vv(3,:,:,:) + ps(:,:,:) = vv(4,:,:,:) + + ncdf->u = u + ncdf->v = v + ncdf->t = t + ncdf->rh = rh + ncdf->ps = ps + + ;************************************************ + ; end of reading be.dat data + ;************************************************ + +end diff --git a/var/mri4dvar/nc_vplocal.ncl b/var/mri4dvar/nc_vplocal.ncl new file mode 100644 index 0000000000..ef0bad0e43 --- /dev/null +++ b/var/mri4dvar/nc_vplocal.ncl @@ -0,0 +1,64 @@ +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + + + filename = "vp_0020" + + varnames = (/"psi","chi_u","t_u","rh","ps_u"/) + nvar = dimsizes(varnames) + + setfileoption("bin","ReadByteOrder","BigEndian") + dims = fbinrecread(filename,0,15,"integer") + ni=dims(12) + nj=dims(13) + nk=dims(14) + print("ni, nj, nk = "+ni+", "+nj+", "+nk) + + v = fbinrecread(filename,1,(/5,nk,nj,ni/),"double") + + system("/bin/rm -f "+filename+".nc") ; remove any pre-existing file + ncdf = addfile(filename+".nc" ,"c") ; open output netCDF file + + ;=================================================================== + ; make time an UNLIMITED dimension; recommended for most applications + ;=================================================================== + ; filedimdef(ncdf,"time",-1,True) + + ;v1 = new((/nk, nj,ni/),double) + ;v2 = new((/nk, nj,ni/),double) + ;v3 = new((/nk, nj,ni/),double) + v4 = new((/nk, nj,ni/),double) + v5 = new((/nk, nj,ni/),double) + + ;do k = 0, nk-1 + ;do j = 0, nj-1 + ;do i = 0, ni-1 + ; v1(k,j,i) = v(i,j,k,1) + ; v2(k,j,i) = v(i,j,k,2) + ; v3(k,j,i) = v(i,j,k,3) + ; v4(k,j,i) = v(i,j,k,4) + ; ;v5(k,j,i) = v(i,j,k,5) + ;end do + ;end do + ;end do + + ;v1(:,:,:) = v(1,:,:,:) + ;v2(:,:,:) = v(2,:,:,:) + ;v3(:,:,:) = v(3,:,:,:) + v4(:,:,:) = v(4,:,:,:) + ;v5(:,:,:) = v(5,:,:,:) + + ;ncdf->v1 = v1 + ;ncdf->v2 = v2 + ;ncdf->v3 = v3 + ncdf->v4 = v4 + ;ncdf->v5 = v5 + + ;************************************************ + ; end of reading be.dat data + ;************************************************ + +end diff --git a/var/mri4dvar/rsl_lite.h b/var/mri4dvar/rsl_lite.h new file mode 100644 index 0000000000..03a47fca20 --- /dev/null +++ b/var/mri4dvar/rsl_lite.h @@ -0,0 +1,168 @@ +#ifndef CRAY +# ifdef NOUNDERSCORE +# define RSL_LITE_ERROR_DUP1 rsl_error_dup1 +# define BYTE_BCAST byte_bcast +# define RSL_LITE_INIT_EXCH rsl_lite_init_exch +# define RSL_LITE_EXCH_Y rsl_lite_exch_y +# define RSL_LITE_EXCH_X rsl_lite_exch_x +# define RSL_LITE_PACK rsl_lite_pack +# define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs +# define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg +# define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info +# define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg +# define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info +# define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs +# define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg +# define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info +# define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg +# define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info +# define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock +# define TASK_FOR_POINT task_for_point +# define TASK_FOR_POINT_MESSAGE task_for_point_message +# define RSL_LITE_INIT_PERIOD rsl_lite_init_period +# define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y +# define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x +# define RSL_LITE_PACK_PERIOD rsl_lite_pack_period +# define RSL_LITE_INIT_SWAP rsl_lite_init_swap +# define RSL_LITE_SWAP rsl_lite_swap +# define RSL_LITE_PACK_SWAP rsl_lite_pack_swap +# define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle +# define RSL_LITE_CYCLE rsl_lite_cycle +# define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle +# define F_PACK_LINT f_pack_lint +# define F_PACK_INT f_pack_int +# define F_UNPACK_LINT f_unpack_lint +# define F_UNPACK_INT f_unpack_int +# define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname +# else +# ifdef F2CSTYLE +# define RSL_LITE_ERROR_DUP1 rsl_error_dup1__ +# define BYTE_BCAST byte_bcast__ +# define RSL_LITE_INIT_EXCH rsl_lite_init_exch__ +# define RSL_LITE_EXCH_Y rsl_lite_exch_y__ +# define RSL_LITE_EXCH_X rsl_lite_exch_x__ +# define RSL_LITE_PACK rsl_lite_pack__ +# define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs__ +# define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg__ +# define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info__ +# define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg__ +# define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info__ +# define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs__ +# define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg__ +# define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info__ +# define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg__ +# define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info__ +# define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock__ +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__ +# define TASK_FOR_POINT task_for_point__ +# define TASK_FOR_POINT_MESSAGE task_for_point_message__ +# define RSL_LITE_INIT_PERIOD rsl_lite_init_period__ +# define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y__ +# define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x__ +# define RSL_LITE_PACK_PERIOD rsl_lite_pack_period__ +# define RSL_LITE_INIT_SWAP rsl_lite_init_swap__ +# define RSL_LITE_SWAP rsl_lite_swap__ +# define RSL_LITE_PACK_SWAP rsl_lite_pack_swap__ +# define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle__ +# define RSL_LITE_CYCLE rsl_lite_cycle__ +# define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle__ +# define F_PACK_LINT f_pack_lint__ +# define F_PACK_INT f_pack_int__ +# define F_UNPACK_LINT f_unpack_lint__ +# define F_UNPACK_INT f_unpack_int__ +# define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname__ +# else +# define RSL_LITE_ERROR_DUP1 rsl_error_dup1_ +# define BYTE_BCAST byte_bcast_ +# define RSL_LITE_INIT_EXCH rsl_lite_init_exch_ +# define RSL_LITE_EXCH_Y rsl_lite_exch_y_ +# define RSL_LITE_EXCH_X rsl_lite_exch_x_ +# define RSL_LITE_PACK rsl_lite_pack_ +# define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs_ +# define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg_ +# define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info_ +# define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg_ +# define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info_ +# define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs_ +# define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg_ +# define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info_ +# define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg_ +# define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info_ +# define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock_ +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_ +# define TASK_FOR_POINT task_for_point_ +# define TASK_FOR_POINT_MESSAGE task_for_point_message_ +# define RSL_LITE_INIT_PERIOD rsl_lite_init_period_ +# define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y_ +# define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x_ +# define RSL_LITE_PACK_PERIOD rsl_lite_pack_period_ +# define RSL_LITE_INIT_SWAP rsl_lite_init_swap_ +# define RSL_LITE_SWAP rsl_lite_swap_ +# define RSL_LITE_PACK_SWAP rsl_lite_pack_swap_ +# define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle_ +# define RSL_LITE_CYCLE rsl_lite_cycle_ +# define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle_ +# define F_PACK_LINT f_pack_lint_ +# define F_PACK_INT f_pack_int_ +# define F_UNPACK_LINT f_unpack_lint_ +# define F_UNPACK_INT f_unpack_int_ +# define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname_ +# endif +# endif +#endif + +#define RSL_SENDBUF 0 +#define RSL_RECVBUF 1 +#define RSL_FREEBUF 3 +#define RSL_MAXPROC 10000 +#define RSL_INVALID -1 + +/* this must be the same as defined in frame/module_driver_constants.F */ +#define DATA_ORDER_XYZ 1 +#define DATA_ORDER_YXZ 2 +#define DATA_ORDER_ZXY 3 +#define DATA_ORDER_ZYX 4 +#define DATA_ORDER_XZY 5 +#define DATA_ORDER_YZX 6 + + +#define RSL_MALLOC(T,N) (T *)rsl_malloc(__FILE__,__LINE__,(sizeof(T))*(N)) +#define RSL_FREE(P) rsl_free(P) + +char * buffer_for_proc ( int P, int size, int code ) ; +void * rsl_malloc( char * f, int l, int s ) ; +typedef int * int_p ; + +#define INDEX_2(A,B,NB) ( (B) + (A)*(NB) ) +#define INDEX_3(A,B,NB,C,NC) INDEX_2( (A), INDEX_2( (B), (C), (NC) ), (NB)*(NC) ) + +#ifndef STUBMPI +# define RSL_FATAL(N) MPI_Abort(MPI_COMM_WORLD, 9) +#else +# define RSL_FATAL(N) exit(9) ; +#endif +#ifndef MS_SUA +# define RSL_TEST_ERR(T,M) {if(T){fprintf(stderr,"rsl_lite error (\"%s\":%d) %s\n",__FILE__,__LINE__,M);RSL_FATAL(5);}} +#else +# define RSL_TEST_ERR(T,M) {if(T){RSL_FATAL(5);}} +#endif + +#ifndef MPI2_SUPPORT +typedef int MPI_Fint; +# define MPI_Comm_c2f(comm) (MPI_Fint)(comm) +# define MPI_Comm_f2c(comm) (MPI_Comm)(comm) +#endif + +typedef struct rsl_list { + struct rsl_list * next ; + void * data ; /* pointer to some node */ +#ifdef crayx1 + int info1 ; /* blank info field */ + int info2 ; /* blank info field */ +#else + short info1 ; /* blank info field */ + short info2 ; /* blank info field */ +#endif +} rsl_list_t ; + diff --git a/var/mri4dvar/run_mri3d4dvar.csh_lsf b/var/mri4dvar/run_mri3d4dvar.csh_lsf new file mode 100755 index 0000000000..b2efdd214d --- /dev/null +++ b/var/mri4dvar/run_mri3d4dvar.csh_lsf @@ -0,0 +1,742 @@ +#!/bin/tcsh -f + +#set echo +set nonomatch +set TOP_DIR=/glade/p/mmm/liuz/cwb2016 +set JOB='LSF' +set PROJID='NMMM0015' +set QUEUE='regular' +set OS=`uname -s` +set WRFDA_DIR=$TOP_DIR/liuz_newcode/WRFDA_V38 +set MULTI_INC_TOOLS=$TOP_DIR/liuz_newcode/multi_inc_tools_new +set DATA_DIR=$TOP_DIR/20150614case/2015061400_ztd30min + +set RUN_STAGE1=true +set RUN_STAGE2=true +set RUN_STAGE3=true + +#---------------- User Configuration -------------- +set VAR4D=$1 # false if 3DVAR +set VAR4D_LBC=false +set MULTI_INC=$2 +set use_cvt=$3 +set use_vp=$4 +set observerclocktime=00:30 +set minimizeclocktime=03:00 +set WORK_DIR=$TOP_DIR/20150614case/$5 +set THIN_FACTOR=($6 $7) +set BE1=$TOP_DIR/20150614case/be.dat_$8 +set BE2=$TOP_DIR/20150614case/be.dat_$9 +set BE3=$TOP_DIR/20150614case/be.dat_2km +#----------------- User Configuration ------------- + +mkdir -p $WORK_DIR; cd $WORK_DIR + +if ( $VAR4D == true ) then + ln -sf ${WRFDA_DIR}/run/RRTM_DATA_DBL RRTM_DATA + ln -sf ${WRFDA_DIR}/run/RRTMG_LW_DATA_DBL RRTMG_LW_DATA + ln -sf ${WRFDA_DIR}/run/RRTMG_SW_DATA_DBL RRTMG_SW_DATA + ln -sf ${WRFDA_DIR}/run/SOILPARM.TBL . + ln -sf ${WRFDA_DIR}/run/VEGPARM.TBL . + ln -sf ${WRFDA_DIR}/run/GENPARM.TBL . +endif +ln -sf ${WRFDA_DIR}/run/LANDUSE.TBL . +ln -sf ${WRFDA_DIR}/var/da/da_wrfvar.exe . + +cp ${DATA_DIR}/wrfinput_d01 orig_fg +if ( $VAR4D == true ) then + cp ${DATA_DIR}/wrfinput_d01 orig_wrfinput_d01 + cp ${DATA_DIR}/wrfbdy_d01 orig_wrfbdy_d01 + cp ${DATA_DIR}/fg02 orig_fg02 +endif + +if ( $VAR4D == true ) then + cp ${DATA_DIR}/namelist.input_cv7_4dvar orig_namelist.input + ln -sf ${DATA_DIR}/ob*.ascii . +else + cp ${DATA_DIR}/namelist.input_cv7_3dvar orig_namelist.input + ln -sf ${DATA_DIR}/ob01.ascii ./ob.ascii +endif + +#=============================================================================; +# Purpose : Script for running WRF-3D/4DVAR with Multi-resolution +# +# Assuming : 1. All the necessary files required by 4DVAR run are +# already under $RUN_DIR, such as be.dat, namelist.input, *.tbl, +# fg, fg02, wrfbdy_d01, da_wrfvar.exe, da_update_bc, etc. +# +# 2. da_bilin.exe, da_bdy.exe, da_thin.exe, da_vp_bilin.exe +# da_vp_split.exe located under ${MULTI_INC_TOOLS} +# +# How to run : When everything is ready to go, call this script instead of +# da_wrfvar.exe for a Multi-incremental run +# +# run_mri3d4dvar.csh +# +# Limitation : Grids need to match +# ( n - 1 ) mod m = 0 +# where n is the x/y grid number of high resolution, m is the +# x/y grid number of low resolution. Default ratio is 1:3. +# +# Platform : All the commands involved by this script are GNU/Linux +# commands on CentOS box. If involved this script other than +# CentOS, commands may not run as your expect, double check +# it before using. +# +# Not fullly test with all platforms, use it at your own risk +# +# jliu@ucar.edu, MMM/NCAR, 01/13/2012 +# +# Remove RUN_STAGE +# Add the capability of different resolutions for different outer-loops +# xinzhang@ucar.edu, MMM/NCAR, 11/25/2013 +# +# Re-write script and add more comments to ease understanding +# Unify Multi-Resolution Incremental 3DVAR and 4DVAR, i.e., MRI-3D/4DVAR +# Zhiquan (Jake) Liu, liuz@ucar.edu, NCAR/MMM, August 2016 +#=============================================================================; + + +#----------------------------User settings------------------------------------; +# +# Use these environment variables to override the default settings +# +# Variable Names Default Value Description +# +# RUN_CMD mpirun -np 16 Job submit command, "" for serial and OpenMP +# +# TIME_STEP_STAGE2 auto detect Stage2 Time step for integration in integer +# seconds as large as 6*DX (in km) and must be +# exactly divisible by VAR4D_bin exactly. +# +# RADT_STAGE2 auto detect Minutes between radiation physics calls for +# Multi_inc stage2. 1 minute per km of dx. +# +# THIN_FACTOR 3 Thinning ratio +# +# MULTI_INC TRUE TRUE/FALSE - Multi-incremental/full resolution +# +# MAX_OUTERLOOP 1 outerloop number for Multi-incremental run +# +if ( ! $?RUN_CMD ) set RUN_CMD="mpiexec -n " # "" - Serial/OpenMP +if ( ! $?NPROCS_NL ) set NPROCS_NL=1024 # Number of processing cores +if ( ! $?NPROCS ) set NPROCS=(1024 1024) # Number of processing cores +if ( ! $?MAX_OUTERLOOP ) set MAX_OUTERLOOP=2 # Only available for Multi-incremental run +if ( ! $?THIN_FACTOR ) set THIN_FACTOR=(1 1) # default decimation factor + @ n1 = $MAX_OUTERLOOP + @ n2 = $#THIN_FACTOR + @ n3 = $#NPROCS + if ( $n1 > $n2 || $n1 > $n3 ) then + echo "The dimension of THIN_FACTOR ($#THIN_FACTOR) should be equal to MAX_OUTERLOOP ($MAX_OUTERLOOP) " + exit -1 + endif + +#----------------------------End of User settings-----------------------------; + +if ( ! $?MULTI_INC_TOOLS ) then + if ( ${#argv} > 0 ) then + set MULTI_INC_TOOLS=$1 + else + set appname=${0:t} + set MULTI_INC_TOOLS=${0:h} + if ( "$MULTI_INC_TOOLS" == "$appname" ) set MULTI_INC_TOOLS="." + endif +endif + +if ( $MULTI_INC == true ) then + + foreach f (da_thin.exe da_bilin.exe da_bdy.exe \ + da_vp_bilin.exe da_vp_split.exe \ + nc_vpglobal.ncl nc_vphires.ncl nc_increment.ncl ) + if ( -e ${MULTI_INC_TOOLS}/$f ) then + if ( "$MULTI_INC_TOOLS" != "." ) then + ln -sf ${MULTI_INC_TOOLS}/$f . + endif + else + echo "$f NOT exists" > FAIL + exit -1 + endif + end + + set FILES_TO_CLEAN=(ana02 ana02_hires ana02_lores \ + wrfvar_output wrfvar_output_hires wrfvar_output_lores \ + FAIL .current_stage .last_stage .final_stage \ + namelist.input \ + rsl* gts* vp_* outerloop_*) + + #rm -rf $FILES_TO_CLEAN + + touch .current_stage .last_stage .final_stage + + set N=1 + #if ( $VAR4D == true ) then + @ nloop = $MAX_OUTERLOOP + 1 + #else + # @ nloop = $MAX_OUTERLOOP + #endif + + while ( $N <= $nloop ) + + if ( $N == $nloop ) then + set RUN_STAGE1=true # only run omb for the last loop + set RUN_STAGE2=false + set RUN_STAGE3=false + set istage=1 # 1 for observer; 0 for normal 3dvar mode + set nouterloop=1 + set ninnerloop=0 + else + set RUN_STAGE1=true + set RUN_STAGE2=true + set RUN_STAGE3=true + set istage=1 + set nouterloop=1 + set ninnerloop=40 + endif + +#---------------- User Configuration -------------- + if ( $N == 1 ) ln -sf ${BE1} be.dat + if ( $N == 2 ) ln -sf ${BE2} be.dat + if ( $N == 3 ) ln -sf ${BE3} be.dat +#---------------- User Configuration -------------- + + if ( $N == 1 ) then + cp orig_fg o${N}s1_fg # stage1 for observer step + if ( $VAR4D == true ) then + cp orig_fg02 o${N}s1_fg02 + endif + else # from 2nd loop, use previous loop's analysis + @ NM1 = $N - 1 + cp ./o${NM1}s3/wrfvar_output_hires o${N}s1_fg + if ( $VAR4D == true ) then + cp orig_fg02 o${N}s1_fg02 + endif + endif + + if ( $RUN_STAGE1 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop-$N : Stage1-Observer |" + echo "--------------------------------------" + + echo "--------------------------------------" + echo "| 1.0 Set up namlist.input for stage1 |" + echo "--------------------------------------" + #----------------------------------- + # &wrfvar1 + # multi_inc=1, # stage1 for omb only + #--------------------------------------- + if ( $OS == "Darwin" ) then + sed -e "/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc][ \t]*=/ c\ \ + multi_inc=${istage}," \ + -e "/[m][a][x]_[e][x][t]_[i][t][s][ \t]*=/ c\ \ + max_ext_its=${nouterloop}," \ + -e "/[n][t][m][a][x][ \t]*=/ c\ \ + ntmax=${ninnerloop}," \ + orig_namelist.input > o${N}s1_namelist.input + else + sed -e "/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc][ \t]*=/ c\multi_inc=${istage}," \ + -e "/[m][a][x]_[e][x][t]_[i][t][s][ \t]*=/ c\max_ext_its=${nouterloop}," \ + -e "/[n][t][m][a][x][ \t]*=/ c\ntmax=${ninnerloop}," \ + orig_namelist.input > o${N}s1_namelist.input + endif + + + if ( $VAR4D == true ) then + echo "--------------------------------------------" + echo "| 1.1 Generating boundary file for stage1 |" + echo "--------------------------------------------" + + da_bdy.exe -fg o${N}s1_fg \ + -fg02 o${N}s1_fg02 \ + -bdy orig_wrfbdy_d01 \ + -o o${N}s1_wrfbdy_d01 \ + >& o${N}s1_da_bdy.log + if ( ! -e o${N}s1_wrfbdy_d01 ) then + echo "generating bdy file for outloop1 stage1 failed" > FAIL + exit -1 + endif + endif + + echo "--------------------------------------------" + echo "| 1.2 run WRF-VAR in observer mode |" + echo "--------------------------------------------" + + if ( -e namelist.input ) rm namelist.input + ln -sf o${N}s1_namelist.input namelist.input + ln -sf o${N}s1_fg fg + if ( $VAR4D == true ) then + ln -sf o${N}s1_fg02 fg02 + ln -sf o${N}s1_fg wrfinput_d01 + ln -sf o${N}s1_wrfbdy_d01 wrfbdy_d01 + endif + + echo "outerloop${N}_stage1" > .current_stage + echo "outerloop${N}_stage1" > .final_stage + +#-------------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < FAIL + exit -1 + endif + + echo "------------------------------" + echo "| 1.3 Save and clean output |" + echo "------------------------------" + + set out_storage=o${N}s1 + if ( ! -d $out_storage ) mkdir $out_storage; #mkdir $out_storage/RSL + mv submit_lsf.csh fort.140 namelist.input namelist.output* $out_storage + mv rsl.* $out_storage + #mv o${N}s1.*.out o${N}s1.*.err $out_storage + rm rej_obs_conv* gts_omb_oma_*.* filtered_obs.* unpert_obs* + rm analysis_increments wrfvar_output + mv gts_omb.* $out_storage # to be used in stage2 + mv gts_omb_oma_* filtered_obs_* qcstat_conv_01 $out_storage + mv buddy_check check_max_iv jo cost_fn grad_fn statistics $out_storage + + echo "outerloop${N}_stage1" > .last_stage + + if ( "`cat .current_stage`" != "outerloop${N}_stage1" && \ + "`cat .last_stage`" != "outerloop${N}_stage1" ) then + echo "outerloop${N}_stage1 was NOT done, aborted Stage2" + exit -1 + endif + endif # end if RUN_STAGE1 + +#--------------------------------- + if ( $RUN_STAGE2 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop-$N : Stage2-Minimizer |" + echo "--------------------------------------" + + echo "--------------------------------------------" + echo "| 2.0 Set up namelist.input for stage2 |" + echo "--------------------------------------------" + + #--------------------------------------- + # &wrfvar1 + # multi_inc=2, # stage2 for minimization + # dx= + # dy=${NL_DY}.0, + # e_we=$NL_E_WE, + # e_sn=$NL_E_SN, + # time_step=$TIME_STEP_STAGE2, + # var4d_bin= + #------------------------------------------ + set NL_DX=`grep -i -E "dx[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c4-` + set NL_DY=`grep -i -E "dy[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c4-` + set NL_E_WE=`grep -i -E "e_we[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c6-` + set NL_E_SN=`grep -i -E "e_sn[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c6-` + + set NL_DX=`echo $NL_DX | sed 's/\.[0-9]*//g'` + set NL_DY=`echo $NL_DY | sed 's/\.[0-9]*//g'` + set NL_E_WE=`echo $NL_E_WE | sed 's/\.[0-9]*//g'` + set NL_E_SN=`echo $NL_E_SN | sed 's/\.[0-9]*//g'` + + @ NL_DX = $NL_DX * $THIN_FACTOR[$N] + @ NL_DY = $NL_DY * $THIN_FACTOR[$N] + @ NL_E_WE = ($NL_E_WE - 1) / $THIN_FACTOR[$N] + 1 + @ NL_E_SN = ($NL_E_SN - 1) / $THIN_FACTOR[$N] + 1 + + @ RADT_STAGE2 = $NL_DX / 1000 + + set NL_VAR4D_BIN=`grep -i -E "var4d_bin[ \t]*=" orig_namelist.input | \ + sed -e 's/\t/ /g' -e 's/ *//g' \ + -e 's/\.[0-9]*//g' -e 's/,//' \ + -e 's/\r//g' | \ + cut -c11-` + @ TIME_STEP_STAGE2 = ( $NL_DX / 1000 ) * 6 + set i=$TIME_STEP_STAGE2 + while ( $i != 0 ) + @ i = $NL_VAR4D_BIN % $TIME_STEP_STAGE2 + @ TIME_STEP_STAGE2-- + end + @ TIME_STEP_STAGE2++ + + if ( $OS == "Darwin" ) then + sed -e '/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc]/d' \ + -e '/&[Ww][Rr][Ff][Vv][Aa][Rr]1$/ a\ \ + multi_inc=2,' \ + -e "/[Dd][Xx][ \t]*=/ c\ \ + dx=${NL_DX}.0," \ + -e "/[Dd][Yy][ \t]*=/ c\ \ + dy=${NL_DY}.0," \ + -e "/[Ee]_[Ww][Ee][ \t]*=/ c\ \ + e_we=$NL_E_WE,"\ + -e "/[Ee]_[Ss][Nn][ \t]*=/ c\ \ + e_sn=$NL_E_SN," \ + -e "/[Tt][Ii][Mm][Ee]_[Ss][Tt][Ee][Pp][ \t]*=/ c\ \ + time_step=$TIME_STEP_STAGE2," \ + -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\ \ + use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\ \ + use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > o${N}s2_namelist.input + else + sed -e '/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc]/d' \ + -e '/&[Ww][Rr][Ff][Vv][Aa][Rr]1$/ a\multi_inc=2,' \ + -e "/[Dd][Xx][ \t]*=/ c\dx=${NL_DX}.0," \ + -e "/[Dd][Yy][ \t]*=/ c\dy=${NL_DY}.0," \ + -e "/[Ee]_[Ww][Ee][ \t]*=/ c\e_we=$NL_E_WE," \ + -e "/[Ee]_[Ss][Nn][ \t]*=/ c\e_sn=$NL_E_SN," \ + -e "/[Tt][Ii][Mm][Ee]_[Ss][Tt][Ee][Pp][ \t]*=/ c\time_step=$TIME_STEP_STAGE2," \ + -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > o${N}s2_namelist.input + endif + + if ( $N > 1 ) then # only do this step from outer loop 2 + + @ NM1 = $N - 1 + + if ( $use_vp == true || $use_cvt == true ) then + echo "--------------------------------------------" + echo "| 2.1 Scatter the global cvt or vp to PEs |" + echo "--------------------------------------------" + + ln -sf ./o${NM1}s3/vp_output.global_hires . + if ( ! -e vp_output.global_hires ) then + echo "vp_output.global_hires is not found" + exit -1 + endif + +#------------------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < FAIL + exit -1 + endif + end + endif + + endif # end if N > 1 + + if ( $THIN_FACTOR[$N] > 1 ) then + echo "--------------------------------------------" + echo "| 2.2 Thin high-res guess to low-res |" + echo "--------------------------------------------" + + ./da_thin.exe -i o${N}s1_fg \ + -o o${N}s2_fg \ + -thin $THIN_FACTOR[$N] \ + >& o${N}s2_thin_fg.log + if ( ! -e o${N}s2_fg ) then + echo "thinning fg failed" > FAIL + exit -1 + endif + + if ( $VAR4D == true ) then # 2nd level fg only for 4DVAR + ./da_thin.exe -i o${N}s1_fg02 \ + -o o${N}s2_fg02 \ + -thin $THIN_FACTOR[$N] \ + >>& o${N}s2_thin_fg02.log + if ( ! -e o${N}s2_fg02 ) then + echo "thinning fg02 failed" > FAIL + exit -1 + endif + endif + else + cp o${N}s1_fg o${N}s2_fg + if ( $VAR4D == true ) cp o${N}s1_fg02 o${N}s2_fg02 + endif + + if ( $VAR4D == true ) then + echo "--------------------------------------------" + echo "| 2.3 Generating boundary file for stage2 |" + echo "--------------------------------------------" + da_bdy.exe -fg o${N}s2_fg \ + -fg02 o${N}s2_fg02 \ + -bdy orig_wrfbdy_d01 \ + -o o${N}s2_wrfbdy_d01 \ + >& o${N}s2_bdy.log + if ( ! -e o${N}s2_wrfbdy_d01 ) then + echo "generating bdy file for outerloop$N stage2 failed" > FAIL + exit -1 + endif + endif + + echo "--------------------------------------------" + echo "| 2.4 Run WRF-VAR minimization at low-res |" + echo "--------------------------------------------" + + if ( -e namelist.input ) rm -f namelist.input + ln -sf o${N}s2_namelist.input namelist.input + ln -sf ./o${N}s1/gts_omb.* . + ln -sf o${N}s2_fg fg + if ( $VAR4D == true ) then + ln -sf o${N}s2_fg02 fg02 + ln -sf o${N}s2_fg wrfinput_d01 + ln -sf o${N}s2_wrfbdy_d01 wrfbdy_d01 + endif + + echo "outerloop${N}_stage2" > .current_stage + echo "outerloop${N}_stage2" > .last_stage + +#--------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < FAIL + exit -1 + endif + + echo "------------------------------" + echo "| 2.5 Save and clean output |" + echo "------------------------------" + + if ( $use_vp == true ) ncl nc_vpglobal.ncl + ncl nc_increment.ncl + + set out_storage=o${N}s2 + if ( ! -d $out_storage ) mkdir $out_storage; mkdir $out_storage/RSL + rm unpert* gts_omb.* gts_omb_oma_*.* filtered_obs.* + mv buddy_check check_max_iv $out_storage + mv rsl.* rej_obs* qcstat_conv_01 $out_storage #/RSL + mv cost_fn grad_fn jo fort.* statistics $out_storage + mv wrfvar_output namelist.output* $out_storage + mv gts_omb_oma_* filtered_obs_* submit_lsf.csh $out_storage + mv analysis_increments* $out_storage + if ( $use_vp == true || $use_cvt == true ) then + if ( $N > 1 ) rm vp_output.global_hires + mv vp_input.* vv_input.* vv_after* vp_output.global* $out_storage + endif + + endif # end if RUN_STAGE2 + +#----------------------------------- + if ( $RUN_STAGE3 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop${N} : Stage3-Regrid |" + echo "--------------------------------------" + + @ NP1 = $N + 1 + + if ( "$VAR4D_LBC" == "t" || "$VAR4D_LBC" == "T" ) then + # this is not well tested yet. turned it off + echo "------------------------------------------------------------" + echo "| 3.1 regridding in model space for 2nd time level (fg02) |" + echo "------------------------------------------------------------" + # only if var4d_lbc=true. + # NOTE: interpolate to original resolution in model space + + ./da_bilin.exe -fg_lores o${N}s2_fg02 \ + -fg_hires o${N}s1_fg02 \ + -an_lores ana02 \ + -ns $THIN_FACTOR[$N] \ + -o ana02_hires >& o${N}s2_bilin_fg02.log + if ( ! -e ana02_hires ) then + echo "regridding increment failed" > FAIL + exit -1 + endif + mv ana02 ana02_lores + else + echo "# Skipped, VAR4D_LBC=$VAR4D_LBC \n" + endif + + echo "------------------------------------------------------------" + echo "| 3.1 regridding in model space for 1st time level (fg) |" + echo "------------------------------------------------------------" + # wrfvar_output_hires = fg_stage1 + S (wrfvar_output_lores - fg_stage2) + #---------------------------------------------------------------------------- + if ( $THIN_FACTOR[$N] > 1 ) then # regrid to model resolution + ./da_bilin.exe -fg_lores o${N}s2_fg \ + -fg_hires o${N}s1_fg \ + -an_lores ./o${N}s2/wrfvar_output \ + -ns $THIN_FACTOR[$N] \ + -o wrfvar_output_hires >& o${N}s3_da_bilin.log + if ( ! -e wrfvar_output_hires ) then + echo "regridding increment failed" > FAIL + exit -1 + endif + else # if DA res. is same as model res., no need for interpolation + cp ./o${N}s2/wrfvar_output wrfvar_output_hires + endif + + if ( $N < $MAX_OUTERLOOP ) then # no need to do this for the last loop + #------------------------------------------------------ + # interpolate vp to next outer loop's resolution + #------------------------------------------------------------- + if ( $use_vp == true || $use_cvt == true ) then + if ( $THIN_FACTOR[$N] != $THIN_FACTOR[$NP1] ) then # only do this if res diff for two loops + echo "---------------------------------------------" + echo "| 3.2 regridding in control variable space |" + echo "---------------------------------------------" + if ( $N < $MAX_OUTERLOOP ) then + @ ratio = $THIN_FACTOR[$N] / $THIN_FACTOR[$NP1] + else + @ ratio = $THIN_FACTOR[$N] # / 1 + endif + + if ( -e vp_output.global ) rm -f vp_output.global + ln -sf ./o${N}s2/vp_output.global . + ./da_vp_bilin.exe -ratio $ratio >& o${N}s3_vp_bilin.log + if ( ! -e vp_output.global_hires ) then + echo "vp_output.global_hires is not generated" > FAIL + exit -1 + endif + else # if resolution same, no interpolation needed. + cp ./o${N}s2/vp_output.global vp_output.global_hires + endif + ncl nc_vphires.ncl + endif + + echo "---------------------------------" + echo "| 3.3 Save and Clean results |" + echo "---------------------------------" + + set out_storage=o${N}s3 + if ( ! -d $out_storage ) mkdir $out_storage + + mv wrfvar_output_hires $out_storage + rm namelist.input + + if ( $use_vp == true || $use_cvt == true ) then + mv vp_output.global_hires* $out_storage + rm vp_output.global + endif + + endif # $N < $MAX_OUTERLOOP + + endif ## end if RUN_STAGE3=true + + @ N++ + + end # End of outerloop + + rm fg fg02 wrfinput_d01 wrfbdy_d01 + +else ## if NOT multi-resolution incremental 3D/4DVAR, no stop outer loop + + ln -sf ${BE3} be.dat + ln -sf orig_fg fg + if ( $VAR4D == true ) then + ln -sf orig_wrfinput_d01 wrfinput_d01 + ln -sf orig_wrfbdy_d01 wrfbdy_d01 + endif + + if ( $OS == "Darwin" ) then + sed -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\ \ + use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\ \ + use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > namelist.input + else + sed -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > namelist.input + endif + +#--------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < $n2 || $n1 > $n3 ) then + echo "The dimension of THIN_FACTOR ($#THIN_FACTOR) should be equal to MAX_OUTERLOOP ($MAX_OUTERLOOP) " + exit -1 + endif + +#----------------------------End of User settings-----------------------------; + +if ( ! $?MULTI_INC_TOOLS ) then + if ( ${#argv} > 0 ) then + set MULTI_INC_TOOLS=$1 + else + set appname=${0:t} + set MULTI_INC_TOOLS=${0:h} + if ( "$MULTI_INC_TOOLS" == "$appname" ) set MULTI_INC_TOOLS="." + endif +endif + +if ( $MULTI_INC == true ) then + + foreach f (da_thin.exe da_bilin.exe da_bdy.exe \ + da_vp_bilin.exe da_vp_split.exe \ + nc_vpglobal.ncl nc_vphires.ncl nc_increment.ncl ) + if ( -e ${MULTI_INC_TOOLS}/$f ) then + if ( "$MULTI_INC_TOOLS" != "." ) then + ln -sf ${MULTI_INC_TOOLS}/$f . + endif + else + echo "$f NOT exists" > FAIL + exit -1 + endif + end + + set FILES_TO_CLEAN=(ana02 ana02_hires ana02_lores \ + wrfvar_output wrfvar_output_hires wrfvar_output_lores \ + FAIL .current_stage .last_stage .final_stage \ + namelist.input \ + rsl* gts* vp_* outerloop_*) + + #rm -rf $FILES_TO_CLEAN + + touch .current_stage .last_stage .final_stage + + set N=1 + #if ( $VAR4D == true ) then + @ nloop = $MAX_OUTERLOOP + 1 + #else + # @ nloop = $MAX_OUTERLOOP + #endif + + while ( $N <= $nloop ) + + if ( $N == $nloop ) then + set RUN_STAGE1=true # only run omb for the last loop + set RUN_STAGE2=false + set RUN_STAGE3=false + set istage=1 # 1 for observer; 0 for normal 3dvar mode + set nouterloop=1 + set ninnerloop=0 + else + set RUN_STAGE1=true + set RUN_STAGE2=true + set RUN_STAGE3=true + set istage=1 + set nouterloop=1 + set ninnerloop=30 + endif + +#---------------- User Configuration -------------- + if ( $N == 1 ) ln -sf ${BE1} be.dat + if ( $N == 2 ) ln -sf ${BE2} be.dat + if ( $N == 3 ) ln -sf ${BE3} be.dat +#---------------- User Configuration -------------- + + if ( $N == 1 ) then + cp orig_fg o${N}s1_fg # stage1 for observer step + if ( $VAR4D == true ) then + cp orig_fg02 o${N}s1_fg02 + endif + else # from 2nd loop, use previous loop's analysis + @ NM1 = $N - 1 + cp ./o${NM1}s3/wrfvar_output_hires o${N}s1_fg + if ( $VAR4D == true ) then + cp orig_fg02 o${N}s1_fg02 + endif + endif + + if ( $RUN_STAGE1 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop-$N : Stage1-Observer |" + echo "--------------------------------------" + + echo "--------------------------------------" + echo "| 1.0 Set up namlist.input for stage1 |" + echo "--------------------------------------" + #----------------------------------- + # &wrfvar1 + # multi_inc=1, # stage1 for omb only + #--------------------------------------- + if ( $OS == "Darwin" ) then + sed -e "/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc][ \t]*=/ c\ \ + multi_inc=${istage}," \ + -e "/[m][a][x]_[e][x][t]_[i][t][s][ \t]*=/ c\ \ + max_ext_its=${nouterloop}," \ + -e "/[n][t][m][a][x][ \t]*=/ c\ \ + ntmax=${ninnerloop}," \ + orig_namelist.input > o${N}s1_namelist.input + else + sed -e "/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc][ \t]*=/ c\multi_inc=${istage}," \ + -e "/[m][a][x]_[e][x][t]_[i][t][s][ \t]*=/ c\max_ext_its=${nouterloop}," \ + -e "/[n][t][m][a][x][ \t]*=/ c\ntmax=${ninnerloop}," \ + orig_namelist.input > o${N}s1_namelist.input + endif + + + if ( $VAR4D == true ) then + echo "--------------------------------------------" + echo "| 1.1 Generating boundary file for stage1 |" + echo "--------------------------------------------" + + da_bdy.exe -fg o${N}s1_fg \ + -fg02 o${N}s1_fg02 \ + -bdy orig_wrfbdy_d01 \ + -o o${N}s1_wrfbdy_d01 \ + >& o${N}s1_da_bdy.log + if ( ! -e o${N}s1_wrfbdy_d01 ) then + echo "generating bdy file for outloop1 stage1 failed" > FAIL + exit -1 + endif + endif + + echo "--------------------------------------------" + echo "| 1.2 run WRF-VAR in observer mode |" + echo "--------------------------------------------" + + if ( -e namelist.input ) rm namelist.input + ln -sf o${N}s1_namelist.input namelist.input + ln -sf o${N}s1_fg fg + if ( $VAR4D == true ) then + ln -sf o${N}s1_fg02 fg02 + ln -sf o${N}s1_fg wrfinput_d01 + ln -sf o${N}s1_wrfbdy_d01 wrfbdy_d01 + endif + + echo "outerloop${N}_stage1" > .current_stage + echo "outerloop${N}_stage1" > .final_stage + +#-------------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < submit_pbs.csh <> log + if ( "`qstat | grep -o -m 1 $jobid`" != $jobid ) then + if ( "`tail rsl.out.0000 | grep -o -m 1 successfully`" != "successfully" ) then + echo "da_wrfvar stage1 failed " > FAIL + exit -1 + else + break + endif + else + @ i++ + endif + end + echo "done" >> log + + echo "------------------------------" + echo "| 1.3 Save and clean output |" + echo "------------------------------" + + set out_storage=o${N}s1 + if ( ! -d $out_storage ) mkdir $out_storage + mkdir $out_storage/RSL + mv submit_pbs.csh fort.140 namelist.input namelist.output* $out_storage + mv rsl.* $out_storage/RSL + #mv o${N}s1.*.out o${N}s1.*.err $out_storage + rm rej_obs_conv* + mv gts_omb.* $out_storage # to be used in stage2 + mv buddy_check check_max_iv jo cost_fn grad_fn statistics $out_storage + + echo "outerloop${N}_stage1" > .last_stage + + if ( "`cat .current_stage`" != "outerloop${N}_stage1" && \ + "`cat .last_stage`" != "outerloop${N}_stage1" ) then + echo "outerloop${N}_stage1 was NOT done, aborted Stage2" + exit -1 + endif + endif # end if RUN_STAGE1 + +#--------------------------------- + if ( $RUN_STAGE2 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop-$N : Stage2-Minimizer |" + echo "--------------------------------------" + + echo "--------------------------------------------" + echo "| 2.0 Set up namelist.input for stage2 |" + echo "--------------------------------------------" + + #--------------------------------------- + # &wrfvar1 + # multi_inc=2, # stage2 for minimization + # dx= + # dy=${NL_DY}.0, + # e_we=$NL_E_WE, + # e_sn=$NL_E_SN, + # time_step=$TIME_STEP_STAGE2, + # var4d_bin= + #------------------------------------------ + set NL_DX=`grep -i -E "dx[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c4-` + set NL_DY=`grep -i -E "dy[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c4-` + set NL_E_WE=`grep -i -E "e_we[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c6-` + set NL_E_SN=`grep -i -E "e_sn[ \t]*=" orig_namelist.input | sed -e 's/\t/ /g' -e 's/ *//g' -e 's/,//' -e 's/\r//g'| cut -c6-` + + set NL_DX=`echo $NL_DX | sed 's/\.[0-9]*//g'` + set NL_DY=`echo $NL_DY | sed 's/\.[0-9]*//g'` + set NL_E_WE=`echo $NL_E_WE | sed 's/\.[0-9]*//g'` + set NL_E_SN=`echo $NL_E_SN | sed 's/\.[0-9]*//g'` + + @ NL_DX = $NL_DX * $THIN_FACTOR[$N] + @ NL_DY = $NL_DY * $THIN_FACTOR[$N] + @ NL_E_WE = ($NL_E_WE - 1) / $THIN_FACTOR[$N] + 1 + @ NL_E_SN = ($NL_E_SN - 1) / $THIN_FACTOR[$N] + 1 + + @ RADT_STAGE2 = $NL_DX / 1000 + + set NL_VAR4D_BIN=`grep -i -E "var4d_bin[ \t]*=" orig_namelist.input | \ + sed -e 's/\t/ /g' -e 's/ *//g' \ + -e 's/\.[0-9]*//g' -e 's/,//' \ + -e 's/\r//g' | \ + cut -c11-` + @ TIME_STEP_STAGE2 = ( $NL_DX / 1000 ) * 6 + set i=$TIME_STEP_STAGE2 + while ( $i != 0 ) + @ i = $NL_VAR4D_BIN % $TIME_STEP_STAGE2 + @ TIME_STEP_STAGE2-- + end + @ TIME_STEP_STAGE2++ + + if ( $OS == "Darwin" ) then + sed -e '/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc]/d' \ + -e '/&[Ww][Rr][Ff][Vv][Aa][Rr]1$/ a\ \ + multi_inc=2,' \ + -e "/[Dd][Xx][ \t]*=/ c\ \ + dx=${NL_DX}.0," \ + -e "/[Dd][Yy][ \t]*=/ c\ \ + dy=${NL_DY}.0," \ + -e "/[Ee]_[Ww][Ee][ \t]*=/ c\ \ + e_we=$NL_E_WE,"\ + -e "/[Ee]_[Ss][Nn][ \t]*=/ c\ \ + e_sn=$NL_E_SN," \ + -e "/[Tt][Ii][Mm][Ee]_[Ss][Tt][Ee][Pp][ \t]*=/ c\ \ + time_step=$TIME_STEP_STAGE2," \ + -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\ \ + use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\ \ + use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > o${N}s2_namelist.input + else + sed -e '/[Mm][Uu][Ll][Tt][Ii]_[Ii][Nn][Cc]/d' \ + -e '/&[Ww][Rr][Ff][Vv][Aa][Rr]1$/ a\multi_inc=2,' \ + -e "/[Dd][Xx][ \t]*=/ c\dx=${NL_DX}.0," \ + -e "/[Dd][Yy][ \t]*=/ c\dy=${NL_DY}.0," \ + -e "/[Ee]_[Ww][Ee][ \t]*=/ c\e_we=$NL_E_WE," \ + -e "/[Ee]_[Ss][Nn][ \t]*=/ c\e_sn=$NL_E_SN," \ + -e "/[Tt][Ii][Mm][Ee]_[Ss][Tt][Ee][Pp][ \t]*=/ c\time_step=$TIME_STEP_STAGE2," \ + -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > o${N}s2_namelist.input + endif + + if ( $N > 1 ) then # only do this step from outer loop 2 + + @ NM1 = $N - 1 + + if ( $use_vp == true || $use_cvt == true ) then + echo "--------------------------------------------" + echo "| 2.1 Scatter the global cvt or vp to PEs |" + echo "--------------------------------------------" + + ln -sf ./o${NM1}s3/vp_output.global_hires . + if ( ! -e vp_output.global_hires ) then + echo "vp_output.global_hires is not found" + exit -1 + endif + +#------------------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < submit_pbs.csh <> log + if ( "`qstat | grep -o -m 1 $jobid`" != $jobid ) then # if job finish + if ( $use_vp == true || $use_cvt == true ) then + foreach f ( vp_input.0* ) + if ( ! -e $f ) then + echo "$f NOT exists" > FAIL + exit -1 + endif + end + break + endif + else + @ i++ + endif + end + echo "done" >> log + + endif # end if N > 1 + + if ( $THIN_FACTOR[$N] > 1 ) then + echo "--------------------------------------------" + echo "| 2.2 Thin high-res guess to low-res |" + echo "--------------------------------------------" + + ./da_thin.exe -i o${N}s1_fg \ + -o o${N}s2_fg \ + -thin $THIN_FACTOR[$N] \ + >& o${N}s2_thin_fg.log + if ( ! -e o${N}s2_fg ) then + echo "thinning fg failed" > FAIL + exit -1 + endif + + if ( $VAR4D == true ) then # 2nd level fg only for 4DVAR + ./da_thin.exe -i o${N}s1_fg02 \ + -o o${N}s2_fg02 \ + -thin $THIN_FACTOR[$N] \ + >>& o${N}s2_thin_fg02.log + if ( ! -e o${N}s2_fg02 ) then + echo "thinning fg02 failed" > FAIL + exit -1 + endif + endif + else + cp o${N}s1_fg o${N}s2_fg + if ( $VAR4D == true ) cp o${N}s1_fg02 o${N}s2_fg02 + endif + + if ( $VAR4D == true ) then + echo "--------------------------------------------" + echo "| 2.3 Generating boundary file for stage2 |" + echo "--------------------------------------------" + da_bdy.exe -fg o${N}s2_fg \ + -fg02 o${N}s2_fg02 \ + -bdy orig_wrfbdy_d01 \ + -o o${N}s2_wrfbdy_d01 \ + >& o${N}s2_bdy.log + if ( ! -e o${N}s2_wrfbdy_d01 ) then + echo "generating bdy file for outerloop$N stage2 failed" > FAIL + exit -1 + endif + endif + + echo "--------------------------------------------" + echo "| 2.4 Run WRF-VAR minimization at low-res |" + echo "--------------------------------------------" + + if ( -e namelist.input ) rm -f namelist.input + ln -sf o${N}s2_namelist.input namelist.input + ln -sf ./o${N}s1/gts_omb.* . + ln -sf o${N}s2_fg fg + if ( $VAR4D == true ) then + ln -sf o${N}s2_fg02 fg02 + ln -sf o${N}s2_fg wrfinput_d01 + ln -sf o${N}s2_wrfbdy_d01 wrfbdy_d01 + endif + + echo "outerloop${N}_stage2" > .current_stage + echo "outerloop${N}_stage2" > .last_stage + +#--------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < submit_pbs.csh <> log + if ( "`qstat | grep -o -m 1 $jobid`" != $jobid ) then # if job finish + if ( "`tail rsl.out.0000 | grep -o -m 1 successfully`" != "successfully" ) then + echo "da_wrfvar stage2_$N failed " > FAIL + exit -1 + else + break + endif + else + @ i++ + endif + end + echo "done" >> log + + echo "------------------------------" + echo "| 2.5 Save and clean output |" + echo "------------------------------" + + #if ( $use_vp == true ) ncl nc_vpglobal.ncl + #ncl nc_increment.ncl + + set out_storage=o${N}s2 + if ( ! -d $out_storage ) mkdir $out_storage; mkdir $out_storage/RSL + rm unpert* gts_omb.* gts_omb_oma_*.* radar_omb_oma_*.* filtered_obs.* rej_obs* + mv buddy_check check_max_iv qcstat_conv_01 $out_storage + mv rsl.* $out_storage/RSL + mv cost_fn grad_fn jo fort.* statistics $out_storage + mv wrfvar_output namelist.output* $out_storage + mv gts_omb_oma_* radar_omb_oma_* filtered_obs_* submit_pbs.csh $out_storage + mv analysis_increments* $out_storage + if ( $use_vp == true || $use_cvt == true ) then + if ( $N > 1 ) rm vp_output.global_hires + mv vp_input.* vv_input.* vv_after* vp_output.global* $out_storage + endif + + endif # end if RUN_STAGE2 + +#----------------------------------- + if ( $RUN_STAGE3 == "true" ) then + + echo "--------------------------------------" + echo "| Run outerloop${N} : Stage3-Regrid |" + echo "--------------------------------------" + + @ NP1 = $N + 1 + + if ( "$VAR4D_LBC" == "t" || "$VAR4D_LBC" == "T" ) then + # this is not well tested yet. turned it off + echo "------------------------------------------------------------" + echo "| 3.1 regridding in model space for 2nd time level (fg02) |" + echo "------------------------------------------------------------" + # only if var4d_lbc=true. + # NOTE: interpolate to original resolution in model space + + ./da_bilin.exe -fg_lores o${N}s2_fg02 \ + -fg_hires o${N}s1_fg02 \ + -an_lores ana02 \ + -ns $THIN_FACTOR[$N] \ + -o ana02_hires >& o${N}s2_bilin_fg02.log + if ( ! -e ana02_hires ) then + echo "regridding increment failed" > FAIL + exit -1 + endif + mv ana02 ana02_lores + else + echo "# Skipped, VAR4D_LBC=$VAR4D_LBC \n" + endif + + echo "------------------------------------------------------------" + echo "| 3.1 regridding in model space for 1st time level (fg) |" + echo "------------------------------------------------------------" + # wrfvar_output_hires = fg_stage1 + S (wrfvar_output_lores - fg_stage2) + #---------------------------------------------------------------------------- + if ( $THIN_FACTOR[$N] > 1 ) then # regrid to model resolution + ./da_bilin.exe -fg_lores o${N}s2_fg \ + -fg_hires o${N}s1_fg \ + -an_lores ./o${N}s2/wrfvar_output \ + -ns $THIN_FACTOR[$N] \ + -o wrfvar_output_hires >& o${N}s3_da_bilin.log + if ( ! -e wrfvar_output_hires ) then + echo "regridding increment failed" > FAIL + exit -1 + endif + else # if DA res. is same as model res., no need for interpolation + cp ./o${N}s2/wrfvar_output wrfvar_output_hires + endif + + if ( $N < $MAX_OUTERLOOP ) then # no need to do this for the last loop + #------------------------------------------------------ + # interpolate vp to next outer loop's resolution + #------------------------------------------------------------- + if ( $use_vp == true || $use_cvt == true ) then + if ( $THIN_FACTOR[$N] != $THIN_FACTOR[$NP1] ) then # only do this if res diff for two loops + echo "---------------------------------------------" + echo "| 3.2 regridding in control variable space |" + echo "---------------------------------------------" + if ( $N < $MAX_OUTERLOOP ) then + @ ratio = $THIN_FACTOR[$N] / $THIN_FACTOR[$NP1] + else + @ ratio = $THIN_FACTOR[$N] # / 1 + endif + + if ( -e vp_output.global ) rm -f vp_output.global + ln -sf ./o${N}s2/vp_output.global . + ./da_vp_bilin.exe -ratio $ratio \ + -cloud_cv_options 3 \ + -use_cv_w 1 >& o${N}s3_vp_bilin.log + if ( ! -e vp_output.global_hires ) then + echo "vp_output.global_hires is not generated" > FAIL + exit -1 + endif + else # if resolution same, no interpolation needed. + cp ./o${N}s2/vp_output.global vp_output.global_hires + endif + #ncl nc_vphires.ncl + endif + + echo "---------------------------------" + echo "| 3.3 Save and Clean results |" + echo "---------------------------------" + + set out_storage=o${N}s3 + if ( ! -d $out_storage ) mkdir $out_storage + + mv wrfvar_output_hires $out_storage + rm namelist.input + + if ( $use_vp == true || $use_cvt == true ) then + mv vp_output.global_hires* $out_storage + rm vp_output.global + endif + + endif # $N < $MAX_OUTERLOOP + + endif ## end if RUN_STAGE3=true + + @ N++ + + end # End of outerloop + + rm fg fg02 wrfinput_d01 wrfbdy_d01 + +else ## if NOT multi-resolution incremental 3D/4DVAR, no stop outer loop +########################################################################### + + ln -sf ${BE3} be.dat + ln -sf orig_fg fg + if ( $VAR4D == true ) then + ln -sf orig_wrfinput_d01 wrfinput_d01 + ln -sf orig_wrfbdy_d01 wrfbdy_d01 + endif + + if ( $OS == "Darwin" ) then + sed -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\ \ + use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\ \ + use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > namelist.input + else + sed -e "/[u][s][e]_[i][n][v][e][r][s][e]_[s][q][u][a][r][e][r][o][o][t][b][ \t]*=/ c\use_inverse_squarerootb=$use_vp," \ + -e "/[u][s][e]_[i][n][t][e][r][p][o][l][a][t][e]_[c][v][t][ \t]*=/ c\use_interpolate_cvt=$use_cvt," \ + orig_namelist.input > namelist.input + endif + +#--------------------------------- + if ( $JOB == 'LSF' ) then + if ( -e submit_lsf.csh ) rm -f submit_lsf.csh +cat > submit_lsf.csh < submit_pbs.csh < +#include "rsl_lite.h" + +/* updated 20051021, new algorithm distributes the remainder, if any, at either ends of the dimension + rather than the first remainder number of processors in the dimension. Idea is that the processes + on the ends have less work because they're boundary processes. New alg works like this: + a b + + + + + + + o o o o o o o o o o o o o + + + + + + + + + represents a process with an extra point (npoints is n/p+1), o processors that don't (n/p) + a and b are the starting process indices in the dimension of the new section of o or x. + JM +*/ + +/* experimental for running some tasks on host and some on MIC + if minx = -99 then miny is the number of grid points I want in the Y dimension. + Otherwise both are set to 1 and it works normally 20121018 JM */ + +static char tfpmess[1024] ; + +TASK_FOR_POINT ( i_p , j_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p , Px_p, Py_p , minx_p, miny_p, ierr_p ) + int_p i_p , j_p , Px_p , Py_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p, minx_p, miny_p, ierr_p ; +{ + int i , j , ids, ide, jds, jde, npx, npy, minx, miny ; /* inputs */ + int Px, Py ; /* output */ + int idim, jdim ; + int rem, a, b ; + i = *i_p - 1 ; + j = *j_p - 1 ; + npx = *npx_p ; + npy = *npy_p ; +#if 0 + minx = *minx_p ; + miny = *miny_p ; +#else + if ( *minx_p == -99 ) { + minx = 1 ; + miny = *miny_p ; + npx = ( *npx_p * *npy_p ) / 2 ; /* x dim gets half the tasks , only decompose Y by 2 */ + if ( npx * 2 != *npx_p * *npy_p ) { + *ierr_p = 1 ; + sprintf(tfpmess,"%d by %d decomp will not work for MIC/HOST splitting. Need even number of tasks\n") ; + } + } else { + minx = 1 ; + miny = 1 ; + } +#endif + ids = *ids_p - 1 ; ide = *ide_p - 1 ; + jds = *jds_p - 1 ; jde = *jde_p - 1 ; + idim = ide - ids + 1 ; + jdim = jde - jds + 1 ; + + *ierr_p = 0 ; + + if ( *minx_p != -99 ) { + /* begin: jm for Peter Johnsen -- noticed problem with polar filters in gwrf + if the number of processors exceeds number of vertical levels */ + if ( npx > idim ) { npx = idim ; } + if ( npy > jdim ) { npy = jdim ; } + + /* begin: wig; 10-Mar-2008 + Check that the number of processors is not so high that the halos begin to overlap. + If they do, then reduce the number of processors allowed for that dimension. + */ + tfpmess[0] = '\0' ; + if ( idim / npx < minx ) { + npx = idim/minx ; + if (npx < 1) { npx = 1 ;} + if (npx != *npx_p) { + sprintf(tfpmess,"RSL_LITE: TASK_FOR_POINT LIMITING PROCESSOR COUNT IN X-DIRECTION TO %d %d\n", npx,*npx_p) ; + *ierr_p = 1 ; + } + } + if ( jdim / npy < miny ) { + npy = jdim/miny ; + if (npy < 1) { npy = 1 ;} + if (npy != *npy_p) { + sprintf(tfpmess,"RSL_LITE: TASK_FOR_POINT LIMITING PROCESSOR COUNT IN Y-DIRECTION TO %d %d\n", npy,*npy_p) ; + *ierr_p = 1 ; + } + } + /* end: wig */ + } + + i = i >= ids ? i : ids ; i = i <= ide ? i : ide ; + rem = idim % npx ; + a = ( rem / 2 ) * ( (idim / npx) + 1 ) ; + b = a + ( npx - rem ) * ( idim / npx ) ; + if ( i-ids < a ) { + Px = (i-ids) / ( (idim / npx) + 1 ) ; + } + else if ( i-ids < b ) { + Px = ( a / ( (idim / npx) + 1 ) ) + (i-a-ids) / ( ( b - a ) / ( npx - rem ) ) ; + } + else { + Px = ( a / ( (idim / npx) + 1 ) ) + (b-a-ids) / ( ( b - a ) / ( npx - rem ) ) + + (i-b-ids) / ( ( idim / npx ) + 1 ) ; + } + + j = j >= jds ? j : jds ; j = j <= jde ? j : jde ; + if ( *minx_p != -99 ) { + rem = jdim % npy ; + a = ( rem / 2 ) * ( (jdim / npy) + 1 ) ; + b = a + ( npy - rem ) * ( jdim / npy ) ; + if ( j-jds < a ) { + Py = (j-jds) / ( (jdim / npy) + 1 ) ; + } + else if ( j-jds < b ) { + Py = ( a / ( (jdim / npy) + 1 ) ) + (j-a-jds) / ( ( b - a ) / ( npy - rem ) ) ; + } + else { + Py = ( a / ( (jdim / npy) + 1 ) ) + (b-a-jds) / ( ( b - a ) / ( npy - rem ) ) + + (j-b-jds) / ( ( jdim / npy ) + 1 ) ; + } + } else { + Py = 1 ; + if ( j <= jde-miny ) Py = 0 ; + } + + *Px_p = Px ; + *Py_p = Py ; +} + +TASK_FOR_POINT_MESSAGE() +{ + fprintf(stderr,"%s\n",tfpmess) ; +} + +#if 0 +main() +{ + int minx, miny, ierr ; + int ips[100], ipe[100] ; + int jps[100], jpe[100] ; + int shw, i , j , ids, ide, jds, jde, npx, npy ; /* inputs */ + int Px, Py, P ; /* output */ + printf("i, j, ids, ide, jds, jde, npx, npy\n") ; + scanf("%d %d %d %d %d %d %d %d",&i, &j, &ids,&ide,&jds,&jde,&npx,&npy ) ; + shw =0 ; + minx = -99 ; + miny = 180 ; + for ( i = 0 ; i < 100 ; i++ ) { ips[i] = 9999999 ; ipe[i] = -99999999 ; } + for ( i = 0 ; i < 100 ; i++ ) { jps[i] = 9999999 ; jpe[i] = -99999999 ; } +#if 1 + for ( j = jds-shw ; j <= jde+shw ; j++ ) + { + for ( i = ids-shw ; i <= ide+shw ; i++ ) + { +#endif + TASK_FOR_POINT ( &i , &j , + &ids, &ide, &jds, &jde , &npx , &npy , + &Px, &Py, &minx, &miny, &ierr ) ; +// printf("(%3d %3d) ",Px,Py) ; + printf("%d %3d\n ",i, Px) ; +#if 1 + } + printf("\n") ; + } +/* for ( i = 0 ; i < npx*npy ; i++ ) { */ +/* fprintf(stderr,"%3d. ips %d ipe %d (%d) jps %d jpe %d (%d)\n", i, ips[i], ipe[i], ipe[i]-ips[i]+1, jps[i], jpe[i], jpe[i]-jps[i]+1 ) ; */ +/* } */ +#endif +} +#endif diff --git a/var/mri4dvar/wraper_mri3d4dvar.csh b/var/mri4dvar/wraper_mri3d4dvar.csh new file mode 100755 index 0000000000..3da5da1e3f --- /dev/null +++ b/var/mri4dvar/wraper_mri3d4dvar.csh @@ -0,0 +1,30 @@ +#!/bin/tcsh -f +# script 1:VAR4D 2:MULTI_INC 3:use_cvt 4:use_vp 5:WORK_DIR 6/7:THIN_FACTOR 8:BE1 9:BE2 + +./run_mri3d4dvar.csh_pbs true true false true ztd30min_mri4dvar_6km6km_512core 3 3 6km 6km > &! log.66 + +#-------- 3DVAR runs with interpolation of CVT +#./run_mri3d4dvar.csh false true true false mri3dvar_2km2km_cvt 1 1 2km 2km > &! log.22_cvt +#./run_mri3d4dvar.csh false true true false mri3dvar_6km6km_cvt 3 3 6km 6km > &! log.66_cvt +#./run_mri3d4dvar.csh false true true false mri3dvar_18km6km_cvt 9 3 18km 6km > &! log.186_cvt +#-------- 3DVAR runs with Inverse of transform U and interpolation of vp +#./run_mri3d4dvar.csh false true false true mri3dvar_2km2km_vp 1 1 2km 2km > &! log.22_vp +#./run_mri3d4dvar.csh false true false true mri3dvar_6km6km_vp 3 3 6km 6km > &! log.66_vp +#./run_mri3d4dvar.csh false true false true mri3dvar_18km6km_vp 9 3 18km 6km > &! log.186_vp +#-------- 3DVAR runs with cvt=0 for the second outer loop +#./run_mri3d4dvar.csh false true false false mri3dvar_2km2km_cvt0 1 1 2km 2km > &! log.22_cvt0 +#./run_mri3d4dvar.csh false true false false mri3dvar_6km6km_cvt0 3 3 6km 6km > &! log.66_cvt0 +#./run_mri3d4dvar.csh false true false false mri3dvar_18km6km_cvt0 9 3 18km 6km > &! log.186_cvt0 +#------------- +#./run_mri3d4dvar.csh true true true false mri3dvar_6km6km_cvt 3 3 6km 6km > &! log.66_cvt +#./run_mri3d4dvar.csh true true true false mri3dvar_18km6km_cvt 9 3 18km 6km > &! log.186_cvt +#-------- 4DVAR runs with Inverse of transform U and interpolation of vp +#./run_mri3d4dvar.csh true true false true mri3dvar_2km2km_vp 1 1 2km 2km > &! log.22_vp +#./run_mri3d4dvar.csh true true false true mri3dvar_6km6km_vp 3 3 6km 6km > &! log.66_vp +#./run_mri3d4dvar.csh true true false true mri3dvar_18km6km_vp 9 3 18km 6km > &! log.186_vp +#-------- 4DVAR runs with cvt=0 for the second outer loop +#./run_mri3d4dvar.csh true true false false mri3dvar_2km2km_cvt0 1 1 2km 2km > &! log.22_cvt0 +#./run_mri3d4dvar.csh true true false false mri3dvar_6km6km_cvt0 3 3 6km 6km > &! log.66_cvt0 +#./run_mri3d4dvar.csh true true false false mri3dvar_18km6km_cvt0 9 3 18km 6km > &! log.186_cvt0 +#-------- 4DVAR runs with interpolation of CVT +#./run_mri3d4dvar.csh true false false false ztd30min_4dvar_2km2km 1 1 2km 2km > &! log.22