Context Navigation

nemogcm.F90 @ 11274

Last change on this file since 11274 was 11101, checked in by frrh, 5 years ago

Merge changes from Met Office GMED ticket 450 to reduce unnecessary
text output from NEMO.
This output, which is typically not switchable, is rarely of interest
in normal (non-debugging) runs and simply redunantley consumes extra
file space.
Further, the presence of this text output has been shown to
significantly degrade performance of models which are run during
Met Office HPC RAID (disk) checks.
The new code introduces switches which are configurable via the
changes made in the associated Met Office MOCI ticket 399.

File size: 44.4 KB

Rev	Line
[2496]	1	MODULE nemogcm
[2442]	2	!!======================================================================
[2496]	3	!! * MODULE nemogcm *
	4	!! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
[2442]	5	!!======================================================================
[1593]	6	!! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code
	7	!! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec)
[3764]	8	!! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
	9	!! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
[1593]	10	!! - ! 1992-06 (L.Terray) coupling implementation
[3764]	11	!! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice
	12	!! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
[2104]	13	!! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
[1593]	14	!! 8.1 ! 1997-06 (M. Imbard, G. Madec)
[3764]	15	!! 8.2 ! 1999-11 (M. Imbard, H. Goosse) LIM sea-ice model
	16	!! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP
[1593]	17	!! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER)
	18	!! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules
	19	!! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
	20	!! - ! 2004-08 (C. Talandier) New trends organization
	21	!! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility
	22	!! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
	23	!! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation
	24	!! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization
	25	!! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
	26	!! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp
[3764]	27	!! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
[2236]	28	!! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
[3294]	29	!! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
	30	!! 3.4 ! 2011-11 (C. Harris) decomposition changes for running with CICE
[4152]	31	!! ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
[1593]	32	!!----------------------------------------------------------------------
[3]	33
	34	!!----------------------------------------------------------------------
[2496]	35	!! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
	36	!! nemo_init : initialization of the NEMO system
[3764]	37	!! nemo_ctl : initialisation of the contol print
[2496]	38	!! nemo_closefile : close remaining open files
[2715]	39	!! nemo_alloc : dynamical allocation
	40	!! nemo_partition : calculate MPP domain decomposition
	41	!! factorise : calculate the factors of the no. of MPI processes
[3]	42	!!----------------------------------------------------------------------
[2382]	43	USE step_oce ! module used in the ocean time stepping module
[2392]	44	USE cla ! cross land advection (tra_cla routine)
[3]	45	USE domcfg ! domain configuration (dom_cfg routine)
	46	USE mppini ! shared/distributed memory setting (mpp_init routine)
	47	USE domain ! domain initialization (dom_init routine)
[3625]	48	#if defined key_nemocice_decomp
	49	USE ice_domain_size, only: nx_global, ny_global
	50	#endif
[3651]	51	USE tideini ! tidal components initialization (tide_ini routine)
[4990]	52	USE bdyini ! open boundary cond. setting (bdy_init routine)
	53	USE bdydta ! open boundary cond. setting (bdy_dta_init routine)
	54	USE bdytides ! open boundary cond. setting (bdytide_init routine)
[3]	55	USE istate ! initial state setting (istate_init routine)
	56	USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
	57	USE ldftra ! lateral diffusivity setting (ldftra_init routine)
[2392]	58	USE zdfini ! vertical physics setting (zdf_init routine)
[3]	59	USE phycst ! physical constant (par_cst routine)
[4990]	60	USE trdini ! dyn/tra trends initialization (trd_init routine)
[3768]	61	USE asminc ! assimilation increments
	62	USE asmbkg ! writing out state trajectory
[10149]	63	USE asmbgc ! biogeochemical assimilation increments
[2236]	64	USE diaptr ! poleward transports (dia_ptr_init routine)
[3294]	65	USE diadct ! sections transports (dia_dct_init routine)
[2236]	66	USE diaobs ! Observation diagnostics (dia_obs_init routine)
[3764]	67	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
[2496]	68	USE step ! NEMO time-stepping (stp routine)
[3609]	69	USE icbini ! handle bergs, initialisation
	70	USE icbstp ! handle bergs, calving, themodynamics and transport
[8280]	71	USE sbccpl
[1359]	72	USE cpl_oasis3 ! OASIS3 coupling
[900]	73	USE c1d ! 1D configuration
	74	USE step_c1d ! Time stepping loop for the 1D configuration
[4245]	75	USE dyndmp ! Momentum damping
[1594]	76	#if defined key_top
[1593]	77	USE trcini ! passive tracer initialisation
[8280]	78	USE trc, ONLY: numstr ! tracer stats unit number
[1594]	79	#endif
[1593]	80	USE lib_mpp ! distributed memory computing
[1412]	81	#if defined key_iomput
[3701]	82	USE xios
[1359]	83	#endif
[3651]	84	USE sbctide, ONLY: lk_tide
[4152]	85	USE crsini ! initialise grid coarsening utility
[4671]	86	USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
[5407]	87	USE sbc_oce, ONLY: lk_oasis
[5329]	88	USE stopar
	89	USE stopts
[268]	90
[2715]	91	IMPLICIT NONE
[3]	92	PRIVATE
	93
[2496]	94	PUBLIC nemo_gcm ! called by model.F90
	95	PUBLIC nemo_init ! needed by AGRIF
[3764]	96	PUBLIC nemo_alloc ! needed by TAM
[467]	97
[2498]	98	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
[1593]	99
[3]	100	!!----------------------------------------------------------------------
[2715]	101	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
[2392]	102	!! $Id$
[2329]	103	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[3]	104	!!----------------------------------------------------------------------
	105	CONTAINS
	106
[2496]	107	SUBROUTINE nemo_gcm
[3]	108	!!----------------------------------------------------------------------
[2496]	109	!! * ROUTINE nemo_gcm *
[3]	110	!!
[3764]	111	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
[1593]	112	!! curvilinear mesh on the sphere.
[3]	113	!!
	114	!! ** Method : - model general initialization
	115	!! - launch the time-stepping (stp routine)
[1593]	116	!! - finalize the run by closing files and communications
[3]	117	!!
[2715]	118	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
[1593]	119	!! Madec, 2008, internal report, IPSL.
[3]	120	!!----------------------------------------------------------------------
	121	INTEGER :: istp ! time step index
[389]	122	!!----------------------------------------------------------------------
[2382]	123	!
[392]	124	#if defined key_agrif
[1593]	125	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
[389]	126	#endif
	127
[1593]	128	! !-----------------------!
[2496]	129	CALL nemo_init !== Initialisations ==!
[1593]	130	! !-----------------------!
[2715]	131	#if defined key_agrif
[3680]	132	CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
	133	CALL Agrif_Declare_Var ! " " " " " DYN/TRA
[2715]	134	# if defined key_top
[3680]	135	CALL Agrif_Declare_Var_top ! " " " " " TOP
[2715]	136	# endif
[3680]	137	# if defined key_lim2
	138	CALL Agrif_Declare_Var_lim2 ! " " " " " LIM
	139	# endif
[2715]	140	#endif
[682]	141	! check that all process are still there... If some process have an error,
	142	! they will never enter in step and other processes will wait until the end of the cpu time!
[900]	143	IF( lk_mpp ) CALL mpp_max( nstop )
[682]	144
[1593]	145	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	146
	147	! !-----------------------!
	148	! !== time stepping ==!
	149	! !-----------------------!
[900]	150	istp = nit000
[2236]	151	#if defined key_c1d
[389]	152	DO WHILE ( istp <= nitend .AND. nstop == 0 )
[900]	153	CALL stp_c1d( istp )
[389]	154	istp = istp + 1
	155	END DO
[2236]	156	#else
	157	IF( lk_asminc ) THEN
	158	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
	159	IF( ln_asmdin ) THEN ! Direct initialization
	160	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
[3764]	161	IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
[2236]	162	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
[10149]	163	IF( lk_bgcinc ) CALL bgc_asm_inc( nit000 - 1 ) ! BGC
[2236]	164	ENDIF
	165	ENDIF
[3764]	166
[6487]	167	#if defined key_agrif
	168	CALL Agrif_Regrid()
	169	#endif
	170
[389]	171	DO WHILE ( istp <= nitend .AND. nstop == 0 )
[392]	172	#if defined key_agrif
[6487]	173	CALL stp ! AGRIF: time stepping
[389]	174	#else
[8280]	175	IF (lk_oasis) CALL sbc_cpl_snd( istp ) ! Coupling to atmos
	176	CALL stp( istp )
	177	! We don't couple on the final timestep because
	178	! our restart file has already been written
	179	! and contains all the necessary data for a
	180	! restart. sbc_cpl_snd could be called here
	181	! but it would require
	182	! a) A test to ensure it was not performed
	183	! on the very last time-step
	184	! b) the presence of another call to
	185	! sbc_cpl_snd call prior to the main DO loop
	186	! This solution produces identical results
	187	! with fewer lines of code.
[389]	188	#endif
	189	istp = istp + 1
[900]	190	IF( lk_mpp ) CALL mpp_max( nstop )
[389]	191	END DO
[2236]	192	#endif
	193
[3609]	194	IF( lk_diaobs ) CALL dia_obs_wri
	195	!
[10149]	196	IF( ( lk_asminc ).AND.( ln_balwri ) ) CALL asm_bgc_bal_wri( nitend ) ! Output balancing increments
	197	!
[3609]	198	IF( ln_icebergs ) CALL icb_end( nitend )
[3764]	199
[1593]	200	! !------------------------!
	201	! !== finalize the run ==!
	202	! !------------------------!
	203	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	204	!
	205	IF( nstop /= 0 .AND. lwp ) THEN ! error print
[682]	206	WRITE(numout,cform_err)
[3764]	207	WRITE(numout,*) nstop, ' error have been found'
[389]	208	ENDIF
[1593]	209	!
[3294]	210	#if defined key_agrif
[6487]	211	IF( .NOT. Agrif_Root() ) THEN
	212	CALL Agrif_ParentGrid_To_ChildGrid()
	213	IF( lk_diaobs ) CALL dia_obs_wri
[9321]	214	IF( nn_timing > 0 ) CALL timing_finalize
[6487]	215	CALL Agrif_ChildGrid_To_ParentGrid()
	216	ENDIF
[3294]	217	#endif
[9321]	218	IF( nn_timing > 0 ) CALL timing_finalize
[3294]	219	!
[2496]	220	CALL nemo_closefile
[4990]	221	!
[3769]	222	#if defined key_iomput
	223	CALL xios_finalize ! end mpp communications with xios
[5407]	224	IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS
[532]	225	#else
[5407]	226	IF( lk_oasis ) THEN
[4990]	227	CALL cpl_finalize ! end coupling and mpp communications with OASIS
	228	ELSE
	229	IF( lk_mpp ) CALL mppstop ! end mpp communications
	230	ENDIF
[532]	231	#endif
[900]	232	!
[8400]	233	! Met Office addition: if failed, return non-zero exit code
	234	IF( nstop /= 0 ) CALL exit( 9 )
	235	!
[2496]	236	END SUBROUTINE nemo_gcm
[389]	237
	238
[2496]	239	SUBROUTINE nemo_init
[389]	240	!!----------------------------------------------------------------------
[2496]	241	!! * ROUTINE nemo_init *
[389]	242	!!
[2496]	243	!! ** Purpose : initialization of the NEMO GCM
[389]	244	!!----------------------------------------------------------------------
[2715]	245	INTEGER :: ji ! dummy loop indices
	246	INTEGER :: ilocal_comm ! local integer
[4147]	247	INTEGER :: ios
[2715]	248	CHARACTER(len=80), DIMENSION(16) :: cltxt
[4990]	249	!
[11101]	250	NAMELIST/namctl/ ln_ctl ,sn_cfctl, nn_print, nn_ictls, nn_ictle, &
[3294]	251	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
[11101]	252	& nn_bench, nn_timing, ln_flush
[4147]	253	NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
[5118]	254	& jpizoom, jpjzoom, jperio, ln_use_jattr
[3]	255	!!----------------------------------------------------------------------
[1593]	256	!
[2496]	257	cltxt = ''
[5407]	258	cxios_context = 'nemo'
[2496]	259	!
[4147]	260	! ! Open reference namelist and configuration namelist files
	261	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
	262	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
[1593]	263	!
[4147]	264	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
	265	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
[4289]	266	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
[4147]	267
	268	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
	269	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
[4289]	270	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
[4147]	271
[1593]	272	!
[4147]	273	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
	274	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
[4289]	275	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
[4147]	276
	277	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
	278	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
[4289]	279	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
[4309]	280
[4147]	281	! Force values for AGRIF zoom (cf. agrif_user.F90)
	282	#if defined key_agrif
	283	IF( .NOT. Agrif_Root() ) THEN
	284	jpiglo = nbcellsx + 2 + 2*nbghostcells
	285	jpjglo = nbcellsy + 2 + 2*nbghostcells
	286	jpi = ( jpiglo-2jpreci + (jpni-1+0) ) / jpni + 2jpreci
	287	jpj = ( jpjglo-2jprecj + (jpnj-1+0) ) / jpnj + 2jprecj
	288	jpidta = jpiglo
	289	jpjdta = jpjglo
	290	jpizoom = 1
	291	jpjzoom = 1
	292	nperio = 0
	293	jperio = 0
[5118]	294	ln_use_jattr = .false.
[4147]	295	ENDIF
	296	#endif
[11101]	297	nprint = nn_print ! convert DOCTOR namelist names into OLD names
	298	lflush = ln_flush ! convert namelist variable to model variable
[4147]	299	!
[1593]	300	! !--------------------------------------------!
	301	! ! set communicator & select the local node !
[4624]	302	! ! NB: mynode also opens output.namelist.dyn !
	303	! ! on unit number numond on first proc !
[1593]	304	! !--------------------------------------------!
[1412]	305	#if defined key_iomput
[2200]	306	IF( Agrif_Root() ) THEN
[5407]	307	IF( lk_oasis ) THEN
[8280]	308	CALL cpl_init( "toyoce", ilocal_comm ) ! nemo local communicator given by oasis
[5407]	309	CALL xios_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios
[4990]	310	ELSE
[5407]	311	CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) ! nemo local communicator given by xios
[4990]	312	ENDIF
[2200]	313	ENDIF
[5407]	314	! Nodes selection (control print return in cltxt)
	315	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
[532]	316	#else
[5407]	317	IF( lk_oasis ) THEN
[4990]	318	IF( Agrif_Root() ) THEN
[8280]	319	CALL cpl_init( "toyoce", ilocal_comm ) ! nemo local communicator given by oasis
[4990]	320	ENDIF
[5407]	321	! Nodes selection (control print return in cltxt)
	322	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
[4990]	323	ELSE
	324	ilocal_comm = 0
[5407]	325	! Nodes selection (control print return in cltxt)
	326	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
[2236]	327	ENDIF
[532]	328	#endif
[2715]	329	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
[3]	330
[11101]	331	IF( sn_cfctl%l_config ) THEN
	332	! Activate finer control of report outputs
	333	! optionally switch off output from selected areas (note this only
	334	! applies to output which does not involve global communications)
	335	IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
	336	& ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
	337	& CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
	338	ELSE
	339	! Use ln_ctl to turn on or off all options.
	340	CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. )
	341	ENDIF
	342
[4624]	343	lwm = (narea == 1) ! control of output namelists
[2715]	344	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
[1579]	345
[11101]	346	IF(lwm .AND. nprint > 2) THEN
[4624]	347	! write merged namelists from earlier to output namelist now that the
	348	! file has been opened in call to mynode. nammpp has already been
	349	! written in mynode (if lk_mpp_mpi)
	350	WRITE( numond, namctl )
	351	WRITE( numond, namcfg )
	352	ENDIF
	353
[3764]	354	! If dimensions of processor grid weren't specified in the namelist file
[2715]	355	! then we calculate them here now that we have our communicator size
	356	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
	357	#if defined key_mpp_mpi
	358	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
	359	#else
	360	jpni = 1
	361	jpnj = 1
	362	jpnij = jpni*jpnj
	363	#endif
	364	END IF
	365
	366	! Calculate domain dimensions given calculated jpni and jpnj
	367	! This used to be done in par_oce.F90 when they were parameters rather
	368	! than variables
	369	IF( Agrif_Root() ) THEN
[3294]	370	#if defined key_nemocice_decomp
[3625]	371	jpi = ( nx_global+2-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
	372	jpj = ( ny_global+2-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
[3294]	373	#else
[3625]	374	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
[2715]	375	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
[3294]	376	#endif
[6487]	377	ENDIF
[2715]	378	jpk = jpkdta ! third dim
[6487]	379	#if defined key_agrif
	380	! simple trick to use same vertical grid as parent
	381	! but different number of levels:
	382	! Save maximum number of levels in jpkdta, then define all vertical grids
	383	! with this number.
	384	! Suppress once vertical online interpolation is ok
	385	IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta)
	386	#endif
[2715]	387	jpim1 = jpi-1 ! inner domain indices
	388	jpjm1 = jpj-1 ! " "
	389	jpkm1 = jpk-1 ! " "
	390	jpij = jpi*jpj ! jpi x j
	391
[1593]	392	IF(lwp) THEN ! open listing units
	393	!
[1581]	394	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
[1593]	395	!
[1579]	396	WRITE(numout,*)
[3294]	397	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
[1593]	398	WRITE(numout,*) ' NEMO team'
[1579]	399	WRITE(numout,*) ' Ocean General Circulation Model'
[5120]	400	WRITE(numout,*) ' version 3.6 (2015) '
[1579]	401	WRITE(numout,*)
	402	WRITE(numout,*)
[3764]	403	DO ji = 1, SIZE(cltxt)
[1593]	404	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
[1579]	405	END DO
[1593]	406	WRITE(numout,cform_aaa) ! Flag AAAAAAA
[11101]	407	IF(lflush) CALL flush(numout)
[1593]	408	!
[473]	409	ENDIF
[2715]	410
[3764]	411	! Now we know the dimensions of the grid and numout has been set we can
[2715]	412	! allocate arrays
	413	CALL nemo_alloc()
	414
[2496]	415	! !-------------------------------!
	416	! ! NEMO general initialization !
	417	! !-------------------------------!
[473]	418
[2496]	419	CALL nemo_ctl ! Control prints & Benchmark
[531]	420
[2082]	421	! ! Domain decomposition
[1593]	422	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
	423	ELSE ; CALL mpp_init2 ! eliminate land processors
[3]	424	ENDIF
[2382]	425	!
[9321]	426	IF( nn_timing > 0 ) CALL timing_init
[3294]	427	!
[2082]	428	! ! General initialization
[2027]	429	CALL phy_cst ! Physical constants
	430	CALL eos_init ! Equation of state
[4245]	431	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
[2027]	432	CALL dom_cfg ! Domain configuration
	433	CALL dom_init ! Domain
[413]	434
[3294]	435	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
	436
[2027]	437	IF( ln_ctl ) CALL prt_ctl_init ! Print control
	438
[3651]	439	CALL istate_init ! ocean initial state (Dynamics and tracers)
	440
[4292]	441	IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics
[3651]	442
[5123]	443	CALL sbc_init ! Forcings : surface module (clem: moved here for bdy purpose)
	444
[4990]	445	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
	446	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
[4292]	447	IF( lk_bdy .AND. lk_tide ) &
[4990]	448	& CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing
[2027]	449
[3294]	450	CALL dyn_nept_init ! simplified form of Neptune effect
[4152]	451	!
	452	IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid
	453	!
	454	! Ocean physics
[2082]	455	! ! Vertical physics
	456	CALL zdf_init ! namelist read
	457	CALL zdf_bfr_init ! bottom friction
	458	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
[2329]	459	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
	460	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
	461	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
[2082]	462	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
[3764]	463	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
[2082]	464	& CALL zdf_ddm_init ! double diffusive mixing
	465	! ! Lateral physics
	466	CALL ldf_tra_init ! Lateral ocean tracer physics
	467	CALL ldf_dyn_init ! Lateral ocean momentum physics
[2392]	468	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
[2082]	469
[2027]	470	! ! Active tracers
	471	CALL tra_qsr_init ! penetrative solar radiation qsr
[2325]	472	CALL tra_bbc_init ! bottom heat flux
[2027]	473	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
[4245]	474	CALL tra_dmp_init ! internal damping trends- tracers
[2027]	475	CALL tra_adv_init ! horizontal & vertical advection
	476	CALL tra_ldf_init ! lateral mixing
	477	CALL tra_zdf_init ! vertical mixing and after tracer fields
	478
	479	! ! Dynamics
[4245]	480	IF( lk_c1d ) CALL dyn_dmp_init ! internal damping trends- momentum
[2027]	481	CALL dyn_adv_init ! advection (vector or flux form)
[2104]	482	CALL dyn_vor_init ! vorticity term including Coriolis
[2027]	483	CALL dyn_ldf_init ! lateral mixing
[2104]	484	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
[2027]	485	CALL dyn_zdf_init ! vertical diffusion
	486	CALL dyn_spg_init ! surface pressure gradient
[3764]	487
[2392]	488	! ! Misc. options
[4147]	489	IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_init ! Cross Land Advection
[3609]	490	CALL icb_init( rdt, nit000) ! initialise icebergs instance
[5329]	491	CALL sto_par_init ! Stochastic parametrization
	492	IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations
[4147]	493
[1594]	494	#if defined key_top
[2027]	495	! ! Passive tracers
[2082]	496	CALL trc_init
[1594]	497	#endif
[4990]	498	! ! Diagnostics
[3294]	499	IF( lk_floats ) CALL flo_init ! drifting Floats
[2027]	500	CALL dia_ptr_init ! Poleward TRansports initialization
[3294]	501	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
[2148]	502	CALL dia_hsb_init ! heat content, salt content and volume budgets
[4990]	503	CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends
[8400]	504	CALL bias_init ! Pressure correction bias
[2392]	505	IF( lk_diaobs ) THEN ! Observation & model comparison
[2382]	506	CALL dia_obs_init ! Initialize observational data
	507	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
[3764]	508	ENDIF
[4990]	509
[2382]	510	! ! Assimilation increments
[2392]	511	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
[2382]	512	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
[11101]	513	IF(lwp .AND. lflush) CALL flush(numout)
[8280]	514
	515	IF (nstop > 0) THEN
	516	CALL CTL_STOP('STOP','Critical errors in NEMO initialisation')
	517	END IF
	518
[1593]	519	!
[2496]	520	END SUBROUTINE nemo_init
[467]	521
	522
[2496]	523	SUBROUTINE nemo_ctl
[467]	524	!!----------------------------------------------------------------------
[2496]	525	!! * ROUTINE nemo_ctl *
[467]	526	!!
[3764]	527	!! ** Purpose : control print setting
[467]	528	!!
[2442]	529	!! ** Method : - print namctl information and check some consistencies
[467]	530	!!----------------------------------------------------------------------
[2442]	531	!
[2496]	532	IF(lwp) THEN ! control print
[531]	533	WRITE(numout,*)
[2496]	534	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
[531]	535	WRITE(numout,*) '~~~~~~~ '
[1593]	536	WRITE(numout,*) ' Namelist namctl'
[1601]	537	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
[11101]	538	WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
	539	WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
	540	WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
	541	WRITE(numout,*) ' sn_cfctl%l_oceout = ', sn_cfctl%l_oceout
	542	WRITE(numout,*) ' sn_cfctl%l_layout = ', sn_cfctl%l_layout
	543	WRITE(numout,*) ' sn_cfctl%l_mppout = ', sn_cfctl%l_mppout
	544	WRITE(numout,*) ' sn_cfctl%l_mpptop = ', sn_cfctl%l_mpptop
	545	WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin
	546	WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax
	547	WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
	548	WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
[1601]	549	WRITE(numout,*) ' level of print nn_print = ', nn_print
[11101]	550	WRITE(numout,*) ' flush numout/stat ln_flush = ', ln_flush
[1601]	551	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
	552	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
	553	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
	554	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
	555	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
	556	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
	557	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
[3610]	558	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
[11101]	559	IF(lflush) CALL flush(numout)
[531]	560	ENDIF
[2442]	561	!
[1601]	562	nictls = nn_ictls
	563	nictle = nn_ictle
	564	njctls = nn_jctls
	565	njctle = nn_jctle
	566	isplt = nn_isplt
	567	jsplt = nn_jsplt
	568	nbench = nn_bench
[4147]	569
	570	IF(lwp) THEN ! control print
	571	WRITE(numout,*)
	572	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
	573	WRITE(numout,*) '~~~~~~~ '
	574	WRITE(numout,*) ' Namelist namcfg'
	575	WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg)
	576	WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz)
	577	WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg
	578	WRITE(numout,*) ' 1st lateral dimension ( >= jpi ) jpidta = ', jpidta
	579	WRITE(numout,*) ' 2nd " " ( >= jpj ) jpjdta = ', jpjdta
	580	WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta
	581	WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo
	582	WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo
	583	WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
	584	WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
	585	WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio
[5118]	586	WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
[11101]	587	IF(lflush) CALL flush(numout)
[4147]	588	ENDIF
[2442]	589	! ! Parameter control
[1593]	590	!
	591	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
[3294]	592	IF( lk_mpp .AND. jpnij > 1 ) THEN
[2496]	593	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
[531]	594	ELSE
	595	IF( isplt == 1 .AND. jsplt == 1 ) THEN
[1593]	596	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
	597	& ' - the print control will be done over the whole domain' )
[531]	598	ENDIF
[1593]	599	ijsplt = isplt * jsplt ! total number of processors ijsplt
[531]	600	ENDIF
	601	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
	602	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
[11101]	603	IF(lwp .AND. lflush) CALL flush(numout)
[1593]	604	!
	605	! ! indices used for the SUM control
	606	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
[3764]	607	lsp_area = .FALSE.
[1593]	608	ELSE ! print control done over a specific area
[531]	609	lsp_area = .TRUE.
	610	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
	611	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
	612	nictls = 1
	613	ENDIF
	614	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
	615	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
	616	nictle = jpiglo
	617	ENDIF
	618	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
	619	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
	620	njctls = 1
	621	ENDIF
	622	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
	623	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
	624	njctle = jpjglo
	625	ENDIF
[1593]	626	ENDIF
	627	ENDIF
[2442]	628	!
[3764]	629	IF( nbench == 1 ) THEN ! Benchmark
[531]	630	SELECT CASE ( cp_cfg )
[1593]	631	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
	632	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
[4147]	633	& ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
[531]	634	END SELECT
	635	ENDIF
[1593]	636	!
[3764]	637	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
	638	& 'f2003 standard. ' , &
	639	& 'Compile with key_nosignedzero enabled' )
	640	!
[2496]	641	END SUBROUTINE nemo_ctl
[467]	642
	643
[2496]	644	SUBROUTINE nemo_closefile
[467]	645	!!----------------------------------------------------------------------
[2496]	646	!! * ROUTINE nemo_closefile *
[467]	647	!!
	648	!! ** Purpose : Close the files
	649	!!----------------------------------------------------------------------
[1593]	650	!
	651	IF( lk_mpp ) CALL mppsync
	652	!
[1685]	653	CALL iom_close ! close all input/output files managed by iom_*
[1593]	654	!
[4147]	655	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
	656	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
	657	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
	658	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
[4624]	659	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
[4147]	660	IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist
	661	IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist
[4624]	662	IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
[4147]	663	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
	664	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
	665	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
	666	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
	667	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
[8280]	668	#if defined key_top
	669	IF( numstr /= -1 ) CLOSE( numstr ) ! tracer statistics
	670	#endif
[1593]	671	!
[2442]	672	numout = 6 ! redefine numout in case it is used after this point...
	673	!
[2496]	674	END SUBROUTINE nemo_closefile
[467]	675
[2715]	676
	677	SUBROUTINE nemo_alloc
	678	!!----------------------------------------------------------------------
	679	!! * ROUTINE nemo_alloc *
	680	!!
	681	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
	682	!!
	683	!! ** Method :
	684	!!----------------------------------------------------------------------
	685	USE diawri , ONLY: dia_wri_alloc
[8400]	686	USE insitu_tem, ONLY: insitu_tem_alloc
[2715]	687	USE dom_oce , ONLY: dom_oce_alloc
	688	USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
	689	USE ldftra_oce, ONLY: ldftra_oce_alloc
	690	USE trc_oce , ONLY: trc_oce_alloc
[3680]	691	#if defined key_diadct
	692	USE diadct , ONLY: diadct_alloc
	693	#endif
[4354]	694	#if defined key_bdy
	695	USE bdy_oce , ONLY: bdy_oce_alloc
	696	#endif
[2715]	697	!
	698	INTEGER :: ierr
	699	!!----------------------------------------------------------------------
	700	!
[3764]	701	ierr = oce_alloc () ! ocean
[2715]	702	ierr = ierr + dia_wri_alloc ()
[8400]	703	ierr = ierr + insitu_tem_alloc()
[2715]	704	ierr = ierr + dom_oce_alloc () ! ocean domain
	705	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
	706	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
	707	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
	708	!
	709	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
	710	!
[3680]	711	#if defined key_diadct
	712	ierr = ierr + diadct_alloc () !
	713	#endif
[4354]	714	#if defined key_bdy
	715	ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization)
	716	#endif
[3680]	717	!
[2715]	718	IF( lk_mpp ) CALL mpp_sum( ierr )
	719	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
	720	!
	721	END SUBROUTINE nemo_alloc
	722
[11101]	723	SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
	724	!!----------------------------------------------------------------------
	725	!! * ROUTINE nemo_set_cfctl *
	726	!!
	727	!! ** Purpose : Set elements of the output control structure to setto.
	728	!! for_all should be .false. unless all areas are to be
	729	!! treated identically.
	730	!!
	731	!! ** Method : Note this routine can be used to switch on/off some
	732	!! types of output for selected areas but any output types
	733	!! that involve global communications (e.g. mpp_max, glob_sum)
	734	!! should be protected from selective switching by the
	735	!! for_all argument
	736	!!----------------------------------------------------------------------
	737	LOGICAL :: setto, for_all
	738	TYPE(sn_ctl) :: sn_cfctl
	739	!!----------------------------------------------------------------------
	740	IF( for_all ) THEN
	741	sn_cfctl%l_runstat = setto
	742	sn_cfctl%l_trcstat = setto
	743	ENDIF
	744	sn_cfctl%l_oceout = setto
	745	sn_cfctl%l_layout = setto
	746	sn_cfctl%l_mppout = setto
	747	sn_cfctl%l_mpptop = setto
	748	END SUBROUTINE nemo_set_cfctl
[2715]	749
	750	SUBROUTINE nemo_partition( num_pes )
	751	!!----------------------------------------------------------------------
	752	!! * ROUTINE nemo_partition *
	753	!!
[3764]	754	!! ** Purpose :
[2715]	755	!!
	756	!! ** Method :
	757	!!----------------------------------------------------------------------
[4990]	758	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
[2715]	759	!
	760	INTEGER, PARAMETER :: nfactmax = 20
	761	INTEGER :: nfact ! The no. of factors returned
	762	INTEGER :: ierr ! Error flag
	763	INTEGER :: ji
	764	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
	765	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
	766	!!----------------------------------------------------------------------
[4990]	767	!
[2715]	768	ierr = 0
[4990]	769	!
[2715]	770	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
[4990]	771	!
[2715]	772	IF( nfact <= 1 ) THEN
	773	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
	774	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
[11101]	775	IF(lflush) CALL flush(numout)
[2715]	776	jpnj = 1
	777	jpni = num_pes
	778	ELSE
	779	! Search through factors for the pair that are closest in value
	780	mindiff = 1000000
	781	imin = 1
	782	DO ji = 1, nfact-1, 2
	783	idiff = ABS( ifact(ji) - ifact(ji+1) )
	784	IF( idiff < mindiff ) THEN
	785	mindiff = idiff
	786	imin = ji
	787	ENDIF
	788	END DO
	789	jpnj = ifact(imin)
	790	jpni = ifact(imin + 1)
	791	ENDIF
	792	!
	793	jpnij = jpni*jpnj
	794	!
	795	END SUBROUTINE nemo_partition
	796
	797
	798	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
	799	!!----------------------------------------------------------------------
	800	!! * ROUTINE factorise *
	801	!!
	802	!! ** Purpose : return the prime factors of n.
[3764]	803	!! knfax factors are returned in array kfax which is of
[2715]	804	!! maximum dimension kmaxfax.
	805	!! ** Method :
	806	!!----------------------------------------------------------------------
	807	INTEGER , INTENT(in ) :: kn, kmaxfax
	808	INTEGER , INTENT( out) :: kerr, knfax
	809	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
	810	!
	811	INTEGER :: ifac, jl, inu
	812	INTEGER, PARAMETER :: ntest = 14
[6487]	813	INTEGER, DIMENSION(ntest) :: ilfax
[4990]	814	!
[6487]	815	! ilfax contains the set of allowed factors.
	816	ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
[2715]	817	!!----------------------------------------------------------------------
[6487]	818	! ilfax contains the set of allowed factors.
	819	ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
[2715]	820
	821	! Clear the error flag and initialise output vars
	822	kerr = 0
	823	kfax = 1
	824	knfax = 0
	825
	826	! Find the factors of n.
	827	IF( kn == 1 ) GOTO 20
	828
	829	! nu holds the unfactorised part of the number.
	830	! knfax holds the number of factors found.
	831	! l points to the allowed factor list.
	832	! ifac holds the current factor.
	833
	834	inu = kn
	835	knfax = 0
	836
	837	DO jl = ntest, 1, -1
	838	!
	839	ifac = ilfax(jl)
	840	IF( ifac > inu ) CYCLE
	841
	842	! Test whether the factor will divide.
	843
	844	IF( MOD(inu,ifac) == 0 ) THEN
	845	!
	846	knfax = knfax + 1 ! Add the factor to the list
	847	IF( knfax > kmaxfax ) THEN
	848	kerr = 6
	849	write (,) 'FACTOR: insufficient space in factor array ', knfax
	850	return
	851	ENDIF
	852	kfax(knfax) = ifac
	853	! Store the other factor that goes with this one
	854	knfax = knfax + 1
	855	kfax(knfax) = inu / ifac
	856	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
	857	ENDIF
	858	!
	859	END DO
	860
	861	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
	862	!
	863	END SUBROUTINE factorise
	864
[3294]	865	#if defined key_mpp_mpi
[4990]	866
[3294]	867	SUBROUTINE nemo_northcomms
	868	!!======================================================================
	869	!! * ROUTINE nemo_northcomms *
[4230]	870	!! nemo_northcomms : Setup for north fold exchanges with explicit
	871	!! point-to-point messaging
[3294]	872	!!=====================================================================
	873	!!----------------------------------------------------------------------
[3764]	874	!!
[3294]	875	!! ** Purpose : Initialization of the northern neighbours lists.
	876	!!----------------------------------------------------------------------
[3764]	877	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
[4230]	878	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
[3294]	879	!!----------------------------------------------------------------------
	880
[4230]	881	INTEGER :: sxM, dxM, sxT, dxT, jn
	882	INTEGER :: njmppmax
[3294]	883
[4230]	884	njmppmax = MAXVAL( njmppt )
	885
	886	!initializes the north-fold communication variables
	887	isendto(:) = 0
[3294]	888	nsndto = 0
	889
[4230]	890	!if I am a process in the north
	891	IF ( njmpp == njmppmax ) THEN
	892	!sxM is the first point (in the global domain) needed to compute the
	893	!north-fold for the current process
	894	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
	895	!dxM is the last point (in the global domain) needed to compute the
	896	!north-fold for the current process
	897	dxM = jpiglo - nimppt(narea) + 2
[3294]	898
[4230]	899	!loop over the other north-fold processes to find the processes
	900	!managing the points belonging to the sxT-dxT range
[4671]	901
	902	DO jn = 1, jpni
[4230]	903	!sxT is the first point (in the global domain) of the jn
	904	!process
[4671]	905	sxT = nfiimpp(jn, jpnj)
[4230]	906	!dxT is the last point (in the global domain) of the jn
	907	!process
[4671]	908	dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
[4230]	909	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
	910	nsndto = nsndto + 1
[4671]	911	isendto(nsndto) = jn
[4645]	912	ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
[4230]	913	nsndto = nsndto + 1
[4671]	914	isendto(nsndto) = jn
[4230]	915	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
	916	nsndto = nsndto + 1
[4671]	917	isendto(nsndto) = jn
[4230]	918	END IF
	919	END DO
[4671]	920	nfsloop = 1
	921	nfeloop = nlci
	922	DO jn = 2,jpni-1
	923	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
	924	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
	925	nfsloop = nldi
	926	ENDIF
	927	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
	928	nfeloop = nlei
	929	ENDIF
	930	ENDIF
	931	END DO
	932
[3294]	933	ENDIF
[4230]	934	l_north_nogather = .TRUE.
[3294]	935	END SUBROUTINE nemo_northcomms
	936	#else
	937	SUBROUTINE nemo_northcomms ! Dummy routine
	938	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
	939	END SUBROUTINE nemo_northcomms
	940	#endif
[4990]	941
[3]	942	!!======================================================================
[2496]	943	END MODULE nemogcm
[4354]	944
	945

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 11274

Download in other formats: