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 trunk/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 4624

Last change on this file since 4624 was 4624, checked in by acc, 10 years ago
#1305. Fix slow start-up problems on some systems by introducing and using lwm logical to restrict output of merged namelists to the first (or only) processor. lwm is true only on the first processor regardless of ln_ctl. Small changes to all flavours of nemogcm.F90 are also required to write namctl and namcfg after the call to mynode which now opens output.namelist.dyn and writes nammpp.
Property svn:keywords set to `Id`
File size: 38.9 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-11 (C. Harris) decomposition changes for running with CICE
31	!! ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
32	!!----------------------------------------------------------------------
33
34	!!----------------------------------------------------------------------
35	!! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
36	!! nemo_init : initialization of the NEMO system
37	!! nemo_ctl : initialisation of the contol print
38	!! nemo_closefile : close remaining open files
39	!! nemo_alloc : dynamical allocation
40	!! nemo_partition : calculate MPP domain decomposition
41	!! factorise : calculate the factors of the no. of MPI processes
42	!!----------------------------------------------------------------------
43	USE step_oce ! module used in the ocean time stepping module
44	USE sbc_oce ! surface boundary condition: ocean
45	USE cla ! cross land advection (tra_cla routine)
46	USE domcfg ! domain configuration (dom_cfg routine)
47	USE mppini ! shared/distributed memory setting (mpp_init routine)
48	USE domain ! domain initialization (dom_init routine)
49	#if defined key_nemocice_decomp
50	USE ice_domain_size, only: nx_global, ny_global
51	#endif
52	USE tideini ! tidal components initialization (tide_ini routine)
53	USE bdyini ! open boundary cond. initialization (bdy_init routine)
54	USE bdydta ! open boundary cond. initialization (bdy_dta_init routine)
55	USE bdytides ! open boundary cond. initialization (bdytide_init routine)
56	USE istate ! initial state setting (istate_init routine)
57	USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
58	USE ldftra ! lateral diffusivity setting (ldftra_init routine)
59	USE zdfini ! vertical physics setting (zdf_init routine)
60	USE phycst ! physical constant (par_cst routine)
61	USE trdmod ! momentum/tracers trends (trd_mod_init routine)
62	USE asminc ! assimilation increments
63	USE asmbkg ! writing out state trajectory
64	USE diaptr ! poleward transports (dia_ptr_init routine)
65	USE diadct ! sections transports (dia_dct_init routine)
66	USE diaobs ! Observation diagnostics (dia_obs_init routine)
67	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
68	USE step ! NEMO time-stepping (stp routine)
69	USE icbini ! handle bergs, initialisation
70	USE icbstp ! handle bergs, calving, themodynamics and transport
71	#if defined key_oasis3
72	USE cpl_oasis3 ! OASIS3 coupling
73	#elif defined key_oasis4
74	USE cpl_oasis4 ! OASIS4 coupling (not working)
75	#endif
76	USE c1d ! 1D configuration
77	USE step_c1d ! Time stepping loop for the 1D configuration
78	USE dyndmp ! Momentum damping
79	#if defined key_top
80	USE trcini ! passive tracer initialisation
81	#endif
82	USE lib_mpp ! distributed memory computing
83	#if defined key_iomput
84	USE xios
85	#endif
86	USE sbctide, ONLY: lk_tide
87	USE crsini ! initialise grid coarsening utility
88	USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges
89
90	IMPLICIT NONE
91	PRIVATE
92
93	PUBLIC nemo_gcm ! called by model.F90
94	PUBLIC nemo_init ! needed by AGRIF
95	PUBLIC nemo_alloc ! needed by TAM
96
97	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
98
99	!!----------------------------------------------------------------------
100	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
101	!! $Id$
102	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
103	!!----------------------------------------------------------------------
104	CONTAINS
105
106	SUBROUTINE nemo_gcm
107	!!----------------------------------------------------------------------
108	!! * ROUTINE nemo_gcm *
109	!!
110	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
111	!! curvilinear mesh on the sphere.
112	!!
113	!! ** Method : - model general initialization
114	!! - launch the time-stepping (stp routine)
115	!! - finalize the run by closing files and communications
116	!!
117	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
118	!! Madec, 2008, internal report, IPSL.
119	!!----------------------------------------------------------------------
120	INTEGER :: istp ! time step index
121	!!----------------------------------------------------------------------
122	!
123
124	#if defined key_agrif
125	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
126	#endif
127
128	! !-----------------------!
129	CALL nemo_init !== Initialisations ==!
130	! !-----------------------!
131	#if defined key_agrif
132	CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
133	CALL Agrif_Declare_Var ! " " " " " DYN/TRA
134	# if defined key_top
135	CALL Agrif_Declare_Var_top ! " " " " " TOP
136	# endif
137	# if defined key_lim2
138	CALL Agrif_Declare_Var_lim2 ! " " " " " LIM
139	# endif
140	#endif
141
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	DO WHILE ( istp <= nitend .AND. nstop == 0 )
168
169	#if defined key_agrif
170	CALL Agrif_Step( stp ) ! AGRIF: time stepping
171	#else
172	CALL stp( istp ) ! standard time stepping
173	#endif
174
175	istp = istp + 1
176	IF( lk_mpp ) CALL mpp_max( nstop )
177	END DO
178	#endif
179
180	IF( lk_diaobs ) CALL dia_obs_wri
181	!
182	IF( ln_icebergs ) CALL icb_end( nitend )
183
184	! !------------------------!
185	! !== finalize the run ==!
186	! !------------------------!
187	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
188	!
189	IF( nstop /= 0 .AND. lwp ) THEN ! error print
190	WRITE(numout,cform_err)
191	WRITE(numout,*) nstop, ' error have been found'
192	ENDIF
193	!
194	#if defined key_agrif
195	CALL Agrif_ParentGrid_To_ChildGrid()
196	IF( lk_diaobs ) CALL dia_obs_wri
197	IF( nn_timing == 1 ) CALL timing_finalize
198	CALL Agrif_ChildGrid_To_ParentGrid()
199	#endif
200	IF( nn_timing == 1 ) CALL timing_finalize
201	!
202	CALL nemo_closefile
203	#if defined key_iomput
204	CALL xios_finalize ! end mpp communications with xios
205	# if defined key_oasis3 \|\| defined key_oasis4
206	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
207	# endif
208	#else
209	# if defined key_oasis3 \|\| defined key_oasis4
210	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
211	# else
212	IF( lk_mpp ) CALL mppstop ! end mpp communications
213	# endif
214	#endif
215	!
216	END SUBROUTINE nemo_gcm
217
218
219	SUBROUTINE nemo_init
220	!!----------------------------------------------------------------------
221	!! * ROUTINE nemo_init *
222	!!
223	!! ** Purpose : initialization of the NEMO GCM
224	!!----------------------------------------------------------------------
225	INTEGER :: ji ! dummy loop indices
226	INTEGER :: ilocal_comm ! local integer
227	INTEGER :: ios
228	CHARACTER(len=80), DIMENSION(16) :: cltxt
229	!!
230	NAMELIST/namctl/ ln_ctl, nn_print, nn_ictls, nn_ictle, &
231	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
232	& nn_bench, nn_timing
233	NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
234	& jpizoom, jpjzoom, jperio
235	!!----------------------------------------------------------------------
236	!
237	cltxt = ''
238	!
239	! ! Open reference namelist and configuration namelist files
240	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
241	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
242	!
243	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
244	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
245	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
246
247	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
248	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
249	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
250
251	!
252	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
253	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
254	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
255
256	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
257	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
258	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
259
260	! Force values for AGRIF zoom (cf. agrif_user.F90)
261	#if defined key_agrif
262	IF( .NOT. Agrif_Root() ) THEN
263	jpiglo = nbcellsx + 2 + 2*nbghostcells
264	jpjglo = nbcellsy + 2 + 2*nbghostcells
265	jpi = ( jpiglo-2jpreci + (jpni-1+0) ) / jpni + 2jpreci
266	jpj = ( jpjglo-2jprecj + (jpnj-1+0) ) / jpnj + 2jprecj
267	jpidta = jpiglo
268	jpjdta = jpjglo
269	jpizoom = 1
270	jpjzoom = 1
271	nperio = 0
272	jperio = 0
273	ENDIF
274	#endif
275	!
276	! !--------------------------------------------!
277	! ! set communicator & select the local node !
278	! ! NB: mynode also opens output.namelist.dyn !
279	! ! on unit number numond on first proc !
280	! !--------------------------------------------!
281	#if defined key_iomput
282	IF( Agrif_Root() ) THEN
283	# if defined key_oasis3 \|\| defined key_oasis4
284	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
285	CALL xios_initialize( "oceanx",local_comm=ilocal_comm )
286	# else
287	CALL xios_initialize( "nemo",return_comm=ilocal_comm )
288	# endif
289	ENDIF
290	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection
291	#else
292	# if defined key_oasis3 \|\| defined key_oasis4
293	IF( Agrif_Root() ) THEN
294	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
295	ENDIF
296	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)
297	# else
298	ilocal_comm = 0
299	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt)
300	# endif
301	#endif
302	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
303
304	lwm = (narea == 1) ! control of output namelists
305	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
306
307	IF(lwm) THEN
308	! write merged namelists from earlier to output namelist now that the
309	! file has been opened in call to mynode. nammpp has already been
310	! written in mynode (if lk_mpp_mpi)
311	WRITE( numond, namctl )
312	WRITE( numond, namcfg )
313	ENDIF
314
315	! If dimensions of processor grid weren't specified in the namelist file
316	! then we calculate them here now that we have our communicator size
317	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
318	#if defined key_mpp_mpi
319	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
320	#else
321	jpni = 1
322	jpnj = 1
323	jpnij = jpni*jpnj
324	#endif
325	END IF
326
327	! Calculate domain dimensions given calculated jpni and jpnj
328	! This used to be done in par_oce.F90 when they were parameters rather
329	! than variables
330	IF( Agrif_Root() ) THEN
331	#if defined key_nemocice_decomp
332	jpi = ( nx_global+2-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
333	jpj = ( ny_global+2-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
334	#else
335	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
336	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
337	#endif
338	ENDIF
339	jpk = jpkdta ! third dim
340	jpim1 = jpi-1 ! inner domain indices
341	jpjm1 = jpj-1 ! " "
342	jpkm1 = jpk-1 ! " "
343	jpij = jpi*jpj ! jpi x j
344
345	IF(lwp) THEN ! open listing units
346	!
347	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
348	!
349	WRITE(numout,*)
350	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
351	WRITE(numout,*) ' NEMO team'
352	WRITE(numout,*) ' Ocean General Circulation Model'
353	WRITE(numout,*) ' version 3.4 (2011) '
354	WRITE(numout,*)
355	WRITE(numout,*)
356	DO ji = 1, SIZE(cltxt)
357	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
358	END DO
359	WRITE(numout,cform_aaa) ! Flag AAAAAAA
360	!
361	ENDIF
362
363	! Now we know the dimensions of the grid and numout has been set we can
364	! allocate arrays
365	CALL nemo_alloc()
366
367	! !-------------------------------!
368	! ! NEMO general initialization !
369	! !-------------------------------!
370
371	CALL nemo_ctl ! Control prints & Benchmark
372
373	! ! Domain decomposition
374	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
375	ELSE ; CALL mpp_init2 ! eliminate land processors
376	ENDIF
377	!
378	IF( nn_timing == 1 ) CALL timing_init
379	!
380	! ! General initialization
381	CALL phy_cst ! Physical constants
382	CALL eos_init ! Equation of state
383	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
384	CALL dom_cfg ! Domain configuration
385	CALL dom_init ! Domain
386
387	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
388
389	IF( ln_ctl ) CALL prt_ctl_init ! Print control
390
391	CALL istate_init ! ocean initial state (Dynamics and tracers)
392
393	IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics
394
395	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
396	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
397	IF( lk_bdy .AND. lk_tide ) &
398	& CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing
399
400	CALL dyn_nept_init ! simplified form of Neptune effect
401
402	!
403	IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid
404	!
405	! Ocean physics
406	CALL sbc_init ! Forcings : surface module
407	! ! Vertical physics
408
409	CALL zdf_init ! namelist read
410
411	CALL zdf_bfr_init ! bottom friction
412
413	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
414	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
415	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
416	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
417	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
418	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
419	& CALL zdf_ddm_init ! double diffusive mixing
420	! ! Lateral physics
421	CALL ldf_tra_init ! Lateral ocean tracer physics
422	CALL ldf_dyn_init ! Lateral ocean momentum physics
423	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
424
425	! ! Active tracers
426	CALL tra_qsr_init ! penetrative solar radiation qsr
427	CALL tra_bbc_init ! bottom heat flux
428	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
429	CALL tra_dmp_init ! internal damping trends- tracers
430	CALL tra_adv_init ! horizontal & vertical advection
431	CALL tra_ldf_init ! lateral mixing
432	CALL tra_zdf_init ! vertical mixing and after tracer fields
433
434	! ! Dynamics
435	IF( lk_c1d ) CALL dyn_dmp_init ! internal damping trends- momentum
436	CALL dyn_adv_init ! advection (vector or flux form)
437	CALL dyn_vor_init ! vorticity term including Coriolis
438	CALL dyn_ldf_init ! lateral mixing
439	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
440	CALL dyn_zdf_init ! vertical diffusion
441	CALL dyn_spg_init ! surface pressure gradient
442
443	! ! Misc. options
444	IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_init ! Cross Land Advection
445	CALL icb_init( rdt, nit000) ! initialise icebergs instance
446
447	#if defined key_top
448	! ! Passive tracers
449	CALL trc_init
450	#endif
451	!
452
453	! Diagnostics
454	IF( lk_floats ) CALL flo_init ! drifting Floats
455	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
456	CALL dia_ptr_init ! Poleward TRansports initialization
457	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
458	CALL dia_hsb_init ! heat content, salt content and volume budgets
459	CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
460	IF( lk_diaobs ) THEN ! Observation & model comparison
461	CALL dia_obs_init ! Initialize observational data
462	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
463	ENDIF
464	! ! Assimilation increments
465	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
466	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
467	!
468	END SUBROUTINE nemo_init
469
470
471	SUBROUTINE nemo_ctl
472	!!----------------------------------------------------------------------
473	!! * ROUTINE nemo_ctl *
474	!!
475	!! ** Purpose : control print setting
476	!!
477	!! ** Method : - print namctl information and check some consistencies
478	!!----------------------------------------------------------------------
479	!
480	IF(lwp) THEN ! control print
481	WRITE(numout,*)
482	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
483	WRITE(numout,*) '~~~~~~~ '
484	WRITE(numout,*) ' Namelist namctl'
485	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
486	WRITE(numout,*) ' level of print nn_print = ', nn_print
487	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
488	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
489	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
490	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
491	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
492	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
493	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
494	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
495	ENDIF
496	!
497	nprint = nn_print ! convert DOCTOR namelist names into OLD names
498	nictls = nn_ictls
499	nictle = nn_ictle
500	njctls = nn_jctls
501	njctle = nn_jctle
502	isplt = nn_isplt
503	jsplt = nn_jsplt
504	nbench = nn_bench
505
506	IF(lwp) THEN ! control print
507	WRITE(numout,*)
508	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
509	WRITE(numout,*) '~~~~~~~ '
510	WRITE(numout,*) ' Namelist namcfg'
511	WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg)
512	WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz)
513	WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg
514	WRITE(numout,*) ' 1st lateral dimension ( >= jpi ) jpidta = ', jpidta
515	WRITE(numout,*) ' 2nd " " ( >= jpj ) jpjdta = ', jpjdta
516	WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta
517	WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo
518	WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo
519	WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
520	WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
521	WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio
522	ENDIF
523	! ! Parameter control
524	!
525	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
526	IF( lk_mpp .AND. jpnij > 1 ) THEN
527	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
528	ELSE
529	IF( isplt == 1 .AND. jsplt == 1 ) THEN
530	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
531	& ' - the print control will be done over the whole domain' )
532	ENDIF
533	ijsplt = isplt * jsplt ! total number of processors ijsplt
534	ENDIF
535	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
536	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
537	!
538	! ! indices used for the SUM control
539	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
540	lsp_area = .FALSE.
541	ELSE ! print control done over a specific area
542	lsp_area = .TRUE.
543	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
544	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
545	nictls = 1
546	ENDIF
547	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
548	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
549	nictle = jpiglo
550	ENDIF
551	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
552	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
553	njctls = 1
554	ENDIF
555	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
556	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
557	njctle = jpjglo
558	ENDIF
559	ENDIF
560	ENDIF
561	!
562	IF( nbench == 1 ) THEN ! Benchmark
563	SELECT CASE ( cp_cfg )
564	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
565	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
566	& ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
567	END SELECT
568	ENDIF
569	!
570	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
571	& 'with the IOM Input/Output manager. ' , &
572	& 'Compile with key_iomput enabled' )
573	!
574	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
575	& 'f2003 standard. ' , &
576	& 'Compile with key_nosignedzero enabled' )
577	!
578	END SUBROUTINE nemo_ctl
579
580
581	SUBROUTINE nemo_closefile
582	!!----------------------------------------------------------------------
583	!! * ROUTINE nemo_closefile *
584	!!
585	!! ** Purpose : Close the files
586	!!----------------------------------------------------------------------
587	!
588	IF( lk_mpp ) CALL mppsync
589	!
590	CALL iom_close ! close all input/output files managed by iom_*
591	!
592	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
593	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
594	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
595	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
596	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
597	IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist
598	IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist
599	IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
600	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
601	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
602	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
603	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
604	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
605
606	!
607	numout = 6 ! redefine numout in case it is used after this point...
608	!
609	END SUBROUTINE nemo_closefile
610
611
612	SUBROUTINE nemo_alloc
613	!!----------------------------------------------------------------------
614	!! * ROUTINE nemo_alloc *
615	!!
616	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
617	!!
618	!! ** Method :
619	!!----------------------------------------------------------------------
620	USE diawri , ONLY: dia_wri_alloc
621	USE dom_oce , ONLY: dom_oce_alloc
622	USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
623	USE ldftra_oce, ONLY: ldftra_oce_alloc
624	USE trc_oce , ONLY: trc_oce_alloc
625	#if defined key_diadct
626	USE diadct , ONLY: diadct_alloc
627	#endif
628	#if defined key_bdy
629	USE bdy_oce , ONLY: bdy_oce_alloc
630	#endif
631	!
632	INTEGER :: ierr
633	!!----------------------------------------------------------------------
634	!
635	ierr = oce_alloc () ! ocean
636	ierr = ierr + dia_wri_alloc ()
637	ierr = ierr + dom_oce_alloc () ! ocean domain
638	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
639	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
640	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
641	!
642	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
643	!
644	#if defined key_diadct
645	ierr = ierr + diadct_alloc () !
646	#endif
647	#if defined key_bdy
648	ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization)
649	#endif
650	!
651	IF( lk_mpp ) CALL mpp_sum( ierr )
652	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
653	!
654	END SUBROUTINE nemo_alloc
655
656
657	SUBROUTINE nemo_partition( num_pes )
658	!!----------------------------------------------------------------------
659	!! * ROUTINE nemo_partition *
660	!!
661	!! ** Purpose :
662	!!
663	!! ** Method :
664	!!----------------------------------------------------------------------
665	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
666	!
667	INTEGER, PARAMETER :: nfactmax = 20
668	INTEGER :: nfact ! The no. of factors returned
669	INTEGER :: ierr ! Error flag
670	INTEGER :: ji
671	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
672	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
673	!!----------------------------------------------------------------------
674
675	ierr = 0
676
677	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
678
679	IF( nfact <= 1 ) THEN
680	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
681	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
682	jpnj = 1
683	jpni = num_pes
684	ELSE
685	! Search through factors for the pair that are closest in value
686	mindiff = 1000000
687	imin = 1
688	DO ji = 1, nfact-1, 2
689	idiff = ABS( ifact(ji) - ifact(ji+1) )
690	IF( idiff < mindiff ) THEN
691	mindiff = idiff
692	imin = ji
693	ENDIF
694	END DO
695	jpnj = ifact(imin)
696	jpni = ifact(imin + 1)
697	ENDIF
698	!
699	jpnij = jpni*jpnj
700	!
701	END SUBROUTINE nemo_partition
702
703
704	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
705	!!----------------------------------------------------------------------
706	!! * ROUTINE factorise *
707	!!
708	!! ** Purpose : return the prime factors of n.
709	!! knfax factors are returned in array kfax which is of
710	!! maximum dimension kmaxfax.
711	!! ** Method :
712	!!----------------------------------------------------------------------
713	INTEGER , INTENT(in ) :: kn, kmaxfax
714	INTEGER , INTENT( out) :: kerr, knfax
715	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
716	!
717	INTEGER :: ifac, jl, inu
718	INTEGER, PARAMETER :: ntest = 14
719	INTEGER :: ilfax(ntest)
720
721	! lfax contains the set of allowed factors.
722	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
723	& 128, 64, 32, 16, 8, 4, 2 /
724	!!----------------------------------------------------------------------
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	SUBROUTINE nemo_northcomms
772	!!======================================================================
773	!! * ROUTINE nemo_northcomms *
774	!! nemo_northcomms : Setup for north fold exchanges with explicit
775	!! point-to-point messaging
776	!!=====================================================================
777	!!----------------------------------------------------------------------
778	!!
779	!! ** Purpose : Initialization of the northern neighbours lists.
780	!!----------------------------------------------------------------------
781	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
782	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
783	!!----------------------------------------------------------------------
784
785	INTEGER :: sxM, dxM, sxT, dxT, jn
786	INTEGER :: njmppmax
787
788	njmppmax = MAXVAL( njmppt )
789
790	!initializes the north-fold communication variables
791	isendto(:) = 0
792	nsndto = 0
793
794	!if I am a process in the north
795	IF ( njmpp == njmppmax ) THEN
796	!sxM is the first point (in the global domain) needed to compute the
797	!north-fold for the current process
798	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
799	!dxM is the last point (in the global domain) needed to compute the
800	!north-fold for the current process
801	dxM = jpiglo - nimppt(narea) + 2
802
803	!loop over the other north-fold processes to find the processes
804	!managing the points belonging to the sxT-dxT range
805	DO jn = jpnij - jpni +1, jpnij
806	IF ( njmppt(jn) == njmppmax ) THEN
807	!sxT is the first point (in the global domain) of the jn
808	!process
809	sxT = nimppt(jn)
810	!dxT is the last point (in the global domain) of the jn
811	!process
812	dxT = nimppt(jn) + nlcit(jn) - 1
813	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
814	nsndto = nsndto + 1
815	isendto(nsndto) = jn
816	ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN
817	nsndto = nsndto + 1
818	isendto(nsndto) = jn
819	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
820	nsndto = nsndto + 1
821	isendto(nsndto) = jn
822	END IF
823	END IF
824	END DO
825	ENDIF
826	l_north_nogather = .TRUE.
827	END SUBROUTINE nemo_northcomms
828	#else
829	SUBROUTINE nemo_northcomms ! Dummy routine
830	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
831	END SUBROUTINE nemo_northcomms
832	#endif
833	!!======================================================================
834	END MODULE nemogcm
835
836

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

Download in other formats: