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

Context Navigation

source: branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 2888

Last change on this file since 2888 was 2888, checked in by davestorkey, 13 years ago
Move changes into updated BDY module and restore old OBC code. (Full merge to take place next year).
Property svn:keywords set to `Id`
File size: 29.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	!! 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 ! open boundary cond. initialization (bdy_init routine)
49	USE bdydta ! open boundary cond. initialization (bdy_dta_init routine)
50	USE bdytides ! open boundary cond. initialization (tide_init routine)
51	USE istate ! initial state setting (istate_init routine)
52	USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
53	USE ldftra ! lateral diffusivity setting (ldftra_init routine)
54	USE zdfini ! vertical physics setting (zdf_init routine)
55	USE phycst ! physical constant (par_cst routine)
56	USE trdmod ! momentum/tracers trends (trd_mod_init routine)
57	USE asminc ! assimilation increments (asm_inc_init routine)
58	USE asmtrj ! writing out state trajectory
59	USE sshwzv ! vertical velocity used in asm
60	USE diaptr ! poleward transports (dia_ptr_init routine)
61	USE diaobs ! Observation diagnostics (dia_obs_init routine)
62	USE step ! NEMO time-stepping (stp routine)
63	#if defined key_oasis3
64	USE cpl_oasis3 ! OASIS3 coupling
65	#elif defined key_oasis4
66	USE cpl_oasis4 ! OASIS4 coupling (not working)
67	#endif
68	USE c1d ! 1D configuration
69	USE step_c1d ! Time stepping loop for the 1D configuration
70	#if defined key_top
71	USE trcini ! passive tracer initialisation
72	#endif
73	USE lib_mpp ! distributed memory computing
74	#if defined key_iomput
75	USE mod_ioclient
76	#endif
77
78	IMPLICIT NONE
79	PRIVATE
80
81	PUBLIC nemo_gcm ! called by model.F90
82	PUBLIC nemo_init ! needed by AGRIF
83
84	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
85
86	!!----------------------------------------------------------------------
87	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
88	!! $Id$
89	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
90	!!----------------------------------------------------------------------
91	CONTAINS
92
93	SUBROUTINE nemo_gcm
94	!!----------------------------------------------------------------------
95	!! * ROUTINE nemo_gcm *
96	!!
97	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
98	!! curvilinear mesh on the sphere.
99	!!
100	!! ** Method : - model general initialization
101	!! - launch the time-stepping (stp routine)
102	!! - finalize the run by closing files and communications
103	!!
104	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
105	!! Madec, 2008, internal report, IPSL.
106	!!----------------------------------------------------------------------
107	INTEGER :: istp ! time step index
108	!!----------------------------------------------------------------------
109	!
110	#if defined key_agrif
111	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
112	#endif
113
114	! !-----------------------!
115	CALL nemo_init !== Initialisations ==!
116	! !-----------------------!
117	#if defined key_agrif
118	CALL Agrif_Declare_Var ! AGRIF: set the meshes
119	# if defined key_top
120	CALL Agrif_Declare_Var_Top ! AGRIF: set the meshes
121	# endif
122	#endif
123	! check that all process are still there... If some process have an error,
124	! they will never enter in step and other processes will wait until the end of the cpu time!
125	IF( lk_mpp ) CALL mpp_max( nstop )
126
127	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
128
129	! !-----------------------!
130	! !== time stepping ==!
131	! !-----------------------!
132	istp = nit000
133	#if defined key_c1d
134	DO WHILE ( istp <= nitend .AND. nstop == 0 )
135	CALL stp_c1d( istp )
136	istp = istp + 1
137	END DO
138	#else
139	IF( lk_asminc ) THEN
140	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
141	IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 ) ! Output trajectory fields
142	IF( ln_asmdin ) THEN ! Direct initialization
143	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
144	IF( ln_dyninc ) THEN
145	CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
146	IF ( ln_asmdin ) CALL ssh_wzv ( nit000 - 1 ) ! update vertical velocity
147	ENDIF
148	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
149	ENDIF
150	ENDIF
151
152	DO WHILE ( istp <= nitend .AND. nstop == 0 )
153	#if defined key_agrif
154	CALL Agrif_Step( stp ) ! AGRIF: time stepping
155	#else
156	CALL stp( istp ) ! standard time stepping
157	#endif
158	istp = istp + 1
159	IF( lk_mpp ) CALL mpp_max( nstop )
160	END DO
161	#endif
162
163	IF( lk_diaobs ) CALL dia_obs_wri
164
165	! !------------------------!
166	! !== finalize the run ==!
167	! !------------------------!
168	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
169	!
170	IF( nstop /= 0 .AND. lwp ) THEN ! error print
171	WRITE(numout,cform_err)
172	WRITE(numout,*) nstop, ' error have been found'
173	ENDIF
174	!
175	CALL nemo_closefile
176	#if defined key_oasis3 \|\| defined key_oasis4
177	CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS
178	#else
179	IF( lk_mpp ) CALL mppstop ! end mpp communications
180	#endif
181	!
182	END SUBROUTINE nemo_gcm
183
184
185	SUBROUTINE nemo_init
186	!!----------------------------------------------------------------------
187	!! * ROUTINE nemo_init *
188	!!
189	!! ** Purpose : initialization of the NEMO GCM
190	!!----------------------------------------------------------------------
191	INTEGER :: ji ! dummy loop indices
192	INTEGER :: ilocal_comm ! local integer
193	CHARACTER(len=80), DIMENSION(16) :: cltxt
194	!!
195	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
196	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
197	!!----------------------------------------------------------------------
198	!
199	cltxt = ''
200	!
201	! ! open Namelist file
202	CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
203	!
204	READ( numnam, namctl ) ! Namelist namctl : Control prints & Benchmark
205	!
206	! !--------------------------------------------!
207	! ! set communicator & select the local node !
208	! !--------------------------------------------!
209	#if defined key_iomput
210	IF( Agrif_Root() ) THEN
211	# if defined key_oasis3 \|\| defined key_oasis4
212	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
213	# endif
214	CALL init_ioclient( ilocal_comm ) ! exchange io_server nemo local communicator with the io_server
215	ENDIF
216	narea = mynode( cltxt, numnam, nstop, ilocal_comm ) ! Nodes selection
217	#else
218	# if defined key_oasis3 \|\| defined key_oasis4
219	IF( Agrif_Root() ) THEN
220	CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis
221	ENDIF
222	narea = mynode( cltxt, numnam, nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)
223	# else
224	ilocal_comm = 0
225	narea = mynode( cltxt, numnam, nstop ) ! Nodes selection (control print return in cltxt)
226	# endif
227	#endif
228	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
229
230	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
231
232	! If dimensions of processor grid weren't specified in the namelist file
233	! then we calculate them here now that we have our communicator size
234	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
235	#if defined key_mpp_mpi
236	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
237	#else
238	jpni = 1
239	jpnj = 1
240	jpnij = jpni*jpnj
241	#endif
242	END IF
243
244	! Calculate domain dimensions given calculated jpni and jpnj
245	! This used to be done in par_oce.F90 when they were parameters rather
246	! than variables
247	IF( Agrif_Root() ) THEN
248	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
249	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
250	jpk = jpkdta ! third dim
251	jpim1 = jpi-1 ! inner domain indices
252	jpjm1 = jpj-1 ! " "
253	jpkm1 = jpk-1 ! " "
254	jpij = jpi*jpj ! jpi x j
255	ENDIF
256
257	IF(lwp) THEN ! open listing units
258	!
259	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
260	!
261	WRITE(numout,*)
262	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean'
263	WRITE(numout,*) ' NEMO team'
264	WRITE(numout,*) ' Ocean General Circulation Model'
265	WRITE(numout,*) ' version 3.3 (2010) '
266	WRITE(numout,*)
267	WRITE(numout,*)
268	DO ji = 1, SIZE(cltxt)
269	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
270	END DO
271	WRITE(numout,cform_aaa) ! Flag AAAAAAA
272	!
273	ENDIF
274
275	! Now we know the dimensions of the grid and numout has been set we can
276	! allocate arrays
277	CALL nemo_alloc()
278
279	! !-------------------------------!
280	! ! NEMO general initialization !
281	! !-------------------------------!
282
283	CALL nemo_ctl ! Control prints & Benchmark
284
285	! ! Domain decomposition
286	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
287	ELSE ; CALL mpp_init2 ! eliminate land processors
288	ENDIF
289	!
290	! ! General initialization
291	CALL phy_cst ! Physical constants
292	CALL eos_init ! Equation of state
293	CALL dom_cfg ! Domain configuration
294	CALL dom_init ! Domain
295
296	IF( ln_ctl ) CALL prt_ctl_init ! Print control
297
298	IF( lk_obc ) CALL obc_init ! Open boundaries
299	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
300	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
301	IF( lk_bdy ) CALL tide_init ! Open boundaries initialisation of tidal harmonic forcing
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.

Download in other formats: