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/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OFF_SRC – NEMO

Context Navigation

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 8809

Last change on this file since 8809 was 8758, checked in by acc, 6 years ago
Branch 2017/dev_r8126_ROBUST08_no_ghost. Changes to eliminate ghost rows and columns. Currently the halo width is still fixed as 1 but a single variable (nn_hls) has been introduced for the halo-size in preparation for allowing this to vary. nn_hls replaces jpreci and jprecj. These changes have passed full SETTE tests but iceberg exchanges across the north-fold remain untested (SETTE tests only release bergs in the SO) and will require further attention. Note layout.dat now reports the jpi and jpj values for the reporting processor only.
Property svn:keywords set to `Id`
File size: 32.1 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	!! 3.4 ! 2011-01 (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation
8	!! 4.0 ! 2016-10 (C. Ethe, G. Madec, S. Flavoni) domain configuration / user defined interface
9	!!----------------------------------------------------------------------
10
11	!!----------------------------------------------------------------------
12	!! nemo_gcm : off-line: solve ocean tracer only
13	!! nemo_init : initialization of the nemo model
14	!! nemo_ctl : initialisation of algorithm flag
15	!! nemo_closefile : close remaining files
16	!!----------------------------------------------------------------------
17	USE dom_oce ! ocean space domain variables
18	USE oce ! dynamics and tracers variables
19	USE trc_oce ! Shared ocean/passive tracers variables
20	USE c1d ! 1D configuration
21	USE domain ! domain initialization from coordinate & bathymetry (dom_init routine)
22	USE usrdef_nam ! user defined configuration
23	USE eosbn2 ! equation of state (eos bn2 routine)
24	! ! ocean physics
25	USE ldftra ! lateral diffusivity setting (ldf_tra_init routine)
26	USE ldfslp ! slopes of neutral surfaces (ldf_slp_init routine)
27	USE traqsr ! solar radiation penetration (tra_qsr_init routine)
28	USE trabbl ! bottom boundary layer (tra_bbl_init routine)
29	USE traldf ! lateral physics (tra_ldf_init routine)
30	USE zdfini ! vertical physics: initialization
31	USE sbcmod ! surface boundary condition (sbc_init routine)
32	USE phycst ! physical constant (par_cst routine)
33	USE dtadyn ! Lecture and Interpolation of the dynamical fields
34	USE trcini ! Initilization of the passive tracers
35	USE daymod ! calendar (day routine)
36	USE trcstp ! passive tracer time-stepping (trc_stp routine)
37	USE dtadyn ! Lecture and interpolation of the dynamical fields
38	! ! Passive tracers needs
39	USE trc ! passive tracer : variables
40	USE trcnam ! passive tracer : namelist
41	USE trcrst ! passive tracer restart
42	USE diaptr ! Need to initialise this as some variables are used in if statements later
43	USE sbc_oce , ONLY : ln_rnf
44	USE sbcrnf ! surface boundary condition : runoffs
45	! ! I/O & MPP
46	USE iom ! I/O library
47	USE in_out_manager ! I/O manager
48	USE mppini ! shared/distributed memory setting (mpp_init routine)
49	USE lib_mpp ! distributed memory computing
50	#if defined key_iomput
51	USE xios
52	#endif
53	USE prtctl ! Print control (prt_ctl_init routine)
54	USE timing ! Timing
55	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
56	USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
57
58
59
60	IMPLICIT NONE
61	PRIVATE
62
63	PUBLIC nemo_gcm ! called by nemo.F90
64
65	CHARACTER (len=64) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
66
67	!!----------------------------------------------------------------------
68	!! NEMO/OPA 3.7 , NEMO Consortium (2016)
69	!! $Id$
70	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
71	!!----------------------------------------------------------------------
72	CONTAINS
73
74	SUBROUTINE nemo_gcm
75	!!----------------------------------------------------------------------
76	!! * ROUTINE nemo_gcm *
77	!!
78	!! ** Purpose : nemo solves the primitive equations on an orthogonal
79	!! curvilinear mesh on the sphere.
80	!!
81	!! ** Method : - model general initialization
82	!! - launch the time-stepping (dta_dyn and trc_stp)
83	!! - finalize the run by closing files and communications
84	!!
85	!! References : Madec, Delecluse,Imbard, and Levy, 1997: internal report, IPSL.
86	!! Madec, 2008, internal report, IPSL.
87	!!----------------------------------------------------------------------
88	INTEGER :: istp, indic ! time step index
89	!!----------------------------------------------------------------------
90
91	CALL nemo_init ! Initializations
92
93	! check that all process are still there... If some process have an error,
94	! they will never enter in step and other processes will wait until the end of the cpu time!
95	IF( lk_mpp ) CALL mpp_max( nstop )
96
97	! !-----------------------!
98	! !== time stepping ==!
99	! !-----------------------!
100	istp = nit000
101	!
102	! Initialize arrays of runoffs structures and read data from the namelist
103	IF ( ln_rnf ) CALL sbc_rnf(istp)
104	!
105	CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
106	!
107	DO WHILE ( istp <= nitend .AND. nstop == 0 ) ! time stepping
108	!
109	IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init)
110	CALL iom_setkt ( istp - nit000 + 1, "nemo" ) ! say to iom that we are at time step kstp
111	CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields
112	IF( .NOT.ln_linssh ) CALL dta_dyn_swp( istp ) ! swap of sea surface height and vertical scale factors
113
114	CALL trc_stp ( istp ) ! time-stepping
115	CALL stp_ctl ( istp, indic ) ! Time loop: control and print
116	istp = istp + 1
117	IF( lk_mpp ) CALL mpp_max( nstop )
118	END DO
119	#if defined key_iomput
120	CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
121	#endif
122
123	! !------------------------!
124	! !== finalize the run ==!
125	! !------------------------!
126	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
127
128	IF( nstop /= 0 .AND. lwp ) THEN ! error print
129	WRITE(numout,cform_err)
130	WRITE(numout,*) nstop, ' error have been found'
131	ENDIF
132	!
133	IF( nn_timing == 1 ) CALL timing_finalize
134	!
135	CALL nemo_closefile
136	!
137	# if defined key_iomput
138	CALL xios_finalize ! end mpp communications
139	# else
140	IF( lk_mpp ) CALL mppstop ! end mpp communications
141	# endif
142	!
143	END SUBROUTINE nemo_gcm
144
145
146	SUBROUTINE nemo_init
147	!!----------------------------------------------------------------------
148	!! * ROUTINE nemo_init *
149	!!
150	!! ** Purpose : initialization of the nemo model in off-line mode
151	!!----------------------------------------------------------------------
152	INTEGER :: ji ! dummy loop indices
153	INTEGER :: ilocal_comm ! local integer
154	INTEGER :: ios, inum ! local integers
155	INTEGER :: iiarea, ijarea ! local integers
156	INTEGER :: iirest, ijrest ! local integers
157	REAL(wp) :: ziglo, zjglo, zkglo, zperio ! local scalars
158	CHARACTER(len=120), DIMENSION(30) :: cltxt, cltxt2, clnam
159	!!
160	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
161	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
162	& nn_timing, nn_diacfl
163
164	NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr
165	!!----------------------------------------------------------------------
166	cltxt = ''
167	cltxt2 = ''
168	clnam = ''
169	cxios_context = 'nemo'
170	!
171	! ! Open reference namelist and configuration namelist files
172	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
173	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
174	!
175	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
176	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
177	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
178
179	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
180	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
181	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
182
183	!
184	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
185	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
186	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
187
188	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
189	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
190	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
191
192
193	! !--------------------------!
194	! ! Set global domain size ! (control print return in cltxt2)
195	!
196	IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
197	CALL domain_cfg ( cltxt2, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
198	!
199	ELSE ! user-defined namelist
200	CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
201	ENDIF
202	!
203	!
204	l_offline = .true. ! passive tracers are run offline
205	!
206	! !--------------------------------------------!
207	! ! set communicator & select the local node !
208	! ! NB: mynode also opens output.namelist.dyn !
209	! ! on unit number numond on first proc !
210	! !--------------------------------------------!
211	#if defined key_iomput
212	CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )
213	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection
214	#else
215	ilocal_comm = 0
216	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt)
217	#endif
218
219	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
220
221	lwm = (narea == 1) ! control of output namelists
222	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
223
224	IF(lwm) THEN
225	! write merged namelists from earlier to output namelist now that the
226	! file has been opened in call to mynode. nammpp has already been
227	! written in mynode (if lk_mpp_mpi)
228	WRITE( numond, namctl )
229	WRITE( numond, namcfg )
230	IF( .NOT.ln_read_cfg ) THEN
231	DO ji = 1, SIZE(clnam)
232	IF( TRIM(clnam (ji)) /= '' ) WRITE(numond, * ) clnam(ji) ! namusr_def print
233	END DO
234	ENDIF
235	ENDIF
236
237	! If dimensions of processor grid weren't specified in the namelist file
238	! then we calculate them here now that we have our communicator size
239	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
240	#if defined key_mpp_mpi
241	CALL nemo_partition(mppsize)
242	#else
243	jpni = 1
244	jpnj = 1
245	jpnij = jpni*jpnj
246	#endif
247	END IF
248
249	iiarea = 1 + MOD( narea - 1 , jpni )
250	ijarea = 1 + ( narea - 1 ) / jpni
251	iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni )
252	ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj )
253	#if defined key_nemocice_decomp
254	jpi = ( nx_global+2-2nn_hls + (jpni-1) ) / jpni + 2nn_hls ! first dim.
255	jpj = ( ny_global+2-2nn_hls + (jpnj-1) ) / jpnj + 2nn_hls ! second dim.
256	jpimax = jpi
257	jpjmax = jpj
258	IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls)
259	IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls)
260	#else
261	jpi = ( jpiglo -2nn_hls + (jpni-1) ) / jpni + 2nn_hls ! first dim.
262	jpj = ( jpjglo -2nn_hls + (jpnj-1) ) / jpnj + 2nn_hls ! second dim.
263	jpimax = jpi
264	jpjmax = jpj
265	IF( iiarea > iirest ) jpi = jpi - 1
266	IF( ijarea > ijrest ) jpj = jpj - 1
267	#endif
268
269	jpk = jpkglo ! third dim
270
271	jpim1 = jpi-1 ! inner domain indices
272	jpjm1 = jpj-1 ! " "
273	jpkm1 = MAX( 1, jpk-1 ) ! " "
274	jpij = jpi*jpj ! jpi x j
275
276
277
278	IF(lwp) THEN ! open listing units
279	!
280	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
281	!
282	WRITE(numout,*)
283	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
284	WRITE(numout,*) ' NEMO team'
285	WRITE(numout,*) ' Ocean General Circulation Model'
286	WRITE(numout,*) ' version 3.6 (2015) '
287	WRITE(numout,*)
288	WRITE(numout,*)
289	DO ji = 1, SIZE(cltxt)
290	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
291	END DO
292	WRITE(numout,cform_aaa) ! Flag AAAAAAA
293	!
294	ENDIF
295
296	! Now we know the dimensions of the grid and numout has been set we can
297	! allocate arrays
298	CALL nemo_alloc()
299
300	! !--------------------------------!
301	! ! Model general initialization !
302	! !--------------------------------!
303
304	CALL nemo_ctl ! Control prints & Benchmark
305
306	! ! Domain decomposition
307	CALL mpp_init
308	!
309	IF( nn_timing == 1 ) CALL timing_init
310	!
311
312	! ! General initialization
313	IF( nn_timing == 1 ) CALL timing_start( 'nemo_init')
314	!
315	CALL phy_cst ! Physical constants
316	CALL eos_init ! Equation of state
317	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
318
319	CALL dom_init ! Domain
320
321	CALL istate_init ! ocean initial state (Dynamics and tracers)
322
323	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
324
325	IF( ln_ctl ) CALL prt_ctl_init ! Print control
326
327	CALL sbc_init ! Forcings : surface module
328
329	CALL ldf_tra_init ! Lateral ocean tracer physics
330	CALL ldf_eiv_init ! Eddy induced velocity param
331	CALL tra_ldf_init ! lateral mixing
332	IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
333
334	CALL tra_qsr_init ! penetrative solar radiation qsr
335	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
336
337	CALL trc_nam_run ! Needed to get restart parameters for passive tracers
338	CALL trc_rst_cal( nit000, 'READ' ) ! calendar
339	CALL dta_dyn_init ! Initialization for the dynamics
340
341	CALL trc_init ! Passive tracers initialization
342	CALL dia_ptr_init ! Initialise diaptr as some variables are used
343	! ! in various advection and diffusion routines
344	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
345	!
346	IF( nn_timing == 1 ) CALL timing_stop( 'nemo_init')
347	!
348	END SUBROUTINE nemo_init
349
350
351	SUBROUTINE nemo_ctl
352	!!----------------------------------------------------------------------
353	!! * ROUTINE nemo_ctl *
354	!!
355	!! ** Purpose : control print setting
356	!!
357	!! ** Method : - print namctl information and check some consistencies
358	!!----------------------------------------------------------------------
359	!
360	IF(lwp) THEN ! control print
361	WRITE(numout,*)
362	WRITE(numout,*) 'nemo_ctl: Control prints'
363	WRITE(numout,*) '~~~~~~~ '
364	WRITE(numout,*) ' Namelist namctl'
365	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
366	WRITE(numout,*) ' level of print nn_print = ', nn_print
367	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
368	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
369	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
370	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
371	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
372	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
373	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
374	ENDIF
375	!
376	nprint = nn_print ! convert DOCTOR namelist names into OLD names
377	nictls = nn_ictls
378	nictle = nn_ictle
379	njctls = nn_jctls
380	njctle = nn_jctle
381	isplt = nn_isplt
382	jsplt = nn_jsplt
383
384
385	IF(lwp) THEN ! control print
386	WRITE(numout,*)
387	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
388	WRITE(numout,*) '~~~~~~~ '
389	WRITE(numout,*) ' Namelist namcfg'
390	WRITE(numout,*) ' read domain configuration files ln_read_cfg = ', ln_read_cfg
391	WRITE(numout,*) ' filename to be read cn_domcfg = ', TRIM(cn_domcfg)
392	WRITE(numout,*) ' write configuration definition files ln_write_cfg = ', ln_write_cfg
393	WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out)
394	WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
395	ENDIF
396
397	! ! Parameter control
398	!
399	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
400	IF( lk_mpp .AND. jpnij > 1 ) 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( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
437	& 'f2003 standard. ' , &
438	& 'Compile with key_nosignedzero enabled' )
439	!
440	END SUBROUTINE nemo_ctl
441
442
443	SUBROUTINE nemo_closefile
444	!!----------------------------------------------------------------------
445	!! * ROUTINE nemo_closefile *
446	!!
447	!! ** Purpose : Close the files
448	!!----------------------------------------------------------------------
449	!
450	IF ( lk_mpp ) CALL mppsync
451	!
452	CALL iom_close ! close all input/output files managed by iom_*
453	!
454	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
455	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
456	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
457	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
458	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
459
460	numout = 6 ! redefine numout in case it is used after this point...
461	!
462	END SUBROUTINE nemo_closefile
463
464
465	SUBROUTINE nemo_alloc
466	!!----------------------------------------------------------------------
467	!! * ROUTINE nemo_alloc *
468	!!
469	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
470	!!
471	!! ** Method :
472	!!----------------------------------------------------------------------
473	USE diawri, ONLY: dia_wri_alloc
474	USE dom_oce, ONLY: dom_oce_alloc
475	USE zdf_oce, ONLY: zdf_oce_alloc
476	USE trc_oce, ONLY: trc_oce_alloc
477	!
478	INTEGER :: ierr
479	!!----------------------------------------------------------------------
480	!
481	ierr = oce_alloc () ! ocean
482	ierr = ierr + dia_wri_alloc ()
483	ierr = ierr + dom_oce_alloc () ! ocean domain
484	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
485	!
486	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
487	!
488	IF( lk_mpp ) CALL mpp_sum( ierr )
489	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
490	!
491	END SUBROUTINE nemo_alloc
492
493
494	SUBROUTINE nemo_partition( num_pes )
495	!!----------------------------------------------------------------------
496	!! * ROUTINE nemo_partition *
497	!!
498	!! ** Purpose :
499	!!
500	!! ** Method :
501	!!----------------------------------------------------------------------
502	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
503	!
504	INTEGER, PARAMETER :: nfactmax = 20
505	INTEGER :: nfact ! The no. of factors returned
506	INTEGER :: ierr ! Error flag
507	INTEGER :: ji
508	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
509	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
510	!!----------------------------------------------------------------------
511
512	ierr = 0
513
514	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
515
516	IF( nfact <= 1 ) THEN
517	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
518	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
519	jpnj = 1
520	jpni = num_pes
521	ELSE
522	! Search through factors for the pair that are closest in value
523	mindiff = 1000000
524	imin = 1
525	DO ji = 1, nfact-1, 2
526	idiff = ABS( ifact(ji) - ifact(ji+1) )
527	IF( idiff < mindiff ) THEN
528	mindiff = idiff
529	imin = ji
530	ENDIF
531	END DO
532	jpnj = ifact(imin)
533	jpni = ifact(imin + 1)
534	ENDIF
535	!
536	jpnij = jpni*jpnj
537	!
538	END SUBROUTINE nemo_partition
539
540
541	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
542	!!----------------------------------------------------------------------
543	!! * ROUTINE factorise *
544	!!
545	!! ** Purpose : return the prime factors of n.
546	!! knfax factors are returned in array kfax which is of
547	!! maximum dimension kmaxfax.
548	!! ** Method :
549	!!----------------------------------------------------------------------
550	INTEGER , INTENT(in ) :: kn, kmaxfax
551	INTEGER , INTENT( out) :: kerr, knfax
552	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
553	!
554	INTEGER :: ifac, jl, inu
555	INTEGER, PARAMETER :: ntest = 14
556	INTEGER :: ilfax(ntest)
557	!
558	! lfax contains the set of allowed factors.
559	ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
560
561	! Clear the error flag and initialise output vars
562	kerr = 0
563	kfax = 1
564	knfax = 0
565
566	! Find the factors of n.
567	IF( kn == 1 ) GOTO 20
568
569	! nu holds the unfactorised part of the number.
570	! knfax holds the number of factors found.
571	! l points to the allowed factor list.
572	! ifac holds the current factor.
573
574	inu = kn
575	knfax = 0
576
577	DO jl = ntest, 1, -1
578	!
579	ifac = ilfax(jl)
580	IF( ifac > inu ) CYCLE
581
582	! Test whether the factor will divide.
583
584	IF( MOD(inu,ifac) == 0 ) THEN
585	!
586	knfax = knfax + 1 ! Add the factor to the list
587	IF( knfax > kmaxfax ) THEN
588	kerr = 6
589	write (,) 'FACTOR: insufficient space in factor array ', knfax
590	return
591	ENDIF
592	kfax(knfax) = ifac
593	! Store the other factor that goes with this one
594	knfax = knfax + 1
595	kfax(knfax) = inu / ifac
596	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
597	ENDIF
598	!
599	END DO
600
601	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
602	!
603	END SUBROUTINE factorise
604
605	#if defined key_mpp_mpi
606	SUBROUTINE nemo_northcomms
607	!!======================================================================
608	!! * ROUTINE nemo_northcomms *
609	!! nemo_northcomms : Setup for north fold exchanges with explicit
610	!! point-to-point messaging
611	!!=====================================================================
612	!!----------------------------------------------------------------------
613	!!
614	!! ** Purpose : Initialization of the northern neighbours lists.
615	!!----------------------------------------------------------------------
616	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
617	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S.
618	!Mocavero, CMCC)
619	!!----------------------------------------------------------------------
620
621	INTEGER :: sxM, dxM, sxT, dxT, jn
622	INTEGER :: njmppmax
623
624	njmppmax = MAXVAL( njmppt )
625
626	!initializes the north-fold communication variables
627	isendto(:) = 0
628	nsndto = 0
629
630	!if I am a process in the north
631	IF ( njmpp == njmppmax ) THEN
632	!sxM is the first point (in the global domain) needed to compute the
633	!north-fold for the current process
634	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
635	!dxM is the last point (in the global domain) needed to compute the
636	!north-fold for the current process
637	dxM = jpiglo - nimppt(narea) + 2
638
639	!loop over the other north-fold processes to find the processes
640	!managing the points belonging to the sxT-dxT range
641
642	DO jn = 1, jpni
643	!sxT is the first point (in the global domain) of the jn
644	!process
645	sxT = nfiimpp(jn, jpnj)
646	!dxT is the last point (in the global domain) of the jn
647	!process
648	dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
649	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
650	nsndto = nsndto + 1
651	isendto(nsndto) = jn
652	ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
653	nsndto = nsndto + 1
654	isendto(nsndto) = jn
655	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
656	nsndto = nsndto + 1
657	isendto(nsndto) = jn
658	END IF
659	END DO
660	nfsloop = 1
661	nfeloop = nlci
662	DO jn = 2,jpni-1
663	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
664	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
665	nfsloop = nldi
666	ENDIF
667	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
668	nfeloop = nlei
669	ENDIF
670	ENDIF
671	END DO
672
673	ENDIF
674	l_north_nogather = .TRUE.
675	END SUBROUTINE nemo_northcomms
676	#else
677	SUBROUTINE nemo_northcomms ! Dummy routine
678	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
679	END SUBROUTINE nemo_northcomms
680	#endif
681
682	SUBROUTINE istate_init
683	!!----------------------------------------------------------------------
684	!! * ROUTINE istate_init *
685	!!
686	!! ** Purpose : Initialization to zero of the dynamics and tracers.
687	!!----------------------------------------------------------------------
688	!
689	! now fields ! after fields !
690	un (:,:,:) = 0._wp ; ua(:,:,:) = 0._wp !
691	vn (:,:,:) = 0._wp ; va(:,:,:) = 0._wp !
692	wn (:,:,:) = 0._wp ! !
693	hdivn(:,:,:) = 0._wp ! !
694	tsn (:,:,:,:) = 0._wp ! !
695	!
696	rhd (:,:,:) = 0.e0
697	rhop (:,:,:) = 0.e0
698	rn2 (:,:,:) = 0.e0
699	!
700	END SUBROUTINE istate_init
701
702	SUBROUTINE stp_ctl( kt, kindic )
703	!!----------------------------------------------------------------------
704	!! * ROUTINE stp_ctl *
705	!!
706	!! ** Purpose : Control the run
707	!!
708	!! ** Method : - Save the time step in numstp
709	!!
710	!! ** Actions : 'time.step' file containing the last ocean time-step
711	!!----------------------------------------------------------------------
712	INTEGER, INTENT(in ) :: kt ! ocean time-step index
713	INTEGER, INTENT(inout) :: kindic ! indicator of solver convergence
714	!!----------------------------------------------------------------------
715	!
716	IF( kt == nit000 .AND. lwp ) THEN
717	WRITE(numout,*)
718	WRITE(numout,*) 'stp_ctl : time-stepping control'
719	WRITE(numout,*) '~~~~~~~'
720	! open time.step file
721	CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
722	ENDIF
723	!
724	IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp
725	IF(lwp) REWIND( numstp ) ! --------------------------
726	!
727	END SUBROUTINE stp_ctl
728	!!======================================================================
729	END MODULE nemogcm

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

Download in other formats: