Context Navigation

nemogcm.F90 @ 2706

Last change on this file since 2706 was 2706, checked in by cetlod, 13 years ago
minor bug correction in OFFLINE component
File size: 22.2 KB

Line
1	MODULE nemogcm
2	!!======================================================================
3	!! * MODULE nemogcm *
4	!! Off-line Ocean : passive tracer evolution, dynamics read in files
5	!!======================================================================
6	!! History : 3.3 ! 2010-05 (C. Ethe) Full reorganization of the off-line: phasing with the on-line
7	!! 4.0 ! 2011-01 (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation
8	!!----------------------------------------------------------------------
9
10	!!----------------------------------------------------------------------
11	!! nemo_gcm : off-line: solve ocean tracer only
12	!! nemo_init : initialization of the nemo model
13	!! nemo_ctl : initialisation of algorithm flag
14	!! nemo_closefile : close remaining files
15	!!----------------------------------------------------------------------
16	USE dom_oce ! ocean space domain variables
17	USE oce ! dynamics and tracers variables
18	USE c1d ! 1D configuration
19	USE domcfg ! domain configuration (dom_cfg routine)
20	USE domain ! domain initialization (dom_init routine)
21	USE istate ! initial state setting (istate_init routine)
22	USE eosbn2 ! equation of state (eos bn2 routine)
23	! ! ocean physics
24	USE ldftra ! lateral diffusivity setting (ldf_tra_init routine)
25	USE ldfslp ! slopes of neutral surfaces (ldf_slp_init routine)
26	USE traqsr ! solar radiation penetration (tra_qsr_init routine)
27	USE trabbl ! bottom boundary layer (tra_bbl_init routine)
28	USE zdfini ! vertical physics: initialization
29	USE sbcmod ! surface boundary condition (sbc_init routine)
30	USE phycst ! physical constant (par_cst routine)
31	USE dtadyn ! Lecture and Interpolation of the dynamical fields
32	USE trcini ! Initilization of the passive tracers
33	USE daymod ! calendar (day routine)
34	USE trcstp ! passive tracer time-stepping (trc_stp routine)
35	USE dtadyn ! Lecture and interpolation of the dynamical fields
36	USE stpctl ! time stepping control (stp_ctl routine)
37	! ! I/O & MPP
38	USE iom ! I/O library
39	USE in_out_manager ! I/O manager
40	USE mppini ! shared/distributed memory setting (mpp_init routine)
41	USE lib_mpp ! distributed memory computing
42	#if defined key_iomput
43	USE mod_ioclient
44	#endif
45	USE prtctl ! Print control (prt_ctl_init routine)
46
47	IMPLICIT NONE
48	PRIVATE
49
50	PUBLIC nemo_gcm ! called by nemo.F90
51
52	CHARACTER (len=64) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
53
54	!!----------------------------------------------------------------------
55	!! NEMO/OFF 3.3 , NEMO Consortium (2010)
56	!! $Id: nemogcm.F90 2528 2010-12-27 17:33:53Z rblod $
57	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
58	!!----------------------------------------------------------------------
59	CONTAINS
60
61	SUBROUTINE nemo_gcm
62	!!----------------------------------------------------------------------
63	!! * ROUTINE nemo_gcm *
64	!!
65	!! ** Purpose : nemo solves the primitive equations on an orthogonal
66	!! curvilinear mesh on the sphere.
67	!!
68	!! ** Method : - model general initialization
69	!! - launch the time-stepping (dta_dyn and trc_stp)
70	!! - finalize the run by closing files and communications
71	!!
72	!! References : Madec, Delecluse,Imbard, and Levy, 1997: internal report, IPSL.
73	!! Madec, 2008, internal report, IPSL.
74	!!----------------------------------------------------------------------
75	INTEGER :: istp, indic ! time step index
76	!!----------------------------------------------------------------------
77
78	CALL nemo_init ! Initializations
79
80	IF( lk_mpp ) CALL mpp_max( nstop )
81
82	! check that all process are still there... If some process have an error,
83	! they will never enter in step and other processes will wait until the end of the cpu time!
84	IF( lk_mpp ) CALL mpp_max( nstop )
85
86	! !-----------------------!
87	! !== time stepping ==!
88	! !-----------------------!
89	istp = nit000
90	!
91	DO WHILE ( istp <= nitend .AND. nstop == 0 ) ! time stepping
92	!
93	IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init)
94	CALL iom_setkt( istp ) ! say to iom that we are at time step kstp
95	CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields
96	CALL trc_stp ( istp ) ! time-stepping
97	CALL stp_ctl ( istp, indic ) ! Time loop: control and print
98	istp = istp + 1
99	IF( lk_mpp ) CALL mpp_max( nstop )
100	END DO
101
102	! !------------------------!
103	! !== finalize the run ==!
104	! !------------------------!
105	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
106
107	IF( nstop /= 0 .AND. lwp ) THEN ! error print
108	WRITE(numout,cform_err)
109	WRITE(numout,*) nstop, ' error have been found'
110	ENDIF
111	!
112	CALL nemo_closefile
113	!
114	IF( lk_mpp ) CALL mppstop ! Close all files (mpp)
115	!
116	END SUBROUTINE nemo_gcm
117
118
119	SUBROUTINE nemo_init
120	!!----------------------------------------------------------------------
121	!! * ROUTINE nemo_init *
122	!!
123	!! ** Purpose : initialization of the nemo model in off-line mode
124	!!----------------------------------------------------------------------
125	INTEGER :: ji ! dummy loop indices
126	INTEGER :: ilocal_comm ! local integer
127	CHARACTER(len=80), DIMENSION(16) :: cltxt = ''
128	!!
129	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
130	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
131	!!----------------------------------------------------------------------
132	!
133	! ! open Namelist file
134	CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
135	!
136	READ( numnam, namctl ) ! Namelist namctl : Control prints & Benchmark
137	!
138	! !--------------------------------------------!
139	! ! set communicator & select the local node !
140	! !--------------------------------------------!
141	#if defined key_iomput
142	CALL init_ioclient( ilocal_comm ) ! exchange io_server nemo local communicator with the io_server
143	narea = mynode( cltxt, numnam, nstop, ilocal_comm ) ! Nodes selection
144	#else
145	ilocal_comm = 0
146	narea = mynode( cltxt, numnam, nstop ) ! Nodes selection (control print return in cltxt)
147	#endif
148
149	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
150
151	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
152
153	! If dimensions of processor grid weren't specified in the namelist file
154	! then we calculate them here now that we have our communicator size
155	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
156	#if defined key_mpp_mpi \|\| defined key_mpp_shmem
157	CALL nemo_partition(mppsize)
158	#else
159	jpni = 1
160	jpnj = 1
161	jpnij = jpni*jpnj
162	#endif
163	END IF
164
165	! Calculate domain dimensions given calculated jpni and jpnj
166	! This used to be done in par_oce.F90 when they were parameters rather
167	! than variables
168	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
169	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
170	jpk = jpkdta ! third dim
171	jpim1 = jpi-1 ! inner domain indices
172	jpjm1 = jpj-1 ! " "
173	jpkm1 = jpk-1 ! " "
174	jpij = jpi*jpj ! jpi x j
175
176
177	IF(lwp) THEN ! open listing units
178	!
179	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
180	!
181	WRITE(numout,*)
182	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean'
183	WRITE(numout,*) ' NEMO team'
184	WRITE(numout,*) ' Ocean General Circulation Model'
185	WRITE(numout,*) ' version 3.3 (2010) '
186	WRITE(numout,*)
187	WRITE(numout,*)
188	DO ji = 1, SIZE(cltxt)
189	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
190	END DO
191	WRITE(numout,cform_aaa) ! Flag AAAAAAA
192	!
193	ENDIF
194
195	! Now we know the dimensions of the grid and numout has been set we can
196	! allocate arrays
197	CALL nemo_alloc()
198
199	! !--------------------------------!
200	! ! Model general initialization !
201	! !--------------------------------!
202
203	CALL nemo_ctl ! Control prints & Benchmark
204
205	! ! Domain decomposition
206	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
207	ELSE ; CALL mpp_init2 ! eliminate land processors
208	ENDIF
209	!
210	! ! General initialization
211	CALL phy_cst ! Physical constants
212	CALL eos_init ! Equation of state
213	CALL dom_cfg ! Domain configuration
214	CALL dom_init ! Domain
215	CALL istate_init ! ocean initial state (Dynamics and tracers)
216
217
218	IF( ln_ctl ) CALL prt_ctl_init ! Print control
219
220	! ! Ocean physics
221	CALL sbc_init ! Forcings : surface module
222	#if ! defined key_degrad
223	CALL ldf_tra_init ! Lateral ocean tracer physics
224	#endif
225	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
226
227	! ! Active tracers
228	CALL tra_qsr_init ! penetrative solar radiation qsr
229	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
230
231	! ! Passive tracers
232	CALL trc_init ! Passive tracers initialization
233	! ! Dynamics
234	CALL dta_dyn_init ! Initialization for the dynamics
235	CALL iom_init ! iom_put initialization
236
237	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
238	!
239	END SUBROUTINE nemo_init
240
241
242	SUBROUTINE nemo_ctl
243	!!----------------------------------------------------------------------
244	!! * ROUTINE nemo_ctl *
245	!!
246	!! ** Purpose : control print setting
247	!!
248	!! ** Method : - print namctl information and check some consistencies
249	!!----------------------------------------------------------------------
250	!
251	IF(lwp) THEN ! Parameter print
252	WRITE(numout,*)
253	WRITE(numout,*) 'nemo_flg: Control prints & Benchmark'
254	WRITE(numout,*) '~~~~~~~ '
255	WRITE(numout,*) ' Namelist namctl'
256	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
257	WRITE(numout,*) ' level of print nn_print = ', nn_print
258	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
259	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
260	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
261	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
262	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
263	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
264	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
265	ENDIF
266	!
267	nprint = nn_print ! convert DOCTOR namelist names into OLD names
268	nictls = nn_ictls
269	nictle = nn_ictle
270	njctls = nn_jctls
271	njctle = nn_jctle
272	isplt = nn_isplt
273	jsplt = nn_jsplt
274	nbench = nn_bench
275	! ! Parameter control
276	!
277	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
278	IF( lk_mpp ) THEN
279	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real splitted domain
280	ELSE
281	IF( isplt == 1 .AND. jsplt == 1 ) THEN
282	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
283	& ' - the print control will be done over the whole domain' )
284	ENDIF
285	ijsplt = isplt * jsplt ! total number of processors ijsplt
286	ENDIF
287	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
288	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
289	!
290	! ! indices used for the SUM control
291	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
292	lsp_area = .FALSE.
293	ELSE ! print control done over a specific area
294	lsp_area = .TRUE.
295	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
296	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
297	nictls = 1
298	ENDIF
299	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
300	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
301	nictle = jpiglo
302	ENDIF
303	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
304	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
305	njctls = 1
306	ENDIF
307	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
308	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
309	njctle = jpjglo
310	ENDIF
311	ENDIF
312	ENDIF
313	!
314	IF( nbench == 1 ) THEN ! Benchmark
315	SELECT CASE ( cp_cfg )
316	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
317	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
318	& ' key_gyre must be used or set nbench = 0' )
319	END SELECT
320	ENDIF
321	!
322	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
323	& 'with the IOM Input/Output manager. ' , &
324	& 'Compile with key_iomput enabled' )
325	!
326	END SUBROUTINE nemo_ctl
327
328
329	SUBROUTINE nemo_closefile
330	!!----------------------------------------------------------------------
331	!! * ROUTINE nemo_closefile *
332	!!
333	!! ** Purpose : Close the files
334	!!----------------------------------------------------------------------
335	!
336	IF ( lk_mpp ) CALL mppsync
337	!
338	CALL iom_close ! close all input/output files managed by iom_*
339	!
340	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
341	IF( numnam /= -1 ) CLOSE( numnam ) ! oce namelist
342	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
343	numout = 6 ! redefine numout in case it is used after this point...
344	!
345	END SUBROUTINE nemo_closefile
346
347
348	SUBROUTINE nemo_alloc
349	!!----------------------------------------------------------------------
350	!! * ROUTINE nemo_alloc *
351	!!
352	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
353	!!
354	!! ** Method :
355	!!----------------------------------------------------------------------
356	USE diawri, ONLY: dia_wri_alloc
357	USE dom_oce, ONLY: dom_oce_alloc
358	USE zdf_oce, ONLY: zdf_oce_alloc
359	USE zdfmxl, ONLY: zdf_mxl_alloc
360	USE ldftra_oce, ONLY: ldftra_oce_alloc
361	USE trc_oce, ONLY: trc_oce_alloc
362	USE wrk_nemo, ONLY: wrk_alloc
363	!
364	INTEGER :: ierr
365	!!----------------------------------------------------------------------
366	!
367	ierr = oce_alloc () ! ocean
368	ierr = ierr + dia_wri_alloc ()
369	ierr = ierr + dom_oce_alloc () ! ocean domain
370	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
371	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
372	ierr = ierr + zdf_mxl_alloc () ! ocean vertical physics
373	!
374	ierr = ierr + lib_mpp_alloc (numout) ! mpp exchanges
375	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
376	ierr = ierr + wrk_alloc(numout, lwp)
377	!
378	IF( lk_mpp ) CALL mpp_sum( ierr )
379	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
380	!
381	END SUBROUTINE nemo_alloc
382
383
384	SUBROUTINE nemo_partition( num_pes )
385	!!----------------------------------------------------------------------
386	!! * ROUTINE nemo_partition *
387	!!
388	!! ** Purpose :
389	!!
390	!! ** Method :
391	!!----------------------------------------------------------------------
392	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
393	!
394	INTEGER, PARAMETER :: nfactmax = 20
395	INTEGER :: nfact ! The no. of factors returned
396	INTEGER :: ierr ! Error flag
397	INTEGER :: ji
398	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
399	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
400	!!----------------------------------------------------------------------
401
402	ierr = 0
403
404	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
405
406	IF( nfact <= 1 ) THEN
407	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
408	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
409	jpnj = 1
410	jpni = num_pes
411	ELSE
412	! Search through factors for the pair that are closest in value
413	mindiff = 1000000
414	imin = 1
415	DO ji = 1, nfact-1, 2
416	idiff = ABS( ifact(ji) - ifact(ji+1) )
417	IF( idiff < mindiff ) THEN
418	mindiff = idiff
419	imin = ji
420	ENDIF
421	END DO
422	jpnj = ifact(imin)
423	jpni = ifact(imin + 1)
424	ENDIF
425	!
426	jpnij = jpni*jpnj
427	!
428	END SUBROUTINE nemo_partition
429
430
431	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
432	!!----------------------------------------------------------------------
433	!! * ROUTINE factorise *
434	!!
435	!! ** Purpose : return the prime factors of n.
436	!! knfax factors are returned in array kfax which is of
437	!! maximum dimension kmaxfax.
438	!! ** Method :
439	!!----------------------------------------------------------------------
440	INTEGER , INTENT(in ) :: kn, kmaxfax
441	INTEGER , INTENT( out) :: kerr, knfax
442	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
443	!
444	INTEGER :: ifac, jl, inu
445	INTEGER, PARAMETER :: ntest = 14
446	INTEGER :: ilfax(ntest)
447	!
448	! lfax contains the set of allowed factors.
449	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
450	& 128, 64, 32, 16, 8, 4, 2 /
451	!!----------------------------------------------------------------------
452
453	! Clear the error flag and initialise output vars
454	kerr = 0
455	kfax = 1
456	knfax = 0
457
458	! Find the factors of n.
459	IF( kn == 1 ) GOTO 20
460
461	! nu holds the unfactorised part of the number.
462	! knfax holds the number of factors found.
463	! l points to the allowed factor list.
464	! ifac holds the current factor.
465
466	inu = kn
467	knfax = 0
468
469	DO jl = ntest, 1, -1
470	!
471	ifac = ilfax(jl)
472	IF( ifac > inu ) CYCLE
473
474	! Test whether the factor will divide.
475
476	IF( MOD(inu,ifac) == 0 ) THEN
477	!
478	knfax = knfax + 1 ! Add the factor to the list
479	IF( knfax > kmaxfax ) THEN
480	kerr = 6
481	write (,) 'FACTOR: insufficient space in factor array ', knfax
482	return
483	ENDIF
484	kfax(knfax) = ifac
485	! Store the other factor that goes with this one
486	knfax = knfax + 1
487	kfax(knfax) = inu / ifac
488	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
489	ENDIF
490	!
491	END DO
492
493	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
494	!
495	END SUBROUTINE factorise
496
497	!!======================================================================
498	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/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 2706

Download in other formats: