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.

nemogcm.F90 in branches/2015/dev_r5803_NOC_WAD/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/2015/dev_r5803_NOC_WAD/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 5870

Last change on this file since 5870 was 5870, checked in by acc, 8 years ago
Branch 2015/dev_r5803_NOC_WAD. Merge in trunk changes from 5803 to 5869 in preparation for merge. Also tidied and reorganised some wetting and drying code. Renamed wadlmt.F90 to wetdry.F90. Wetting drying code changes restricted to domzgr.F90, domvvl.F90 nemogcm.F90 sshwzv.F90, dynspg_ts.F90, wetdry.F90 and dynhpg.F90. Code passes full SETTE tests with ln_wd=.false.. Still awaiting test case for checking with ln_wd=.false.
Property svn:keywords set to `Id`
File size: 40.1 KB

Line
1	MODULE nemogcm
2	!!======================================================================
3	!! * MODULE nemogcm *
4	!! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
5	!!======================================================================
6	!! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code
7	!! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec)
8	!! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
9	!! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
10	!! - ! 1992-06 (L.Terray) coupling implementation
11	!! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice
12	!! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
13	!! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
14	!! 8.1 ! 1997-06 (M. Imbard, G. Madec)
15	!! 8.2 ! 1999-11 (M. Imbard, H. Goosse) LIM sea-ice model
16	!! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP
17	!! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER)
18	!! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules
19	!! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
20	!! - ! 2004-08 (C. Talandier) New trends organization
21	!! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility
22	!! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
23	!! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation
24	!! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization
25	!! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
26	!! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp
27	!! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
28	!! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
29	!! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
30	!! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add nemo_northcomms
31	!! - ! 2011-11 (C. Harris) decomposition changes for running with CICE
32	!! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
33	!! - ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) nemo_northcomms: setup avoiding MPI communication
34	!! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla)
35	!! 3.6.?! 2015-11 (H. Liu) Add Wetting and Drying
36	!!----------------------------------------------------------------------
37
38	!!----------------------------------------------------------------------
39	!! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
40	!! nemo_init : initialization of the NEMO system
41	!! nemo_ctl : initialisation of the contol print
42	!! nemo_closefile : close remaining open files
43	!! nemo_alloc : dynamical allocation
44	!! nemo_partition : calculate MPP domain decomposition
45	!! factorise : calculate the factors of the no. of MPI processes
46	!!----------------------------------------------------------------------
47	USE step_oce ! module used in the ocean time stepping module (step.F90)
48	USE domcfg ! domain configuration (dom_cfg routine)
49	USE mppini ! shared/distributed memory setting (mpp_init routine)
50	USE domain ! domain initialization (dom_init routine)
51	#if defined key_nemocice_decomp
52	USE ice_domain_size, only: nx_global, ny_global
53	#endif
54	USE tideini ! tidal components initialization (tide_ini routine)
55	USE bdyini ! open boundary cond. setting (bdy_init routine)
56	USE bdydta ! open boundary cond. setting (bdy_dta_init routine)
57	USE bdytides ! open boundary cond. setting (bdytide_init routine)
58	USE istate ! initial state setting (istate_init routine)
59	USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
60	USE ldftra ! lateral diffusivity setting (ldftra_init routine)
61	USE zdfini ! vertical physics setting (zdf_init routine)
62	USE phycst ! physical constant (par_cst routine)
63	USE trdini ! dyn/tra trends initialization (trd_init routine)
64	USE asminc ! assimilation increments
65	USE asmbkg ! writing out state trajectory
66	USE diaptr ! poleward transports (dia_ptr_init routine)
67	USE diadct ! sections transports (dia_dct_init routine)
68	USE diaobs ! Observation diagnostics (dia_obs_init routine)
69	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
70	USE step ! NEMO time-stepping (stp routine)
71	USE icbini ! handle bergs, initialisation
72	USE icbstp ! handle bergs, calving, themodynamics and transport
73	USE cpl_oasis3 ! OASIS3 coupling
74	USE c1d ! 1D configuration
75	USE step_c1d ! Time stepping loop for the 1D configuration
76	USE dyndmp ! Momentum damping
77	#if defined key_top
78	USE trcini ! passive tracer initialisation
79	#endif
80	USE lib_mpp ! distributed memory computing
81	#if defined key_iomput
82	USE xios ! xIOserver
83	#endif
84	USE sbctide, ONLY : lk_tide
85	USE crsini ! initialise grid coarsening utility
86	USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
87	USE sbc_oce, ONLY : lk_oasis
88	USE stopar
89	USE stopts
90	USE wet_dry ! Wetting and drying setting (wad_init routine)
91
92	IMPLICIT NONE
93	PRIVATE
94
95	PUBLIC nemo_gcm ! called by model.F90
96	PUBLIC nemo_init ! needed by AGRIF
97	PUBLIC nemo_alloc ! needed by TAM
98
99	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
100
101	!!----------------------------------------------------------------------
102	!! NEMO/OPA 3.7 , NEMO Consortium (2015)
103	!! $Id$
104	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
105	!!----------------------------------------------------------------------
106	CONTAINS
107
108	SUBROUTINE nemo_gcm
109	!!----------------------------------------------------------------------
110	!! * ROUTINE nemo_gcm *
111	!!
112	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
113	!! curvilinear mesh on the sphere.
114	!!
115	!! ** Method : - model general initialization
116	!! - launch the time-stepping (stp routine)
117	!! - finalize the run by closing files and communications
118	!!
119	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
120	!! Madec, 2008, internal report, IPSL.
121	!!----------------------------------------------------------------------
122	INTEGER :: istp ! time step index
123	!!----------------------------------------------------------------------
124	!
125	#if defined key_agrif
126	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
127	#endif
128
129	! !-----------------------!
130	CALL nemo_init !== Initialisations ==!
131	! !-----------------------!
132	#if defined key_agrif
133	CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
134	CALL Agrif_Declare_Var ! " " " " " DYN/TRA
135	# if defined key_top
136	CALL Agrif_Declare_Var_top ! " " " " " TOP
137	# endif
138	# if defined key_lim2
139	CALL Agrif_Declare_Var_lim2 ! " " " " " LIM
140	# endif
141	#endif
142	! check that all process are still there... If some process have an error,
143	! they will never enter in step and other processes will wait until the end of the cpu time!
144	IF( lk_mpp ) CALL mpp_max( nstop )
145
146	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
147
148	! !-----------------------!
149	! !== time stepping ==!
150	! !-----------------------!
151	istp = nit000
152	#if defined key_c1d
153	DO WHILE ( istp <= nitend .AND. nstop == 0 )
154	CALL stp_c1d( istp )
155	istp = istp + 1
156	END DO
157	#else
158	IF( lk_asminc ) THEN
159	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
160	IF( ln_asmdin ) THEN ! Direct initialization
161	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
162	IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
163	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
164	ENDIF
165	ENDIF
166
167	#if defined key_agrif
168	CALL Agrif_Regrid()
169	#endif
170
171	DO WHILE ( istp <= nitend .AND. nstop == 0 )
172	#if defined key_agrif
173	CALL stp ! AGRIF: time stepping
174	#else
175	CALL stp( istp ) ! standard time stepping
176	#endif
177	istp = istp + 1
178	IF( lk_mpp ) CALL mpp_max( nstop )
179	END DO
180	#endif
181
182	IF( lk_diaobs ) CALL dia_obs_wri
183	!
184	IF( ln_icebergs ) CALL icb_end( nitend )
185
186	! !------------------------!
187	! !== finalize the run ==!
188	! !------------------------!
189	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
190	!
191	IF( nstop /= 0 .AND. lwp ) THEN ! error print
192	WRITE(numout,cform_err)
193	WRITE(numout,*) nstop, ' error have been found'
194	ENDIF
195	!
196	#if defined key_agrif
197	IF(.NOT.Agrif_Root() ) THEN
198	CALL Agrif_ParentGrid_To_ChildGrid()
199	IF( lk_diaobs ) CALL dia_obs_wri
200	IF( nn_timing == 1 ) CALL timing_finalize
201	CALL Agrif_ChildGrid_To_ParentGrid()
202	ENDIF
203	#endif
204	IF( nn_timing == 1 ) CALL timing_finalize
205	!
206	CALL nemo_closefile
207	!
208	#if defined key_iomput
209	CALL xios_finalize ! end mpp communications with xios
210	IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS
211	#else
212	IF( lk_oasis ) THEN
213	CALL cpl_finalize ! end coupling and mpp communications with OASIS
214	ELSE
215	IF( lk_mpp ) CALL mppstop ! end mpp communications
216	ENDIF
217	#endif
218	!
219	END SUBROUTINE nemo_gcm
220
221
222	SUBROUTINE nemo_init
223	!!----------------------------------------------------------------------
224	!! * ROUTINE nemo_init *
225	!!
226	!! ** Purpose : initialization of the NEMO GCM
227	!!----------------------------------------------------------------------
228	INTEGER :: ji ! dummy loop indices
229	INTEGER :: ilocal_comm ! local integer
230	INTEGER :: ios
231	CHARACTER(len=80), DIMENSION(16) :: cltxt
232	!
233	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
234	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
235	& nn_bench, nn_timing
236	NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
237	& jpizoom, jpjzoom, jperio, ln_use_jattr
238	!!----------------------------------------------------------------------
239	!
240	cltxt = ''
241	cxios_context = 'nemo'
242	!
243	! ! Open reference namelist and configuration namelist files
244	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
245	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
246	!
247	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
248	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
249	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
250
251	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
252	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
253	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
254
255	!
256	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
257	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
258	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
259
260	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
261	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
262	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
263
264
265	! Force values for AGRIF zoom (cf. agrif_user.F90)
266	#if defined key_agrif
267	IF( .NOT. Agrif_Root() ) THEN
268	jpiglo = nbcellsx + 2 + 2*nbghostcells
269	jpjglo = nbcellsy + 2 + 2*nbghostcells
270	jpi = ( jpiglo-2jpreci + (jpni-1+0) ) / jpni + 2jpreci
271	jpj = ( jpjglo-2jprecj + (jpnj-1+0) ) / jpnj + 2jprecj
272	jpidta = jpiglo
273	jpjdta = jpjglo
274	jpizoom = 1
275	jpjzoom = 1
276	nperio = 0
277	jperio = 0
278	ln_use_jattr = .false.
279	ENDIF
280	#endif
281	!
282	! !--------------------------------------------!
283	! ! set communicator & select the local node !
284	! ! NB: mynode also opens output.namelist.dyn !
285	! ! on unit number numond on first proc !
286	! !--------------------------------------------!
287	#if defined key_iomput
288	IF( Agrif_Root() ) THEN
289	IF( lk_oasis ) THEN
290	CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
291	CALL xios_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios
292	ELSE
293	CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) ! nemo local communicator given by xios
294	ENDIF
295	ENDIF
296	! Nodes selection (control print return in cltxt)
297	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
298	#else
299	IF( lk_oasis ) THEN
300	IF( Agrif_Root() ) THEN
301	CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
302	ENDIF
303	! Nodes selection (control print return in cltxt)
304	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
305	ELSE
306	ilocal_comm = 0
307	! Nodes selection (control print return in cltxt)
308	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
309	ENDIF
310	#endif
311	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
312
313	lwm = (narea == 1) ! control of output namelists
314	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
315
316	IF(lwm) THEN
317	! write merged namelists from earlier to output namelist now that the
318	! file has been opened in call to mynode. nammpp has already been
319	! written in mynode (if lk_mpp_mpi)
320	WRITE( numond, namctl )
321	WRITE( numond, namcfg )
322	ENDIF
323
324	! If dimensions of processor grid weren't specified in the namelist file
325	! then we calculate them here now that we have our communicator size
326	IF( jpni < 1 .OR. jpnj < 1 ) THEN
327	#if defined key_mpp_mpi
328	IF( Agrif_Root() ) CALL nemo_partition( mppsize )
329	#else
330	jpni = 1
331	jpnj = 1
332	jpnij = jpni*jpnj
333	#endif
334	ENDIF
335
336	! Calculate domain dimensions given calculated jpni and jpnj
337	! This used to be done in par_oce.F90 when they were parameters rather than variables
338	IF( Agrif_Root() ) THEN
339	#if defined key_nemocice_decomp
340	jpi = ( nx_global+2-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
341	jpj = ( ny_global+2-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
342	#else
343	jpi = ( jpiglo -2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
344	jpj = ( jpjglo -2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
345	#endif
346	ENDIF
347	jpk = jpkdta ! third dim
348	#if defined key_agrif
349	! simple trick to use same vertical grid as parent but different number of levels:
350	! Save maximum number of levels in jpkdta, then define all vertical grids with this number.
351	! Suppress once vertical online interpolation is ok
352	IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent( jpkdta )
353	#endif
354	jpim1 = jpi-1 ! inner domain indices
355	jpjm1 = jpj-1 ! " "
356	jpkm1 = jpk-1 ! " "
357	jpij = jpi*jpj ! jpi x j
358
359	IF(lwp) THEN ! open listing units
360	!
361	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
362	!
363	WRITE(numout,*)
364	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
365	WRITE(numout,*) ' NEMO team'
366	WRITE(numout,*) ' Ocean General Circulation Model'
367	WRITE(numout,*) ' version 3.7 (2015) '
368	WRITE(numout,*)
369	WRITE(numout,*)
370	DO ji = 1, SIZE(cltxt)
371	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
372	END DO
373	WRITE(numout,cform_aaa) ! Flag AAAAAAA
374	!
375	ENDIF
376
377	! Now we know the dimensions of the grid and numout has been set we can
378	! allocate arrays
379	CALL nemo_alloc()
380
381	! !-------------------------------!
382	! ! NEMO general initialization !
383	! !-------------------------------!
384
385	CALL nemo_ctl ! Control prints & Benchmark
386
387	! ! Domain decomposition
388	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
389	ELSE ; CALL mpp_init2 ! eliminate land processors
390	ENDIF
391	!
392	IF( nn_timing == 1 ) CALL timing_init
393	!
394	! ! General initialization
395	CALL phy_cst ! Physical constants
396	CALL eos_init ! Equation of state
397	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
398	CALL wad_init ! Wetting and drying options
399	CALL dom_cfg ! Domain configuration
400	CALL dom_init ! Domain
401	IF( ln_crs ) CALL crs_init ! coarsened grid: domain initialization
402	IF( ln_nnogather ) CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined)
403	IF( ln_ctl ) CALL prt_ctl_init ! Print control
404	CALL istate_init ! ocean initial state (Dynamics and tracers)
405
406	! ! external forcing
407	!!gm to be added : creation and call of sbc_apr_init
408	IF( lk_tide ) CALL tide_init( nit000 ) ! tidal harmonics
409	CALL sbc_init ! surface boundary conditions (including sea-ice)
410	!!gm ==>> bdy_init should call bdy_dta_init and bdytide_init NOT in nemogcm !!!
411	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
412	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
413	IF( lk_bdy .AND. lk_tide ) &
414	& CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing
415
416	! ! Ocean physics
417	! ! Vertical physics
418	CALL zdf_init ! namelist read
419	CALL zdf_bfr_init ! bottom friction
420	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
421	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
422	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
423	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
424	IF( lk_zdfddm ) CALL zdf_ddm_init ! double diffusive mixing
425
426	! ! Lateral physics
427	CALL ldf_tra_init ! Lateral ocean tracer physics
428	CALL ldf_eiv_init ! eddy induced velocity param.
429	CALL ldf_dyn_init ! Lateral ocean momentum physics
430
431	! ! Active tracers
432	CALL tra_qsr_init ! penetrative solar radiation qsr
433	CALL tra_bbc_init ! bottom heat flux
434	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
435	CALL tra_dmp_init ! internal tracer damping
436	CALL tra_adv_init ! horizontal & vertical advection
437	CALL tra_ldf_init ! lateral mixing
438	CALL tra_zdf_init ! vertical mixing and after tracer fields
439
440	! ! Dynamics
441	IF( lk_c1d ) CALL dyn_dmp_init ! internal momentum damping
442	CALL dyn_adv_init ! advection (vector or flux form)
443	CALL dyn_vor_init ! vorticity term including Coriolis
444	CALL dyn_ldf_init ! lateral mixing
445	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
446	CALL dyn_zdf_init ! vertical diffusion
447	CALL dyn_spg_init ! surface pressure gradient
448
449	#if defined key_top
450	! ! Passive tracers
451	CALL trc_init
452	#endif
453	IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
454
455	! ! Icebergs
456	CALL icb_init( rdt, nit000) ! initialise icebergs instance
457
458	! ! Misc. options
459	CALL sto_par_init ! Stochastic parametrization
460	IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations
461
462	! ! Diagnostics
463	IF( lk_floats ) CALL flo_init ! drifting Floats
464	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
465	CALL dia_ptr_init ! Poleward TRansports initialization
466	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
467	CALL dia_hsb_init ! heat content, salt content and volume budgets
468	CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends
469	IF( lk_diaobs ) THEN ! Observation & model comparison
470	CALL dia_obs_init ! Initialize observational data
471	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
472	ENDIF
473	! ! Assimilation increments
474	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
475	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
476	!
477	END SUBROUTINE nemo_init
478
479
480	SUBROUTINE nemo_ctl
481	!!----------------------------------------------------------------------
482	!! * ROUTINE nemo_ctl *
483	!!
484	!! ** Purpose : control print setting
485	!!
486	!! ** Method : - print namctl information and check some consistencies
487	!!----------------------------------------------------------------------
488	!
489	IF(lwp) THEN ! control print
490	WRITE(numout,*)
491	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
492	WRITE(numout,*) '~~~~~~~ '
493	WRITE(numout,*) ' Namelist namctl'
494	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
495	WRITE(numout,*) ' level of print nn_print = ', nn_print
496	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
497	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
498	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
499	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
500	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
501	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
502	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
503	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
504	ENDIF
505	!
506	nprint = nn_print ! convert DOCTOR namelist names into OLD names
507	nictls = nn_ictls
508	nictle = nn_ictle
509	njctls = nn_jctls
510	njctle = nn_jctle
511	isplt = nn_isplt
512	jsplt = nn_jsplt
513	nbench = nn_bench
514
515	IF(lwp) THEN ! control print
516	WRITE(numout,*)
517	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
518	WRITE(numout,*) '~~~~~~~ '
519	WRITE(numout,*) ' Namelist namcfg'
520	WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg)
521	WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz)
522	WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg
523	WRITE(numout,*) ' 1st lateral dimension ( >= jpiglo ) jpidta = ', jpidta
524	WRITE(numout,*) ' 2nd " " ( >= jpjglo ) jpjdta = ', jpjdta
525	WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta
526	WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo
527	WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo
528	WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
529	WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
530	WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio
531	WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
532	ENDIF
533	! ! Parameter control
534	!
535	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
536	IF( lk_mpp .AND. jpnij > 1 ) THEN
537	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
538	ELSE
539	IF( isplt == 1 .AND. jsplt == 1 ) THEN
540	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
541	& ' - the print control will be done over the whole domain' )
542	ENDIF
543	ijsplt = isplt * jsplt ! total number of processors ijsplt
544	ENDIF
545	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
546	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
547	!
548	! ! indices used for the SUM control
549	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
550	lsp_area = .FALSE.
551	ELSE ! print control done over a specific area
552	lsp_area = .TRUE.
553	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
554	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
555	nictls = 1
556	ENDIF
557	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
558	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
559	nictle = jpiglo
560	ENDIF
561	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
562	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
563	njctls = 1
564	ENDIF
565	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
566	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
567	njctle = jpjglo
568	ENDIF
569	ENDIF
570	ENDIF
571	!
572	IF( nbench == 1 ) THEN ! Benchmark
573	SELECT CASE ( cp_cfg )
574	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
575	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
576	& ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
577	END SELECT
578	ENDIF
579	!
580	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
581	& 'f2003 standard. ' , &
582	& 'Compile with key_nosignedzero enabled' )
583	!
584	END SUBROUTINE nemo_ctl
585
586
587	SUBROUTINE nemo_closefile
588	!!----------------------------------------------------------------------
589	!! * ROUTINE nemo_closefile *
590	!!
591	!! ** Purpose : Close the files
592	!!----------------------------------------------------------------------
593	!
594	IF( lk_mpp ) CALL mppsync
595	!
596	CALL iom_close ! close all input/output files managed by iom_*
597	!
598	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
599	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
600	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
601	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
602	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
603	IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist
604	IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist
605	IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
606	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
607	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
608	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
609	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
610	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
611	!
612	numout = 6 ! redefine numout in case it is used after this point...
613	!
614	END SUBROUTINE nemo_closefile
615
616
617	SUBROUTINE nemo_alloc
618	!!----------------------------------------------------------------------
619	!! * ROUTINE nemo_alloc *
620	!!
621	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
622	!!
623	!! ** Method :
624	!!----------------------------------------------------------------------
625	USE diawri , ONLY: dia_wri_alloc
626	USE dom_oce , ONLY: dom_oce_alloc
627	USE trc_oce , ONLY: trc_oce_alloc
628	#if defined key_diadct
629	USE diadct , ONLY: diadct_alloc
630	#endif
631	#if defined key_bdy
632	USE bdy_oce , ONLY: bdy_oce_alloc
633	#endif
634	!
635	INTEGER :: ierr
636	!!----------------------------------------------------------------------
637	!
638	ierr = oce_alloc () ! ocean
639	ierr = ierr + dia_wri_alloc ()
640	ierr = ierr + dom_oce_alloc () ! ocean domain
641	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
642	!
643	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
644	!
645	#if defined key_diadct
646	ierr = ierr + diadct_alloc () !
647	#endif
648	#if defined key_bdy
649	ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization)
650	#endif
651	!
652	IF( lk_mpp ) CALL mpp_sum( ierr )
653	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
654	!
655	END SUBROUTINE nemo_alloc
656
657
658	SUBROUTINE nemo_partition( num_pes )
659	!!----------------------------------------------------------------------
660	!! * ROUTINE nemo_partition *
661	!!
662	!! ** Purpose :
663	!!
664	!! ** Method :
665	!!----------------------------------------------------------------------
666	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
667	!
668	INTEGER, PARAMETER :: nfactmax = 20
669	INTEGER :: nfact ! The no. of factors returned
670	INTEGER :: ierr ! Error flag
671	INTEGER :: ji
672	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
673	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
674	!!----------------------------------------------------------------------
675	!
676	ierr = 0
677	!
678	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
679	!
680	IF( nfact <= 1 ) THEN
681	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
682	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
683	jpnj = 1
684	jpni = num_pes
685	ELSE
686	! Search through factors for the pair that are closest in value
687	mindiff = 1000000
688	imin = 1
689	DO ji = 1, nfact-1, 2
690	idiff = ABS( ifact(ji) - ifact(ji+1) )
691	IF( idiff < mindiff ) THEN
692	mindiff = idiff
693	imin = ji
694	ENDIF
695	END DO
696	jpnj = ifact(imin)
697	jpni = ifact(imin + 1)
698	ENDIF
699	!
700	jpnij = jpni*jpnj
701	!
702	END SUBROUTINE nemo_partition
703
704
705	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
706	!!----------------------------------------------------------------------
707	!! * ROUTINE factorise *
708	!!
709	!! ** Purpose : return the prime factors of n.
710	!! knfax factors are returned in array kfax which is of
711	!! maximum dimension kmaxfax.
712	!! ** Method :
713	!!----------------------------------------------------------------------
714	INTEGER , INTENT(in ) :: kn, kmaxfax
715	INTEGER , INTENT( out) :: kerr, knfax
716	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
717	!
718	INTEGER :: ifac, jl, inu
719	INTEGER, PARAMETER :: ntest = 14
720	INTEGER, DIMENSION(ntest) :: ilfax
721	!!----------------------------------------------------------------------
722	!
723	! lfax contains the set of allowed factors.
724	ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
725	!
726	! Clear the error flag and initialise output vars
727	kerr = 0
728	kfax = 1
729	knfax = 0
730	!
731	! Find the factors of n.
732	IF( kn == 1 ) GOTO 20
733
734	! nu holds the unfactorised part of the number.
735	! knfax holds the number of factors found.
736	! l points to the allowed factor list.
737	! ifac holds the current factor.
738	!
739	inu = kn
740	knfax = 0
741	!
742	DO jl = ntest, 1, -1
743	!
744	ifac = ilfax(jl)
745	IF( ifac > inu ) CYCLE
746
747	! Test whether the factor will divide.
748
749	IF( MOD(inu,ifac) == 0 ) THEN
750	!
751	knfax = knfax + 1 ! Add the factor to the list
752	IF( knfax > kmaxfax ) THEN
753	kerr = 6
754	write (,) 'FACTOR: insufficient space in factor array ', knfax
755	return
756	ENDIF
757	kfax(knfax) = ifac
758	! Store the other factor that goes with this one
759	knfax = knfax + 1
760	kfax(knfax) = inu / ifac
761	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
762	ENDIF
763	!
764	END DO
765	!
766	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
767	!
768	END SUBROUTINE factorise
769
770	#if defined key_mpp_mpi
771
772	SUBROUTINE nemo_northcomms
773	!!----------------------------------------------------------------------
774	!! * ROUTINE nemo_northcomms *
775	!! ** Purpose : Setup for north fold exchanges with explicit
776	!! point-to-point messaging
777	!!
778	!! ** Method : Initialization of the northern neighbours lists.
779	!!----------------------------------------------------------------------
780	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
781	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
782	!!----------------------------------------------------------------------
783	INTEGER :: sxM, dxM, sxT, dxT, jn
784	INTEGER :: njmppmax
785	!!----------------------------------------------------------------------
786	!
787	njmppmax = MAXVAL( njmppt )
788	!
789	!initializes the north-fold communication variables
790	isendto(:) = 0
791	nsndto = 0
792	!
793	!if I am a process in the north
794	IF ( njmpp == njmppmax ) THEN
795	!sxM is the first point (in the global domain) needed to compute the
796	!north-fold for the current process
797	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
798	!dxM is the last point (in the global domain) needed to compute the
799	!north-fold for the current process
800	dxM = jpiglo - nimppt(narea) + 2
801
802	!loop over the other north-fold processes to find the processes
803	!managing the points belonging to the sxT-dxT range
804
805	DO jn = 1, jpni
806	!sxT is the first point (in the global domain) of the jn
807	!process
808	sxT = nfiimpp(jn, jpnj)
809	!dxT is the last point (in the global domain) of the jn
810	!process
811	dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
812	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
813	nsndto = nsndto + 1
814	isendto(nsndto) = jn
815	ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
816	nsndto = nsndto + 1
817	isendto(nsndto) = jn
818	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
819	nsndto = nsndto + 1
820	isendto(nsndto) = jn
821	END IF
822	END DO
823	nfsloop = 1
824	nfeloop = nlci
825	DO jn = 2,jpni-1
826	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
827	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
828	nfsloop = nldi
829	ENDIF
830	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
831	nfeloop = nlei
832	ENDIF
833	ENDIF
834	END DO
835
836	ENDIF
837	l_north_nogather = .TRUE.
838	END SUBROUTINE nemo_northcomms
839
840	#else
841	SUBROUTINE nemo_northcomms ! Dummy routine
842	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
843	END SUBROUTINE nemo_northcomms
844	#endif
845
846	!!======================================================================
847	END MODULE nemogcm
848

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

Download in other formats: