Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

domwri.F90 @ 2007

Last change on this file since 2007 was 2007, checked in by smasson, 14 years ago
update branches/DEV_r1879_FCM/NEMOGCM/NEMO with tags/nemo_v3_2_1/NEMO
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 16.1 KB

Line
1	MODULE domwri
2	!!======================================================================
3	!! * MODULE domwri *
4	!! Ocean initialization : write the ocean domain mesh ask file(s)
5	!!======================================================================
6
7	!!----------------------------------------------------------------------
8	!! dom_wri : create and write mesh and mask file(s)
9	!! nmsh = 1 : mesh_mask file
10	!! = 2 : mesh and mask file
11	!! = 3 : mesh_hgr, mesh_zgr and mask
12	!!----------------------------------------------------------------------
13	!! * Modules used
14	USE dom_oce ! ocean space and time domain
15	USE in_out_manager
16	USE iom
17	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
18	USE lib_mpp
19
20	IMPLICIT NONE
21	PRIVATE
22
23	PUBLIC dom_wri ! routine called by inidom.F90
24
25	!! * Substitutions
26	# include "vectopt_loop_substitute.h90"
27	!!----------------------------------------------------------------------
28	!! OPA 9.0 , LOCEAN-IPSL (2005)
29	!! $Id$
30	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
31	!!----------------------------------------------------------------------
32
33	CONTAINS
34
35	SUBROUTINE dom_wri
36	!!----------------------------------------------------------------------
37	!! * ROUTINE dom_wri *
38	!!
39	!! ** Purpose : Create the NetCDF file(s) which contain(s) all the
40	!! ocean domain informations (mesh and mask arrays). This (these)
41	!! file(s) is (are) used for visualisation (SAXO software) and
42	!! diagnostic computation.
43	!!
44	!! ** Method : Write in a file all the arrays generated in routines
45	!! domhgr, domzgr, and dommsk. Note: the file contain depends on
46	!! the vertical coord. used (z-coord, partial steps, s-coord)
47	!! MOD(nmsh, 3) = 1 : 'mesh_mask.nc' file
48	!! = 2 : 'mesh.nc' and mask.nc' files
49	!! = 0 : 'mesh_hgr.nc', 'mesh_zgr.nc' and
50	!! 'mask.nc' files
51	!! For huge size domain, use option 2 or 3 depending on your
52	!! vertical coordinate.
53	!!
54	!! if nmsh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw]
55	!! if 3 < nmsh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays
56	!! corresponding to the depth of the bottom points hdep[tw]
57	!! if 6 < nmsh <= 9: write 2D arrays corresponding to the depth and the
58	!! thickness of the bottom points hdep[tw] and e3[tw]_ps
59	!!
60	!! ** output file :
61	!! meshmask.nc : domain size, horizontal grid-point position,
62	!! masks, depth and vertical scale factors
63	!!
64	!! History :
65	!! ! 97-02 (G. Madec) Original code
66	!! ! 99-11 (M. Imbard) NetCDF FORMAT with IOIPSL
67	!! 9.0 ! 02-08 (G. Madec) F90 and several file
68	!!----------------------------------------------------------------------
69	INTEGER :: inum0 ! temprary units for 'mesh_mask.nc' file
70	INTEGER :: inum1 ! temprary units for 'mesh.nc' file
71	INTEGER :: inum2 ! temprary units for 'mask.nc' file
72	INTEGER :: inum3 ! temprary units for 'mesh_hgr.nc' file
73	INTEGER :: inum4 ! temprary units for 'mesh_zgr.nc' file
74	INTEGER :: ji, jj, jk, ik
75	REAL(wp), DIMENSION(jpi,jpj) :: zprt ! temporary array for bathymetry
76	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu ! 3D depth of U point
77	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepv ! 3D depth of V point
78	CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations)
79	CHARACTER(len=21) :: clnam1 ! filename (mesh informations)
80	CHARACTER(len=21) :: clnam2 ! filename (mask informations)
81	CHARACTER(len=21) :: clnam3 ! filename (horizontal mesh informations)
82	CHARACTER(len=21) :: clnam4 ! filename (vertical mesh informations)
83	!!----------------------------------------------------------------------
84
85	IF(lwp) WRITE(numout,*)
86	IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)'
87	IF(lwp) WRITE(numout,*) '~~~~~~~'
88
89	clnam0 = 'mesh_mask' ! filename (mesh and mask informations)
90	clnam1 = 'mesh' ! filename (mesh informations)
91	clnam2 = 'mask' ! filename (mask informations)
92	clnam3 = 'mesh_hgr' ! filename (horizontal mesh informations)
93	clnam4 = 'mesh_zgr' ! filename (vertical mesh informations)
94
95	SELECT CASE ( MOD(nmsh, 3) )
96	! ! ============================
97	CASE ( 1 ) ! create 'mesh_mask.nc' file
98	! ! ============================
99	CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )
100	inum2 = inum0 ! put all the informations
101	inum3 = inum0 ! in unit inum0
102	inum4 = inum0
103
104	! ! ============================
105	CASE ( 2 ) ! create 'mesh.nc' and
106	! ! 'mask.nc' files
107	! ! ============================
108	CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib )
109	CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
110	inum3 = inum1 ! put mesh informations
111	inum4 = inum1 ! in unit inum1
112	! ! ============================
113	CASE ( 0 ) ! create 'mesh_hgr.nc'
114	! ! 'mesh_zgr.nc' and
115	! ! 'mask.nc' files
116	! ! ============================
117	CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib )
118	CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib )
119	CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib )
120
121	END SELECT
122
123	! ! masks (inum2)
124	CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask
125	CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 )
126	CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 )
127	CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 )
128
129
130	zprt = tmask(:,:,1) * dom_uniq('T') ! ! unique point mask
131	CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 )
132	zprt = umask(:,:,1) * dom_uniq('U')
133	CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 )
134	zprt = vmask(:,:,1) * dom_uniq('V')
135	CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 )
136	zprt = fmask(:,:,1) * dom_uniq('F')
137	CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 )
138
139	! ! horizontal mesh (inum3)
140	CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r4 ) ! ! latitude
141	CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r4 )
142	CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r4 )
143	CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r4 )
144
145	CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r4 ) ! ! longitude
146	CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r4 )
147	CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r4 )
148	CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r4 )
149
150	CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors
151	CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 )
152	CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 )
153	CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 )
154
155	CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors
156	CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 )
157	CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 )
158	CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 )
159
160	CALL iom_rstput( 0, 0, inum3, 'ff', ff, ktype = jp_r8 ) ! ! coriolis factor
161
162	! note that mbathy has been modified in dommsk or in solver.
163	! it is the number of non-zero "w" levels in the water, and the minimum
164	! value (on land) is 2. We define zprt as the number of "T" points in the ocean
165	! at any location, and zero on land.
166	!
167	zprt = tmask(:,:,1)*(mbathy-1)
168	CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i2 )
169
170	#if ! defined key_zco
171	IF( ln_sco ) THEN ! s-coordinate
172	CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) ! ! depth
173	CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu )
174	CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv )
175	CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf )
176
177	CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt ) ! ! scaling coef.
178	CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw )
179	CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w )
180	CALL iom_rstput( 0, 0, inum4, 'esigt', esigt )
181	CALL iom_rstput( 0, 0, inum4, 'esigw', esigw )
182
183	CALL iom_rstput( 0, 0, inum4, 'e3t', e3t ) ! ! scale factors
184	CALL iom_rstput( 0, 0, inum4, 'e3u', e3u )
185	CALL iom_rstput( 0, 0, inum4, 'e3v', e3v )
186	CALL iom_rstput( 0, 0, inum4, 'e3w', e3w )
187
188	CALL iom_rstput( 0, 0, inum4, 'gdept_0' , gdept_0 ) ! ! stretched system
189	CALL iom_rstput( 0, 0, inum4, 'gdepw_0' , gdepw_0 )
190	ENDIF
191
192	IF( ln_zps ) THEN ! z-coordinate - partial steps
193
194	IF( nmsh <= 6 ) THEN ! ! 3D vertical scale factors
195	CALL iom_rstput( 0, 0, inum4, 'e3t', e3t )
196	CALL iom_rstput( 0, 0, inum4, 'e3u', e3u )
197	CALL iom_rstput( 0, 0, inum4, 'e3v', e3v )
198	CALL iom_rstput( 0, 0, inum4, 'e3w', e3w )
199	ELSE ! ! 2D bottom scale factors
200	DO jj = 1,jpj ; DO ji = 1,jpi
201	ik = NINT( zprt(ji,jj) ) ! take care that mbathy is not what you think it is here !
202	IF ( ik /= 0 ) THEN ; e3tp(ji,jj) = e3t(ji,jj,ik) ; e3wp(ji,jj) = e3w(ji,jj,ik)
203	ELSE ; e3tp(ji,jj) = 0. ; e3wp(ji,jj) = 0.
204	ENDIF
205	END DO ; END DO
206	CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp )
207	CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp )
208	END IF
209
210	IF( nmsh <= 3 ) THEN ! ! 3D depth
211	CALL iom_rstput( 0, 0, inum4, 'gdept', gdept, ktype = jp_r4 )
212	DO jk = 1,jpk ; DO jj = 1, jpjm1 ; DO ji = 1, fs_jpim1 ! vector opt.
213	zdepu(ji,jj,jk) = MIN( gdept(ji,jj,jk), gdept(ji+1,jj ,jk) )
214	zdepv(ji,jj,jk) = MIN( gdept(ji,jj,jk), gdept(ji ,jj+1,jk) )
215	END DO ; END DO ; END DO
216	CALL lbc_lnk( zdepu, 'U', 1. ) ; CALL lbc_lnk( zdepv, 'V', 1. )
217	CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 )
218	CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 )
219	CALL iom_rstput( 0, 0, inum4, 'gdepw', gdepw, ktype = jp_r4 )
220	ELSE ! ! 2D bottom depth
221	DO jj = 1,jpj ; DO ji = 1,jpi
222	ik = NINT( zprt(ji,jj) ) ! take care that mbathy is not what you think it is here !
223	IF ( ik /= 0 ) THEN ; hdept(ji,jj) = gdept(ji,jj,ik) ; hdepw(ji,jj) = gdepw(ji,jj,ik+1)
224	ELSE ; hdept(ji,jj) = 0. ; hdepw(ji,jj) = 0.
225	ENDIF
226	END DO ; END DO
227	CALL iom_rstput( 0, 0, inum4, 'hdept' , hdept, ktype = jp_r4 )
228	CALL iom_rstput( 0, 0, inum4, 'hdepw' , hdepw, ktype = jp_r4 )
229	ENDIF
230
231	CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 ) ! ! reference z-coord.
232	CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 )
233	CALL iom_rstput( 0, 0, inum4, 'e3t_0' , e3t_0 )
234	CALL iom_rstput( 0, 0, inum4, 'e3w_0' , e3w_0 )
235	ENDIF
236
237	#endif
238
239	IF( ln_zco ) THEN
240	! ! z-coordinate - full steps
241	CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 ) ! ! depth
242	CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 )
243	CALL iom_rstput( 0, 0, inum4, 'e3t_0' , e3t_0 ) ! ! scale factors
244	CALL iom_rstput( 0, 0, inum4, 'e3w_0' , e3w_0 )
245	ENDIF
246	! ! ============================
247	! ! close the files
248	! ! ============================
249	SELECT CASE ( MOD(nmsh, 3) )
250	CASE ( 1 )
251	CALL iom_close( inum0 )
252	CASE ( 2 )
253	CALL iom_close( inum1 )
254	CALL iom_close( inum2 )
255	CASE ( 0 )
256	CALL iom_close( inum2 )
257	CALL iom_close( inum3 )
258	CALL iom_close( inum4 )
259	END SELECT
260
261	END SUBROUTINE dom_wri
262
263
264	FUNCTION dom_uniq( cdgrd ) RESULT( puniq )
265	!!----------------------------------------------------------------------
266	!! * ROUTINE dom_uniq *
267	!!
268	!! ** Purpose : identify unique point of a grid (TUVF)
269	!!
270	!! ** Method : 1) aplly lbc_lnk on an array with different values for each element
271	!! 2) check which elements have been changed
272	!!
273	!!----------------------------------------------------------------------
274	CHARACTER(len=1) , INTENT(in ) :: cdgrd !
275	REAL(wp), DIMENSION(jpi,jpj) :: puniq !
276
277	REAL(wp), DIMENSION(jpi,jpj ) :: ztstref ! array with different values for each element
278	REAL(wp) :: zshift ! shift value link to the process number
279	LOGICAL , DIMENSION(jpi,jpj,1) :: lldbl ! is the point unique or not?
280	INTEGER :: ji ! dummy loop indices
281	!!----------------------------------------------------------------------
282
283	! build an array with different values for each element
284	! in mpp: make sure that these values are different even between process
285	! -> apply a shift value according to the process number
286	zshift = jpi * jpj * ( narea - 1 )
287	ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji, wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
288
289	puniq(:,:) = ztstref(:,:) ! default definition
290	CALL lbc_lnk( puniq, cdgrd, 1. ) ! apply boundary conditions
291	lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed
292
293	puniq(:,:) = 1. ! default definition
294	! fill only the inner part of the cpu with llbl converted into real
295	puniq(nldi:nlei,nldj:nlej) = REAL(COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ), wp)
296
297	END FUNCTION dom_uniq
298
299
300	!!======================================================================
301	END MODULE domwri

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

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

Context Navigation

source: branches/DEV_r1879_FCM/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90 @ 2007

Download in other formats: