Context Navigation

nemogcm.F90 @ 2874

Last change on this file since 2874 was 2874, checked in by charris, 13 years ago

Code for running NEMO with CICE (for fully coupled mode this should be used in combination with dev_r2802_UKMO8_sbccpl). Changes are described briefly below.

physct: Constants modified to be consistent with CICE

nemogcm / prtctl / mppini: Changes to NEMO decomposition (activated using key_nemocice_decomp) to produce 'square' options in CICE. Can run without this key / code but this requires a global gather / scatter in the NEMO-CICE coupling which gets very slow on large processors numbers.

sbc_ice: CICE options and arrays added

sbcmod: CICE option added, including calls for initialising and finalising CICE.

sbcblk_core: Make sure necessary forcing field are available for CICE

sbcice_cice: Main CICE coupling code.

Property svn:keywords set to Id

File size: 29.0 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	!! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
30	!!----------------------------------------------------------------------
31
32	!!----------------------------------------------------------------------
33	!! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
34	!! nemo_init : initialization of the NEMO system
35	!! nemo_ctl : initialisation of the contol print
36	!! nemo_closefile : close remaining open files
37	!! nemo_alloc : dynamical allocation
38	!! nemo_partition : calculate MPP domain decomposition
39	!! factorise : calculate the factors of the no. of MPI processes
40	!!----------------------------------------------------------------------
41	USE step_oce ! module used in the ocean time stepping module
42	USE sbc_oce ! surface boundary condition: ocean
43	USE cla ! cross land advection (tra_cla routine)
44	USE domcfg ! domain configuration (dom_cfg routine)
45	USE mppini ! shared/distributed memory setting (mpp_init routine)
46	USE domain ! domain initialization (dom_init routine)
47	USE obcini ! open boundary cond. initialization (obc_ini routine)
48	USE bdyini ! unstructured open boundary cond. initialization (bdy_init routine)
49	USE istate ! initial state setting (istate_init routine)
50	USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
51	USE ldftra ! lateral diffusivity setting (ldftra_init routine)
52	USE zdfini ! vertical physics setting (zdf_init routine)
53	USE phycst ! physical constant (par_cst routine)
54	USE trdmod ! momentum/tracers trends (trd_mod_init routine)
55	USE asminc ! assimilation increments (asm_inc_init routine)
56	USE asmtrj ! writing out state trajectory
57	USE sshwzv ! vertical velocity used in asm
58	USE diaptr ! poleward transports (dia_ptr_init routine)
59	USE diaobs ! Observation diagnostics (dia_obs_init routine)
60	USE step ! NEMO time-stepping (stp routine)
61	#if defined key_oasis3
62	USE cpl_oasis3 ! OASIS3 coupling
63	#elif defined key_oasis4
64	USE cpl_oasis4 ! OASIS4 coupling (not working)
65	#endif
66	USE c1d ! 1D configuration
67	USE step_c1d ! Time stepping loop for the 1D configuration
68	#if defined key_top
69	USE trcini ! passive tracer initialisation
70	#endif
71	USE lib_mpp ! distributed memory computing
72	#if defined key_iomput
73	USE mod_ioclient
74	#endif
75
76	IMPLICIT NONE
77	PRIVATE
78
79	PUBLIC nemo_gcm ! called by model.F90
80	PUBLIC nemo_init ! needed by AGRIF
81
82	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
83
84	!!----------------------------------------------------------------------
85	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
86	!! $Id$
87	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
88	!!----------------------------------------------------------------------
89	CONTAINS
90
91	SUBROUTINE nemo_gcm
92	!!----------------------------------------------------------------------
93	!! * ROUTINE nemo_gcm *
94	!!
95	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
96	!! curvilinear mesh on the sphere.
97	!!
98	!! ** Method : - model general initialization
99	!! - launch the time-stepping (stp routine)
100	!! - finalize the run by closing files and communications
101	!!
102	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
103	!! Madec, 2008, internal report, IPSL.
104	!!----------------------------------------------------------------------
105	INTEGER :: istp ! time step index
106	!!----------------------------------------------------------------------
107	!
108	#if defined key_agrif
109	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
110	#endif
111
112	! !-----------------------!
113	CALL nemo_init !== Initialisations ==!
114	! !-----------------------!
115	#if defined key_agrif
116	CALL Agrif_Declare_Var ! AGRIF: set the meshes
117	# if defined key_top
118	CALL Agrif_Declare_Var_Top ! AGRIF: set the meshes
119	# endif
120	#endif
121	! check that all process are still there... If some process have an error,
122	! they will never enter in step and other processes will wait until the end of the cpu time!
123	IF( lk_mpp ) CALL mpp_max( nstop )
124
125	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
126
127	! !-----------------------!
128	! !== time stepping ==!
129	! !-----------------------!
130	istp = nit000
131	#if defined key_c1d
132	DO WHILE ( istp <= nitend .AND. nstop == 0 )
133	CALL stp_c1d( istp )
134	istp = istp + 1
135	END DO
136	#else
137	IF( lk_asminc ) THEN
138	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
139	IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 ) ! Output trajectory fields
140	IF( ln_asmdin ) THEN ! Direct initialization
141	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
142	IF( ln_dyninc ) THEN
143	CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
144	IF ( ln_asmdin ) CALL ssh_wzv ( nit000 - 1 ) ! update vertical velocity
145	ENDIF
146	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
147	ENDIF
148	ENDIF
149
150	DO WHILE ( istp <= nitend .AND. nstop == 0 )
151	#if defined key_agrif
152	CALL Agrif_Step( stp ) ! AGRIF: time stepping
153	#else
154	CALL stp( istp ) ! standard time stepping
155	#endif
156	istp = istp + 1
157	IF( lk_mpp ) CALL mpp_max( nstop )
158	END DO
159	#endif
160
161	IF( lk_diaobs ) CALL dia_obs_wri
162
163	! !------------------------!
164	! !== finalize the run ==!
165	! !------------------------!
166	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
167	!
168	IF( nstop /= 0 .AND. lwp ) THEN ! error print
169	WRITE(numout,cform_err)
170	WRITE(numout,*) nstop, ' error have been found'
171	ENDIF
172	!
173	CALL nemo_closefile
174	#if defined key_oasis3 \|\| defined key_oasis4
175	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
176	#else
177	IF( lk_mpp ) CALL mppstop ! end mpp communications
178	#endif
179	!
180	END SUBROUTINE nemo_gcm
181
182
183	SUBROUTINE nemo_init
184	!!----------------------------------------------------------------------
185	!! * ROUTINE nemo_init *
186	!!
187	!! ** Purpose : initialization of the NEMO GCM
188	!!----------------------------------------------------------------------
189	INTEGER :: ji ! dummy loop indices
190	INTEGER :: ilocal_comm ! local integer
191	CHARACTER(len=80), DIMENSION(16) :: cltxt
192	!!
193	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
194	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
195	!!----------------------------------------------------------------------
196	!
197	cltxt = ''
198	!
199	! ! open Namelist file
200	CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
201	!
202	READ( numnam, namctl ) ! Namelist namctl : Control prints & Benchmark
203	!
204	! !--------------------------------------------!
205	! ! set communicator & select the local node !
206	! !--------------------------------------------!
207	#if defined key_iomput
208	IF( Agrif_Root() ) THEN
209	# if defined key_oasis3 \|\| defined key_oasis4
210	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
211	# endif
212	CALL init_ioclient( ilocal_comm ) ! exchange io_server nemo local communicator with the io_server
213	ENDIF
214	narea = mynode( cltxt, numnam, nstop, ilocal_comm ) ! Nodes selection
215	#else
216	# if defined key_oasis3 \|\| defined key_oasis4
217	IF( Agrif_Root() ) THEN
218	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
219	ENDIF
220	narea = mynode( cltxt, numnam, nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)
221	# else
222	ilocal_comm = 0
223	narea = mynode( cltxt, numnam, nstop ) ! Nodes selection (control print return in cltxt)
224	# endif
225	#endif
226	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
227
228	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
229
230	! If dimensions of processor grid weren't specified in the namelist file
231	! then we calculate them here now that we have our communicator size
232	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
233	#if defined key_mpp_mpi
234	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
235	#else
236	jpni = 1
237	jpnj = 1
238	jpnij = jpni*jpnj
239	#endif
240	END IF
241
242	! Calculate domain dimensions given calculated jpni and jpnj
243	! This used to be done in par_oce.F90 when they were parameters rather
244	! than variables
245	IF( Agrif_Root() ) THEN
246	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
247	#if defined key_nemocice_decomp
248	jpj = ( jpjglo+1-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
249	#else
250	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
251	#endif
252	jpk = jpkdta ! third dim
253	jpim1 = jpi-1 ! inner domain indices
254	jpjm1 = jpj-1 ! " "
255	jpkm1 = jpk-1 ! " "
256	jpij = jpi*jpj ! jpi x j
257	ENDIF
258
259	IF(lwp) THEN ! open listing units
260	!
261	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
262	!
263	WRITE(numout,*)
264	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean'
265	WRITE(numout,*) ' NEMO team'
266	WRITE(numout,*) ' Ocean General Circulation Model'
267	WRITE(numout,*) ' version 3.3 (2010) '
268	WRITE(numout,*)
269	WRITE(numout,*)
270	DO ji = 1, SIZE(cltxt)
271	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
272	END DO
273	WRITE(numout,cform_aaa) ! Flag AAAAAAA
274	!
275	ENDIF
276
277	! Now we know the dimensions of the grid and numout has been set we can
278	! allocate arrays
279	CALL nemo_alloc()
280
281	! !-------------------------------!
282	! ! NEMO general initialization !
283	! !-------------------------------!
284
285	CALL nemo_ctl ! Control prints & Benchmark
286
287	! ! Domain decomposition
288	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
289	ELSE ; CALL mpp_init2 ! eliminate land processors
290	ENDIF
291	!
292	! ! General initialization
293	CALL phy_cst ! Physical constants
294	CALL eos_init ! Equation of state
295	CALL dom_cfg ! Domain configuration
296	CALL dom_init ! Domain
297
298	IF( ln_ctl ) CALL prt_ctl_init ! Print control
299
300	IF( lk_obc ) CALL obc_init ! Open boundaries
301	IF( lk_bdy ) CALL bdy_init ! Unstructured open boundaries
302
303	CALL istate_init ! ocean initial state (Dynamics and tracers)
304
305	! ! Ocean physics
306	CALL sbc_init ! Forcings : surface module
307	! ! Vertical physics
308	CALL zdf_init ! namelist read
309	CALL zdf_bfr_init ! bottom friction
310	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
311	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
312	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
313	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
314	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
315	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
316	& CALL zdf_ddm_init ! double diffusive mixing
317	! ! Lateral physics
318	CALL ldf_tra_init ! Lateral ocean tracer physics
319	CALL ldf_dyn_init ! Lateral ocean momentum physics
320	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
321
322	! ! Active tracers
323	CALL tra_qsr_init ! penetrative solar radiation qsr
324	CALL tra_bbc_init ! bottom heat flux
325	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
326	IF( lk_tradmp ) CALL tra_dmp_init ! internal damping trends
327	CALL tra_adv_init ! horizontal & vertical advection
328	CALL tra_ldf_init ! lateral mixing
329	CALL tra_zdf_init ! vertical mixing and after tracer fields
330
331	! ! Dynamics
332	CALL dyn_adv_init ! advection (vector or flux form)
333	CALL dyn_vor_init ! vorticity term including Coriolis
334	CALL dyn_ldf_init ! lateral mixing
335	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
336	CALL dyn_zdf_init ! vertical diffusion
337	CALL dyn_spg_init ! surface pressure gradient
338
339	! ! Misc. options
340	IF( nn_cla == 1 ) CALL cla_init ! Cross Land Advection
341
342	#if defined key_top
343	! ! Passive tracers
344	CALL trc_init
345	#endif
346	! ! Diagnostics
347	CALL iom_init ! iom_put initialization
348	IF( lk_floats ) CALL flo_init ! drifting Floats
349	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
350	CALL dia_ptr_init ! Poleward TRansports initialization
351	CALL dia_hsb_init ! heat content, salt content and volume budgets
352	CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
353	IF( lk_diaobs ) THEN ! Observation & model comparison
354	CALL dia_obs_init ! Initialize observational data
355	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
356	ENDIF
357	! ! Assimilation increments
358	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
359	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
360	!
361	END SUBROUTINE nemo_init
362
363
364	SUBROUTINE nemo_ctl
365	!!----------------------------------------------------------------------
366	!! * ROUTINE nemo_ctl *
367	!!
368	!! ** Purpose : control print setting
369	!!
370	!! ** Method : - print namctl information and check some consistencies
371	!!----------------------------------------------------------------------
372	!
373	IF(lwp) THEN ! control print
374	WRITE(numout,*)
375	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
376	WRITE(numout,*) '~~~~~~~ '
377	WRITE(numout,*) ' Namelist namctl'
378	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
379	WRITE(numout,*) ' level of print nn_print = ', nn_print
380	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
381	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
382	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
383	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
384	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
385	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
386	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
387	ENDIF
388	!
389	nprint = nn_print ! convert DOCTOR namelist names into OLD names
390	nictls = nn_ictls
391	nictle = nn_ictle
392	njctls = nn_jctls
393	njctle = nn_jctle
394	isplt = nn_isplt
395	jsplt = nn_jsplt
396	nbench = nn_bench
397	! ! Parameter control
398	!
399	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
400	IF( lk_mpp ) THEN
401	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
402	ELSE
403	IF( isplt == 1 .AND. jsplt == 1 ) THEN
404	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
405	& ' - the print control will be done over the whole domain' )
406	ENDIF
407	ijsplt = isplt * jsplt ! total number of processors ijsplt
408	ENDIF
409	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
410	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
411	!
412	! ! indices used for the SUM control
413	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
414	lsp_area = .FALSE.
415	ELSE ! print control done over a specific area
416	lsp_area = .TRUE.
417	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
418	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
419	nictls = 1
420	ENDIF
421	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
422	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
423	nictle = jpiglo
424	ENDIF
425	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
426	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
427	njctls = 1
428	ENDIF
429	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
430	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
431	njctle = jpjglo
432	ENDIF
433	ENDIF
434	ENDIF
435	!
436	IF( nbench == 1 ) THEN ! Benchmark
437	SELECT CASE ( cp_cfg )
438	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
439	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
440	& ' key_gyre must be used or set nbench = 0' )
441	END SELECT
442	ENDIF
443	!
444	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
445	& 'with the IOM Input/Output manager. ' , &
446	& 'Compile with key_iomput enabled' )
447	!
448	END SUBROUTINE nemo_ctl
449
450
451	SUBROUTINE nemo_closefile
452	!!----------------------------------------------------------------------
453	!! * ROUTINE nemo_closefile *
454	!!
455	!! ** Purpose : Close the files
456	!!----------------------------------------------------------------------
457	!
458	IF( lk_mpp ) CALL mppsync
459	!
460	CALL iom_close ! close all input/output files managed by iom_*
461	!
462	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
463	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
464	IF( numnam /= -1 ) CLOSE( numnam ) ! oce namelist
465	IF( numnam_ice /= -1 ) CLOSE( numnam_ice ) ! ice namelist
466	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
467	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
468	!
469	numout = 6 ! redefine numout in case it is used after this point...
470	!
471	END SUBROUTINE nemo_closefile
472
473
474	SUBROUTINE nemo_alloc
475	!!----------------------------------------------------------------------
476	!! * ROUTINE nemo_alloc *
477	!!
478	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
479	!!
480	!! ** Method :
481	!!----------------------------------------------------------------------
482	USE diawri , ONLY: dia_wri_alloc
483	USE dom_oce , ONLY: dom_oce_alloc
484	USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
485	USE ldftra_oce, ONLY: ldftra_oce_alloc
486	USE trc_oce , ONLY: trc_oce_alloc
487	USE wrk_nemo , ONLY: wrk_alloc
488	!
489	INTEGER :: ierr
490	!!----------------------------------------------------------------------
491	!
492	ierr = oce_alloc () ! ocean
493	ierr = ierr + dia_wri_alloc ()
494	ierr = ierr + dom_oce_alloc () ! ocean domain
495	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
496	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
497	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
498	!
499	ierr = ierr + lib_mpp_alloc (numout) ! mpp exchanges
500	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
501	!
502	ierr = ierr + wrk_alloc(numout, lwp) ! workspace
503	!
504	IF( lk_mpp ) CALL mpp_sum( ierr )
505	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
506	!
507	END SUBROUTINE nemo_alloc
508
509
510	SUBROUTINE nemo_partition( num_pes )
511	!!----------------------------------------------------------------------
512	!! * ROUTINE nemo_partition *
513	!!
514	!! ** Purpose :
515	!!
516	!! ** Method :
517	!!----------------------------------------------------------------------
518	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
519	!
520	INTEGER, PARAMETER :: nfactmax = 20
521	INTEGER :: nfact ! The no. of factors returned
522	INTEGER :: ierr ! Error flag
523	INTEGER :: ji
524	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
525	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
526	!!----------------------------------------------------------------------
527
528	ierr = 0
529
530	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
531
532	IF( nfact <= 1 ) THEN
533	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
534	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
535	jpnj = 1
536	jpni = num_pes
537	ELSE
538	! Search through factors for the pair that are closest in value
539	mindiff = 1000000
540	imin = 1
541	DO ji = 1, nfact-1, 2
542	idiff = ABS( ifact(ji) - ifact(ji+1) )
543	IF( idiff < mindiff ) THEN
544	mindiff = idiff
545	imin = ji
546	ENDIF
547	END DO
548	jpnj = ifact(imin)
549	jpni = ifact(imin + 1)
550	ENDIF
551	!
552	jpnij = jpni*jpnj
553	!
554	END SUBROUTINE nemo_partition
555
556
557	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
558	!!----------------------------------------------------------------------
559	!! * ROUTINE factorise *
560	!!
561	!! ** Purpose : return the prime factors of n.
562	!! knfax factors are returned in array kfax which is of
563	!! maximum dimension kmaxfax.
564	!! ** Method :
565	!!----------------------------------------------------------------------
566	INTEGER , INTENT(in ) :: kn, kmaxfax
567	INTEGER , INTENT( out) :: kerr, knfax
568	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
569	!
570	INTEGER :: ifac, jl, inu
571	INTEGER, PARAMETER :: ntest = 14
572	INTEGER :: ilfax(ntest)
573
574	! lfax contains the set of allowed factors.
575	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
576	& 128, 64, 32, 16, 8, 4, 2 /
577	!!----------------------------------------------------------------------
578
579	! Clear the error flag and initialise output vars
580	kerr = 0
581	kfax = 1
582	knfax = 0
583
584	! Find the factors of n.
585	IF( kn == 1 ) GOTO 20
586
587	! nu holds the unfactorised part of the number.
588	! knfax holds the number of factors found.
589	! l points to the allowed factor list.
590	! ifac holds the current factor.
591
592	inu = kn
593	knfax = 0
594
595	DO jl = ntest, 1, -1
596	!
597	ifac = ilfax(jl)
598	IF( ifac > inu ) CYCLE
599
600	! Test whether the factor will divide.
601
602	IF( MOD(inu,ifac) == 0 ) THEN
603	!
604	knfax = knfax + 1 ! Add the factor to the list
605	IF( knfax > kmaxfax ) THEN
606	kerr = 6
607	write (,) 'FACTOR: insufficient space in factor array ', knfax
608	return
609	ENDIF
610	kfax(knfax) = ifac
611	! Store the other factor that goes with this one
612	knfax = knfax + 1
613	kfax(knfax) = inu / ifac
614	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
615	ENDIF
616	!
617	END DO
618
619	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
620	!
621	END SUBROUTINE factorise
622
623	!!======================================================================
624	END MODULE nemogcm

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

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

Context Navigation

source: branches/2011/dev_r2802_UKMO8_cice/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 2874

Download in other formats: