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/2013/dev_r3853_CNRS9_ConfSetting/NEMOGCM/NEMO/OFF_SRC – NEMO

Context Navigation

source: branches/2013/dev_r3853_CNRS9_ConfSetting/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 3875

Last change on this file since 3875 was 3875, checked in by clevy, 11 years ago
Configuration Setting/Step? 1, see ticket:#1074
File size: 29.4 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 xios
44	#endif
45	USE prtctl ! Print control (prt_ctl_init routine)
46	USE timing ! Timing
47	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
48
49	IMPLICIT NONE
50	PRIVATE
51
52	PUBLIC nemo_gcm ! called by nemo.F90
53
54	CHARACTER (len=64) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
55
56	!!----------------------------------------------------------------------
57	!! NEMO/OFF 3.3 , NEMO Consortium (2010)
58	!! $Id: nemogcm.F90 2528 2010-12-27 17:33:53Z rblod $
59	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
60	!!----------------------------------------------------------------------
61	CONTAINS
62
63	SUBROUTINE nemo_gcm
64	!!----------------------------------------------------------------------
65	!! * ROUTINE nemo_gcm *
66	!!
67	!! ** Purpose : nemo solves the primitive equations on an orthogonal
68	!! curvilinear mesh on the sphere.
69	!!
70	!! ** Method : - model general initialization
71	!! - launch the time-stepping (dta_dyn and trc_stp)
72	!! - finalize the run by closing files and communications
73	!!
74	!! References : Madec, Delecluse,Imbard, and Levy, 1997: internal report, IPSL.
75	!! Madec, 2008, internal report, IPSL.
76	!!----------------------------------------------------------------------
77	INTEGER :: istp, indic ! time step index
78	!!----------------------------------------------------------------------
79
80	CALL nemo_init ! Initializations
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	CALL iom_init ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
92	!
93	DO WHILE ( istp <= nitend .AND. nstop == 0 ) ! time stepping
94	!
95	IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init)
96	CALL iom_setkt( istp - nit000 + 1 ) ! say to iom that we are at time step kstp
97	CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields
98	CALL trc_stp ( istp ) ! time-stepping
99	CALL stp_ctl ( istp, indic ) ! Time loop: control and print
100	istp = istp + 1
101	IF( lk_mpp ) CALL mpp_max( nstop )
102	END DO
103	#if defined key_iomput
104	CALL xios_context_finalize() ! needed for XIOS+AGRIF
105	#endif
106
107	! !------------------------!
108	! !== finalize the run ==!
109	! !------------------------!
110	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
111
112	IF( nstop /= 0 .AND. lwp ) THEN ! error print
113	WRITE(numout,cform_err)
114	WRITE(numout,*) nstop, ' error have been found'
115	ENDIF
116	!
117	IF( nn_timing == 1 ) CALL timing_finalize
118	!
119	CALL nemo_closefile
120	!
121	# if defined key_iomput
122	CALL xios_finalize ! end mpp communications
123	# else
124	IF( lk_mpp ) CALL mppstop ! end mpp communications
125	# endif
126	!
127	END SUBROUTINE nemo_gcm
128
129
130	SUBROUTINE nemo_init
131	!!----------------------------------------------------------------------
132	!! * ROUTINE nemo_init *
133	!!
134	!! ** Purpose : initialization of the nemo model in off-line mode
135	!!----------------------------------------------------------------------
136	INTEGER :: ji ! dummy loop indices
137	INTEGER :: ilocal_comm ! local integer
138	INTEGER :: ios
139	CHARACTER(len=80), DIMENSION(16) :: cltxt
140	!!
141	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
142	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
143	& nn_bench, nn_timing
144	!!----------------------------------------------------------------------
145	!
146	cltxt = ''
147	!
148	! ! Open reference namelist and configuration namelist files
149	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
150	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
151	CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
152	!
153	!
154	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
155	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
156	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', lwp )
157
158	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
159	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
160	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', lwp )
161	WRITE( numond, namctl )
162	!
163	! !--------------------------------------------!
164	! ! set communicator & select the local node !
165	! !--------------------------------------------!
166	#if defined key_iomput
167	CALL xios_initialize( "nemo",return_comm=ilocal_comm )
168	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection
169	#else
170	ilocal_comm = 0
171	narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt)
172	#endif
173
174	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
175
176	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
177
178	! If dimensions of processor grid weren't specified in the namelist file
179	! then we calculate them here now that we have our communicator size
180	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
181	#if defined key_mpp_mpi
182	CALL nemo_partition(mppsize)
183	#else
184	jpni = 1
185	jpnj = 1
186	jpnij = jpni*jpnj
187	#endif
188	END IF
189
190	! Calculate domain dimensions given calculated jpni and jpnj
191	! This used to be done in par_oce.F90 when they were parameters rather
192	! than variables
193	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
194	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
195	jpk = jpkdta ! third dim
196	jpim1 = jpi-1 ! inner domain indices
197	jpjm1 = jpj-1 ! " "
198	jpkm1 = jpk-1 ! " "
199	jpij = jpi*jpj ! jpi x j
200
201
202	IF(lwp) THEN ! open listing units
203	!
204	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
205	!
206	WRITE(numout,*)
207	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
208	WRITE(numout,*) ' NEMO team'
209	WRITE(numout,*) ' Ocean General Circulation Model'
210	WRITE(numout,*) ' version 3.5 (2012) '
211	WRITE(numout,*)
212	WRITE(numout,*)
213	DO ji = 1, SIZE(cltxt)
214	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
215	END DO
216	WRITE(numout,cform_aaa) ! Flag AAAAAAA
217	!
218	ENDIF
219
220	! Now we know the dimensions of the grid and numout has been set we can
221	! allocate arrays
222	CALL nemo_alloc()
223
224	! !--------------------------------!
225	! ! Model general initialization !
226	! !--------------------------------!
227
228	CALL nemo_ctl ! Control prints & Benchmark
229
230	! ! Domain decomposition
231	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
232	ELSE ; CALL mpp_init2 ! eliminate land processors
233	ENDIF
234	!
235	IF( nn_timing == 1 ) CALL timing_init
236	!
237
238	! ! General initialization
239	IF( nn_timing == 1 ) CALL timing_start( 'nemo_init')
240	!
241	CALL phy_cst ! Physical constants
242	CALL eos_init ! Equation of state
243	CALL dom_cfg ! Domain configuration
244	CALL dom_init ! Domain
245	CALL istate_init ! ocean initial state (Dynamics and tracers)
246
247	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
248
249	IF( ln_ctl ) CALL prt_ctl_init ! Print control
250
251	! ! Ocean physics
252	CALL sbc_init ! Forcings : surface module
253	#if ! defined key_degrad
254	CALL ldf_tra_init ! Lateral ocean tracer physics
255	#endif
256	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
257
258	! ! Active tracers
259	CALL tra_qsr_init ! penetrative solar radiation qsr
260	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
261
262	! ! Passive tracers
263	CALL trc_init ! Passive tracers initialization
264	! ! Dynamics
265	CALL dta_dyn_init ! Initialization for the dynamics
266
267	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
268	!
269	IF( nn_timing == 1 ) CALL timing_stop( 'nemo_init')
270	!
271	END SUBROUTINE nemo_init
272
273
274	SUBROUTINE nemo_ctl
275	!!----------------------------------------------------------------------
276	!! * ROUTINE nemo_ctl *
277	!!
278	!! ** Purpose : control print setting
279	!!
280	!! ** Method : - print namctl information and check some consistencies
281	!!----------------------------------------------------------------------
282	!
283	IF(lwp) THEN ! Parameter print
284	WRITE(numout,*)
285	WRITE(numout,*) 'nemo_flg: Control prints & Benchmark'
286	WRITE(numout,*) '~~~~~~~ '
287	WRITE(numout,*) ' Namelist namctl'
288	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
289	WRITE(numout,*) ' level of print nn_print = ', nn_print
290	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
291	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
292	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
293	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
294	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
295	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
296	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
297	ENDIF
298	!
299	nprint = nn_print ! convert DOCTOR namelist names into OLD names
300	nictls = nn_ictls
301	nictle = nn_ictle
302	njctls = nn_jctls
303	njctle = nn_jctle
304	isplt = nn_isplt
305	jsplt = nn_jsplt
306	nbench = nn_bench
307	! ! Parameter control
308	!
309	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
310	IF( lk_mpp ) THEN
311	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real splitted domain
312	ELSE
313	IF( isplt == 1 .AND. jsplt == 1 ) THEN
314	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
315	& ' - the print control will be done over the whole domain' )
316	ENDIF
317	ijsplt = isplt * jsplt ! total number of processors ijsplt
318	ENDIF
319	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
320	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
321	!
322	! ! indices used for the SUM control
323	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
324	lsp_area = .FALSE.
325	ELSE ! print control done over a specific area
326	lsp_area = .TRUE.
327	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
328	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
329	nictls = 1
330	ENDIF
331	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
332	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
333	nictle = jpiglo
334	ENDIF
335	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
336	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
337	njctls = 1
338	ENDIF
339	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
340	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
341	njctle = jpjglo
342	ENDIF
343	ENDIF
344	ENDIF
345	!
346	IF( nbench == 1 ) THEN ! Benchmark
347	SELECT CASE ( cp_cfg )
348	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
349	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
350	& ' key_gyre must be used or set nbench = 0' )
351	END SELECT
352	ENDIF
353	!
354	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ', &
355	& 'with the IOM Input/Output manager. ' , &
356	& 'Compile with key_iomput enabled' )
357	!
358	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
359	& 'f2003 standard. ' , &
360	& 'Compile with key_nosignedzero enabled' )
361	!
362	END SUBROUTINE nemo_ctl
363
364
365	SUBROUTINE nemo_closefile
366	!!----------------------------------------------------------------------
367	!! * ROUTINE nemo_closefile *
368	!!
369	!! ** Purpose : Close the files
370	!!----------------------------------------------------------------------
371	!
372	IF ( lk_mpp ) CALL mppsync
373	!
374	CALL iom_close ! close all input/output files managed by iom_*
375	!
376	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
377	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
378	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
379	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
380	numout = 6 ! redefine numout in case it is used after this point...
381	!
382	END SUBROUTINE nemo_closefile
383
384
385	SUBROUTINE nemo_alloc
386	!!----------------------------------------------------------------------
387	!! * ROUTINE nemo_alloc *
388	!!
389	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
390	!!
391	!! ** Method :
392	!!----------------------------------------------------------------------
393	USE diawri, ONLY: dia_wri_alloc
394	USE dom_oce, ONLY: dom_oce_alloc
395	USE zdf_oce, ONLY: zdf_oce_alloc
396	USE ldftra_oce, ONLY: ldftra_oce_alloc
397	USE trc_oce, ONLY: trc_oce_alloc
398	!
399	INTEGER :: ierr
400	!!----------------------------------------------------------------------
401	!
402	ierr = oce_alloc () ! ocean
403	ierr = ierr + dia_wri_alloc ()
404	ierr = ierr + dom_oce_alloc () ! ocean domain
405	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
406	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
407	!
408	ierr = ierr + lib_mpp_alloc (numout) ! mpp exchanges
409	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
410	!
411	IF( lk_mpp ) CALL mpp_sum( ierr )
412	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
413	!
414	END SUBROUTINE nemo_alloc
415
416
417	SUBROUTINE nemo_partition( num_pes )
418	!!----------------------------------------------------------------------
419	!! * ROUTINE nemo_partition *
420	!!
421	!! ** Purpose :
422	!!
423	!! ** Method :
424	!!----------------------------------------------------------------------
425	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
426	!
427	INTEGER, PARAMETER :: nfactmax = 20
428	INTEGER :: nfact ! The no. of factors returned
429	INTEGER :: ierr ! Error flag
430	INTEGER :: ji
431	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
432	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
433	!!----------------------------------------------------------------------
434
435	ierr = 0
436
437	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
438
439	IF( nfact <= 1 ) THEN
440	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
441	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
442	jpnj = 1
443	jpni = num_pes
444	ELSE
445	! Search through factors for the pair that are closest in value
446	mindiff = 1000000
447	imin = 1
448	DO ji = 1, nfact-1, 2
449	idiff = ABS( ifact(ji) - ifact(ji+1) )
450	IF( idiff < mindiff ) THEN
451	mindiff = idiff
452	imin = ji
453	ENDIF
454	END DO
455	jpnj = ifact(imin)
456	jpni = ifact(imin + 1)
457	ENDIF
458	!
459	jpnij = jpni*jpnj
460	!
461	END SUBROUTINE nemo_partition
462
463
464	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
465	!!----------------------------------------------------------------------
466	!! * ROUTINE factorise *
467	!!
468	!! ** Purpose : return the prime factors of n.
469	!! knfax factors are returned in array kfax which is of
470	!! maximum dimension kmaxfax.
471	!! ** Method :
472	!!----------------------------------------------------------------------
473	INTEGER , INTENT(in ) :: kn, kmaxfax
474	INTEGER , INTENT( out) :: kerr, knfax
475	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
476	!
477	INTEGER :: ifac, jl, inu
478	INTEGER, PARAMETER :: ntest = 14
479	INTEGER :: ilfax(ntest)
480	!
481	! lfax contains the set of allowed factors.
482	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
483	& 128, 64, 32, 16, 8, 4, 2 /
484	!!----------------------------------------------------------------------
485
486	! Clear the error flag and initialise output vars
487	kerr = 0
488	kfax = 1
489	knfax = 0
490
491	! Find the factors of n.
492	IF( kn == 1 ) GOTO 20
493
494	! nu holds the unfactorised part of the number.
495	! knfax holds the number of factors found.
496	! l points to the allowed factor list.
497	! ifac holds the current factor.
498
499	inu = kn
500	knfax = 0
501
502	DO jl = ntest, 1, -1
503	!
504	ifac = ilfax(jl)
505	IF( ifac > inu ) CYCLE
506
507	! Test whether the factor will divide.
508
509	IF( MOD(inu,ifac) == 0 ) THEN
510	!
511	knfax = knfax + 1 ! Add the factor to the list
512	IF( knfax > kmaxfax ) THEN
513	kerr = 6
514	write (,) 'FACTOR: insufficient space in factor array ', knfax
515	return
516	ENDIF
517	kfax(knfax) = ifac
518	! Store the other factor that goes with this one
519	knfax = knfax + 1
520	kfax(knfax) = inu / ifac
521	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
522	ENDIF
523	!
524	END DO
525
526	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
527	!
528	END SUBROUTINE factorise
529
530	#if defined key_mpp_mpi
531	SUBROUTINE nemo_northcomms
532	!!======================================================================
533	!! * ROUTINE nemo_northcomms *
534	!! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging
535	!!=====================================================================
536	!!----------------------------------------------------------------------
537	!!
538	!! ** Purpose : Initialization of the northern neighbours lists.
539	!!----------------------------------------------------------------------
540	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
541	!!----------------------------------------------------------------------
542
543	INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices
544	INTEGER :: ijpj ! number of rows involved in north-fold exchange
545	INTEGER :: northcomms_alloc ! allocate return status
546	REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace
547	LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace
548
549	IF(lwp) WRITE(numout,*)
550	IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists'
551	IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
552
553	!!----------------------------------------------------------------------
554	ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc )
555	ALLOCATE( lrankset(jpnij), stat = northcomms_alloc )
556	IF( northcomms_alloc /= 0 ) THEN
557	WRITE(numout,cform_war)
558	WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays'
559	CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' )
560	ENDIF
561	nsndto = 0
562	isendto = -1
563	ijpj = 4
564	!
565	! This routine has been called because ln_nnogather has been set true ( nammpp )
566	! However, these first few exchanges have to use the mpi_allgather method to
567	! establish the neighbour lists to use in subsequent peer to peer exchanges.
568	! Consequently, set l_north_nogather to be false here and set it true only after
569	! the lists have been established.
570	!
571	l_north_nogather = .FALSE.
572	!
573	! Exchange and store ranks on northern rows
574
575	DO jtyp = 1,4
576
577	lrankset = .FALSE.
578	znnbrs = narea
579	SELECT CASE (jtyp)
580	CASE(1)
581	CALL lbc_lnk( znnbrs, 'T', 1. ) ! Type 1: T,W-points
582	CASE(2)
583	CALL lbc_lnk( znnbrs, 'U', 1. ) ! Type 2: U-point
584	CASE(3)
585	CALL lbc_lnk( znnbrs, 'V', 1. ) ! Type 3: V-point
586	CASE(4)
587	CALL lbc_lnk( znnbrs, 'F', 1. ) ! Type 4: F-point
588	END SELECT
589
590	IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
591	DO jj = nlcj-ijpj+1, nlcj
592	ij = jj - nlcj + ijpj
593	DO ji = 1,jpi
594	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
595	& lrankset(INT(znnbrs(ji,jj))) = .true.
596	END DO
597	END DO
598
599	DO jj = 1,jpnij
600	IF ( lrankset(jj) ) THEN
601	nsndto(jtyp) = nsndto(jtyp) + 1
602	IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
603	CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
604	& ' jpmaxngh will need to be increased ')
605	ENDIF
606	isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank
607	ENDIF
608	END DO
609	ENDIF
610
611	END DO
612
613	!
614	! Type 5: I-point
615	!
616	! ICE point exchanges may involve some averaging. The neighbours list is
617	! built up using two exchanges to ensure that the whole stencil is covered.
618	! lrankset should not be reset between these 'J' and 'K' point exchanges
619
620	jtyp = 5
621	lrankset = .FALSE.
622	znnbrs = narea
623	CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point
624
625	IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
626	DO jj = nlcj-ijpj+1, nlcj
627	ij = jj - nlcj + ijpj
628	DO ji = 1,jpi
629	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
630	& lrankset(INT(znnbrs(ji,jj))) = .true.
631	END DO
632	END DO
633	ENDIF
634
635	znnbrs = narea
636	CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point
637
638	IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN
639	DO jj = nlcj-ijpj+1, nlcj
640	ij = jj - nlcj + ijpj
641	DO ji = 1,jpi
642	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
643	& lrankset( INT(znnbrs(ji,jj))) = .true.
644	END DO
645	END DO
646
647	DO jj = 1,jpnij
648	IF ( lrankset(jj) ) THEN
649	nsndto(jtyp) = nsndto(jtyp) + 1
650	IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
651	CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
652	& ' jpmaxngh will need to be increased ')
653	ENDIF
654	isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank
655	ENDIF
656	END DO
657	!
658	! For northern row areas, set l_north_nogather so that all subsequent exchanges
659	! can use peer to peer communications at the north fold
660	!
661	l_north_nogather = .TRUE.
662	!
663	ENDIF
664	DEALLOCATE( znnbrs )
665	DEALLOCATE( lrankset )
666
667	END SUBROUTINE nemo_northcomms
668	#else
669	SUBROUTINE nemo_northcomms ! Dummy routine
670	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
671	END SUBROUTINE nemo_northcomms
672	#endif
673	!!======================================================================
674	END MODULE nemogcm

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

Download in other formats: