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/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/DOM – NEMO

source: NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/DOM/domutl.F90 @ 13553

Last change on this file since 13553 was 13553, checked in by hadcv, 4 years ago

Merge in trunk up to [13550]
  • Property svn:keywords set to Id
File size: 6.6 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, is_tile_3d, is_tile_4d
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   PURE FUNCTION is_tile_2d( pt )
119      !!
120      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pt
121      INTEGER :: is_tile_2d
122      !!
123      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
124         is_tile_2d = 1
125      ELSE
126         is_tile_2d = 0
127      ENDIF
128   END FUNCTION is_tile_2d
129
130
131   PURE FUNCTION is_tile_3d( pt )
132      !!
133      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pt
134      INTEGER :: is_tile_3d
135      !!
136      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
137         is_tile_3d = 1
138      ELSE
139         is_tile_3d = 0
140      ENDIF
141   END FUNCTION is_tile_3d
142
143
144   PURE FUNCTION is_tile_4d( pt )
145      !!
146      REAL(wp), DIMENSION(:,:,:,:), INTENT(in) ::   pt
147      INTEGER :: is_tile_4d
148      !!
149      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
150         is_tile_4d = 1
151      ELSE
152         is_tile_4d = 0
153      ENDIF
154   END FUNCTION is_tile_4d
155
156   !!======================================================================
157END MODULE domutl
Note: See TracBrowser for help on using the repository browser.