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.
crsdomwri.F90 in NEMO/trunk/src/OCE/CRS – NEMO

source: NEMO/trunk/src/OCE/CRS/crsdomwri.F90 @ 13286

Last change on this file since 13286 was 13286, checked in by smasson, 4 years ago

trunk: merge extra halos branch in trunk, see #2366

  • Property svn:keywords set to Id
File size: 10.3 KB
Line 
1MODULE crsdomwri
2   !!======================================================================
3   !! Coarse Ocean initialization : write the coarse ocean domain mesh and mask files
4   !!======================================================================
5   !! History :  3.6   ! 2012-06  (J. Simeon, C. Calone, C Ethe )  from domwri, reduced and modified for coarse grid
6   !!----------------------------------------------------------------------
7
8   !!----------------------------------------------------------------------
9   !!   crs_dom_wri    : create and write mesh and mask file(s)
10   !!----------------------------------------------------------------------
11   USE timing          ! Timing
12   USE dom_oce         ! ocean space and time domain
13   USE in_out_manager  ! I/O manager
14   USE par_kind, ONLY: wp
15   USE lib_mpp         ! MPP library
16   USE iom_def
17   USE iom
18   USE crs         ! coarse grid domain
19   USE crsdom         ! coarse grid domain
20   USE crslbclnk       ! crs mediator to lbclnk
21
22   IMPLICIT NONE
23   PRIVATE
24
25   PUBLIC crs_dom_wri        ! routine called by crsini.F90
26
27   !!----------------------------------------------------------------------
28   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
29   !! $Id$
30   !! Software governed by the CeCILL license (see ./LICENSE)
31   !!----------------------------------------------------------------------
32CONTAINS
33
34   SUBROUTINE crs_dom_wri
35      !!----------------------------------------------------------------------
36      !!                  ***  ROUTINE crs_dom_wri  ***
37      !!
38      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
39      !!      ocean domain informations (mesh and mask arrays). This (these)
40      !!      file(s) is (are) used for visualisation (SAXO software) and
41      !!      diagnostic computation.
42      !!
43      !! ** Method  :   Write in a file all the arrays generated in routines
44      !!      crsini for meshes and mask. In three separate files:
45      !!      domain size, horizontal grid-point position,
46      !!      masks, depth and vertical scale factors
47      !!     
48      !! ** Output files :   mesh_hgr_crs.nc, mesh_zgr_crs.nc, mesh_mask.nc
49      !!----------------------------------------------------------------------
50      INTEGER           ::   ji, jj, jk   ! dummy loop indices
51      INTEGER           ::   inum         ! local units for 'mesh_mask.nc' file
52      CHARACTER(len=21) ::   clnam        ! filename (mesh and mask informations)
53      !                                   !  workspace
54      REAL(wp), DIMENSION(jpi_crs,jpj_crs    ) ::   zprt, zprw 
55      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) ::   zdepu, zdepv
56      !!----------------------------------------------------------------------
57      !
58      !
59      IF(lwp) WRITE(numout,*)
60      IF(lwp) WRITE(numout,*) 'crs_dom_wri : create NetCDF mesh and mask file'
61      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
62     
63      clnam = 'mesh_mask_crs'  ! filename (mesh and mask informations)
64     
65
66      !                            ! ============================
67      !                            !  create 'mesh_mask.nc' file
68      !                            ! ============================
69      !
70      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )
71 
72      CALL iom_rstput( 0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1 )    ! land-sea mask
73      CALL iom_rstput( 0, 0, inum, 'umask', umask_crs, ktype = jp_i1 )
74      CALL iom_rstput( 0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1 )
75      CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 )
76     
77      CALL dom_uniq_crs( zprw, 'T' )
78      zprt = tmask_crs(:,:,1) * zprw
79      CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 )
80      CALL dom_uniq_crs( zprw, 'U' )
81      zprt = umask_crs(:,:,1) * zprw
82      CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) 
83      CALL dom_uniq_crs( zprw, 'V' )
84      zprt = vmask_crs(:,:,1) * zprw
85      CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) 
86      CALL dom_uniq_crs( zprw, 'F' )
87      zprt = fmask_crs(:,:,1) * zprw
88      CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) 
89      !========================================================
90      !                                                         ! horizontal mesh
91      CALL iom_rstput( 0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4 )     !    ! latitude
92      CALL iom_rstput( 0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4 )
93      CALL iom_rstput( 0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4 )
94      CALL iom_rstput( 0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4 )
95     
96      CALL iom_rstput( 0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4 )     !    ! longitude
97      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4 )
98      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4 )
99      CALL iom_rstput( 0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4 )
100     
101      CALL iom_rstput( 0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8 )         !    ! e1 scale factors
102      CALL iom_rstput( 0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8 )
103      CALL iom_rstput( 0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8 )
104      CALL iom_rstput( 0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8 )
105     
106      CALL iom_rstput( 0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8 )         !    ! e2 scale factors
107      CALL iom_rstput( 0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8 )
108      CALL iom_rstput( 0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8 )
109      CALL iom_rstput( 0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8 )
110     
111      CALL iom_rstput( 0, 0, inum, 'ff', ff_crs, ktype = jp_r8 )           !    ! coriolis factor
112
113      !========================================================
114      !                                                         ! vertical mesh
115!     ! note that mbkt is set to 1 over land ==> use surface tmask_crs
116      zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp )
117      CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points
118      !
119      CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs )     
120      CALL iom_rstput( 0, 0, inum, 'e3w', e3w_crs )     
121      CALL iom_rstput( 0, 0, inum, 'e3u', e3u_crs )     
122      CALL iom_rstput( 0, 0, inum, 'e3v', e3v_crs )     
123      !
124      CALL iom_rstput( 0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4 ) 
125      DO jk = 1,jpk   
126         DO jj = 1, jpj_crsm1   
127            DO ji = 1, jpi_crsm1  ! jes what to do for jpim1??vector opt.
128               zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj  ,jk) ) * umask_crs(ji,jj,jk)
129               zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji  ,jj+1,jk) ) * vmask_crs(ji,jj,jk)
130            END DO   
131         END DO   
132      END DO
133      CALL crs_lbc_lnk( zdepu,'U', 1.0_wp )   ;   CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) 
134      !
135      CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 )
136      CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 )
137      CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 )
138      !
139      CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d )     !    ! reference z-coord.
140      CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d )
141      CALL iom_rstput( 0, 0, inum, 'e3t_1d'  , e3t_1d   )
142      CALL iom_rstput( 0, 0, inum, 'e3w_1d'  , e3w_1d   )
143      !
144      CALL iom_rstput(  0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) 
145      CALL iom_rstput(  0, 0, inum, 'facvol_t' , facvol_t  ) 
146      CALL iom_rstput(  0, 0, inum, 'facvol_w' , facvol_w  ) 
147      CALL iom_rstput(  0, 0, inum, 'facsurfu' , facsurfu  ) 
148      CALL iom_rstput(  0, 0, inum, 'facsurfv' , facsurfv  ) 
149      CALL iom_rstput(  0, 0, inum, 'e1e2w_msk', e1e2w_msk ) 
150      CALL iom_rstput(  0, 0, inum, 'e2e3u_msk', e2e3u_msk ) 
151      CALL iom_rstput(  0, 0, inum, 'e1e3v_msk', e1e3v_msk )
152      CALL iom_rstput(  0, 0, inum, 'e1e2w'    , e1e2w_crs ) 
153      CALL iom_rstput(  0, 0, inum, 'e2e3u'    , e2e3u_crs ) 
154      CALL iom_rstput(  0, 0, inum, 'e1e3v'    , e1e3v_crs )
155      CALL iom_rstput(  0, 0, inum, 'bt'       , bt_crs    )
156      CALL iom_rstput(  0, 0, inum, 'r1_bt'    , r1_bt_crs )
157      !
158      CALL iom_rstput(  0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) 
159      CALL iom_rstput(  0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) 
160      CALL iom_rstput(  0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt  ) 
161      !                                     ! ============================
162      !                                     !        close the files
163      !                                     ! ============================
164      CALL iom_close( inum )
165      !
166   END SUBROUTINE crs_dom_wri
167
168
169   SUBROUTINE dom_uniq_crs( puniq, cdgrd )
170      !!----------------------------------------------------------------------
171      !!                  ***  ROUTINE crs_dom_uniq_crs  ***
172      !!                   
173      !! ** Purpose :   identify unique point of a grid (TUVF)
174      !!
175      !! ** Method  :   1) apply crs_lbc_lnk on an array with different values for each element
176      !!                2) check which elements have been changed
177      !!----------------------------------------------------------------------
178      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
179      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
180      !
181      REAL(wp) ::  zshift   ! shift value link to the process number
182      INTEGER  ::  ji       ! dummy loop indices
183      LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) ::   lluniq  ! store whether each point is unique or not
184      REAL(wp), DIMENSION(jpi_crs,jpj_crs  ) ::   ztstref
185      !!----------------------------------------------------------------------
186      !
187      ! build an array with different values for each element
188      ! in mpp: make sure that these values are different even between process
189      ! -> apply a shift value according to the process number
190      zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 )   ! we should use jpimax_crs but not existing
191      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) )
192      !
193      puniq(:,:) = ztstref(:,:)                   ! default definition
194      CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp )            ! apply boundary conditions
195      lluniq(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed
196      !
197      puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp )
198      !
199   END SUBROUTINE dom_uniq_crs
200
201   !!======================================================================
202
203END MODULE crsdomwri
204
205
Note: See TracBrowser for help on using the repository browser.