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/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90 @ 4416

Last change on this file since 4416 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

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