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/2016/dev_r6393_NOC_WAD/NEMOGCM/CONFIG/WAD_TEST_CASES/MY_SRC – NEMO

source: branches/2016/dev_r6393_NOC_WAD/NEMOGCM/CONFIG/WAD_TEST_CASES/MY_SRC/domwri.F90 @ 6986

Last change on this file since 6986 was 6986, checked in by acc, 8 years ago

Branch dev_r6393_NOC_WAD. Introduced some WAD test cases, tidied and corrected WAD code
File size: 20.9 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   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   dom_wri        : create and write mesh and mask file(s)
14   !!   dom_uniq       : identify unique point of a grid (TUVF)
15   !!----------------------------------------------------------------------
16   USE dom_oce         ! ocean space and time domain
17   USE in_out_manager  ! I/O manager
18   USE iom             ! I/O library
19   USE lbclnk          ! lateral boundary conditions - mpp exchanges
20   USE lib_mpp         ! MPP library
21   USE wrk_nemo        ! Memory allocation
22   USE timing          ! Timing
23
24   IMPLICIT NONE
25   PRIVATE
26
27   PUBLIC   dom_wri              ! routine called by inidom.F90
28   PUBLIC   dom_wri_coordinate   ! routine called by domhgr.F90
29   !! * Substitutions
30#  include "vectopt_loop_substitute.h90"
31   !!----------------------------------------------------------------------
32   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
33   !! $Id: domwri.F90 5836 2015-10-26 14:49:40Z cetlod $
34   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE dom_wri_coordinate
39      !!----------------------------------------------------------------------
40      !!                  ***  ROUTINE dom_wri_coordinate  ***
41      !!                   
42      !! ** Purpose :   Create the NetCDF file which contains all the
43      !!              standard coordinate information plus the surface,
44      !!              e1e2u and e1e2v. By doing so, those surface will
45      !!              not be changed by the reduction of e1u or e2v scale
46      !!              factors in some straits.
47      !!                 NB: call just after the read of standard coordinate
48      !!              and the reduction of scale factors in some straits
49      !!
50      !! ** output file :   coordinate_e1e2u_v.nc
51      !!----------------------------------------------------------------------
52      INTEGER           ::   inum0    ! temprary units for 'coordinate_e1e2u_v.nc' file
53      CHARACTER(len=21) ::   clnam0   ! filename (mesh and mask informations)
54      !                                   !  workspaces
55      REAL(wp), POINTER, DIMENSION(:,:  ) :: zprt, zprw 
56      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv
57      !!----------------------------------------------------------------------
58      !
59      IF( nn_timing == 1 )  CALL timing_start('dom_wri_coordinate')
60      !
61      IF(lwp) WRITE(numout,*)
62      IF(lwp) WRITE(numout,*) 'dom_wri_coordinate : create NetCDF coordinate file'
63      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'
64     
65      clnam0 = 'coordinate_e1e2u_v'  ! filename (mesh and mask informations)
66     
67      !  create 'coordinate_e1e2u_v.nc' file
68      ! ============================
69      !
70      CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )
71      !
72      !                                                         ! horizontal mesh (inum3)
73      CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude
74      CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r4 )
75      CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r4 )
76      CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r4 )
77     
78      CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude
79      CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r4 )
80      CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r4 )
81      CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r4 )
82     
83      CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
84      CALL iom_rstput( 0, 0, inum0, 'e1u', e1u, ktype = jp_r8 )
85      CALL iom_rstput( 0, 0, inum0, 'e1v', e1v, ktype = jp_r8 )
86      CALL iom_rstput( 0, 0, inum0, 'e1f', e1f, ktype = jp_r8 )
87     
88      CALL iom_rstput( 0, 0, inum0, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
89      CALL iom_rstput( 0, 0, inum0, 'e2u', e2u, ktype = jp_r8 )
90      CALL iom_rstput( 0, 0, inum0, 'e2v', e2v, ktype = jp_r8 )
91      CALL iom_rstput( 0, 0, inum0, 'e2f', e2f, ktype = jp_r8 )
92     
93      CALL iom_rstput( 0, 0, inum0, 'e1e2u', e1e2u, ktype = jp_r8 )
94      CALL iom_rstput( 0, 0, inum0, 'e1e2v', e1e2v, ktype = jp_r8 )
95
96      CALL iom_close( inum0 )
97      !
98      IF( nn_timing == 1 )  CALL timing_stop('dom_wri_coordinate')
99      !
100   END SUBROUTINE dom_wri_coordinate
101
102
103   SUBROUTINE dom_wri
104      !!----------------------------------------------------------------------
105      !!                  ***  ROUTINE dom_wri  ***
106      !!                   
107      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
108      !!      ocean domain informations (mesh and mask arrays). This (these)
109      !!      file(s) is (are) used for visualisation (SAXO software) and
110      !!      diagnostic computation.
111      !!
112      !! ** Method  :   Write in a file all the arrays generated in routines
113      !!      domhgr, domzgr, and dommsk. Note: the file contain depends on
114      !!      the vertical coord. used (z-coord, partial steps, s-coord)
115      !!            MOD(nmsh, 3) = 1  :   'mesh_mask.nc' file
116      !!                         = 2  :   'mesh.nc' and mask.nc' files
117      !!                         = 0  :   'mesh_hgr.nc', 'mesh_zgr.nc' and
118      !!                                  'mask.nc' files
119      !!      For huge size domain, use option 2 or 3 depending on your
120      !!      vertical coordinate.
121      !!
122      !!      if     nmsh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw]
123      !!      if 3 < nmsh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays
124      !!                        corresponding to the depth of the bottom t- and w-points
125      !!      if 6 < nmsh <= 9: write 2D arrays corresponding to the depth and the
126      !!                        thickness (e3[tw]_ps) of the bottom points
127      !!
128      !! ** output file :   meshmask.nc  : domain size, horizontal grid-point position,
129      !!                                   masks, depth and vertical scale factors
130      !!----------------------------------------------------------------------
131      !!
132      INTEGER           ::   inum0    ! temprary units for 'mesh_mask.nc' file
133      INTEGER           ::   inum1    ! temprary units for 'mesh.nc'      file
134      INTEGER           ::   inum2    ! temprary units for 'mask.nc'      file
135      INTEGER           ::   inum3    ! temprary units for 'mesh_hgr.nc'  file
136      INTEGER           ::   inum4    ! temprary units for 'mesh_zgr.nc'  file
137      CHARACTER(len=21) ::   clnam0   ! filename (mesh and mask informations)
138      CHARACTER(len=21) ::   clnam1   ! filename (mesh informations)
139      CHARACTER(len=21) ::   clnam2   ! filename (mask informations)
140      CHARACTER(len=21) ::   clnam3   ! filename (horizontal mesh informations)
141      CHARACTER(len=21) ::   clnam4   ! filename (vertical   mesh informations)
142      INTEGER           ::   ji, jj, jk   ! dummy loop indices
143      !                                   !  workspaces
144      REAL(wp), POINTER, DIMENSION(:,:  ) :: zprt, zprw 
145      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv
146      !!----------------------------------------------------------------------
147      !
148      IF( nn_timing == 1 )  CALL timing_start('dom_wri')
149      !
150      CALL wrk_alloc( jpi, jpj, zprt, zprw )
151      CALL wrk_alloc( jpi, jpj, jpk, zdepu, zdepv )
152      !
153      IF(lwp) WRITE(numout,*)
154      IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)'
155      IF(lwp) WRITE(numout,*) '~~~~~~~'
156     
157      clnam0 = 'mesh_mask'  ! filename (mesh and mask informations)
158      clnam1 = 'mesh'       ! filename (mesh informations)
159      clnam2 = 'mask'       ! filename (mask informations)
160      clnam3 = 'mesh_hgr'   ! filename (horizontal mesh informations)
161      clnam4 = 'mesh_zgr'   ! filename (vertical   mesh informations)
162     
163      SELECT CASE ( MOD(nmsh, 3) )
164         !                                  ! ============================
165      CASE ( 1 )                            !  create 'mesh_mask.nc' file
166         !                                  ! ============================
167         CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )
168         inum2 = inum0                                            ! put all the informations
169         inum3 = inum0                                            ! in unit inum0
170         inum4 = inum0
171         
172         !                                  ! ============================
173      CASE ( 2 )                            !  create 'mesh.nc' and
174         !                                  !         'mask.nc' files
175         !                                  ! ============================
176         CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib )
177         CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
178         inum3 = inum1                                            ! put mesh informations
179         inum4 = inum1                                            ! in unit inum1
180         !                                  ! ============================
181      CASE ( 0 )                            !  create 'mesh_hgr.nc'
182         !                                  !         'mesh_zgr.nc' and
183         !                                  !         'mask.nc'     files
184         !                                  ! ============================
185         CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
186         CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib )
187         CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib )
188         !
189      END SELECT
190     
191      !                                                         ! masks (inum2)
192      CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask
193      CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 )
194      CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 )
195      CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 )
196     
197      CALL dom_uniq( zprw, 'T' )
198      DO jj = 1, jpj
199         DO ji = 1, jpi
200            jk=mikt(ji,jj) 
201            zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
202         END DO
203      END DO                             !    ! unique point mask
204      CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 ) 
205      CALL dom_uniq( zprw, 'U' )
206      DO jj = 1, jpj
207         DO ji = 1, jpi
208            jk=miku(ji,jj) 
209            zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
210         END DO
211      END DO
212      CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 ) 
213      CALL dom_uniq( zprw, 'V' )
214      DO jj = 1, jpj
215         DO ji = 1, jpi
216            jk=mikv(ji,jj) 
217            zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
218         END DO
219      END DO
220      CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 
221      CALL dom_uniq( zprw, 'F' )
222      DO jj = 1, jpj
223         DO ji = 1, jpi
224            jk=mikf(ji,jj) 
225            zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
226         END DO
227      END DO
228      CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) 
229
230      !                                                         ! horizontal mesh (inum3)
231      CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude
232      CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r4 )
233      CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r4 )
234      CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r4 )
235     
236      CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude
237      CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r4 )
238      CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r4 )
239      CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r4 )
240     
241      CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
242      CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 )
243      CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 )
244      CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 )
245     
246      CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
247      CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 )
248      CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 )
249      CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 )
250     
251      CALL iom_rstput( 0, 0, inum3, 'ff', ff, ktype = jp_r8 )           !    ! coriolis factor
252     
253      ! note that mbkt is set to 1 over land ==> use surface tmask
254      zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp )
255      CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points
256      CALL iom_rstput( 0, 0, inum4, 'bathy', bathy, ktype = jp_r8 )     !    ! 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.