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 @ 13514

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

Tiling variables, functions and namelist
  • Property svn:keywords set to Id
File size: 6.7 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, zmask, zdist
56      !!--------------------------------------------------------------------
57      !
58      ik = 1
59      IF ( PRESENT(kkk) ) ik=kkk
60      !
61      CALL dom_uniq(zmask,cdgrid)
62      !
63      SELECT CASE( cdgrid )
64      CASE( 'U' )    ;   zglam(:,:) = glamu(:,:)   ;   zgphi(:,:) = gphiu(:,:)   ;   zmask(:,:) = zmask(:,:) * umask(:,:,ik)
65      CASE( 'V' )    ;   zglam(:,:) = glamv(:,:)   ;   zgphi(:,:) = gphiv(:,:)   ;   zmask(:,:) = zmask(:,:) * vmask(:,:,ik)
66      CASE( 'F' )    ;   zglam(:,:) = glamf(:,:)   ;   zgphi(:,:) = gphif(:,:)   ;   zmask(:,:) = zmask(:,:) * fmask(:,:,ik)
67      CASE DEFAULT   ;   zglam(:,:) = glamt(:,:)   ;   zgphi(:,:) = gphit(:,:)   ;   zmask(:,:) = zmask(:,:) * tmask(:,:,ik)
68      END SELECT
69      !
70      zlon       = MOD( plon       + 720., 360. )                                     ! plon between    0 and 360
71      zglam(:,:) = MOD( zglam(:,:) + 720., 360. )                                     ! glam between    0 and 360
72      IF( zlon > 270. )   zlon = zlon - 360.                                          ! zlon between  -90 and 270
73      IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180
74      zglam(:,:) = zglam(:,:) - zlon
75
76      zgphi(:,:) = zgphi(:,:) - plat
77      zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:)
78     
79      IF( lk_mpp ) THEN 
80         CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc)
81         kii = iloc(1) ; kjj = iloc(2)
82      ELSE
83         iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 )
84         kii = iloc(1) + nimpp - 1
85         kjj = iloc(2) + njmpp - 1
86      ENDIF
87      !
88   END SUBROUTINE dom_ngb
89
90
91   SUBROUTINE dom_uniq( puniq, cdgrd )
92      !!----------------------------------------------------------------------
93      !!                  ***  ROUTINE dom_uniq  ***
94      !!                   
95      !! ** Purpose :   identify unique point of a grid (TUVF)
96      !!
97      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
98      !!                2) check which elements have been changed
99      !!----------------------------------------------------------------------
100      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
101      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
102      !
103      REAL(wp)                       ::  zshift   ! shift value link to the process number
104      INTEGER                        ::  ji       ! dummy loop indices
105      LOGICAL , DIMENSION(jpi,jpj,1) ::   lluniq  ! store whether each point is unique or not
106      REAL(wp), DIMENSION(jpi,jpj  ) ::   ztstref
107      !!----------------------------------------------------------------------
108      !
109      ! build an array with different values for each element
110      ! in mpp: make sure that these values are different even between process
111      ! -> apply a shift value according to the process number
112      zshift = jpimax * jpjmax * ( narea - 1 )
113      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
114      !
115      puniq(:,:) = ztstref(:,:)                    ! default definition
116      CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. )   ! apply boundary conditions
117      lluniq(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have not been changed
118      !
119      puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp )
120      !
121   END SUBROUTINE dom_uniq
122
123
124   PURE FUNCTION is_tile_2d( pt )
125      !!
126      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pt
127      INTEGER :: is_tile_2d
128      !!
129      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
130         is_tile_2d = 1
131      ELSE
132         is_tile_2d = 0
133      ENDIF
134   END FUNCTION is_tile_2d
135
136
137   PURE FUNCTION is_tile_3d( pt )
138      !!
139      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pt
140      INTEGER :: is_tile_3d
141      !!
142      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
143         is_tile_3d = 1
144      ELSE
145         is_tile_3d = 0
146      ENDIF
147   END FUNCTION is_tile_3d
148
149
150   PURE FUNCTION is_tile_4d( pt )
151      !!
152      REAL(wp), DIMENSION(:,:,:,:), INTENT(in) ::   pt
153      INTEGER :: is_tile_4d
154      !!
155      IF( ln_tile .AND. SIZE(pt, 1) < jpi ) THEN
156         is_tile_4d = 1
157      ELSE
158         is_tile_4d = 0
159      ENDIF
160   END FUNCTION is_tile_4d
161
162   !!======================================================================
163END MODULE domutl
Note: See TracBrowser for help on using the repository browser.