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

Context Navigation

source: branches/2014/dev_r4650_UKMO10_Tidally_Meaned_Diagnostics/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 4756

Last change on this file since 4756 was 4756, checked in by deazer, 10 years ago
Added two new routines, diatmb and dia25h to handle 25hourly and tmb output. modified diawri to call these routines when logicals are true logicals are set by new namelist addition set to true in AMM12 cfg and false in reference default should be false. additional call in dynspg_ts for barotropic U and V Created extra fields in field_def.xml and extrae file groups in iodef.xml
Property svn:keywords set to `Id`
File size: 39.2 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	USE diatmb ! Top,middle,bottom output
90	USE dia25h ! 25h mean output
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 4.0 , NEMO Consortium (2011)
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
126	#if defined key_agrif
127	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
128	#endif
129
130	! !-----------------------!
131	CALL nemo_init !== Initialisations ==!
132	! !-----------------------!
133	#if defined key_agrif
134	CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
135	CALL Agrif_Declare_Var ! " " " " " DYN/TRA
136	# if defined key_top
137	CALL Agrif_Declare_Var_top ! " " " " " TOP
138	# endif
139	# if defined key_lim2
140	CALL Agrif_Declare_Var_lim2 ! " " " " " LIM
141	# endif
142	#endif
143
144	! check that all process are still there... If some process have an error,
145	! they will never enter in step and other processes will wait until the end of the cpu time!
146	IF( lk_mpp ) CALL mpp_max( nstop )
147
148	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
149
150	! !-----------------------!
151	! !== time stepping ==!
152	! !-----------------------!
153	istp = nit000
154	#if defined key_c1d
155	DO WHILE ( istp <= nitend .AND. nstop == 0 )
156	CALL stp_c1d( istp )
157	istp = istp + 1
158	END DO
159	#else
160	IF( lk_asminc ) THEN
161	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
162	IF( ln_asmdin ) THEN ! Direct initialization
163	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
164	IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
165	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
166	ENDIF
167	ENDIF
168
169	DO WHILE ( istp <= nitend .AND. nstop == 0 )
170
171	#if defined key_agrif
172	CALL Agrif_Step( stp ) ! AGRIF: time stepping
173	#else
174	CALL stp( istp ) ! standard time stepping
175	#endif
176
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	CALL Agrif_ParentGrid_To_ChildGrid()
198	IF( lk_diaobs ) CALL dia_obs_wri
199	IF( nn_timing == 1 ) CALL timing_finalize
200	CALL Agrif_ChildGrid_To_ParentGrid()
201	#endif
202	IF( nn_timing == 1 ) CALL timing_finalize
203	!
204	CALL nemo_closefile
205	#if defined key_iomput
206	CALL xios_finalize ! end mpp communications with xios
207	# if defined key_oasis3 \|\| defined key_oasis4
208	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
209	# endif
210	#else
211	# if defined key_oasis3 \|\| defined key_oasis4
212	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
213	# else
214	IF( lk_mpp ) CALL mppstop ! end mpp communications
215	# endif
216	#endif
217	!
218	END SUBROUTINE nemo_gcm
219
220
221	SUBROUTINE nemo_init
222	!!----------------------------------------------------------------------
223	!! * ROUTINE nemo_init *
224	!!
225	!! ** Purpose : initialization of the NEMO GCM
226	!!----------------------------------------------------------------------
227	INTEGER :: ji ! dummy loop indices
228	INTEGER :: ilocal_comm ! local integer
229	INTEGER :: ios
230	CHARACTER(len=80), DIMENSION(16) :: cltxt
231	!!
232	NAMELIST/namctl/ ln_ctl, nn_print, nn_ictls, nn_ictle, &
233	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
234	& nn_bench, nn_timing
235	NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
236	& jpizoom, jpjzoom, jperio
237	!!----------------------------------------------------------------------
238	!
239	cltxt = ''
240	!
241	! ! Open reference namelist and configuration namelist files
242	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
243	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
244	!
245	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
246	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
247	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
248
249	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
250	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
251	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
252
253	!
254	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
255	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
256	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
257
258	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
259	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
260	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
261
262	! Force values for AGRIF zoom (cf. agrif_user.F90)
263	#if defined key_agrif
264	IF( .NOT. Agrif_Root() ) THEN
265	jpiglo = nbcellsx + 2 + 2*nbghostcells
266	jpjglo = nbcellsy + 2 + 2*nbghostcells
267	jpi = ( jpiglo-2jpreci + (jpni-1+0) ) / jpni + 2jpreci
268	jpj = ( jpjglo-2jprecj + (jpnj-1+0) ) / jpnj + 2jprecj
269	jpidta = jpiglo
270	jpjdta = jpjglo
271	jpizoom = 1
272	jpjzoom = 1
273	nperio = 0
274	jperio = 0
275	ENDIF
276	#endif
277	!
278	! !--------------------------------------------!
279	! ! set communicator & select the local node !
280	! ! NB: mynode also opens output.namelist.dyn !
281	! ! on unit number numond on first proc !
282	! !--------------------------------------------!
283	#if defined key_iomput
284	IF( Agrif_Root() ) THEN
285	# if defined key_oasis3 \|\| defined key_oasis4
286	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
287	CALL xios_initialize( "oceanx",local_comm=ilocal_comm )
288	# else
289	CALL xios_initialize( "nemo",return_comm=ilocal_comm )
290	# endif
291	ENDIF
292	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection
293	#else
294	# if defined key_oasis3 \|\| defined key_oasis4
295	IF( Agrif_Root() ) THEN
296	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
297	ENDIF
298	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)
299	# else
300	ilocal_comm = 0
301	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt)
302	# endif
303	#endif
304	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
305
306	lwm = (narea == 1) ! control of output namelists
307	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
308
309	IF(lwm) THEN
310	! write merged namelists from earlier to output namelist now that the
311	! file has been opened in call to mynode. nammpp has already been
312	! written in mynode (if lk_mpp_mpi)
313	WRITE( numond, namctl )
314	WRITE( numond, namcfg )
315	ENDIF
316
317	! If dimensions of processor grid weren't specified in the namelist file
318	! then we calculate them here now that we have our communicator size
319	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
320	#if defined key_mpp_mpi
321	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
322	#else
323	jpni = 1
324	jpnj = 1
325	jpnij = jpni*jpnj
326	#endif
327	END IF
328
329	! Calculate domain dimensions given calculated jpni and jpnj
330	! This used to be done in par_oce.F90 when they were parameters rather
331	! than variables
332	IF( Agrif_Root() ) THEN
333	#if defined key_nemocice_decomp
334	jpi = ( nx_global+2-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
335	jpj = ( ny_global+2-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
336	#else
337	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
338	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
339	#endif
340	ENDIF
341	jpk = jpkdta ! third dim
342	jpim1 = jpi-1 ! inner domain indices
343	jpjm1 = jpj-1 ! " "
344	jpkm1 = jpk-1 ! " "
345	jpij = jpi*jpj ! jpi x j
346
347	IF(lwp) THEN ! open listing units
348	!
349	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
350	!
351	WRITE(numout,*)
352	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
353	WRITE(numout,*) ' NEMO team'
354	WRITE(numout,*) ' Ocean General Circulation Model'
355	WRITE(numout,*) ' version 3.4 (2011) '
356	WRITE(numout,*)
357	WRITE(numout,*)
358	DO ji = 1, SIZE(cltxt)
359	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
360	END DO
361	WRITE(numout,cform_aaa) ! Flag AAAAAAA
362	!
363	ENDIF
364
365	! Now we know the dimensions of the grid and numout has been set we can
366	! allocate arrays
367	CALL nemo_alloc()
368
369	! !-------------------------------!
370	! ! NEMO general initialization !
371	! !-------------------------------!
372
373	CALL nemo_ctl ! Control prints & Benchmark
374
375	! ! Domain decomposition
376	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
377	ELSE ; CALL mpp_init2 ! eliminate land processors
378	ENDIF
379	!
380	IF( nn_timing == 1 ) CALL timing_init
381	!
382	! ! General initialization
383	CALL phy_cst ! Physical constants
384	CALL eos_init ! Equation of state
385	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
386	CALL dom_cfg ! Domain configuration
387	CALL dom_init ! Domain
388
389	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
390
391	IF( ln_ctl ) CALL prt_ctl_init ! Print control
392
393	CALL istate_init ! ocean initial state (Dynamics and tracers)
394
395	IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics
396
397	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
398	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
399	IF( lk_bdy .AND. lk_tide ) &
400	& CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing
401
402	CALL dyn_nept_init ! simplified form of Neptune effect
403
404	!
405	IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid
406	!
407	! Ocean physics
408	CALL sbc_init ! Forcings : surface module
409	! ! Vertical physics
410
411	CALL zdf_init ! namelist read
412
413	CALL zdf_bfr_init ! bottom friction
414
415	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
416	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
417	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
418	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
419	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
420	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
421	& CALL zdf_ddm_init ! double diffusive mixing
422	! ! Lateral physics
423	CALL ldf_tra_init ! Lateral ocean tracer physics
424	CALL ldf_dyn_init ! Lateral ocean momentum physics
425	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
426
427	! ! Active tracers
428	CALL tra_qsr_init ! penetrative solar radiation qsr
429	CALL tra_bbc_init ! bottom heat flux
430	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
431	CALL tra_dmp_init ! internal damping trends- tracers
432	CALL tra_adv_init ! horizontal & vertical advection
433	CALL tra_ldf_init ! lateral mixing
434	CALL tra_zdf_init ! vertical mixing and after tracer fields
435
436	! ! Dynamics
437	IF( lk_c1d ) CALL dyn_dmp_init ! internal damping trends- momentum
438	CALL dyn_adv_init ! advection (vector or flux form)
439	CALL dyn_vor_init ! vorticity term including Coriolis
440	CALL dyn_ldf_init ! lateral mixing
441	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
442	CALL dyn_zdf_init ! vertical diffusion
443	CALL dyn_spg_init ! surface pressure gradient
444
445	! ! Misc. options
446	IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_init ! Cross Land Advection
447	CALL icb_init( rdt, nit000) ! initialise icebergs instance
448
449	#if defined key_top
450	! ! Passive tracers
451	CALL trc_init
452	#endif
453	!
454
455	! Diagnostics
456	IF( lk_floats ) CALL flo_init ! drifting Floats
457	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
458	CALL dia_ptr_init ! Poleward TRansports initialization
459	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
460	CALL dia_hsb_init ! heat content, salt content and volume budgets
461	CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
462	IF( lk_diaobs ) THEN ! Observation & model comparison
463	CALL dia_obs_init ! Initialize observational data
464	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
465	ENDIF
466	! ! Assimilation increments
467	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
468	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
469	CALL dia_tmb_init ! TMB outputs
470	CALL dia_25h_init ! 25h mean outputs
471
472	!
473	END SUBROUTINE nemo_init
474
475
476	SUBROUTINE nemo_ctl
477	!!----------------------------------------------------------------------
478	!! * ROUTINE nemo_ctl *
479	!!
480	!! ** Purpose : control print setting
481	!!
482	!! ** Method : - print namctl information and check some consistencies
483	!!----------------------------------------------------------------------
484	!
485	IF(lwp) THEN ! control print
486	WRITE(numout,*)
487	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
488	WRITE(numout,*) '~~~~~~~ '
489	WRITE(numout,*) ' Namelist namctl'
490	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
491	WRITE(numout,*) ' level of print nn_print = ', nn_print
492	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
493	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
494	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
495	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
496	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
497	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
498	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
499	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
500	ENDIF
501	!
502	nprint = nn_print ! convert DOCTOR namelist names into OLD names
503	nictls = nn_ictls
504	nictle = nn_ictle
505	njctls = nn_jctls
506	njctle = nn_jctle
507	isplt = nn_isplt
508	jsplt = nn_jsplt
509	nbench = nn_bench
510
511	IF(lwp) THEN ! control print
512	WRITE(numout,*)
513	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
514	WRITE(numout,*) '~~~~~~~ '
515	WRITE(numout,*) ' Namelist namcfg'
516	WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg)
517	WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz)
518	WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg
519	WRITE(numout,*) ' 1st lateral dimension ( >= jpi ) jpidta = ', jpidta
520	WRITE(numout,*) ' 2nd " " ( >= jpj ) jpjdta = ', jpjdta
521	WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta
522	WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo
523	WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo
524	WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
525	WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
526	WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio
527	ENDIF
528	! ! Parameter control
529	!
530	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
531	IF( lk_mpp .AND. jpnij > 1 ) THEN
532	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
533	ELSE
534	IF( isplt == 1 .AND. jsplt == 1 ) THEN
535	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
536	& ' - the print control will be done over the whole domain' )
537	ENDIF
538	ijsplt = isplt * jsplt ! total number of processors ijsplt
539	ENDIF
540	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
541	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
542	!
543	! ! indices used for the SUM control
544	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
545	lsp_area = .FALSE.
546	ELSE ! print control done over a specific area
547	lsp_area = .TRUE.
548	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
549	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
550	nictls = 1
551	ENDIF
552	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
553	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
554	nictle = jpiglo
555	ENDIF
556	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
557	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
558	njctls = 1
559	ENDIF
560	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
561	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
562	njctle = jpjglo
563	ENDIF
564	ENDIF
565	ENDIF
566	!
567	IF( nbench == 1 ) THEN ! Benchmark
568	SELECT CASE ( cp_cfg )
569	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
570	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
571	& ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
572	END SELECT
573	ENDIF
574	!
575	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
576	& 'with the IOM Input/Output manager. ' , &
577	& 'Compile with key_iomput enabled' )
578	!
579	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
580	& 'f2003 standard. ' , &
581	& 'Compile with key_nosignedzero enabled' )
582	!
583	END SUBROUTINE nemo_ctl
584
585
586	SUBROUTINE nemo_closefile
587	!!----------------------------------------------------------------------
588	!! * ROUTINE nemo_closefile *
589	!!
590	!! ** Purpose : Close the files
591	!!----------------------------------------------------------------------
592	!
593	IF( lk_mpp ) CALL mppsync
594	!
595	CALL iom_close ! close all input/output files managed by iom_*
596	!
597	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
598	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
599	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
600	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
601	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
602	IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist
603	IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist
604	IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
605	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
606	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
607	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
608	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
609	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
610
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 ldfdyn_oce, ONLY: ldfdyn_oce_alloc
628	USE ldftra_oce, ONLY: ldftra_oce_alloc
629	USE trc_oce , ONLY: trc_oce_alloc
630	USE insitu_tem, ONLY: insitu_tem_alloc
631	#if defined key_diadct
632	USE diadct , ONLY: diadct_alloc
633	#endif
634	#if defined key_bdy
635	USE bdy_oce , ONLY: bdy_oce_alloc
636	#endif
637	!
638	INTEGER :: ierr
639	!!----------------------------------------------------------------------
640	!
641	ierr = oce_alloc () ! ocean
642	ierr = ierr + dia_wri_alloc ()
643	ierr = ierr + dom_oce_alloc () ! ocean domain
644	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
645	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
646	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
647	ierr = ierr + insitu_tem_alloc()
648	!
649	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
650	!
651	#if defined key_diadct
652	ierr = ierr + diadct_alloc () !
653	#endif
654	#if defined key_bdy
655	ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization)
656	#endif
657	!
658	IF( lk_mpp ) CALL mpp_sum( ierr )
659	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
660	!
661	END SUBROUTINE nemo_alloc
662
663
664	SUBROUTINE nemo_partition( num_pes )
665	!!----------------------------------------------------------------------
666	!! * ROUTINE nemo_partition *
667	!!
668	!! ** Purpose :
669	!!
670	!! ** Method :
671	!!----------------------------------------------------------------------
672	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
673	!
674	INTEGER, PARAMETER :: nfactmax = 20
675	INTEGER :: nfact ! The no. of factors returned
676	INTEGER :: ierr ! Error flag
677	INTEGER :: ji
678	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
679	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
680	!!----------------------------------------------------------------------
681
682	ierr = 0
683
684	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
685
686	IF( nfact <= 1 ) THEN
687	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
688	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
689	jpnj = 1
690	jpni = num_pes
691	ELSE
692	! Search through factors for the pair that are closest in value
693	mindiff = 1000000
694	imin = 1
695	DO ji = 1, nfact-1, 2
696	idiff = ABS( ifact(ji) - ifact(ji+1) )
697	IF( idiff < mindiff ) THEN
698	mindiff = idiff
699	imin = ji
700	ENDIF
701	END DO
702	jpnj = ifact(imin)
703	jpni = ifact(imin + 1)
704	ENDIF
705	!
706	jpnij = jpni*jpnj
707	!
708	END SUBROUTINE nemo_partition
709
710
711	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
712	!!----------------------------------------------------------------------
713	!! * ROUTINE factorise *
714	!!
715	!! ** Purpose : return the prime factors of n.
716	!! knfax factors are returned in array kfax which is of
717	!! maximum dimension kmaxfax.
718	!! ** Method :
719	!!----------------------------------------------------------------------
720	INTEGER , INTENT(in ) :: kn, kmaxfax
721	INTEGER , INTENT( out) :: kerr, knfax
722	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
723	!
724	INTEGER :: ifac, jl, inu
725	INTEGER, PARAMETER :: ntest = 14
726	INTEGER :: ilfax(ntest)
727
728	! lfax contains the set of allowed factors.
729	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
730	& 128, 64, 32, 16, 8, 4, 2 /
731	!!----------------------------------------------------------------------
732
733	! Clear the error flag and initialise output vars
734	kerr = 0
735	kfax = 1
736	knfax = 0
737
738	! Find the factors of n.
739	IF( kn == 1 ) GOTO 20
740
741	! nu holds the unfactorised part of the number.
742	! knfax holds the number of factors found.
743	! l points to the allowed factor list.
744	! ifac holds the current factor.
745
746	inu = kn
747	knfax = 0
748
749	DO jl = ntest, 1, -1
750	!
751	ifac = ilfax(jl)
752	IF( ifac > inu ) CYCLE
753
754	! Test whether the factor will divide.
755
756	IF( MOD(inu,ifac) == 0 ) THEN
757	!
758	knfax = knfax + 1 ! Add the factor to the list
759	IF( knfax > kmaxfax ) THEN
760	kerr = 6
761	write (,) 'FACTOR: insufficient space in factor array ', knfax
762	return
763	ENDIF
764	kfax(knfax) = ifac
765	! Store the other factor that goes with this one
766	knfax = knfax + 1
767	kfax(knfax) = inu / ifac
768	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
769	ENDIF
770	!
771	END DO
772
773	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
774	!
775	END SUBROUTINE factorise
776
777	#if defined key_mpp_mpi
778	SUBROUTINE nemo_northcomms
779	!!======================================================================
780	!! * ROUTINE nemo_northcomms *
781	!! nemo_northcomms : Setup for north fold exchanges with explicit
782	!! point-to-point messaging
783	!!=====================================================================
784	!!----------------------------------------------------------------------
785	!!
786	!! ** Purpose : Initialization of the northern neighbours lists.
787	!!----------------------------------------------------------------------
788	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
789	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
790	!!----------------------------------------------------------------------
791
792	INTEGER :: sxM, dxM, sxT, dxT, jn
793	INTEGER :: njmppmax
794
795	njmppmax = MAXVAL( njmppt )
796
797	!initializes the north-fold communication variables
798	isendto(:) = 0
799	nsndto = 0
800
801	!if I am a process in the north
802	IF ( njmpp == njmppmax ) THEN
803	!sxM is the first point (in the global domain) needed to compute the
804	!north-fold for the current process
805	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
806	!dxM is the last point (in the global domain) needed to compute the
807	!north-fold for the current process
808	dxM = jpiglo - nimppt(narea) + 2
809
810	!loop over the other north-fold processes to find the processes
811	!managing the points belonging to the sxT-dxT range
812	DO jn = jpnij - jpni +1, jpnij
813	IF ( njmppt(jn) == njmppmax ) THEN
814	!sxT is the first point (in the global domain) of the jn
815	!process
816	sxT = nimppt(jn)
817	!dxT is the last point (in the global domain) of the jn
818	!process
819	dxT = nimppt(jn) + nlcit(jn) - 1
820	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
821	nsndto = nsndto + 1
822	isendto(nsndto) = jn
823	ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
824	nsndto = nsndto + 1
825	isendto(nsndto) = jn
826	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
827	nsndto = nsndto + 1
828	isendto(nsndto) = jn
829	END IF
830	END IF
831	END DO
832	ENDIF
833	l_north_nogather = .TRUE.
834	END SUBROUTINE nemo_northcomms
835	#else
836	SUBROUTINE nemo_northcomms ! Dummy routine
837	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
838	END SUBROUTINE nemo_northcomms
839	#endif
840	!!======================================================================
841	END MODULE nemogcm
842
843

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

Download in other formats: