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

source: trunk/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

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