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/NEMO/OPA_SRC/DOM – NEMO

source: branches/2016/dev_r6409_SIMPLIF_2_usrdef/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90 @ 6624

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

#1692 - branch SIMPLIF_2_usrdef: add domain_cfg.nc file which includes jperio, and vert. coord. logicals. +code cleaning
  • Property svn:keywords set to Id
File size: 22.2 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   
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_r8 )     !    ! latitude
75      CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r8 )
76      CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r8 )
77      CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r8 )
78     
79      CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude
80      CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r8 )
81      CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r8 )
82      CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r8 )
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      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      INTEGER           ::   izco, izps, isco, icav
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      !                                                         ! global domain size
193      CALL iom_rstput( 0, 0, inum2, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
194      CALL iom_rstput( 0, 0, inum2, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
195      CALL iom_rstput( 0, 0, inum2, 'jpkglo', REAL( jpk   , wp), ktype = jp_i4 )
196
197      !                                                         ! domain characteristics
198      CALL iom_rstput( 0, 0, inum2, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
199      !                                                         ! type of vertical coordinate
200      IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF
201      IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF
202      IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF
203      CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 )
204      CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 )
205      CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 )
206      !                                                         ! ocean cavities under iceshelves
207      IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF
208      CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 )
209 
210      !                                                         ! masks (inum2)
211      CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask
212      CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 )
213      CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 )
214      CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 )
215     
216      CALL dom_uniq( zprw, 'T' )
217      DO jj = 1, jpj
218         DO ji = 1, jpi
219            jk=mikt(ji,jj) 
220            zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
221         END DO
222      END DO                             !    ! unique point mask
223      CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 ) 
224      CALL dom_uniq( zprw, 'U' )
225      DO jj = 1, jpj
226         DO ji = 1, jpi
227            jk=miku(ji,jj) 
228            zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
229         END DO
230      END DO
231      CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 ) 
232      CALL dom_uniq( zprw, 'V' )
233      DO jj = 1, jpj
234         DO ji = 1, jpi
235            jk=mikv(ji,jj) 
236            zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
237         END DO
238      END DO
239      CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 
240      CALL dom_uniq( zprw, 'F' )
241      DO jj = 1, jpj
242         DO ji = 1, jpi
243            jk=mikf(ji,jj) 
244            zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj)                        !    ! unique point mask
245         END DO
246      END DO
247      CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) 
248
249      !                                                         ! horizontal mesh (inum3)
250      CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r8 )     !    ! latitude
251      CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r8 )
252      CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r8 )
253      CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r8 )
254     
255      CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude
256      CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r8 )
257      CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r8 )
258      CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r8 )
259     
260      CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
261      CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 )
262      CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 )
263      CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 )
264     
265      CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
266      CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 )
267      CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 )
268      CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 )
269     
270      CALL iom_rstput( 0, 0, inum3, 'ff_f', ff_f, ktype = jp_r8 )           !    ! coriolis factor
271      CALL iom_rstput( 0, 0, inum3, 'ff_t', ff_t, ktype = jp_r8 )
272     
273      ! note that mbkt is set to 1 over land ==> use surface tmask
274      zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp )
275      CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i4 )     !    ! nb of ocean T-points
276      zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp )
277      CALL iom_rstput( 0, 0, inum4, 'misf', zprt, ktype = jp_i4 )       !    ! nb of ocean T-points
278      zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp )
279      CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r8 )       !    ! nb of ocean T-points
280           
281      IF( ln_sco ) THEN                                         ! s-coordinate
282         CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt )
283         CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu )
284         CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv )
285         CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf )
286         !
287         CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt )         !    ! scaling coef.
288         CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw ) 
289         CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w )
290         CALL iom_rstput( 0, 0, inum4, 'esigt', esigt )
291         CALL iom_rstput( 0, 0, inum4, 'esigw', esigw )
292         !
293         CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )         !    ! scale factors
294         CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 )
295         CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 )
296         CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 )
297         CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 )             !    ! Max. grid stiffness ratio
298         !
299         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system
300         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d )
301         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 )
302         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 )
303      ENDIF
304     
305      IF( ln_zps ) THEN                                         ! z-coordinate - partial steps
306         !
307         IF( nmsh <= 6 ) THEN                                   !    ! 3D vertical scale factors
308            CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )         
309            CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 )
310            CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 )
311            CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 )
312         ELSE                                                   !    ! 2D masked bottom ocean scale factors
313            DO jj = 1,jpj   
314               DO ji = 1,jpi
315                  e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj)
316                  e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj)
317               END DO
318            END DO
319            CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp )     
320            CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp )
321         END IF
322         !
323         IF( nmsh <= 3 ) THEN                                   !    ! 3D depth
324            CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 )
325            DO jk = 1,jpk   
326               DO jj = 1, jpjm1   
327                  DO ji = 1, fs_jpim1   ! vector opt.
328                     zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj  ,jk) )
329                     zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji  ,jj+1,jk) )
330                  END DO
331               END DO
332            END DO
333            CALL lbc_lnk( zdepu, 'U', 1. )   ;   CALL lbc_lnk( zdepv, 'V', 1. )
334            CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r8 )
335            CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r8 )
336            CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 )
337         ELSE                                                   !    ! 2D bottom depth
338            DO jj = 1,jpj   
339               DO ji = 1,jpi
340                  zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj)  ) * ssmask(ji,jj)
341                  zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * ssmask(ji,jj)
342               END DO
343            END DO
344            CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r8 )
345            CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r8 )
346         ENDIF
347         !
348         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! reference z-coord.
349         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d )
350         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   )
351         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   )
352      ENDIF
353     
354      IF( ln_zco ) THEN
355         !                                                      ! z-coordinate - full steps
356         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! depth
357         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d )
358         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   )   !    ! scale factors
359         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   )
360      ENDIF
361      !                                     ! ============================
362      !                                     !        close the files
363      !                                     ! ============================
364      SELECT CASE ( MOD(nmsh, 3) )
365      CASE ( 1 )               
366         CALL iom_close( inum0 )
367      CASE ( 2 )
368         CALL iom_close( inum1 )
369         CALL iom_close( inum2 )
370      CASE ( 0 )
371         CALL iom_close( inum2 )
372         CALL iom_close( inum3 )
373         CALL iom_close( inum4 )
374      END SELECT
375      !
376      CALL wrk_dealloc( jpi, jpj, zprt, zprw )
377      CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv )
378      !
379      IF( nn_timing == 1 )  CALL timing_stop('dom_wri')
380      !
381   END SUBROUTINE dom_wri
382
383
384   SUBROUTINE dom_uniq( puniq, cdgrd )
385      !!----------------------------------------------------------------------
386      !!                  ***  ROUTINE dom_uniq  ***
387      !!                   
388      !! ** Purpose :   identify unique point of a grid (TUVF)
389      !!
390      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
391      !!                2) check which elements have been changed
392      !!----------------------------------------------------------------------
393      !
394      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
395      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
396      !
397      REAL(wp) ::  zshift   ! shift value link to the process number
398      INTEGER  ::  ji       ! dummy loop indices
399      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
400      REAL(wp), POINTER, DIMENSION(:,:) :: ztstref
401      !!----------------------------------------------------------------------
402      !
403      IF( nn_timing == 1 )  CALL timing_start('dom_uniq')
404      !
405      CALL wrk_alloc( jpi, jpj, ztstref )
406      !
407      ! build an array with different values for each element
408      ! in mpp: make sure that these values are different even between process
409      ! -> apply a shift value according to the process number
410      zshift = jpi * jpj * ( narea - 1 )
411      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
412      !
413      puniq(:,:) = ztstref(:,:)                   ! default definition
414      CALL lbc_lnk( puniq, cdgrd, 1. )            ! apply boundary conditions
415      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed
416      !
417      puniq(:,:) = 1.                             ! default definition
418      ! fill only the inner part of the cpu with llbl converted into real
419      puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )
420      !
421      CALL wrk_dealloc( jpi, jpj, ztstref )
422      !
423      IF( nn_timing == 1 )  CALL timing_stop('dom_uniq')
424      !
425   END SUBROUTINE dom_uniq
426
427   !!======================================================================
428END MODULE domwri
Note: See TracBrowser for help on using the repository browser.