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.
domutl.F90 in NEMO/trunk/src/OCE/DOM – NEMO

source: NEMO/trunk/src/OCE/DOM/domutl.F90

Last change on this file was 14834, checked in by hadcv, 3 years ago

#2600: Merge in dev_r14273_HPC-02_Daley_Tiling
  • Property svn:keywords set to Id
File size: 7.4 KB
Line 
1MODULE domutl
2   !!======================================================================
3   !!                       ***  MODULE  domutl  ***
4   !! Grid utilities:
5   !!======================================================================
6   !! History : 4.2  !  2020-04  (S. Masson)  Original code
7   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   dom_ngb       : find the closest grid point from a given lon/lat position
11   !!   dom_uniq      : identify unique point of a grid (TUVF)
12   !!----------------------------------------------------------------------
13   !
14   USE dom_oce        ! ocean space and time domain
15   !
16   USE in_out_manager ! I/O manager
17   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
18   USE lib_mpp        ! for mppsum
19
20   IMPLICIT NONE
21   PRIVATE
22
23   INTERFACE is_tile
24      MODULE PROCEDURE is_tile_2d_sp, is_tile_3d_sp, is_tile_4d_sp, is_tile_2d_dp, is_tile_3d_dp, is_tile_4d_dp
25   END INTERFACE is_tile
26
27   PUBLIC dom_ngb    ! routine called in iom.F90 module
28   PUBLIC dom_uniq   ! Called by dommsk and domwri
29   PUBLIC is_tile
30
31   !!----------------------------------------------------------------------
32   !! NEMO/OCE 4.2 , NEMO Consortium (2020)
33   !! $Id$
34   !! Software governed by the CeCILL license (see ./LICENSE)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk )
39      !!----------------------------------------------------------------------
40      !!                    ***  ROUTINE dom_ngb  ***
41      !!
42      !! ** Purpose :   find the closest grid point from a given lon/lat position
43      !!
44      !! ** Method  :   look for minimum distance in cylindrical projection
45      !!                -> not good if located at too high latitude...
46      !!----------------------------------------------------------------------
47      REAL(wp)        , INTENT(in   ) ::   plon, plat   ! longitude,latitude of the point
48      INTEGER         , INTENT(  out) ::   kii, kjj     ! i-,j-index of the closes grid point
49      INTEGER         , INTENT(in   ), OPTIONAL :: kkk  ! k-index of the mask level used
50      CHARACTER(len=1), INTENT(in   ) ::   cdgrid       ! grid name 'T', 'U', 'V', 'W'
51      !
52      INTEGER :: ik         ! working level
53      INTEGER , DIMENSION(2) ::   iloc
54      REAL(wp)               ::   zlon, zmini
55      REAL(wp), DIMENSION(jpi,jpj) ::   zglam, zgphi, zdist
56      LOGICAL , DIMENSION(jpi,jpj) ::   llmsk
57      !!--------------------------------------------------------------------
58      !
59      ik = 1
60      IF ( PRESENT(kkk) ) ik=kkk
61      !
62      SELECT CASE( cdgrid )
63      CASE( 'U' ) ;   zglam(:,:) = glamu(:,:)   ;   zgphi(:,:) = gphiu(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * umask(:,:,ik) == 1._wp
64      CASE( 'V' ) ;   zglam(:,:) = glamv(:,:)   ;   zgphi(:,:) = gphiv(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * vmask(:,:,ik) == 1._wp
65      CASE( 'F' ) ;   zglam(:,:) = glamf(:,:)   ;   zgphi(:,:) = gphif(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * fmask(:,:,ik) == 1._wp
66      CASE DEFAULT;   zglam(:,:) = glamt(:,:)   ;   zgphi(:,:) = gphit(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * tmask(:,:,ik) == 1._wp
67      END SELECT
68      !
69      zlon       = MOD( plon       + 720., 360. )                                     ! plon between    0 and 360
70      zglam(:,:) = MOD( zglam(:,:) + 720., 360. )                                     ! glam between    0 and 360
71      IF( zlon > 270. )   zlon = zlon - 360.                                          ! zlon between  -90 and 270
72      IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180
73      zglam(:,:) = zglam(:,:) - zlon
74      !
75      zgphi(:,:) = zgphi(:,:) - plat
76      zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:)
77      !
78      CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. )
79      kii = iloc(1)
80      kjj = iloc(2)
81      !
82   END SUBROUTINE dom_ngb
83
84
85   SUBROUTINE dom_uniq( puniq, cdgrd )
86      !!----------------------------------------------------------------------
87      !!                  ***  ROUTINE dom_uniq  ***
88      !!
89      !! ** Purpose :   identify unique point of a grid (TUVF)
90      !!
91      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
92      !!                2) check which elements have been changed
93      !!----------------------------------------------------------------------
94      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
95      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
96      !
97      REAL(wp)                       ::  zshift   ! shift value link to the process number
98      INTEGER                        ::  ji       ! dummy loop indices
99      LOGICAL , DIMENSION(jpi,jpj,1) ::   lluniq  ! store whether each point is unique or not
100      REAL(wp), DIMENSION(jpi,jpj  ) ::   ztstref
101      !!----------------------------------------------------------------------
102      !
103      ! build an array with different values for each element
104      ! in mpp: make sure that these values are different even between process
105      ! -> apply a shift value according to the process number
106      zshift = jpimax * jpjmax * ( narea - 1 )
107      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
108      !
109      puniq(:,:) = ztstref(:,:)                    ! default definition
110      CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. )   ! apply boundary conditions
111      lluniq(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have not been changed
112      !
113      puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp )
114      !
115   END SUBROUTINE dom_uniq
116
117
118   INTEGER FUNCTION is_tile_2d_sp( pt )
119      REAL(sp), DIMENSION(:,:), INTENT(in) ::   pt
120
121      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
122         is_tile_2d_sp = 1
123      ELSE
124         is_tile_2d_sp = 0
125      ENDIF
126   END FUNCTION is_tile_2d_sp
127
128
129   INTEGER FUNCTION is_tile_2d_dp( pt )
130      REAL(dp), DIMENSION(:,:), INTENT(in) ::   pt
131
132      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
133         is_tile_2d_dp = 1
134      ELSE
135         is_tile_2d_dp = 0
136      ENDIF
137   END FUNCTION is_tile_2d_dp
138
139
140   INTEGER FUNCTION is_tile_3d_sp( pt )
141      REAL(sp), DIMENSION(:,:,:), INTENT(in) ::   pt
142
143      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
144         is_tile_3d_sp = 1
145      ELSE
146         is_tile_3d_sp = 0
147      ENDIF
148   END FUNCTION is_tile_3d_sp
149
150
151   INTEGER FUNCTION is_tile_3d_dp( pt )
152      REAL(dp), DIMENSION(:,:,:), INTENT(in) ::   pt
153
154      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
155         is_tile_3d_dp = 1
156      ELSE
157         is_tile_3d_dp = 0
158      ENDIF
159   END FUNCTION is_tile_3d_dp
160
161
162   INTEGER FUNCTION is_tile_4d_sp( pt )
163      REAL(sp), DIMENSION(:,:,:,:), INTENT(in) ::   pt
164
165      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
166         is_tile_4d_sp = 1
167      ELSE
168         is_tile_4d_sp = 0
169      ENDIF
170   END FUNCTION is_tile_4d_sp
171
172
173   INTEGER FUNCTION is_tile_4d_dp( pt )
174      REAL(dp), DIMENSION(:,:,:,:), INTENT(in) ::   pt
175
176      IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
177         is_tile_4d_dp = 1
178      ELSE
179         is_tile_4d_dp = 0
180      ENDIF
181   END FUNCTION is_tile_4d_dp
182   !!======================================================================
183END MODULE domutl
Note: See TracBrowser for help on using the repository browser.