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_tam.F90 in branches/2012/dev_r3604_LEGI8_TAM/NEMOGCM/NEMO/OPATAM_SRC – NEMO

Context Navigation

source: branches/2012/dev_r3604_LEGI8_TAM/NEMOGCM/NEMO/OPATAM_SRC/nemogcm_tam.F90 @ 3612

Last change on this file since 3612 was 3612, checked in by pabouttier, 11 years ago
Fix allocation of rnf variable for GYRE in NEMOTAM - see ticket #1008
File size: 37.1 KB

Rev	Line
[3611]	1	MODULE nemogcm_tam
	2	#if defined key_tam
	3	!!======================================================================
	4	!! * MODULE nemogcm *
	5	!! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
	6	!!======================================================================
	7	!! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code
	8	!! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec)
	9	!! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
	10	!! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
	11	!! - ! 1992-06 (L.Terray) coupling implementation
	12	!! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice
	13	!! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
	14	!! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
	15	!! 8.1 ! 1997-06 (M. Imbard, G. Madec)
	16	!! 8.2 ! 1999-11 (M. Imbard, H. Goosse) LIM sea-ice model
	17	!! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP
	18	!! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER)
	19	!! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules
	20	!! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
	21	!! - ! 2004-08 (C. Talandier) New trends organization
	22	!! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility
	23	!! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
	24	!! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation
	25	!! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization
	26	!! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
	27	!! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp
	28	!! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
	29	!! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
	30	!! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
	31	!! 3.4 ! 2011-11 (C. Harris) decomposition changes for running with CICE
	32	!! History of TAM:
	33	!! 3.4 ! 2012-07 (P.-A. Bouttier) Phasing with 3.4 version
	34	!!----------------------------------------------------------------------
	35
	36	!!----------------------------------------------------------------------
	37	!! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
	38	!! nemo_init : initialization of the NEMO system
	39	!! nemo_ctl : initialisation of the contol print
	40	!! nemo_closefile : close remaining open files
	41	!! nemo_alloc : dynamical allocation
	42	!! nemo_partition : calculate MPP domain decomposition
	43	!! factorise : calculate the factors of the no. of MPI processes
	44	!!----------------------------------------------------------------------
	45	USE step_oce ! module used in the ocean time stepping module
	46	USE sbc_oce ! surface boundary condition: ocean
	47	USE cla ! cross land advection (tra_cla routine)
	48	USE domcfg ! domain configuration (dom_cfg routine)
	49	USE mppini ! shared/distributed memory setting (mpp_init routine)
	50	USE domain ! domain initialization (dom_init routine)
	51	USE obcini ! open boundary cond. initialization (obc_ini routine)
	52	USE bdyini ! open boundary cond. initialization (bdy_init routine)
	53	USE bdydta ! open boundary cond. initialization (bdy_dta_init routine)
	54	USE bdytides ! open boundary cond. initialization (tide_init routine)
	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)
	58	USE zdfini ! vertical physics setting (zdf_init routine)
	59	USE phycst ! physical constant (par_cst routine)
	60	USE trdmod ! momentum/tracers trends (trd_mod_init routine)
	61	USE diaptr ! poleward transports (dia_ptr_init routine)
	62	USE diadct ! sections transports (dia_dct_init routine)
	63	USE diaobs ! Observation diagnostics (dia_obs_init routine)
	64	USE step ! NEMO time-stepping (stp routine)
	65	USE tradmp
	66	USE trabbl
	67	#if defined key_oasis3
	68	USE cpl_oasis3 ! OASIS3 coupling
	69	#elif defined key_oasis4
	70	USE cpl_oasis4 ! OASIS4 coupling (not working)
	71	#endif
	72	USE c1d ! 1D configuration
	73	USE step_c1d ! Time stepping loop for the 1D configuration
	74	#if defined key_top
	75	USE trcini ! passive tracer initialisation
	76	#endif
	77	USE lib_mpp ! distributed memory computing
	78	#if defined key_iomput
	79	USE mod_ioclient
	80	#endif
	81	USE nemogcm
	82	USE step_tam
	83	USE step_oce_tam
	84	USE zdf_oce_tam
	85	USE trabbl_tam
	86	USE tamtst
	87	USE tamctl
	88	USE lib_mpp_tam
	89	USE tamtrj
	90	!USE trj_tam
	91	IMPLICIT NONE
	92	PRIVATE
	93
	94	PUBLIC nemo_gcm_tam ! called by model.F90
	95	PUBLIC nemo_init_tam ! needed by AGRIF
	96
	97	CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
	98
	99	!!----------------------------------------------------------------------
	100	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
	101	!! $Id$
	102	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	103	!!----------------------------------------------------------------------
	104	CONTAINS
	105
	106	SUBROUTINE nemo_gcm_tam
	107	!!----------------------------------------------------------------------
	108	!! * ROUTINE nemo_gcm_tam *
	109	!!
	110	!! ** Purpose : NEMO solves the primitive equations on an orthogonal
	111	!! curvilinear mesh on the sphere.
	112	!!
	113	!! ** Method : - model general initialization
	114	!! - launch the time-stepping (stp routine)
	115	!! - finalize the run by closing files and communications
	116	!!
	117	!! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
	118	!! Madec, 2008, internal report, IPSL.
	119	!!----------------------------------------------------------------------
	120	INTEGER :: istp ! time step index
	121	!!----------------------------------------------------------------------
	122	! !-----------------------!
	123	! !== Initialisations ==!
	124	CALL nemo_init_tam !-----------------------!
	125	!
	126	! check that all process are still there... If some process have an error,
	127	! they will never enter in step and other processes will wait until the end of the cpu time!
	128	IF( lk_mpp ) CALL mpp_max( nstop )
	129
	130	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	131
	132	! !-----------------------!
	133	! !== time stepping ==!
	134	! !-----------------------!
	135	istp = nit000
	136	CALL tam_tst
	137	! !------------------------!
	138	! !== finalize the run ==!
	139	! !------------------------!
	140	IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
	141	!
	142	IF( nstop /= 0 .AND. lwp ) THEN ! error print
	143	WRITE(numout,cform_err)
	144	WRITE(numout,*) nstop, ' error have been found'
	145	ENDIF
	146	!
	147	IF( nn_timing == 1 ) CALL timing_finalize
	148	!!
	149	CALL nemo_closefile
	150	IF( lk_mpp ) CALL mppstop ! end mpp communications
	151	!
	152	END SUBROUTINE nemo_gcm_tam
	153
	154
	155	SUBROUTINE nemo_init_tam
	156	!!----------------------------------------------------------------------
	157	!! * ROUTINE nemo_init *
	158	!!
	159	!! ** Purpose : initialization of the NEMO GCM
	160	!!----------------------------------------------------------------------
	161	INTEGER :: ji ! dummy loop indices
	162	INTEGER :: ilocal_comm ! local integer
	163	CHARACTER(len=80), DIMENSION(16) :: cltxt
	164	!!
	165	NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &
	166	& nn_isplt, nn_jsplt, nn_jctls, nn_jctle, &
	167	& nn_bench, nn_timing
	168	!!----------------------------------------------------------------------
	169	!
	170	cltxt = ''
	171	!
	172	! ! open Namelist file
	173	CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
	174	!!
	175	READ( numnam, namctl ) ! Namelist namctl : Control prints & Benchmark
	176	!
	177	! !--------------------------------------------!
	178	! ! set communicator & select the local node !
	179	! !--------------------------------------------!
	180	ilocal_comm = 0
	181	narea = mynode( cltxt, numnam, nstop ) ! Nodes selection (control print return in cltxt)
	182	narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )
	183
	184	lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print
	185
	186	! If dimensions of processor grid weren't specified in the namelist file
	187	! then we calculate them here now that we have our communicator size
	188	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
	189	#if defined key_mpp_mpi
	190	IF( Agrif_Root() ) CALL nemo_partition(mppsize)
	191	#else
	192	jpni = 1
	193	jpnj = 1
	194	jpnij = jpni*jpnj
	195	#endif
	196	END IF
	197
	198	! Calculate domain dimensions given calculated jpni and jpnj
	199	! This used to be done in par_oce.F90 when they were parameters rather
	200	! than variables
	201	IF( Agrif_Root() ) THEN
	202	jpi = ( jpiglo-2jpreci + (jpni-1) ) / jpni + 2jpreci ! first dim.
	203	jpj = ( jpjglo-2jprecj + (jpnj-1) ) / jpnj + 2jprecj ! second dim.
	204	jpk = jpkdta ! third dim
	205	jpim1 = jpi-1 ! inner domain indices
	206	jpjm1 = jpj-1 ! " "
	207	jpkm1 = jpk-1 ! " "
	208	jpij = jpi*jpj ! jpi x j
	209	ENDIF
	210
	211	IF(lwp) THEN ! open listing units
	212	!
	213	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
	214	!
	215	WRITE(numout,*)
	216	WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
	217	WRITE(numout,*) ' NEMO team'
	218	WRITE(numout,*) ' Ocean General Circulation Model'
	219	WRITE(numout,*) ' version 3.4 (2011) '
	220	WRITE(numout,*) ' NEMOTAM '
	221	WRITE(numout,*)
	222	WRITE(numout,*)
	223	DO ji = 1, SIZE(cltxt)
	224	IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode
	225	END DO
	226	WRITE(numout,cform_aaa) ! Flag AAAAAAA
	227	!
	228	ENDIF
	229
	230	! Now we know the dimensions of the grid and numout has been set we can
	231	! allocate arrays
	232	CALL nemo_alloc()
	233
	234	! ! Domain decomposition
	235	IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out
	236	ELSE ; CALL mpp_init2 ! eliminate land processors
	237	ENDIF
	238	!
	239	IF( nn_timing == 1 ) CALL timing_init
	240	!
	241	! ! General initialization
	242	CALL phy_cst ! Physical constants
	243	CALL eos_init ! Equation of state
	244	CALL dom_cfg ! Domain configuration
	245	CALL dom_init ! Domain
	246
	247	IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)
	248
	249	IF( ln_ctl ) CALL prt_ctl_init ! Print control
	250
	251	IF( lk_obc ) CALL obc_init ! Open boundaries
	252	IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation
	253	IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays
	254	IF( lk_bdy ) CALL tide_init ! Open boundaries initialisation of tidal harmonic forcing
	255
	256	CALL flush(numout)
	257	CALL dyn_nept_init ! simplified form of Neptune effect
	258	CALL flush(numout)
	259
	260	CALL istate_init ! ocean initial state (Dynamics and tracers)
	261
	262	! ! Ocean physics
	263	CALL sbc_init ! Forcings : surface module
	264	! ! Vertical physics
	265	CALL zdf_init ! namelist read
	266	CALL zdf_bfr_init ! bottom friction
	267	IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
	268	IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
	269	IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
	270	IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
	271	IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
	272	IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
	273	& CALL zdf_ddm_init ! double diffusive mixing
	274	! ! Lateral physics
	275	CALL ldf_tra_init ! Lateral ocean tracer physics
	276	CALL ldf_dyn_init ! Lateral ocean momentum physics
	277	IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
	278
	279	! ! Active tracers
	280	CALL tra_qsr_init ! penetrative solar radiation qsr
	281	CALL tra_bbc_init ! bottom heat flux
	282	IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme
	283	IF( ln_tradmp ) CALL tra_dmp_init ! internal damping trends
	284	CALL tra_adv_init ! horizontal & vertical advection
	285	CALL tra_ldf_init ! lateral mixing
	286	CALL tra_zdf_init ! vertical mixing and after tracer fields
	287
	288	! ! Dynamics
	289	CALL dyn_adv_init ! advection (vector or flux form)
	290	CALL dyn_vor_init ! vorticity term including Coriolis
	291	CALL dyn_ldf_init ! lateral mixing
	292	CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure
	293	CALL dyn_zdf_init ! vertical diffusion
	294	CALL dyn_spg_init ! surface pressure gradient
	295
	296	! ! Misc. options
	297	IF( nn_cla == 1 ) CALL cla_init ! Cross Land Advection
	298
	299	#if defined key_top
	300	! ! Passive tracers
	301	CALL trc_init
	302	#endif
	303	! ! Diagnostics
	304	IF( lk_floats ) CALL flo_init ! drifting Floats
	305	CALL iom_init ! iom_put initialization
	306	IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
	307	CALL dia_ptr_init ! Poleward TRansports initialization
	308	IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
	309	CALL dia_hsb_init ! heat content, salt content and volume budgets
	310	CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
	311	IF( lk_diaobs ) THEN ! Observation & model comparison
	312	CALL dia_obs_init ! Initialize observational data
	313	CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
	314	ENDIF
	315	! ! Assimilation increments
	316	IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
	317	!
[3612]	318	IF( ln_rnf ) CALL sbc_rnf_init
[3611]	319	!!!!!!!!!!!!! TAM initialisation !!!!!!!!!!!!!!!!!!!!!!!!!!!
	320	CALL nemo_alloc_tam
	321	CALL nemo_ctl_tam ! Control prints & Benchmark
	322
	323	CALL istate_init_tan ! ocean initial state (Dynamics and tracers)
	324	CALL istate_init_adj ! ocean initial state (Dynamics and tracers)
	325	! ! Ocean physics
	326	CALL sbc_init_tam ! Forcings : surface module
	327	! ! Vertical physics
	328	! CALL zdf_init_tam ! namelist read
	329	!IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz
	330	!IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme
	331	!IF( lk_zdfgls ) CALL zdf_gls_init ! GLS closure scheme
	332	!IF( lk_zdfkpp ) CALL zdf_kpp_init ! KPP closure scheme
	333	!IF( lk_zdftmx ) CALL zdf_tmx_init ! tidal vertical mixing
	334	!IF( lk_zdfddm .AND. .NOT. lk_zdfkpp ) &
	335	!& CALL zdf_ddm_init ! double diffusive mixing
	336	! ! Lateral physics
	337	!CALL ldf_tra_init ! Lateral ocean tracer physics
	338	!CALL ldf_dyn_init ! Lateral ocean momentum physics
	339	!IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing
	340
	341	! ! Active tracers
	342	CALL tra_qsr_init_tam ! penetrative solar radiation qsr
	343	IF( lk_trabbl ) CALL tra_bbl_init_tam ! advective (and/or diffusive) bottom boundary layer scheme
	344	IF( ln_tradmp ) CALL tra_dmp_init_tam ! internal damping trends
	345	CALL tra_adv_init_tam ! horizontal & vertical advection
	346	CALL tra_ldf_init_tam ! lateral mixing
	347	CALL tra_zdf_init_tam ! vertical mixing and after tracer fields
	348
	349	! ! Dynamics
	350	CALL dyn_adv_init_tam ! advection (vector or flux form)
	351	CALL dyn_vor_init_tam ! vorticity term including Coriolis
	352	CALL dyn_ldf_init_tam ! lateral mixing
	353	CALL dyn_hpg_init_tam ! horizontal gradient of Hydrostatic pressure
	354	CALL dyn_zdf_init_tam ! vertical diffusion
	355	CALL dyn_spg_init_tam ! surface pressure gradient
	356
	357	! ! Misc. options
	358	IF( nn_cla == 1 ) CALL cla_init_tam ! Cross Land Advection
	359	CALL sbc_rnf_init_tam
	360	!#if defined key_top
	361	!! ! Passive tracers
	362	!CALL trc_init
	363	!#endif
	364	!! ! Diagnostics
	365	!IF( lk_floats ) CALL flo_init ! drifting Floats
	366	!CALL iom_init ! iom_put initialization
	367	!IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag
	368	!CALL dia_ptr_init ! Poleward TRansports initialization
	369	!IF( lk_diadct ) CALL dia_dct_init ! Sections tranports
	370	!CALL dia_hsb_init ! heat content, salt content and volume budgets
	371	!CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends
	372	!IF( lk_diaobs ) THEN ! Observation & model comparison
	373	!CALL dia_obs_init ! Initialize observational data
	374	!CALL dia_obs( nit000 - 1 ) ! Observation operator for restart
	375	!ENDIF
	376	!! ! Assimilation increments
	377	!IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments
	378	!IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
	379	!
	380	CALL tam_trj_init
	381	CALL tam_tst_init
	382	!CALL tl_trj_ini
	383	END SUBROUTINE nemo_init_tam
	384
	385
	386	SUBROUTINE nemo_ctl_tam
	387	!!----------------------------------------------------------------------
	388	!! * ROUTINE nemo_ctl *
	389	!!
	390	!! ** Purpose : control print setting
	391	!!
	392	!! ** Method : - print namctl information and check some consistencies
	393	!!----------------------------------------------------------------------
	394	!
	395	IF(lwp) THEN ! control print
	396	WRITE(numout,*)
	397	WRITE(numout,*) 'nemo_ctl_tam: Control prints & Benchmark'
	398	WRITE(numout,*) '~~~~~~~ '
	399	WRITE(numout,*) ' Namelist namctl'
	400	WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl
	401	WRITE(numout,*) ' level of print nn_print = ', nn_print
	402	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
	403	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
	404	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
	405	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
	406	WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
	407	WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
	408	WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench
	409	ENDIF
	410	!
	411	nprint = nn_print ! convert DOCTOR namelist names into OLD names
	412	nictls = nn_ictls
	413	nictle = nn_ictle
	414	njctls = nn_jctls
	415	njctle = nn_jctle
	416	isplt = nn_isplt
	417	jsplt = nn_jsplt
	418	nbench = nn_bench
	419	! ! Parameter control
	420	!
	421	IF( ln_ctl ) THEN ! sub-domain area indices for the control prints
	422	IF( lk_mpp .AND. jpnij > 1 ) THEN
	423	isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
	424	ELSE
	425	IF( isplt == 1 .AND. jsplt == 1 ) THEN
	426	CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
	427	& ' - the print control will be done over the whole domain' )
	428	ENDIF
	429	ijsplt = isplt * jsplt ! total number of processors ijsplt
	430	ENDIF
	431	IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
	432	IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
	433	!
	434	! ! indices used for the SUM control
	435	IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
	436	lsp_area = .FALSE.
	437	ELSE ! print control done over a specific area
	438	lsp_area = .TRUE.
	439	IF( nictls < 1 .OR. nictls > jpiglo ) THEN
	440	CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
	441	nictls = 1
	442	ENDIF
	443	IF( nictle < 1 .OR. nictle > jpiglo ) THEN
	444	CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
	445	nictle = jpiglo
	446	ENDIF
	447	IF( njctls < 1 .OR. njctls > jpjglo ) THEN
	448	CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
	449	njctls = 1
	450	ENDIF
	451	IF( njctle < 1 .OR. njctle > jpjglo ) THEN
	452	CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
	453	njctle = jpjglo
	454	ENDIF
	455	ENDIF
	456	ENDIF
	457	!
	458	IF( nbench == 1 ) THEN ! Benchmark
	459	SELECT CASE ( cp_cfg )
	460	CASE ( 'gyre' ) ; CALL ctl_warn( ' The Benchmark is activated ' )
	461	CASE DEFAULT ; CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:', &
	462	& ' key_gyre must be used or set nbench = 0' )
	463	END SELECT
	464	ENDIF
	465	!
	466	IF( lk_c1d .AND. .NOT.lk_iomput ) CALL ctl_stop( 'nemo_ctl_tam: The 1D configuration must be used ', &
	467	& 'with the IOM Input/Output manager. ' , &
	468	& 'Compile with key_iomput enabled' )
	469	!
	470	END SUBROUTINE nemo_ctl_tam
	471
	472
	473	SUBROUTINE nemo_closefile
	474	!!----------------------------------------------------------------------
	475	!! * ROUTINE nemo_closefile *
	476	!!
	477	!! ** Purpose : Close the files
	478	!!----------------------------------------------------------------------
	479	!
	480	IF( lk_mpp ) CALL mppsync
	481	!
	482	CALL iom_close ! close all input/output files managed by iom_*
	483	!
	484	IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
	485	IF( numsol /= -1 ) CLOSE( numsol ) ! solver file
	486	IF( numnam /= -1 ) CLOSE( numnam ) ! oce namelist
	487	IF( numnam_ice /= -1 ) CLOSE( numnam_ice ) ! ice namelist
	488	IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
	489	IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
	490	IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
	491	IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
	492	IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
	493	!
	494	numout = 6 ! redefine numout in case it is used after this point...
	495	!
	496	END SUBROUTINE nemo_closefile
	497
	498
	499	SUBROUTINE nemo_alloc_tam
	500	!!----------------------------------------------------------------------
	501	!! * ROUTINE nemo_alloc *
	502	!!
	503	!! ** Purpose : Allocate all the dynamic arrays of the OPA modules
	504	!!
	505	!! ** Method :
	506	!!----------------------------------------------------------------------
	507	!
	508	INTEGER :: ierr
	509	!!----------------------------------------------------------------------
	510	!
	511	ierr = oce_alloc_tam ( 0 ) ! ocean
	512	ierr = ierr + zdf_oce_alloc_tam ( ) ! ocean vertical physics
	513	!
	514	ierr = ierr + lib_mpp_alloc_adj (numout) ! mpp exchanges
	515	ierr = ierr + trc_oce_alloc_tam ( 0 ) ! shared TRC / TRA arrays
	516	ierr = ierr + sbc_oce_alloc_tam ( 0 ) ! shared TRC / TRA arrays
	517	ierr = ierr + sol_oce_alloc_tam ( 0 ) ! shared TRC / TRA arrays
	518	!
	519	IF( lk_mpp ) CALL mpp_sum( ierr )
	520	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc_tam : unable to allocate standard ocean arrays' )
	521	!
	522	END SUBROUTINE nemo_alloc_tam
	523
	524
	525	SUBROUTINE nemo_partition( num_pes )
	526	!!----------------------------------------------------------------------
	527	!! * ROUTINE nemo_partition *
	528	!!
	529	!! ** Purpose :
	530	!!
	531	!! ** Method :
	532	!!----------------------------------------------------------------------
	533	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
	534	!
	535	INTEGER, PARAMETER :: nfactmax = 20
	536	INTEGER :: nfact ! The no. of factors returned
	537	INTEGER :: ierr ! Error flag
	538	INTEGER :: ji
	539	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
	540	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
	541	!!----------------------------------------------------------------------
	542
	543	ierr = 0
	544
	545	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
	546
	547	IF( nfact <= 1 ) THEN
	548	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
	549	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
	550	jpnj = 1
	551	jpni = num_pes
	552	ELSE
	553	! Search through factors for the pair that are closest in value
	554	mindiff = 1000000
	555	imin = 1
	556	DO ji = 1, nfact-1, 2
	557	idiff = ABS( ifact(ji) - ifact(ji+1) )
	558	IF( idiff < mindiff ) THEN
	559	mindiff = idiff
	560	imin = ji
	561	ENDIF
	562	END DO
	563	jpnj = ifact(imin)
	564	jpni = ifact(imin + 1)
	565	ENDIF
	566	!
	567	jpnij = jpni*jpnj
	568	!
	569	END SUBROUTINE nemo_partition
	570
	571
	572	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
	573	!!----------------------------------------------------------------------
	574	!! * ROUTINE factorise *
	575	!!
	576	!! ** Purpose : return the prime factors of n.
	577	!! knfax factors are returned in array kfax which is of
	578	!! maximum dimension kmaxfax.
	579	!! ** Method :
	580	!!----------------------------------------------------------------------
	581	INTEGER , INTENT(in ) :: kn, kmaxfax
	582	INTEGER , INTENT( out) :: kerr, knfax
	583	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
	584	!
	585	INTEGER :: ifac, jl, inu
	586	INTEGER, PARAMETER :: ntest = 14
	587	INTEGER :: ilfax(ntest)
	588
	589	! lfax contains the set of allowed factors.
	590	data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, &
	591	& 128, 64, 32, 16, 8, 4, 2 /
	592	!!----------------------------------------------------------------------
	593
	594	! Clear the error flag and initialise output vars
	595	kerr = 0
	596	kfax = 1
	597	knfax = 0
	598
	599	! Find the factors of n.
	600	IF( kn == 1 ) GOTO 20
	601
	602	! nu holds the unfactorised part of the number.
	603	! knfax holds the number of factors found.
	604	! l points to the allowed factor list.
	605	! ifac holds the current factor.
	606
	607	inu = kn
	608	knfax = 0
	609
	610	DO jl = ntest, 1, -1
	611	!
	612	ifac = ilfax(jl)
	613	IF( ifac > inu ) CYCLE
	614
	615	! Test whether the factor will divide.
	616
	617	IF( MOD(inu,ifac) == 0 ) THEN
	618	!
	619	knfax = knfax + 1 ! Add the factor to the list
	620	IF( knfax > kmaxfax ) THEN
	621	kerr = 6
	622	write (,) 'FACTOR: insufficient space in factor array ', knfax
	623	return
	624	ENDIF
	625	kfax(knfax) = ifac
	626	! Store the other factor that goes with this one
	627	knfax = knfax + 1
	628	kfax(knfax) = inu / ifac
	629	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
	630	ENDIF
	631	!
	632	END DO
	633
	634	20 CONTINUE ! Label 20 is the exit point from the factor search loop.
	635	!
	636	END SUBROUTINE factorise
	637
	638	#if defined key_mpp_mpi
	639	SUBROUTINE nemo_northcomms
	640	!!======================================================================
	641	!! * ROUTINE nemo_northcomms *
	642	!! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging
	643	!!=====================================================================
	644	!!----------------------------------------------------------------------
	645	!!
	646	!! ** Purpose : Initialization of the northern neighbours lists.
	647	!!----------------------------------------------------------------------
	648	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
	649	!!----------------------------------------------------------------------
	650
	651	INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices
	652	INTEGER :: ijpj ! number of rows involved in north-fold exchange
	653	INTEGER :: northcomms_alloc ! allocate return status
	654	REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace
	655	LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace
	656
	657	IF(lwp) WRITE(numout,*)
	658	IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists'
	659	IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
	660
	661	!!----------------------------------------------------------------------
	662	ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc )
	663	ALLOCATE( lrankset(jpnij), stat = northcomms_alloc )
	664	IF( northcomms_alloc /= 0 ) THEN
	665	WRITE(numout,cform_war)
	666	WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays'
	667	CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' )
	668	ENDIF
	669	nsndto = 0
	670	isendto = -1
	671	ijpj = 4
	672	!
	673	! This routine has been called because ln_nnogather has been set true ( nammpp )
	674	! However, these first few exchanges have to use the mpi_allgather method to
	675	! establish the neighbour lists to use in subsequent peer to peer exchanges.
	676	! Consequently, set l_north_nogather to be false here and set it true only after
	677	! the lists have been established.
	678	!
	679	l_north_nogather = .FALSE.
	680	!
	681	! Exchange and store ranks on northern rows
	682
	683	DO jtyp = 1,4
	684
	685	lrankset = .FALSE.
	686	znnbrs = narea
	687	SELECT CASE (jtyp)
	688	CASE(1)
	689	CALL lbc_lnk( znnbrs, 'T', 1. ) ! Type 1: T,W-points
	690	CASE(2)
	691	CALL lbc_lnk( znnbrs, 'U', 1. ) ! Type 2: U-point
	692	CASE(3)
	693	CALL lbc_lnk( znnbrs, 'V', 1. ) ! Type 3: V-point
	694	CASE(4)
	695	CALL lbc_lnk( znnbrs, 'F', 1. ) ! Type 4: F-point
	696	END SELECT
	697
	698	IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
	699	DO jj = nlcj-ijpj+1, nlcj
	700	ij = jj - nlcj + ijpj
	701	DO ji = 1,jpi
	702	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
	703	& lrankset(INT(znnbrs(ji,jj))) = .true.
	704	END DO
	705	END DO
	706
	707	DO jj = 1,jpnij
	708	IF ( lrankset(jj) ) THEN
	709	nsndto(jtyp) = nsndto(jtyp) + 1
	710	IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
	711	CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
	712	& ' jpmaxngh will need to be increased ')
	713	ENDIF
	714	isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank
	715	ENDIF
	716	END DO
	717	ENDIF
	718
	719	END DO
	720
	721	!
	722	! Type 5: I-point
	723	!
	724	! ICE point exchanges may involve some averaging. The neighbours list is
	725	! built up using two exchanges to ensure that the whole stencil is covered.
	726	! lrankset should not be reset between these 'J' and 'K' point exchanges
	727
	728	jtyp = 5
	729	lrankset = .FALSE.
	730	znnbrs = narea
	731	CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point
	732
	733	IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN
	734	DO jj = nlcj-ijpj+1, nlcj
	735	ij = jj - nlcj + ijpj
	736	DO ji = 1,jpi
	737	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
	738	& lrankset(INT(znnbrs(ji,jj))) = .true.
	739	END DO
	740	END DO
	741	ENDIF
	742
	743	znnbrs = narea
	744	CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point
	745
	746	IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN
	747	DO jj = nlcj-ijpj+1, nlcj
	748	ij = jj - nlcj + ijpj
	749	DO ji = 1,jpi
	750	IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) &
	751	& lrankset( INT(znnbrs(ji,jj))) = .true.
	752	END DO
	753	END DO
	754
	755	DO jj = 1,jpnij
	756	IF ( lrankset(jj) ) THEN
	757	nsndto(jtyp) = nsndto(jtyp) + 1
	758	IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN
	759	CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', &
	760	& ' jpmaxngh will need to be increased ')
	761	ENDIF
	762	isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank
	763	ENDIF
	764	END DO
	765	!
	766	! For northern row areas, set l_north_nogather so that all subsequent exchanges
	767	! can use peer to peer communications at the north fold
	768	!
	769	l_north_nogather = .TRUE.
	770	!
	771	ENDIF
	772	DEALLOCATE( znnbrs )
	773	DEALLOCATE( lrankset )
	774
	775	END SUBROUTINE nemo_northcomms
	776	#else
	777	SUBROUTINE nemo_northcomms ! Dummy routine
	778	WRITE(,) 'nemo_northcomms: You should not have seen this print! error?'
	779	END SUBROUTINE nemo_northcomms
	780	#endif
	781	#else
	782	CONTAINS
	783	SUBROUTINE nemo_gcm_tam
	784	WRITE(,) 'nemo_gcm_tam: You should not have seen this print! error?'
	785	END SUBROUTINE nemo_gcm_tam
	786	#endif
	787	!!======================================================================
	788	END MODULE nemogcm_tam

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

Download in other formats: