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/2012/dev_MERGE_2012/NEMOGCM/NEMO/OFF_SRC – NEMO

Context Navigation

source: branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 3680

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

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

Download in other formats: