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

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

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