da_transform_xtoy_crtmk_f.inc
References to this file elsewhere.
1 subroutine da_transform_xtoy_crtmk_f ( xa, iv, xp, y )
2
3 !---------------------------------------------------------------------------
4 ! PURPOSE: transform from analysis increment to
5 ! pertubation radiance.
6 ! K-Matrix vesion of da_transform_xtoy_crtm
7 ! use stored Jacobian to directly multi (no need re-call K-matrix)
8 !
9 ! METHOD: delta_y = H delta_x
10 ! 1. input reference state of CRTM_TL
11 ! 2. interpolate analysis increment to obs location
12 ! 3. Call CRTM_TL
13 !
14 ! HISTORY: 11/16/2006 - Creation Zhiquan Liu
15 !
16 !---------------------------------------------------------------------------
17
18 IMPLICIT NONE
19
20 TYPE (x_type), INTENT(IN) :: xa ! delta_x
21 TYPE (xpose_type), INTENT(IN) :: xp ! Domain decomposition vars.
22 TYPE (y_type), INTENT(INOUT) :: y ! H' delta_x
23 TYPE (ob_type), INTENT(IN) :: iv ! O-B structure.
24
25 INTEGER :: l, i, j, k ! Index dimension.
26 INTEGER :: num_rad ! Number of radiance obs
27 REAL :: dx, dxm ! Interpolation weights.
28 REAL :: dy, dym ! Interpolation weights.
29 INTEGER :: inst, n
30 REAL, pointer :: q_tl(:),t_tl(:)
31 REAL :: ps_tl
32
33 ! CRTM local varaibles and types
34 INTEGER :: Allocate_Status
35 !---------------------------------------------------------
36
37 #if !defined(CRTM)
38 call da_error(__FILE__,__LINE__, &
39 (/"Must compile with $CRTM option for radiances"/))
40 #else
41 IF ( iv%num_inst < 1 ) return
42
43 if (trace_use) call da_trace_entry("da_transform_xtoy_crtmk_f")
44
45 !-------------------------------------------------------------------------------
46
47 do inst = 1, iv%num_inst ! loop for sensor
48 if ( iv%instid(inst)%num_rad < 1 ) cycle
49 num_rad = iv%instid(inst)%num_rad
50
51 ALLOCATE( t_tl ( xp%kte-xp%kts+1 ), &
52 q_tl ( xp%kte-xp%kts+1 ), &
53 STAT = Allocate_Status )
54 IF ( Allocate_Status /= 0 ) THEN
55 call da_error(__FILE__,__LINE__, &
56 (/"Error in allocatting t_tl q_tl"/))
57 END IF
58
59 !----------------------------------------------------------------------------
60
61 do n=1,num_rad
62
63 ! [1.2] Interpolate horizontally Atmoshere_TL variables to ob:
64 !-----------------------------------------------------
65 ! [1.6] Get horizontal interpolation weights:
66 !-----------------------------------------------------
67
68 i = iv%instid(inst)%loc_i(n)
69 j = iv%instid(inst)%loc_j(n)
70 dx = iv%instid(inst)%loc_dx(n)
71 dy = iv%instid(inst)%loc_dy(n)
72 dxm = iv%instid(inst)%loc_dxm(n)
73 dym = iv%instid(inst)%loc_dym(n)
74
75 do k=xp%kts,xp%kte ! from bottem to top
76 call da_interp_lin_2d( xa%t(:,:,k), xp%ims, xp%ime, xp%jms, xp%jme, &
77 i, j, dx, dy, dxm, dym, & ! temperature (in K)
78 t_tl(xp%kte-k+1) )
79 call da_interp_lin_2d( xa%q(:,:,k), xp%ims, xp%ime, xp%jms, xp%jme, &
80 i, j, dx, dy, dxm, dym, & ! specific humidity (in kg/kg)
81 q_tl(xp%kte-k+1) )
82 if ( iv%instid(inst)%pm(xp%kte-k+1,n) < 75. ) q_tl(xp%kte-k+1) = 0.
83 end do
84 call da_interp_lin_2d( xa%psfc, xp%ims, xp%ime, xp%jms, xp%jme, &
85 i, j, dx, dy, dxm, dym, & ! in Pa
86 ps_tl )
87 ps_tl = ps_tl*0.01
88 q_tl(:) = q_tl(:)*1000. ! in g/kg
89
90 ! [1.5] Scale transformation and fill zero for no-control variable
91 y%instid(inst)%tb(:,n) = 0.
92 do l=1, iv%instid(inst)%nchan
93 y%instid(inst)%tb(l,n) = y%instid(inst)%tb(l,n) + &
94 iv%instid(inst)%ps_jacobian(l,n)*ps_tl
95 do k=xp%kts,xp%kte
96 y%instid(inst)%tb(l,n) = y%instid(inst)%tb(l,n) &
97 + iv%instid(inst)%t_jacobian(l,k,n)*t_tl(k) &
98 + iv%instid(inst)%q_jacobian(l,k,n)*q_tl(k)
99 end do
100 end do
101
102 !if (n <=10 ) write(6,'(15f8.3)') y%instid(inst)%tb(:,n)
103
104 end do ! end loop for pixels
105
106 !-------------------------------------------------------------------
107 ! [2.0] Deallocating CRTM structures
108 !-------------------------------------------------------------------
109
110 deallocate( t_tl, q_tl, &
111 STAT = Allocate_Status )
112 if ( Allocate_Status /= 0 ) THEN
113 call da_error(__FILE__,__LINE__, &
114 (/"Error in deallocatting t_tl q_tl"/))
115 endif
116
117 end do ! end loop for sensor
118
119 if (trace_use) call da_trace_exit("da_transform_xtoy_crtmk_f")
120 #endif
121
122 end subroutine da_transform_xtoy_crtmk_f
123