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/branches/UKMO/dev_r9950_GO6_mixing/src/OCE/CRS – NEMO

source: NEMO/branches/UKMO/dev_r9950_GO6_mixing/src/OCE/CRS/crsdomwri.F90 @ 10323

Last change on this file since 10323 was 10323, checked in by davestorkey, 5 years ago

UKMO/dev_r9950_GO6_mixing: Update to be relative to rev 10321 of NEMO4_beta_mirror branch.

File size: 11.5 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      INTEGER           ::   iif, iil, ijf, ijl
53      CHARACTER(len=21) ::   clnam        ! filename (mesh and mask informations)
54      !                                   !  workspace
55      REAL(wp), DIMENSION(jpi_crs,jpj_crs    ) ::   zprt, zprw 
56      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) ::   zdepu, zdepv
57      !!----------------------------------------------------------------------
58      !
59      !
60      IF(lwp) WRITE(numout,*)
61      IF(lwp) WRITE(numout,*) 'crs_dom_wri : create NetCDF mesh and mask file'
62      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
63     
64      clnam = 'mesh_mask_crs'  ! filename (mesh and mask informations)
65     
66
67      !                            ! ============================
68      !                            !  create 'mesh_mask.nc' file
69      !                            ! ============================
70      !
71      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib )
72 
73      CALL iom_rstput( 0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1 )    ! land-sea mask
74      CALL iom_rstput( 0, 0, inum, 'umask', umask_crs, ktype = jp_i1 )
75      CALL iom_rstput( 0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1 )
76      CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 )
77     
78     
79      tmask_i_crs(:,:) = tmask_crs(:,:,1)
80      iif = nn_hls
81      iil = nlci_crs - nn_hls + 1
82      ijf = nn_hls
83      ijl = nlcj_crs - nn_hls + 1
84     
85      tmask_i_crs( 1:iif ,    :  ) = 0._wp
86      tmask_i_crs(iil:jpi_crs,    :  ) = 0._wp
87      tmask_i_crs(   :   , 1:ijf ) = 0._wp
88      tmask_i_crs(   :   ,ijl:jpj_crs) = 0._wp
89     
90     
91      tpol_crs(1:jpiglo_crs,:) = 1._wp
92      fpol_crs(1:jpiglo_crs,:) = 1._wp
93      IF( jperio == 3 .OR. jperio == 4 ) THEN
94         tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp
95         fpol_crs(       1      :jpiglo_crs,:) = 0._wp
96         IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN
97            DO ji = iif+1, iil-1
98               tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) &
99               & * tpol_crs(mig_crs(ji),1)
100            ENDDO
101         ENDIF
102      ENDIF
103      IF( jperio == 5 .OR. jperio == 6 ) THEN
104         tpol_crs(      1       :jpiglo_crs,:)=0._wp
105         fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp
106      ENDIF
107     
108      CALL iom_rstput( 0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1 )
109                                   !    ! unique point mask
110      CALL dom_uniq_crs( zprw, 'U' )
111      zprt = umask_crs(:,:,1) * zprw
112      CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) 
113      CALL dom_uniq_crs( zprw, 'V' )
114      zprt = vmask_crs(:,:,1) * zprw
115      CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) 
116      CALL dom_uniq_crs( zprw, 'F' )
117      zprt = fmask_crs(:,:,1) * zprw
118      CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) 
119      !========================================================
120      !                                                         ! horizontal mesh
121      CALL iom_rstput( 0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4 )     !    ! latitude
122      CALL iom_rstput( 0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4 )
123      CALL iom_rstput( 0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4 )
124      CALL iom_rstput( 0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4 )
125     
126      CALL iom_rstput( 0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4 )     !    ! longitude
127      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4 )
128      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4 )
129      CALL iom_rstput( 0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4 )
130     
131      CALL iom_rstput( 0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8 )         !    ! e1 scale factors
132      CALL iom_rstput( 0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8 )
133      CALL iom_rstput( 0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8 )
134      CALL iom_rstput( 0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8 )
135     
136      CALL iom_rstput( 0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8 )         !    ! e2 scale factors
137      CALL iom_rstput( 0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8 )
138      CALL iom_rstput( 0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8 )
139      CALL iom_rstput( 0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8 )
140     
141      CALL iom_rstput( 0, 0, inum, 'ff', ff_crs, ktype = jp_r8 )           !    ! coriolis factor
142
143      !========================================================
144      !                                                         ! vertical mesh
145!     ! note that mbkt is set to 1 over land ==> use surface tmask_crs
146      zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp )
147      CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points
148      !
149      CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs )     
150      CALL iom_rstput( 0, 0, inum, 'e3w', e3w_crs )     
151      CALL iom_rstput( 0, 0, inum, 'e3u', e3u_crs )     
152      CALL iom_rstput( 0, 0, inum, 'e3v', e3v_crs )     
153      !
154      CALL iom_rstput( 0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4 ) 
155      DO jk = 1,jpk   
156         DO jj = 1, jpj_crsm1   
157            DO ji = 1, jpi_crsm1  ! jes what to do for fs_jpim1??vector opt.
158               zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj  ,jk) ) * umask_crs(ji,jj,jk)
159               zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji  ,jj+1,jk) ) * vmask_crs(ji,jj,jk)
160            END DO   
161         END DO   
162      END DO
163      CALL crs_lbc_lnk( zdepu,'U', 1. )   ;   CALL crs_lbc_lnk( zdepv,'V', 1. ) 
164      !
165      CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 )
166      CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 )
167      CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 )
168      !
169      CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d )     !    ! reference z-coord.
170      CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d )
171      CALL iom_rstput( 0, 0, inum, 'e3t_1d'  , e3t_1d   )
172      CALL iom_rstput( 0, 0, inum, 'e3w_1d'  , e3w_1d   )
173      !
174      CALL iom_rstput(  0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) 
175      CALL iom_rstput(  0, 0, inum, 'facvol_t' , facvol_t  ) 
176      CALL iom_rstput(  0, 0, inum, 'facvol_w' , facvol_w  ) 
177      CALL iom_rstput(  0, 0, inum, 'facsurfu' , facsurfu  ) 
178      CALL iom_rstput(  0, 0, inum, 'facsurfv' , facsurfv  ) 
179      CALL iom_rstput(  0, 0, inum, 'e1e2w_msk', e1e2w_msk ) 
180      CALL iom_rstput(  0, 0, inum, 'e2e3u_msk', e2e3u_msk ) 
181      CALL iom_rstput(  0, 0, inum, 'e1e3v_msk', e1e3v_msk )
182      CALL iom_rstput(  0, 0, inum, 'e1e2w'    , e1e2w_crs ) 
183      CALL iom_rstput(  0, 0, inum, 'e2e3u'    , e2e3u_crs ) 
184      CALL iom_rstput(  0, 0, inum, 'e1e3v'    , e1e3v_crs )
185      CALL iom_rstput(  0, 0, inum, 'bt'       , bt_crs    )
186      CALL iom_rstput(  0, 0, inum, 'r1_bt'    , r1_bt_crs )
187      !
188      CALL iom_rstput(  0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) 
189      CALL iom_rstput(  0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) 
190      CALL iom_rstput(  0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt  ) 
191      !                                     ! ============================
192      !                                     !        close the files
193      !                                     ! ============================
194      CALL iom_close( inum )
195      !
196   END SUBROUTINE crs_dom_wri
197
198
199   SUBROUTINE dom_uniq_crs( puniq, cdgrd )
200      !!----------------------------------------------------------------------
201      !!                  ***  ROUTINE crs_dom_uniq_crs  ***
202      !!                   
203      !! ** Purpose :   identify unique point of a grid (TUVF)
204      !!
205      !! ** Method  :   1) apply crs_lbc_lnk on an array with different values for each element
206      !!                2) check which elements have been changed
207      !!----------------------------------------------------------------------
208      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
209      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
210      !
211      REAL(wp) ::  zshift   ! shift value link to the process number
212      INTEGER  ::  ji       ! dummy loop indices
213      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
214      REAL(wp), DIMENSION(jpi_crs,jpj_crs) :: ztstref
215      !!----------------------------------------------------------------------
216      !
217      ! build an array with different values for each element
218      ! in mpp: make sure that these values are different even between process
219      ! -> apply a shift value according to the process number
220      zshift = jpi_crs * jpj_crs * ( narea - 1 )
221      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) )
222      !
223      puniq(:,:) = ztstref(:,:)                   ! default definition
224      CALL crs_lbc_lnk( puniq,cdgrd, 1. )            ! apply boundary conditions
225      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed
226      !
227      puniq(:,:) = 1.                             ! default definition
228      ! fill only the inner part of the cpu with llbl converted into real
229      puniq(nldi_crs:nlei_crs,nldj_crs:nlej_crs) = REAL( COUNT( lldbl(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:), dim = 3 ) , wp )
230      !
231   END SUBROUTINE dom_uniq_crs
232
233   !!======================================================================
234
235END MODULE crsdomwri
236
237
Note: See TracBrowser for help on using the repository browser.