New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
obs_rot_vel.F90 in branches/UKMO/dev_r5518_flux_correction/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/UKMO/dev_r5518_flux_correction/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90 @ 8702

Last change on this file since 8702 was 8702, checked in by davestorkey, 6 years ago

UKMO dev_r5518_flux_correction branch: clear SVN keywords.

File size: 8.6 KB
Line 
1MODULE obs_rot_vel
2   !!======================================================================
3   !!                       ***  MODULE obs_rot_vel  ***
4   !! Observation diagnostics: Read the velocity profile observations
5   !!======================================================================
6
7   !!----------------------------------------------------------------------
8   !!   obs_rotvel : Rotate velocity data into N-S,E-W directorions
9   !!----------------------------------------------------------------------
10   !! * Modules used   
11   USE wrk_nemo                 ! Memory Allocation
12   USE par_kind                 ! Precision variables
13   USE par_oce                  ! Ocean parameters
14   USE in_out_manager           ! I/O manager
15   USE dom_oce                  ! Ocean space and time domain variables
16   USE obs_grid                 ! Grid search
17   USE obs_utils                ! For error handling
18   USE obs_profiles_def         ! Profile definitions
19   USE obs_inter_h2d            ! Horizontal interpolation
20   USE obs_inter_sup            ! MPP support routines for interpolation
21   USE geo2ocean                ! Rotation of vectors
22   USE obs_fbm                  ! Feedback definitions
23
24   IMPLICIT NONE
25
26   !! * Routine accessibility
27   PRIVATE
28
29   PUBLIC obs_rotvel            ! Rotate the observations
30
31   !!----------------------------------------------------------------------
32   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
33   !! $Id$
34   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
35   !!----------------------------------------------------------------------
36
37CONTAINS
38
39   SUBROUTINE obs_rotvel( profdata, k2dint, pu, pv )
40      !!---------------------------------------------------------------------
41      !!
42      !!                   *** ROUTINE obs_rea_pro_dri ***
43      !!
44      !! ** Purpose : Rotate velocity data into N-S,E-W directorions
45      !!
46      !! ** Method  : Interpolation of geo2ocean coefficients on U,V grid
47      !!              to observation point followed by a similar computations
48      !!              as in geo2ocean.
49      !!
50      !! ** Action  : Review if there is a better way to do this.
51      !!
52      !! References :
53      !!
54      !! History : 
55      !!      ! :  2009-02 (K. Mogensen) : New routine
56      !!----------------------------------------------------------------------
57      !! * Modules used
58      !! * Arguments
59      TYPE(obs_prof), INTENT(INOUT) :: profdata    ! Profile data to be read
60      INTEGER, INTENT(IN) :: k2dint     ! Horizontal interpolation methed
61      REAL(wp), DIMENSION(*) :: &
62         & pu, &
63         & pv
64      !! * Local declarations
65      REAL(wp), DIMENSION(2,2,1) :: zweig
66      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
67         & zmasku, &
68         & zmaskv, &
69         & zcoslu, &
70         & zsinlu, &
71         & zcoslv, &
72         & zsinlv, &
73         & zglamu, &
74         & zgphiu, &
75         & zglamv, &
76         & zgphiv
77      REAL(wp), DIMENSION(1) :: &
78         & zsinu, &
79         & zcosu, &
80         & zsinv, &
81         & zcosv
82      REAL(wp) :: zsin
83      REAL(wp) :: zcos
84      REAL(wp), DIMENSION(1) :: zobsmask
85      REAL(wp), POINTER, DIMENSION(:,:) :: zsingu,zcosgu,zsingv,zcosgv
86      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
87         & igrdiu, &
88         & igrdju, &
89         & igrdiv, &
90         & igrdjv
91      INTEGER :: ji
92      INTEGER :: jk
93
94      CALL wrk_alloc(jpi,jpj,zsingu,zcosgu,zsingv,zcosgv) 
95
96      !-----------------------------------------------------------------------
97      ! Allocate data for message parsing and interpolation
98      !-----------------------------------------------------------------------
99
100      ALLOCATE( &
101         & igrdiu(2,2,profdata%nprof), &
102         & igrdju(2,2,profdata%nprof), &
103         & zglamu(2,2,profdata%nprof), &
104         & zgphiu(2,2,profdata%nprof), &
105         & zmasku(2,2,profdata%nprof), &
106         & zcoslu(2,2,profdata%nprof), &
107         & zsinlu(2,2,profdata%nprof), &
108         & igrdiv(2,2,profdata%nprof), &
109         & igrdjv(2,2,profdata%nprof), &
110         & zglamv(2,2,profdata%nprof), &
111         & zgphiv(2,2,profdata%nprof), &
112         & zmaskv(2,2,profdata%nprof), &
113         & zcoslv(2,2,profdata%nprof), &
114         & zsinlv(2,2,profdata%nprof)  &
115         & )
116
117      !-----------------------------------------------------------------------
118      ! Receive the angles on the U and V grids.
119      !-----------------------------------------------------------------------
120
121      CALL obs_rot( zsingu, zcosgu, zsingv, zcosgv )
122
123      DO ji = 1, profdata%nprof
124         igrdiu(1,1,ji) = profdata%mi(ji,1)-1
125         igrdju(1,1,ji) = profdata%mj(ji,1)-1
126         igrdiu(1,2,ji) = profdata%mi(ji,1)-1
127         igrdju(1,2,ji) = profdata%mj(ji,1)
128         igrdiu(2,1,ji) = profdata%mi(ji,1)
129         igrdju(2,1,ji) = profdata%mj(ji,1)-1
130         igrdiu(2,2,ji) = profdata%mi(ji,1)
131         igrdju(2,2,ji) = profdata%mj(ji,1)
132         igrdiv(1,1,ji) = profdata%mi(ji,2)-1
133         igrdjv(1,1,ji) = profdata%mj(ji,2)-1
134         igrdiv(1,2,ji) = profdata%mi(ji,2)-1
135         igrdjv(1,2,ji) = profdata%mj(ji,2)
136         igrdiv(2,1,ji) = profdata%mi(ji,2)
137         igrdjv(2,1,ji) = profdata%mj(ji,2)-1
138         igrdiv(2,2,ji) = profdata%mi(ji,2)
139         igrdjv(2,2,ji) = profdata%mj(ji,2)
140      END DO
141
142      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &
143         &                  glamu, zglamu )
144      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &
145         &                  gphiu, zgphiu )
146      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &
147         &                  umask(:,:,1), zmasku )
148      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &
149         &                  zsingu, zsinlu )
150      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &
151         &                  zcosgu, zcoslu )
152      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &
153         &                  glamv, zglamv )
154      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &
155         &                  gphiv, zgphiv )
156      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &
157         &                  vmask(:,:,1), zmaskv )
158      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &
159         &                  zsingv, zsinlv )
160      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &
161         &                  zcosgv, zcoslv )
162
163      DO ji = 1, profdata%nprof
164           
165         CALL obs_int_h2d_init( 1, 1, k2dint, &
166            &                   profdata%rlam(ji), profdata%rphi(ji), &
167            &                   zglamu(:,:,ji), zgphiu(:,:,ji), &
168            &                   zmasku(:,:,ji), zweig, zobsmask )
169         
170         CALL obs_int_h2d( 1, 1, zweig, zsinlu(:,:,ji),  zsinu )
171
172         CALL obs_int_h2d( 1, 1, zweig, zcoslu(:,:,ji),  zcosu )
173
174         CALL obs_int_h2d_init( 1, 1, k2dint, &
175            &                   profdata%rlam(ji), profdata%rphi(ji), &
176            &                   zglamv(:,:,ji), zgphiv(:,:,ji), &
177            &                   zmaskv(:,:,ji), zweig, zobsmask )
178         
179         CALL obs_int_h2d( 1, 1, zweig, zsinlv(:,:,ji),  zsinv )
180
181         CALL obs_int_h2d( 1, 1, zweig, zcoslv(:,:,ji),  zcosv )
182
183         ! Assume that the angle at observation point is the
184         ! mean of u and v cosines/sines
185
186         zcos = 0.5_wp * ( zcosu(1) + zcosv(1) )
187         zsin = 0.5_wp * ( zsinu(1) + zsinv(1) )
188         
189         IF ( ( profdata%npvsta(ji,1) /= profdata%npvsta(ji,2) ) .OR. &
190            & ( profdata%npvend(ji,1) /= profdata%npvend(ji,2) ) ) THEN
191            CALL fatal_error( 'Different number of U and V observations '// &
192               'in a profile in obs_rotvel', __LINE__ )
193         ENDIF
194
195         DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1)
196            IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. &
197               & ( profdata%var(1)%vmod(jk) /= fbrmdi ) ) THEN
198               pu(jk) = profdata%var(1)%vmod(jk) * zcos - &
199                  &     profdata%var(2)%vmod(jk) * zsin
200               pv(jk) = profdata%var(2)%vmod(jk) * zcos + &
201                  &     profdata%var(1)%vmod(jk) * zsin
202            ELSE
203               pu(jk) = fbrmdi
204               pv(jk) = fbrmdi
205            ENDIF
206         END DO
207
208      END DO
209     
210      DEALLOCATE( &
211         & igrdiu, &
212         & igrdju, &
213         & zglamu, &
214         & zgphiu, &
215         & zmasku, &
216         & zcoslu, &
217         & zsinlu, &
218         & igrdiv, &
219         & igrdjv, &
220         & zglamv, &
221         & zgphiv, &
222         & zmaskv, &
223         & zcoslv, &
224         & zsinlv  &
225         & )
226
227      CALL wrk_dealloc(jpi,jpj,zsingu,zcosgu,zsingv,zcosgv) 
228
229   END SUBROUTINE obs_rotvel
230
231END MODULE obs_rot_vel
Note: See TracBrowser for help on using the repository browser.