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.
domwri.F90 in branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/DOM – NEMO

source: branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90 @ 5737

Last change on this file since 5737 was 5737, checked in by gm, 9 years ago

#1593: LDF-ADV, step I: Phasing of horizontal scale factors correct 2

  • Property svn:keywords set to Id
File size: 20.8 KB
Line 
1MODULE domwri
2   !!======================================================================
3   !!                       ***  MODULE domwri  ***
4   !! Ocean initialization : write the ocean domain mesh file(s)
5   !!======================================================================
6   !! History :  OPA  ! 1997-02  (G. Madec)  Original code
7   !!            8.1  ! 1999-11  (M. Imbard)  NetCDF FORMAT with IOIPSL
8   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90 and several file
9   !!            3.0  ! 2008-01  (S. Masson) add dom_uniq
10   !!            4.0  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
11   !!----------------------------------------------------------------------
12
13   !!----------------------------------------------------------------------
14   !!   dom_wri        : create and write mesh and mask file(s)
15   !!   dom_uniq       :
16   !!----------------------------------------------------------------------
17   USE dom_oce         ! ocean space and time domain
18   USE in_out_manager  ! I/O manager
19   USE iom             ! I/O library
20   USE lbclnk          ! lateral boundary conditions - mpp exchanges
21   USE lib_mpp         ! MPP library
22   USE wrk_nemo        ! Memory allocation
23   USE timing          ! Timing
24
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC   dom_wri              ! routine called by inidom.F90
29   PUBLIC   dom_wri_coordinate   ! routine called by domhgr.F90
30   !! * Substitutions
31#  include "vectopt_loop_substitute.h90"
32   !!----------------------------------------------------------------------
33   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
34   !! $Id$
35   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
36   !!----------------------------------------------------------------------
37CONTAINS
38
39
40
41   SUBROUTINE dom_wri_coordinate
42      !!----------------------------------------------------------------------
43      !!                  ***  ROUTINE dom_wri_coordinate  ***
44      !!                   
45      !! ** Purpose :   Create the NetCDF file which contains all the
46      !!              standard coordinate information plus the surface,
47      !!              e1e2u and e1e2v. By doing so, those surface will
48      !!              not be changed by the reduction of e1u or e2v scale
49      !!              factors in some straits.
50      !!                 NB: call just after the read of standard coordinate
51      !!              and the reduction of scale factors in some straits
52      !!
53      !! ** output file :   coordinate_e1e2u_v.nc
54      !!----------------------------------------------------------------------
55      INTEGER           ::   inum0    ! temprary units for 'coordinate_e1e2u_v.nc' file
56      CHARACTER(len=21) ::   clnam0   ! filename (mesh and mask informations)
57      !                                   !  workspaces
58      REAL(wp), POINTER, DIMENSION(:,:  ) :: zprt, zprw 
59      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv
60      !!----------------------------------------------------------------------
61      !
62      IF( nn_timing == 1 )  CALL timing_start('dom_wri_coordinate')
63      !
64      IF(lwp) WRITE(numout,*)
65      IF(lwp) WRITE(numout,*) 'dom_wri_coordinate : create NetCDF coordinate file'
66      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'
67     
68      clnam0 = 'coordinate_e1e2u_v'  ! filename (mesh and mask informations)
69     
70      !  create 'coordinate_e1e2u_v.nc' file
71      ! ============================
72      !
73      CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )
74      !
75      !                                                         ! horizontal mesh (inum3)
76      CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude
77      CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r4 )
78      CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r4 )
79      CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r4 )
80     
81      CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude
82      CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r4 )
83      CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r4 )
84      CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r4 )
85     
86      CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
87      CALL iom_rstput( 0, 0, inum0, 'e1u', e1u, ktype = jp_r8 )
88      CALL iom_rstput( 0, 0, inum0, 'e1v', e1v, ktype = jp_r8 )
89      CALL iom_rstput( 0, 0, inum0, 'e1f', e1f, ktype = jp_r8 )
90     
91      CALL iom_rstput( 0, 0, inum0, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
92      CALL iom_rstput( 0, 0, inum0, 'e2u', e2u, ktype = jp_r8 )
93      CALL iom_rstput( 0, 0, inum0, 'e2v', e2v, ktype = jp_r8 )
94      CALL iom_rstput( 0, 0, inum0, 'e2f', e2f, ktype = jp_r8 )
95     
96      CALL iom_rstput( 0, 0, inum0, 'e1e2u', e1e2u, ktype = jp_r8 )
97      CALL iom_rstput( 0, 0, inum0, 'e1e2v', e1e2v, ktype = jp_r8 )
98
99      CALL iom_close( inum0 )
100      !
101      IF( nn_timing == 1 )  CALL timing_stop('dom_wri_coordinate')
102      !
103   END SUBROUTINE dom_wri_coordinate
104
105
106   SUBROUTINE dom_wri
107      !!----------------------------------------------------------------------
108      !!                  ***  ROUTINE dom_wri  ***
109      !!                   
110      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
111      !!      ocean domain informations (mesh and mask arrays). This (these)
112      !!      file(s) is (are) used for visualisation (SAXO software) and
113      !!      diagnostic computation.
114      !!
115      !! ** Method  :   Write in a file all the arrays generated in routines
116      !!      domhgr, domzgr, and dommsk. Note: the file contain depends on
117      !!      the vertical coord. used (z-coord, partial steps, s-coord)
118      !!            MOD(nmsh, 3) = 1  :   'mesh_mask.nc' file
119      !!                         = 2  :   'mesh.nc' and mask.nc' files
120      !!                         = 0  :   'mesh_hgr.nc', 'mesh_zgr.nc' and
121      !!                                  'mask.nc' files
122      !!      For huge size domain, use option 2 or 3 depending on your
123      !!      vertical coordinate.
124      !!
125      !!      if     nmsh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw]
126      !!      if 3 < nmsh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays
127      !!                        corresponding to the depth of the bottom t- and w-points
128      !!      if 6 < nmsh <= 9: write 2D arrays corresponding to the depth and the
129      !!                        thickness (e3[tw]_ps) of the bottom points
130      !!
131      !! ** output file :   meshmask.nc  : domain size, horizontal grid-point position,
132      !!                                   masks, depth and vertical scale factors
133      !!----------------------------------------------------------------------
134      !!
135      INTEGER           ::   inum0    ! temprary units for 'mesh_mask.nc' file
136      INTEGER           ::   inum1    ! temprary units for 'mesh.nc'      file
137      INTEGER           ::   inum2    ! temprary units for 'mask.nc'      file
138      INTEGER           ::   inum3    ! temprary units for 'mesh_hgr.nc'  file
139      INTEGER           ::   inum4    ! temprary units for 'mesh_zgr.nc'  file
140      CHARACTER(len=21) ::   clnam0   ! filename (mesh and mask informations)
141      CHARACTER(len=21) ::   clnam1   ! filename (mesh informations)
142      CHARACTER(len=21) ::   clnam2   ! filename (mask informations)
143      CHARACTER(len=21) ::   clnam3   ! filename (horizontal mesh informations)
144      CHARACTER(len=21) ::   clnam4   ! filename (vertical   mesh informations)
145      INTEGER           ::   ji, jj, jk   ! dummy loop indices
146      !                                   !  workspaces
147      REAL(wp), POINTER, DIMENSION(:,:  ) :: zprt, zprw 
148      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv
149      !!----------------------------------------------------------------------
150      !
151      IF( nn_timing == 1 )  CALL timing_start('dom_wri')
152      !
153      CALL wrk_alloc( jpi, jpj, zprt, zprw )
154      CALL wrk_alloc( jpi, jpj, jpk, zdepu, zdepv )
155      !
156      IF(lwp) WRITE(numout,*)
157      IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)'
158      IF(lwp) WRITE(numout,*) '~~~~~~~'
159     
160      clnam0 = 'mesh_mask'  ! filename (mesh and mask informations)
161      clnam1 = 'mesh'       ! filename (mesh informations)
162      clnam2 = 'mask'       ! filename (mask informations)
163      clnam3 = 'mesh_hgr'   ! filename (horizontal mesh informations)
164      clnam4 = 'mesh_zgr'   ! filename (vertical   mesh informations)
165     
166      SELECT CASE ( MOD(nmsh, 3) )
167         !                                  ! ============================
168      CASE ( 1 )                            !  create 'mesh_mask.nc' file
169         !                                  ! ============================
170         CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )
171         inum2 = inum0                                            ! put all the informations
172         inum3 = inum0                                            ! in unit inum0
173         inum4 = inum0
174         
175         !                                  ! ============================
176      CASE ( 2 )                            !  create 'mesh.nc' and
177         !                                  !         'mask.nc' files
178         !                                  ! ============================
179         CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib )
180         CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
181         inum3 = inum1                                            ! put mesh informations
182         inum4 = inum1                                            ! in unit inum1
183         !                                  ! ============================
184      CASE ( 0 )                            !  create 'mesh_hgr.nc'
185         !                                  !         'mesh_zgr.nc' and
186         !                                  !         'mask.nc'     files
187         !                                  ! ============================
188         CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
189         CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib )
190         CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib )
191         !
192      END SELECT
193     
194      !                                                         ! masks (inum2)
195      CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask
196      CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 )
197      CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 )
198      CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 )
199     
200      CALL dom_uniq( zprw, 'T' )
201      DO jj = 1, jpj
202         DO ji = 1, jpi
203            jk=mikt(ji,jj) 
204            zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
205         END DO
206      END DO                             !    ! unique point mask
207      CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 ) 
208      CALL dom_uniq( zprw, 'U' )
209      DO jj = 1, jpj
210         DO ji = 1, jpi
211            jk=miku(ji,jj) 
212            zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
213         END DO
214      END DO
215      CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 ) 
216      CALL dom_uniq( zprw, 'V' )
217      DO jj = 1, jpj
218         DO ji = 1, jpi
219            jk=mikv(ji,jj) 
220            zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
221         END DO
222      END DO
223      CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 
224      CALL dom_uniq( zprw, 'F' )
225      DO jj = 1, jpj
226         DO ji = 1, jpi
227            jk=mikf(ji,jj) 
228            zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
229         END DO
230      END DO
231      CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) 
232
233      !                                                         ! horizontal mesh (inum3)
234      CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude
235      CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r4 )
236      CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r4 )
237      CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r4 )
238     
239      CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude
240      CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r4 )
241      CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r4 )
242      CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r4 )
243     
244      CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
245      CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 )
246      CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 )
247      CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 )
248     
249      CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
250      CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 )
251      CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 )
252      CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 )
253     
254      CALL iom_rstput( 0, 0, inum3, 'ff', ff, ktype = jp_r8 )           !    ! coriolis factor
255     
256      ! note that mbkt is set to 1 over land ==> use surface tmask
257      zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp )
258      CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points
259      zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp )
260      CALL iom_rstput( 0, 0, inum4, 'misf', zprt, ktype = jp_i2 )       !    ! nb of ocean T-points
261      zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp )
262      CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r4 )       !    ! nb of ocean T-points
263           
264      IF( ln_sco ) THEN                                         ! s-coordinate
265         CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt )
266         CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu )
267         CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv )
268         CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf )
269         !
270         CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt )         !    ! scaling coef.
271         CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw ) 
272         CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w )
273         CALL iom_rstput( 0, 0, inum4, 'esigt', esigt )
274         CALL iom_rstput( 0, 0, inum4, 'esigw', esigw )
275         !
276         CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )         !    ! scale factors
277         CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 )
278         CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 )
279         CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 )
280         CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 )             !    ! Max. grid stiffness ratio
281         !
282         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system
283         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d )
284         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )     
285         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )
286      ENDIF
287     
288      IF( ln_zps ) THEN                                         ! z-coordinate - partial steps
289         !
290         IF( nmsh <= 6 ) THEN                                   !    ! 3D vertical scale factors
291            CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )         
292            CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 )
293            CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 )
294            CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 )
295         ELSE                                                   !    ! 2D masked bottom ocean scale factors
296            DO jj = 1,jpj   
297               DO ji = 1,jpi
298                  e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj)
299                  e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj)
300               END DO
301            END DO
302            CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp )     
303            CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp )
304         END IF
305         !
306         IF( nmsh <= 3 ) THEN                                   !    ! 3D depth
307            CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )     
308            DO jk = 1,jpk   
309               DO jj = 1, jpjm1   
310                  DO ji = 1, fs_jpim1   ! vector opt.
311                     zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj  ,jk) )
312                     zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji  ,jj+1,jk) )
313                  END DO   
314               END DO   
315            END DO
316            CALL lbc_lnk( zdepu, 'U', 1. )   ;   CALL lbc_lnk( zdepv, 'V', 1. ) 
317            CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 )
318            CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 )
319            CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )
320         ELSE                                                   !    ! 2D bottom depth
321            DO jj = 1,jpj   
322               DO ji = 1,jpi
323                  zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj)  ) * ssmask(ji,jj)
324                  zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * ssmask(ji,jj)
325               END DO
326            END DO
327            CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r4 )     
328            CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r4 ) 
329         ENDIF
330         !
331         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! reference z-coord.
332         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d )
333         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   )
334         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   )
335      ENDIF
336     
337      IF( ln_zco ) THEN
338         !                                                      ! z-coordinate - full steps
339         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! depth
340         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d )
341         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   )   !    ! scale factors
342         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   )
343      ENDIF
344      !                                     ! ============================
345      !                                     !        close the files
346      !                                     ! ============================
347      SELECT CASE ( MOD(nmsh, 3) )
348      CASE ( 1 )               
349         CALL iom_close( inum0 )
350      CASE ( 2 )
351         CALL iom_close( inum1 )
352         CALL iom_close( inum2 )
353      CASE ( 0 )
354         CALL iom_close( inum2 )
355         CALL iom_close( inum3 )
356         CALL iom_close( inum4 )
357      END SELECT
358      !
359      CALL wrk_dealloc( jpi, jpj, zprt, zprw )
360      CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv )
361      !
362      IF( nn_timing == 1 )  CALL timing_stop('dom_wri')
363      !
364   END SUBROUTINE dom_wri
365
366
367   SUBROUTINE dom_uniq( puniq, cdgrd )
368      !!----------------------------------------------------------------------
369      !!                  ***  ROUTINE dom_uniq  ***
370      !!                   
371      !! ** Purpose :   identify unique point of a grid (TUVF)
372      !!
373      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
374      !!                2) check which elements have been changed
375      !!----------------------------------------------------------------------
376      !
377      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
378      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
379      !
380      REAL(wp) ::  zshift   ! shift value link to the process number
381      INTEGER  ::  ji       ! dummy loop indices
382      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
383      REAL(wp), POINTER, DIMENSION(:,:) :: ztstref
384      !!----------------------------------------------------------------------
385      !
386      IF( nn_timing == 1 )  CALL timing_start('dom_uniq')
387      !
388      CALL wrk_alloc( jpi, jpj, ztstref )
389      !
390      ! build an array with different values for each element
391      ! in mpp: make sure that these values are different even between process
392      ! -> apply a shift value according to the process number
393      zshift = jpi * jpj * ( narea - 1 )
394      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
395      !
396      puniq(:,:) = ztstref(:,:)                   ! default definition
397      CALL lbc_lnk( puniq, cdgrd, 1. )            ! apply boundary conditions
398      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed
399      !
400      puniq(:,:) = 1.                             ! default definition
401      ! fill only the inner part of the cpu with llbl converted into real
402      puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )
403      !
404      CALL wrk_dealloc( jpi, jpj, ztstref )
405      !
406      IF( nn_timing == 1 )  CALL timing_stop('dom_uniq')
407      !
408   END SUBROUTINE dom_uniq
409
410   !!======================================================================
411END MODULE domwri
Note: See TracBrowser for help on using the repository browser.