subroutine init_4dvar 1,6
implicit none
integer :: idum1, idum2, run_seconds ,rc
TYPE(WRFU_TimeInterval) :: run_length
integer :: itmp
real :: rtmp
if (trace_use_dull) call da_trace_entry
("init_4dvar")
run_length = head_grid%stop_subtime - head_grid%start_subtime
CALL WRFU_TimeIntervalGet( run_length, S=run_seconds, rc=rc )
if ( run_seconds .gt. config_flags%interval_seconds ) then
write(unit=message(1),fmt='(A)') 'In 4D-Var assimilation window, lateral boundary update is not allowed.'
write(unit=message(2),fmt='(A)') '"run_seconds" must be less than or equal to "interval_seconds"'
write(unit=message(3),fmt='(A,I0)')'run_seconds = ',run_seconds
write(unit=message(4),fmt='(A,I0)')'interval_seconds = ',config_flags%interval_seconds
call da_error
(__FILE__,__LINE__,message(1:4))
end if
! Save the some physics options, as they will be changed in TL and AD model.
call nl_get_mp_physics (head_grid%id, itmp)
original_mp_physics = itmp
call nl_get_mp_physics_ad (head_grid%id, itmp)
original_mp_physics_ad = itmp
call nl_get_ra_lw_physics (head_grid%id, itmp)
original_ra_lw_physics = itmp
call nl_get_ra_sw_physics (head_grid%id, itmp)
original_ra_sw_physics = itmp
call nl_get_sf_sfclay_physics (head_grid%id, itmp)
original_sf_sfclay_physics = itmp
call nl_get_bl_pbl_physics (head_grid%id, itmp)
original_bl_pbl_physics = itmp
call nl_get_cu_physics (head_grid%id, itmp)
original_cu_physics = itmp
call nl_get_cudt (head_grid%id, rtmp)
original_cudt = rtmp
!call nl_get_mp_zero_out (head_grid%id, original_mp_zero_out)
!call nl_get_sf_surface_physics (head_grid%id, original_sf_surface_physics)
call nl_get_ifsnow (head_grid%id, itmp)
original_ifsnow = itmp
call nl_get_icloud (head_grid%id, itmp)
original_icloud = itmp
!call nl_get_isfflx (head_grid%id, original_isfflx)
! Initialize linked list for trajectory
call xtraj_io_initialize
! Initialize linked list for adjoint forcing and tl. pertbation
call adtl_initialize
! Initialize coefficiences for Jc DF
if ( head_grid%jcdfi_use .OR. head_grid%jcdfi_diag == 1 ) call jcdfi_init_coef
if (.not. associated(model_grid)) model_grid => head_grid
model_config_flags = config_flags
if (trace_use_dull) call da_trace_exit
("init_4dvar")
end subroutine init_4dvar
subroutine clean_4dvar 1,4
if (trace_use_dull) call da_trace_entry
("clean_4dvar")
! Release linked list for trajectory
call xtraj_io_initialize
! Release linked list for ad. forcing and tl. pertubation
call adtl_initialize
if (associated(model_grid)) nullify(model_grid)
if (trace_use_dull) call da_trace_exit
("clean_4dvar")
end subroutine clean_4dvar
subroutine input_nl_xtraj ( time ) 1,3
implicit none
character*256, intent(in) :: time
if (trace_use_dull) call da_trace_entry
("input_nl_xtraj")
call read_nl_xtraj
( time )
if (trace_use_dull) call da_trace_entry
("input_nl_xtraj")
end subroutine input_nl_xtraj
subroutine push_tl_pert (time ),3
implicit none
character*256, intent(in) :: time
if (trace_use_dull) call da_trace_entry
("push_tl_pert")
call save_tl_pert
( time )
if (trace_use_dull) call da_trace_entry
("push_tl_pert")
end subroutine push_tl_pert
subroutine push_ad_forcing (time ) 1,3
implicit none
character*256, intent(in) :: time
if (trace_use_dull) call da_trace_entry
("push_ad_forcing")
call save_ad_forcing
( time )
if (trace_use_dull) call da_trace_entry
("push_ad_forcing")
end subroutine push_ad_forcing
subroutine pop_tl_pert (time ) 1,3
implicit none
character*256, intent(in) :: time
if (trace_use_dull) call da_trace_entry
("pop_tl_pert")
call read_tl_pert
( time )
if (trace_use_dull) call da_trace_entry
("pop_tl_pert")
end subroutine pop_tl_pert
subroutine pop_ad_forcing (time ),3
implicit none
character*256, intent(in) :: time
if (trace_use_dull) call da_trace_entry
("pop_ad_forcing")
call read_ad_forcing
( time )
if (trace_use_dull) call da_trace_entry
("pop_ad_forcing")
end subroutine pop_ad_forcing
subroutine kj_swap (source, target, is, ie, js, je, ks, ke) 21,2
implicit none
integer, intent(in) :: is, ie, js, je, ks, ke
real, dimension(is:ie,js:je,ks:ke), intent(in) :: source
real, dimension(is:ie,ks:ke,js:je), intent(out) :: target
integer :: i, j, k
if (trace_use_dull) call da_trace_entry
("kj_swap")
do j = js, je
do k = ks, ke
do i = is, ie
target(i,k,j) = source(i,j,k)
enddo
enddo
enddo
if (trace_use_dull) call da_trace_entry
("kj_swap")
end subroutine kj_swap
subroutine kj_swap_reverse (source, target, is, ie, js, je, ks, ke) 23,2
implicit none
integer, intent(in) :: is, ie, js, je, ks, ke
real, dimension(is:ie,js:je,ks:ke), intent(out) :: target
real, dimension(is:ie,ks:ke,js:je), intent(in) :: source
integer :: i, j, k
if (trace_use_dull) call da_trace_entry
("kj_swap_reverse")
do k = ks, ke
do j = js, je
do i = is, ie
target(i,j,k) = source(i,k,j)
enddo
enddo
enddo
if (trace_use_dull) call da_trace_entry
("kj_swap_reverse")
end subroutine kj_swap_reverse
subroutine upsidedown_ad_forcing 2,3
implicit none
integer :: nobwin
if (trace_use_dull) call da_trace_entry
("upsidedown_ad_forcing")
! In this method, we will swap linked list node objects (references to the data).
! Swapping starts from the first node object and the first node object is swapped
! with the last node object. Then, the second node object is swapped with the one
! before the last nodes object.
call swap_ad_forcing
( num_fgat_time/2 )
if (trace_use_dull) call da_trace_entry
("upsidedown_ad_forcing")
end subroutine upsidedown_ad_forcing