Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

crsdomwri.F90 @ 10986

Last change on this file since 10986 was 10986, checked in by andmirek, 5 years ago
GMED 462 add flush
File size: 11.5 KB

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

Note: See TracBrowser for help on using the repository browser.

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0_mirror_text_diagnostics/src/OCE/CRS/crsdomwri.F90 @ 10986

Download in other formats: