Context Navigation

nemogcm.F90 @ 7701

Last change on this file since 7701 was 7701, checked in by frrh, 7 years ago

Improve control of numstr unit.

In addition to only producing output, and doing the
related global sums when we really need them, we
need to restrict it to one instance on the master PE
in all circumstances and to explicitly close it at the
end of the run. (Currently if lwp = true you get a separate
file for every PE containing identical information and none
of the tracer.stat files are explicitly closed.)

File size: 39.5 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
[2236]	63	USE diaptr ! poleward transports (dia_ptr_init routine)
[3294]	64	USE diadct ! sections transports (dia_dct_init routine)
[2236]	65	USE diaobs ! Observation diagnostics (dia_obs_init routine)
[3764]	66	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
[2496]	67	USE step ! NEMO time-stepping (stp routine)
[3609]	68	USE icbini ! handle bergs, initialisation
	69	USE icbstp ! handle bergs, calving, themodynamics and transport
[1359]	70	USE cpl_oasis3 ! OASIS3 coupling
[900]	71	USE c1d ! 1D configuration
	72	USE step_c1d ! Time stepping loop for the 1D configuration
[4245]	73	USE dyndmp ! Momentum damping
[1594]	74	#if defined key_top
[1593]	75	USE trcini ! passive tracer initialisation
[7701]	76	USE trc, ONLY: numstr ! tracer stats unit number
[1594]	77	#endif
[1593]	78	USE lib_mpp ! distributed memory computing
[1412]	79	#if defined key_iomput
[3701]	80	USE xios
[1359]	81	#endif
[3651]	82	USE sbctide, ONLY: lk_tide
[4152]	83	USE crsini ! initialise grid coarsening utility
[4671]	84	USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
[5407]	85	USE sbc_oce, ONLY: lk_oasis
[5329]	86	USE stopar
	87	USE stopts
[268]	88
[2715]	89	IMPLICIT NONE
[3]	90	PRIVATE
	91
[2496]	92	PUBLIC nemo_gcm ! called by model.F90
	93	PUBLIC nemo_init ! needed by AGRIF
[3764]	94	PUBLIC nemo_alloc ! needed by TAM
[467]	95
[2498]	96	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
[1593]	97
[3]	98	!!----------------------------------------------------------------------
[2715]	99	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
[2392]	100	!! $Id$
[2329]	101	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[3]	102	!!----------------------------------------------------------------------
	103	CONTAINS
	104
[2496]	105	SUBROUTINE nemo_gcm
[3]	106	!!----------------------------------------------------------------------
[2496]	107	!! * ROUTINE nemo_gcm *
[3]	108	!!
[3764]	109	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
[1593]	110	!! curvilinear mesh on the sphere.
[3]	111	!!
	112	!! ** Method : - model general initialization
	113	!! - launch the time-stepping (stp routine)
[1593]	114	!! - finalize the run by closing files and communications
[3]	115	!!
[2715]	116	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
[1593]	117	!! Madec, 2008, internal report, IPSL.
[3]	118	!!----------------------------------------------------------------------
	119	INTEGER :: istp ! time step index
[389]	120	!!----------------------------------------------------------------------
[2382]	121	!
[392]	122	#if defined key_agrif
[1593]	123	CALL Agrif_Init_Grids() ! AGRIF: set the meshes
[389]	124	#endif
	125
[1593]	126	! !-----------------------!
[2496]	127	CALL nemo_init !== Initialisations ==!
[1593]	128	! !-----------------------!
[2715]	129	#if defined key_agrif
[3680]	130	CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
	131	CALL Agrif_Declare_Var ! " " " " " DYN/TRA
[2715]	132	# if defined key_top
[3680]	133	CALL Agrif_Declare_Var_top ! " " " " " TOP
[2715]	134	# endif
[3680]	135	# if defined key_lim2
	136	CALL Agrif_Declare_Var_lim2 ! " " " " " LIM
	137	# endif
[2715]	138	#endif
[682]	139	! check that all process are still there... If some process have an error,
	140	! they will never enter in step and other processes will wait until the end of the cpu time!
[900]	141	IF( lk_mpp ) CALL mpp_max( nstop )
[682]	142
[1593]	143	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	144
	145	! !-----------------------!
	146	! !== time stepping ==!
	147	! !-----------------------!
[900]	148	istp = nit000
[2236]	149	#if defined key_c1d
[389]	150	DO WHILE ( istp <= nitend .AND. nstop == 0 )
[900]	151	CALL stp_c1d( istp )
[389]	152	istp = istp + 1
	153	END DO
[2236]	154	#else
	155	IF( lk_asminc ) THEN
	156	IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields
	157	IF( ln_asmdin ) THEN ! Direct initialization
	158	IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers
[3764]	159	IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics
[2236]	160	IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH
	161	ENDIF
	162	ENDIF
[3764]	163
[389]	164	DO WHILE ( istp <= nitend .AND. nstop == 0 )
[392]	165	#if defined key_agrif
[1593]	166	CALL Agrif_Step( stp ) ! AGRIF: time stepping
[389]	167	#else
[1593]	168	CALL stp( istp ) ! standard time stepping
[389]	169	#endif
	170	istp = istp + 1
[900]	171	IF( lk_mpp ) CALL mpp_max( nstop )
[389]	172	END DO
[2236]	173	#endif
	174
[3609]	175	IF( lk_diaobs ) CALL dia_obs_wri
	176	!
	177	IF( ln_icebergs ) CALL icb_end( nitend )
[3764]	178
[1593]	179	! !------------------------!
	180	! !== finalize the run ==!
	181	! !------------------------!
	182	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	183	!
	184	IF( nstop /= 0 .AND. lwp ) THEN ! error print
[682]	185	WRITE(numout,cform_err)
[3764]	186	WRITE(numout,*) nstop, ' error have been found'
[389]	187	ENDIF
[1593]	188	!
[3294]	189	#if defined key_agrif
	190	CALL Agrif_ParentGrid_To_ChildGrid()
	191	IF( lk_diaobs ) CALL dia_obs_wri
	192	IF( nn_timing == 1 ) CALL timing_finalize
	193	CALL Agrif_ChildGrid_To_ParentGrid()
	194	#endif
	195	IF( nn_timing == 1 ) CALL timing_finalize
	196	!
[2496]	197	CALL nemo_closefile
[4990]	198	!
[3769]	199	#if defined key_iomput
	200	CALL xios_finalize ! end mpp communications with xios
[5407]	201	IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS
[532]	202	#else
[5407]	203	IF( lk_oasis ) THEN
[4990]	204	CALL cpl_finalize ! end coupling and mpp communications with OASIS
	205	ELSE
	206	IF( lk_mpp ) CALL mppstop ! end mpp communications
	207	ENDIF
[532]	208	#endif
[900]	209	!
[2496]	210	END SUBROUTINE nemo_gcm
[389]	211
	212
[2496]	213	SUBROUTINE nemo_init
[389]	214	!!----------------------------------------------------------------------
[2496]	215	!! * ROUTINE nemo_init *
[389]	216	!!
[2496]	217	!! ** Purpose : initialization of the NEMO GCM
[389]	218	!!----------------------------------------------------------------------
[2715]	219	INTEGER :: ji ! dummy loop indices
	220	INTEGER :: ilocal_comm ! local integer
[4147]	221	INTEGER :: ios
[2715]	222	CHARACTER(len=80), DIMENSION(16) :: cltxt
[4990]	223	!
	224	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
[3294]	225	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
	226	& nn_bench, nn_timing
[4147]	227	NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
[5118]	228	& jpizoom, jpjzoom, jperio, ln_use_jattr
[3]	229	!!----------------------------------------------------------------------
[1593]	230	!
[2496]	231	cltxt = ''
[5407]	232	cxios_context = 'nemo'
[2496]	233	!
[4147]	234	! ! Open reference namelist and configuration namelist files
	235	CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
	236	CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
[1593]	237	!
[4147]	238	REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark
	239	READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
[4289]	240	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
[4147]	241
	242	REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark
	243	READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
[4289]	244	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
[4147]	245
[1593]	246	!
[4147]	247	REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark
	248	READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
[4289]	249	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
[4147]	250
	251	REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark
	252	READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
[4289]	253	904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )
[4309]	254
[4147]	255	! Force values for AGRIF zoom (cf. agrif_user.F90)
	256	#if defined key_agrif
	257	IF( .NOT. Agrif_Root() ) THEN
	258	jpiglo = nbcellsx + 2 + 2*nbghostcells
	259	jpjglo = nbcellsy + 2 + 2*nbghostcells
	260	jpi = ( jpiglo-2jpreci + (jpni-1+0) ) / jpni + 2jpreci
	261	jpj = ( jpjglo-2jprecj + (jpnj-1+0) ) / jpnj + 2jprecj
	262	jpidta = jpiglo
	263	jpjdta = jpjglo
	264	jpizoom = 1
	265	jpjzoom = 1
	266	nperio = 0
	267	jperio = 0
[5118]	268	ln_use_jattr = .false.
[4147]	269	ENDIF
	270	#endif
	271	!
[1593]	272	! !--------------------------------------------!
	273	! ! set communicator & select the local node !
[4624]	274	! ! NB: mynode also opens output.namelist.dyn !
	275	! ! on unit number numond on first proc !
[1593]	276	! !--------------------------------------------!
[1412]	277	#if defined key_iomput
[2200]	278	IF( Agrif_Root() ) THEN
[5407]	279	IF( lk_oasis ) THEN
	280	CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
	281	CALL xios_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios
[4990]	282	ELSE
[5407]	283	CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) ! nemo local communicator given by xios
[4990]	284	ENDIF
[2200]	285	ENDIF
[5407]	286	! Nodes selection (control print return in cltxt)
	287	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
[532]	288	#else
[5407]	289	IF( lk_oasis ) THEN
[4990]	290	IF( Agrif_Root() ) THEN
[5407]	291	CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
[4990]	292	ENDIF
[5407]	293	! Nodes selection (control print return in cltxt)
	294	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
[4990]	295	ELSE
	296	ilocal_comm = 0
[5407]	297	! Nodes selection (control print return in cltxt)
	298	narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
[2236]	299	ENDIF
[532]	300	#endif
[2715]	301	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
[3]	302
[4624]	303	lwm = (narea == 1) ! control of output namelists
[2715]	304	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
[1579]	305
[4624]	306	IF(lwm) THEN
	307	! write merged namelists from earlier to output namelist now that the
	308	! file has been opened in call to mynode. nammpp has already been
	309	! written in mynode (if lk_mpp_mpi)
	310	WRITE( numond, namctl )
	311	WRITE( numond, namcfg )
	312	ENDIF
	313
[3764]	314	! If dimensions of processor grid weren't specified in the namelist file
[2715]	315	! then we calculate them here now that we have our communicator size
	316	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
	317	#if defined key_mpp_mpi
	318	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
	319	#else
	320	jpni = 1
	321	jpnj = 1
	322	jpnij = jpni*jpnj
	323	#endif
	324	END IF
	325
	326	! Calculate domain dimensions given calculated jpni and jpnj
	327	! This used to be done in par_oce.F90 when they were parameters rather
	328	! than variables
	329	IF( Agrif_Root() ) THEN
[3294]	330	#if defined key_nemocice_decomp
[3625]	331	jpi = ( nx_global+2-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
	332	jpj = ( ny_global+2-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
[3294]	333	#else
[3625]	334	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
[2715]	335	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
[3294]	336	#endif
[4147]	337	ENDIF
[2715]	338	jpk = jpkdta ! third dim
	339	jpim1 = jpi-1 ! inner domain indices
	340	jpjm1 = jpj-1 ! " "
	341	jpkm1 = jpk-1 ! " "
	342	jpij = jpi*jpj ! jpi x j
	343
[1593]	344	IF(lwp) THEN ! open listing units
	345	!
[1581]	346	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
[1593]	347	!
[1579]	348	WRITE(numout,*)
[3294]	349	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
[1593]	350	WRITE(numout,*) ' NEMO team'
[1579]	351	WRITE(numout,*) ' Ocean General Circulation Model'
[5120]	352	WRITE(numout,*) ' version 3.6 (2015) '
[1579]	353	WRITE(numout,*)
	354	WRITE(numout,*)
[3764]	355	DO ji = 1, SIZE(cltxt)
[1593]	356	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
[1579]	357	END DO
[1593]	358	WRITE(numout,cform_aaa) ! Flag AAAAAAA
	359	!
[473]	360	ENDIF
[2715]	361
[3764]	362	! Now we know the dimensions of the grid and numout has been set we can
[2715]	363	! allocate arrays
	364	CALL nemo_alloc()
	365
[2496]	366	! !-------------------------------!
	367	! ! NEMO general initialization !
	368	! !-------------------------------!
[473]	369
[2496]	370	CALL nemo_ctl ! Control prints & Benchmark
[531]	371
[2082]	372	! ! Domain decomposition
[1593]	373	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
	374	ELSE ; CALL mpp_init2 ! eliminate land processors
[3]	375	ENDIF
[2382]	376	!
[3294]	377	IF( nn_timing == 1 ) CALL timing_init
	378	!
[2082]	379	! ! General initialization
[2027]	380	CALL phy_cst ! Physical constants
	381	CALL eos_init ! Equation of state
[4245]	382	IF( lk_c1d ) CALL c1d_init ! 1D column configuration
[2027]	383	CALL dom_cfg ! Domain configuration
	384	CALL dom_init ! Domain
[413]	385
[3294]	386	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
	387
[2027]	388	IF( ln_ctl ) CALL prt_ctl_init ! Print control
	389
[3651]	390	CALL istate_init ! ocean initial state (Dynamics and tracers)
	391
[4292]	392	IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics
[3651]	393
[5123]	394	CALL sbc_init ! Forcings : surface module (clem: moved here for bdy purpose)
	395
[4990]	396	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
	397	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
[4292]	398	IF( lk_bdy .AND. lk_tide ) &
[4990]	399	& CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing
[2027]	400
[3294]	401	CALL dyn_nept_init ! simplified form of Neptune effect
[4152]	402	!
	403	IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid
	404	!
	405	! Ocean physics
[2082]	406	! ! Vertical physics
	407	CALL zdf_init ! namelist read
	408	CALL zdf_bfr_init ! bottom friction
	409	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
[2329]	410	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
	411	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
	412	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
[2082]	413	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
[3764]	414	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
[2082]	415	& CALL zdf_ddm_init ! double diffusive mixing
	416	! ! Lateral physics
	417	CALL ldf_tra_init ! Lateral ocean tracer physics
	418	CALL ldf_dyn_init ! Lateral ocean momentum physics
[2392]	419	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
[2082]	420
[2027]	421	! ! Active tracers
	422	CALL tra_qsr_init ! penetrative solar radiation qsr
[2325]	423	CALL tra_bbc_init ! bottom heat flux
[2027]	424	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
[4245]	425	CALL tra_dmp_init ! internal damping trends- tracers
[2027]	426	CALL tra_adv_init ! horizontal & vertical advection
	427	CALL tra_ldf_init ! lateral mixing
	428	CALL tra_zdf_init ! vertical mixing and after tracer fields
	429
	430	! ! Dynamics
[4245]	431	IF( lk_c1d ) CALL dyn_dmp_init ! internal damping trends- momentum
[2027]	432	CALL dyn_adv_init ! advection (vector or flux form)
[2104]	433	CALL dyn_vor_init ! vorticity term including Coriolis
[2027]	434	CALL dyn_ldf_init ! lateral mixing
[2104]	435	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
[2027]	436	CALL dyn_zdf_init ! vertical diffusion
	437	CALL dyn_spg_init ! surface pressure gradient
[3764]	438
[2392]	439	! ! Misc. options
[4147]	440	IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_init ! Cross Land Advection
[3609]	441	CALL icb_init( rdt, nit000) ! initialise icebergs instance
[5329]	442	CALL sto_par_init ! Stochastic parametrization
	443	IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations
[4147]	444
[1594]	445	#if defined key_top
[2027]	446	! ! Passive tracers
[2082]	447	CALL trc_init
[1594]	448	#endif
[4990]	449	! ! Diagnostics
[3294]	450	IF( lk_floats ) CALL flo_init ! drifting Floats
[2392]	451	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
[2027]	452	CALL dia_ptr_init ! Poleward TRansports initialization
[3294]	453	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
[2148]	454	CALL dia_hsb_init ! heat content, salt content and volume budgets
[4990]	455	CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends
[2392]	456	IF( lk_diaobs ) THEN ! Observation & model comparison
[2382]	457	CALL dia_obs_init ! Initialize observational data
	458	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
[3764]	459	ENDIF
[4990]	460
[2382]	461	! ! Assimilation increments
[2392]	462	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
[2382]	463	IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
[1593]	464	!
[2496]	465	END SUBROUTINE nemo_init
[467]	466
	467
[2496]	468	SUBROUTINE nemo_ctl
[467]	469	!!----------------------------------------------------------------------
[2496]	470	!! * ROUTINE nemo_ctl *
[467]	471	!!
[3764]	472	!! ** Purpose : control print setting
[467]	473	!!
[2442]	474	!! ** Method : - print namctl information and check some consistencies
[467]	475	!!----------------------------------------------------------------------
[2442]	476	!
[2496]	477	IF(lwp) THEN ! control print
[531]	478	WRITE(numout,*)
[2496]	479	WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
[531]	480	WRITE(numout,*) '~~~~~~~ '
[1593]	481	WRITE(numout,*) ' Namelist namctl'
[1601]	482	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
	483	WRITE(numout,*) ' level of print nn_print = ', nn_print
	484	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
	485	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
	486	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
	487	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
	488	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
	489	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
	490	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
[3610]	491	WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing
[531]	492	ENDIF
[2442]	493	!
[1601]	494	nprint = nn_print ! convert DOCTOR namelist names into OLD names
	495	nictls = nn_ictls
	496	nictle = nn_ictle
	497	njctls = nn_jctls
	498	njctle = nn_jctle
	499	isplt = nn_isplt
	500	jsplt = nn_jsplt
	501	nbench = nn_bench
[4147]	502
	503	IF(lwp) THEN ! control print
	504	WRITE(numout,*)
	505	WRITE(numout,*) 'namcfg : configuration initialization through namelist read'
	506	WRITE(numout,*) '~~~~~~~ '
	507	WRITE(numout,*) ' Namelist namcfg'
	508	WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg)
	509	WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz)
	510	WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg
	511	WRITE(numout,*) ' 1st lateral dimension ( >= jpi ) jpidta = ', jpidta
	512	WRITE(numout,*) ' 2nd " " ( >= jpj ) jpjdta = ', jpjdta
	513	WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta
	514	WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo
	515	WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo
	516	WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
	517	WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
	518	WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio
[5118]	519	WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
[4147]	520	ENDIF
[2442]	521	! ! Parameter control
[1593]	522	!
	523	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
[3294]	524	IF( lk_mpp .AND. jpnij > 1 ) THEN
[2496]	525	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
[531]	526	ELSE
	527	IF( isplt == 1 .AND. jsplt == 1 ) THEN
[1593]	528	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
	529	& ' - the print control will be done over the whole domain' )
[531]	530	ENDIF
[1593]	531	ijsplt = isplt * jsplt ! total number of processors ijsplt
[531]	532	ENDIF
	533	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
	534	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
[1593]	535	!
	536	! ! indices used for the SUM control
	537	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
[3764]	538	lsp_area = .FALSE.
[1593]	539	ELSE ! print control done over a specific area
[531]	540	lsp_area = .TRUE.
	541	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
	542	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
	543	nictls = 1
	544	ENDIF
	545	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
	546	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
	547	nictle = jpiglo
	548	ENDIF
	549	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
	550	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
	551	njctls = 1
	552	ENDIF
	553	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
	554	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
	555	njctle = jpjglo
	556	ENDIF
[1593]	557	ENDIF
	558	ENDIF
[2442]	559	!
[3764]	560	IF( nbench == 1 ) THEN ! Benchmark
[531]	561	SELECT CASE ( cp_cfg )
[1593]	562	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
	563	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
[4147]	564	& ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
[531]	565	END SELECT
	566	ENDIF
[1593]	567	!
[3764]	568	IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', &
	569	& 'f2003 standard. ' , &
	570	& 'Compile with key_nosignedzero enabled' )
	571	!
[2496]	572	END SUBROUTINE nemo_ctl
[467]	573
	574
[2496]	575	SUBROUTINE nemo_closefile
[467]	576	!!----------------------------------------------------------------------
[2496]	577	!! * ROUTINE nemo_closefile *
[467]	578	!!
	579	!! ** Purpose : Close the files
	580	!!----------------------------------------------------------------------
[1593]	581	!
	582	IF( lk_mpp ) CALL mppsync
	583	!
[1685]	584	CALL iom_close ! close all input/output files managed by iom_*
[1593]	585	!
[4147]	586	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
	587	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
	588	IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist
	589	IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist
[4624]	590	IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
[4147]	591	IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist
	592	IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist
[4624]	593	IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
[4147]	594	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
	595	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
	596	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
	597	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
	598	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
[7701]	599	IF( numstr /= -1 ) CLOSE( numstr ) ! tracer statistics
[3294]	600
[1593]	601	!
[2442]	602	numout = 6 ! redefine numout in case it is used after this point...
	603	!
[2496]	604	END SUBROUTINE nemo_closefile
[467]	605
[2715]	606
	607	SUBROUTINE nemo_alloc
	608	!!----------------------------------------------------------------------
	609	!! * ROUTINE nemo_alloc *
	610	!!
	611	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
	612	!!
	613	!! ** Method :
	614	!!----------------------------------------------------------------------
	615	USE diawri , ONLY: dia_wri_alloc
	616	USE dom_oce , ONLY: dom_oce_alloc
	617	USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
	618	USE ldftra_oce, ONLY: ldftra_oce_alloc
	619	USE trc_oce , ONLY: trc_oce_alloc
[3680]	620	#if defined key_diadct
	621	USE diadct , ONLY: diadct_alloc
	622	#endif
[4354]	623	#if defined key_bdy
	624	USE bdy_oce , ONLY: bdy_oce_alloc
	625	#endif
[2715]	626	!
	627	INTEGER :: ierr
	628	!!----------------------------------------------------------------------
	629	!
[3764]	630	ierr = oce_alloc () ! ocean
[2715]	631	ierr = ierr + dia_wri_alloc ()
	632	ierr = ierr + dom_oce_alloc () ! ocean domain
	633	ierr = ierr + ldfdyn_oce_alloc() ! ocean lateral physics : dynamics
	634	ierr = ierr + ldftra_oce_alloc() ! ocean lateral physics : tracers
	635	ierr = ierr + zdf_oce_alloc () ! ocean vertical physics
	636	!
	637	ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays
	638	!
[3680]	639	#if defined key_diadct
	640	ierr = ierr + diadct_alloc () !
	641	#endif
[4354]	642	#if defined key_bdy
	643	ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization)
	644	#endif
[3680]	645	!
[2715]	646	IF( lk_mpp ) CALL mpp_sum( ierr )
	647	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
	648	!
	649	END SUBROUTINE nemo_alloc
	650
	651
	652	SUBROUTINE nemo_partition( num_pes )
	653	!!----------------------------------------------------------------------
	654	!! * ROUTINE nemo_partition *
	655	!!
[3764]	656	!! ** Purpose :
[2715]	657	!!
	658	!! ** Method :
	659	!!----------------------------------------------------------------------
[4990]	660	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
[2715]	661	!
	662	INTEGER, PARAMETER :: nfactmax = 20
	663	INTEGER :: nfact ! The no. of factors returned
	664	INTEGER :: ierr ! Error flag
	665	INTEGER :: ji
	666	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
	667	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
	668	!!----------------------------------------------------------------------
[4990]	669	!
[2715]	670	ierr = 0
[4990]	671	!
[2715]	672	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
[4990]	673	!
[2715]	674	IF( nfact <= 1 ) THEN
	675	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
	676	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
	677	jpnj = 1
	678	jpni = num_pes
	679	ELSE
	680	! Search through factors for the pair that are closest in value
	681	mindiff = 1000000
	682	imin = 1
	683	DO ji = 1, nfact-1, 2
	684	idiff = ABS( ifact(ji) - ifact(ji+1) )
	685	IF( idiff < mindiff ) THEN
	686	mindiff = idiff
	687	imin = ji
	688	ENDIF
	689	END DO
	690	jpnj = ifact(imin)
	691	jpni = ifact(imin + 1)
	692	ENDIF
	693	!
	694	jpnij = jpni*jpnj
	695	!
	696	END SUBROUTINE nemo_partition
	697
	698
	699	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
	700	!!----------------------------------------------------------------------
	701	!! * ROUTINE factorise *
	702	!!
	703	!! ** Purpose : return the prime factors of n.
[3764]	704	!! knfax factors are returned in array kfax which is of
[2715]	705	!! maximum dimension kmaxfax.
	706	!! ** Method :
	707	!!----------------------------------------------------------------------
	708	INTEGER , INTENT(in ) :: kn, kmaxfax
	709	INTEGER , INTENT( out) :: kerr, knfax
	710	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
	711	!
	712	INTEGER :: ifac, jl, inu
	713	INTEGER, PARAMETER :: ntest = 14
	714	INTEGER :: ilfax(ntest)
[4990]	715	!
[2715]	716	! lfax contains the set of allowed factors.
	717	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
	718	& 128, 64, 32, 16, 8, 4, 2 /
	719	!!----------------------------------------------------------------------
	720
	721	! Clear the error flag and initialise output vars
	722	kerr = 0
	723	kfax = 1
	724	knfax = 0
	725
	726	! Find the factors of n.
	727	IF( kn == 1 ) GOTO 20
	728
	729	! nu holds the unfactorised part of the number.
	730	! knfax holds the number of factors found.
	731	! l points to the allowed factor list.
	732	! ifac holds the current factor.
	733
	734	inu = kn
	735	knfax = 0
	736
	737	DO jl = ntest, 1, -1
	738	!
	739	ifac = ilfax(jl)
	740	IF( ifac > inu ) CYCLE
	741
	742	! Test whether the factor will divide.
	743
	744	IF( MOD(inu,ifac) == 0 ) THEN
	745	!
	746	knfax = knfax + 1 ! Add the factor to the list
	747	IF( knfax > kmaxfax ) THEN
	748	kerr = 6
	749	write (,) 'FACTOR: insufficient space in factor array ', knfax
	750	return
	751	ENDIF
	752	kfax(knfax) = ifac
	753	! Store the other factor that goes with this one
	754	knfax = knfax + 1
	755	kfax(knfax) = inu / ifac
	756	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
	757	ENDIF
	758	!
	759	END DO
	760
	761	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
	762	!
	763	END SUBROUTINE factorise
	764
[3294]	765	#if defined key_mpp_mpi
[4990]	766
[3294]	767	SUBROUTINE nemo_northcomms
	768	!!======================================================================
	769	!! * ROUTINE nemo_northcomms *
[4230]	770	!! nemo_northcomms : Setup for north fold exchanges with explicit
	771	!! point-to-point messaging
[3294]	772	!!=====================================================================
	773	!!----------------------------------------------------------------------
[3764]	774	!!
[3294]	775	!! ** Purpose : Initialization of the northern neighbours lists.
	776	!!----------------------------------------------------------------------
[3764]	777	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
[4230]	778	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
[3294]	779	!!----------------------------------------------------------------------
	780
[4230]	781	INTEGER :: sxM, dxM, sxT, dxT, jn
	782	INTEGER :: njmppmax
[3294]	783
[4230]	784	njmppmax = MAXVAL( njmppt )
	785
	786	!initializes the north-fold communication variables
	787	isendto(:) = 0
[3294]	788	nsndto = 0
	789
[4230]	790	!if I am a process in the north
	791	IF ( njmpp == njmppmax ) THEN
	792	!sxM is the first point (in the global domain) needed to compute the
	793	!north-fold for the current process
	794	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
	795	!dxM is the last point (in the global domain) needed to compute the
	796	!north-fold for the current process
	797	dxM = jpiglo - nimppt(narea) + 2
[3294]	798
[4230]	799	!loop over the other north-fold processes to find the processes
	800	!managing the points belonging to the sxT-dxT range
[4671]	801
	802	DO jn = 1, jpni
[4230]	803	!sxT is the first point (in the global domain) of the jn
	804	!process
[4671]	805	sxT = nfiimpp(jn, jpnj)
[4230]	806	!dxT is the last point (in the global domain) of the jn
	807	!process
[4671]	808	dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
[4230]	809	IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
	810	nsndto = nsndto + 1
[4671]	811	isendto(nsndto) = jn
[4645]	812	ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
[4230]	813	nsndto = nsndto + 1
[4671]	814	isendto(nsndto) = jn
[4230]	815	ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
	816	nsndto = nsndto + 1
[4671]	817	isendto(nsndto) = jn
[4230]	818	END IF
	819	END DO
[4671]	820	nfsloop = 1
	821	nfeloop = nlci
	822	DO jn = 2,jpni-1
	823	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
	824	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
	825	nfsloop = nldi
	826	ENDIF
	827	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
	828	nfeloop = nlei
	829	ENDIF
	830	ENDIF
	831	END DO
	832
[3294]	833	ENDIF
[4230]	834	l_north_nogather = .TRUE.
[3294]	835	END SUBROUTINE nemo_northcomms
	836	#else
	837	SUBROUTINE nemo_northcomms ! Dummy routine
	838	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
	839	END SUBROUTINE nemo_northcomms
	840	#endif
[4990]	841
[3]	842	!!======================================================================
[2496]	843	END MODULE nemogcm
[4354]	844
	845

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_MEDUSA_optim_RH/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 7701

Download in other formats: