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_r6409_SIMPLIF_2_usrdef/NEMOGCM/TOOLS/DOMAINcfg/src – NEMO

source: branches/2016/dev_r6409_SIMPLIF_2_usrdef/NEMOGCM/TOOLS/DOMAINcfg/src/domwri.f90 @ 6951

Last change on this file since 6951 was 6951, checked in by flavoni, 8 years ago

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