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 @ 2797

Last change on this file since 2797 was 2797, checked in by davestorkey, 13 years ago

Delete BDY module and first implementation of new OBC module.

Initial restructuring.
Use fldread to read open boundary data.

Property svn:keywords set to Id

File size: 28.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	!! 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_init routine)
48	USE obcdta ! open boundary cond. initialization (obc_dta_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	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
248	jpk = jpkdta ! third dim
249	jpim1 = jpi-1 ! inner domain indices
250	jpjm1 = jpj-1 ! " "
251	jpkm1 = jpk-1 ! " "
252	jpij = jpi*jpj ! jpi x j
253	ENDIF
254
255	IF(lwp) THEN ! open listing units
256	!
257	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
258	!
259	WRITE(numout,*)
260	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean'
261	WRITE(numout,*) ' NEMO team'
262	WRITE(numout,*) ' Ocean General Circulation Model'
263	WRITE(numout,*) ' version 3.3 (2010) '
264	WRITE(numout,*)
265	WRITE(numout,*)
266	DO ji = 1, SIZE(cltxt)
267	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
268	END DO
269	WRITE(numout,cform_aaa) ! Flag AAAAAAA
270	!
271	ENDIF
272
273	! Now we know the dimensions of the grid and numout has been set we can
274	! allocate arrays
275	CALL nemo_alloc()
276
277	! !-------------------------------!
278	! ! NEMO general initialization !
279	! !-------------------------------!
280
281	CALL nemo_ctl ! Control prints & Benchmark
282
283	! ! Domain decomposition
284	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
285	ELSE ; CALL mpp_init2 ! eliminate land processors
286	ENDIF
287	!
288	! ! General initialization
289	CALL phy_cst ! Physical constants
290	CALL eos_init ! Equation of state
291	CALL dom_cfg ! Domain configuration
292	CALL dom_init ! Domain
293
294	IF( ln_ctl ) CALL prt_ctl_init ! Print control
295
296	IF( lk_obc ) CALL obc_init ! Open boundaries initialisation
297	IF( lk_obc ) CALL obc_dta_init ! Open boundaries initialisation of external data arrays
298
299	CALL istate_init ! ocean initial state (Dynamics and tracers)
300
301	! ! Ocean physics
302	CALL sbc_init ! Forcings : surface module
303	! ! Vertical physics
304	CALL zdf_init ! namelist read
305	CALL zdf_bfr_init ! bottom friction
306	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
307	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
308	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
309	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
310	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
311	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
312	& CALL zdf_ddm_init ! double diffusive mixing
313	! ! Lateral physics
314	CALL ldf_tra_init ! Lateral ocean tracer physics
315	CALL ldf_dyn_init ! Lateral ocean momentum physics
316	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
317
318	! ! Active tracers
319	CALL tra_qsr_init ! penetrative solar radiation qsr
320	CALL tra_bbc_init ! bottom heat flux
321	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
322	IF( lk_tradmp ) CALL tra_dmp_init ! internal damping trends
323	CALL tra_adv_init ! horizontal & vertical advection
324	CALL tra_ldf_init ! lateral mixing
325	CALL tra_zdf_init ! vertical mixing and after tracer fields
326
327	! ! Dynamics
328	CALL dyn_adv_init ! advection (vector or flux form)
329	CALL dyn_vor_init ! vorticity term including Coriolis
330	CALL dyn_ldf_init ! lateral mixing
331	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
332	CALL dyn_zdf_init ! vertical diffusion
333	CALL dyn_spg_init ! surface pressure gradient
334
335	! ! Misc. options
336	IF( nn_cla == 1 ) CALL cla_init ! Cross Land Advection
337
338	#if defined key_top
339	! ! Passive tracers
340	CALL trc_init
341	#endif
342	! ! Diagnostics
343	CALL iom_init ! iom_put initialization
344	IF( lk_floats ) CALL flo_init ! drifting Floats
345	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
346	CALL dia_ptr_init ! Poleward TRansports initialization
347	CALL dia_hsb_init ! heat content, salt content and volume budgets
348	CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
349	IF( lk_diaobs ) THEN ! Observation & model comparison
350	CALL dia_obs_init ! Initialize observational data
351	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
352	ENDIF
353	! ! Assimilation increments
354	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
355	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
356	!
357	END SUBROUTINE nemo_init
358
359
360	SUBROUTINE nemo_ctl
361	!!----------------------------------------------------------------------
362	!! * ROUTINE nemo_ctl *
363	!!
364	!! ** Purpose : control print setting
365	!!
366	!! ** Method : - print namctl information and check some consistencies
367	!!----------------------------------------------------------------------
368	!
369	IF(lwp) THEN ! control print
370	WRITE(numout,*)
371	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
372	WRITE(numout,*) '~~~~~~~ '
373	WRITE(numout,*) ' Namelist namctl'
374	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
375	WRITE(numout,*) ' level of print nn_print = ', nn_print
376	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
377	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
378	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
379	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
380	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
381	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
382	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
383	ENDIF
384	!
385	nprint = nn_print ! convert DOCTOR namelist names into OLD names
386	nictls = nn_ictls
387	nictle = nn_ictle
388	njctls = nn_jctls
389	njctle = nn_jctle
390	isplt = nn_isplt
391	jsplt = nn_jsplt
392	nbench = nn_bench
393	! ! Parameter control
394	!
395	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
396	IF( lk_mpp ) THEN
397	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
398	ELSE
399	IF( isplt == 1 .AND. jsplt == 1 ) THEN
400	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
401	& ' - the print control will be done over the whole domain' )
402	ENDIF
403	ijsplt = isplt * jsplt ! total number of processors ijsplt
404	ENDIF
405	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
406	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
407	!
408	! ! indices used for the SUM control
409	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
410	lsp_area = .FALSE.
411	ELSE ! print control done over a specific area
412	lsp_area = .TRUE.
413	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
414	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
415	nictls = 1
416	ENDIF
417	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
418	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
419	nictle = jpiglo
420	ENDIF
421	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
422	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
423	njctls = 1
424	ENDIF
425	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
426	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
427	njctle = jpjglo
428	ENDIF
429	ENDIF
430	ENDIF
431	!
432	IF( nbench == 1 ) THEN ! Benchmark
433	SELECT CASE ( cp_cfg )
434	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
435	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
436	& ' key_gyre must be used or set nbench = 0' )
437	END SELECT
438	ENDIF
439	!
440	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
441	& 'with the IOM Input/Output manager. ' , &
442	& 'Compile with key_iomput enabled' )
443	!
444	END SUBROUTINE nemo_ctl
445
446
447	SUBROUTINE nemo_closefile
448	!!----------------------------------------------------------------------
449	!! * ROUTINE nemo_closefile *
450	!!
451	!! ** Purpose : Close the files
452	!!----------------------------------------------------------------------
453	!
454	IF( lk_mpp ) CALL mppsync
455	!
456	CALL iom_close ! close all input/output files managed by iom_*
457	!
458	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
459	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
460	IF( numnam /= -1 ) CLOSE( numnam ) ! oce namelist
461	IF( numnam_ice /= -1 ) CLOSE( numnam_ice ) ! ice namelist
462	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
463	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
464	!
465	numout = 6 ! redefine numout in case it is used after this point...
466	!
467	END SUBROUTINE nemo_closefile
468
469
470	SUBROUTINE nemo_alloc
471	!!----------------------------------------------------------------------
472	!! * ROUTINE nemo_alloc *
473	!!
474	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
475	!!
476	!! ** Method :
477	!!----------------------------------------------------------------------
478	USE diawri , ONLY: dia_wri_alloc
479	USE dom_oce , ONLY: dom_oce_alloc
480	USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
481	USE ldftra_oce, ONLY: ldftra_oce_alloc
482	USE trc_oce , ONLY: trc_oce_alloc
483	USE wrk_nemo , ONLY: wrk_alloc
484	!
485	INTEGER :: ierr
486	!!----------------------------------------------------------------------
487	!
488	ierr = oce_alloc () ! ocean
489	ierr = ierr + dia_wri_alloc ()
490	ierr = ierr + dom_oce_alloc () ! ocean domain
491	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
492	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
493	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
494	!
495	ierr = ierr + lib_mpp_alloc (numout) ! mpp exchanges
496	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
497	!
498	ierr = ierr + wrk_alloc(numout, lwp) ! workspace
499	!
500	IF( lk_mpp ) CALL mpp_sum( ierr )
501	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
502	!
503	END SUBROUTINE nemo_alloc
504
505
506	SUBROUTINE nemo_partition( num_pes )
507	!!----------------------------------------------------------------------
508	!! * ROUTINE nemo_partition *
509	!!
510	!! ** Purpose :
511	!!
512	!! ** Method :
513	!!----------------------------------------------------------------------
514	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
515	!
516	INTEGER, PARAMETER :: nfactmax = 20
517	INTEGER :: nfact ! The no. of factors returned
518	INTEGER :: ierr ! Error flag
519	INTEGER :: ji
520	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
521	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
522	!!----------------------------------------------------------------------
523
524	ierr = 0
525
526	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
527
528	IF( nfact <= 1 ) THEN
529	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
530	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
531	jpnj = 1
532	jpni = num_pes
533	ELSE
534	! Search through factors for the pair that are closest in value
535	mindiff = 1000000
536	imin = 1
537	DO ji = 1, nfact-1, 2
538	idiff = ABS( ifact(ji) - ifact(ji+1) )
539	IF( idiff < mindiff ) THEN
540	mindiff = idiff
541	imin = ji
542	ENDIF
543	END DO
544	jpnj = ifact(imin)
545	jpni = ifact(imin + 1)
546	ENDIF
547	!
548	jpnij = jpni*jpnj
549	!
550	END SUBROUTINE nemo_partition
551
552
553	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
554	!!----------------------------------------------------------------------
555	!! * ROUTINE factorise *
556	!!
557	!! ** Purpose : return the prime factors of n.
558	!! knfax factors are returned in array kfax which is of
559	!! maximum dimension kmaxfax.
560	!! ** Method :
561	!!----------------------------------------------------------------------
562	INTEGER , INTENT(in ) :: kn, kmaxfax
563	INTEGER , INTENT( out) :: kerr, knfax
564	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
565	!
566	INTEGER :: ifac, jl, inu
567	INTEGER, PARAMETER :: ntest = 14
568	INTEGER :: ilfax(ntest)
569
570	! lfax contains the set of allowed factors.
571	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
572	& 128, 64, 32, 16, 8, 4, 2 /
573	!!----------------------------------------------------------------------
574
575	! Clear the error flag and initialise output vars
576	kerr = 0
577	kfax = 1
578	knfax = 0
579
580	! Find the factors of n.
581	IF( kn == 1 ) GOTO 20
582
583	! nu holds the unfactorised part of the number.
584	! knfax holds the number of factors found.
585	! l points to the allowed factor list.
586	! ifac holds the current factor.
587
588	inu = kn
589	knfax = 0
590
591	DO jl = ntest, 1, -1
592	!
593	ifac = ilfax(jl)
594	IF( ifac > inu ) CYCLE
595
596	! Test whether the factor will divide.
597
598	IF( MOD(inu,ifac) == 0 ) THEN
599	!
600	knfax = knfax + 1 ! Add the factor to the list
601	IF( knfax > kmaxfax ) THEN
602	kerr = 6
603	write (,) 'FACTOR: insufficient space in factor array ', knfax
604	return
605	ENDIF
606	kfax(knfax) = ifac
607	! Store the other factor that goes with this one
608	knfax = knfax + 1
609	kfax(knfax) = inu / ifac
610	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
611	ENDIF
612	!
613	END DO
614
615	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
616	!
617	END SUBROUTINE factorise
618
619	!!======================================================================
620	END MODULE nemogcm

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

Download in other formats: