Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

dynspg_flt.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 5 years ago
The Dr Hook changes from my perl code.
File size: 21.9 KB

Rev	Line
[358]	1	MODULE dynspg_flt
	2	!!======================================================================
	3	!! * MODULE dynspg_flt *
	4	!! Ocean dynamics: surface pressure gradient trend
	5	!!======================================================================
[1438]	6	!! History OPA ! 1998-05 (G. Roullet) free surface
	7	!! ! 1998-10 (G. Madec, M. Imbard) release 8.2
	8	!! NEMO O.1 ! 2002-08 (G. Madec) F90: Free form and module
	9	!! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries
	10	!! 1.0 ! 2004-08 (C. Talandier) New trends organization
	11	!! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
	12	!! 2.0 ! 2006-07 (S. Masson) distributed restart using iom
	13	!! - ! 2006-08 (J.Chanut, A.Sellar) Calls to BDY routines.
	14	!! 3.2 ! 2009-03 (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module
[4990]	15	!! 3.7 ! 2014-04 (F. Roquet, G. Madec) add some trends diag
[358]	16	!!----------------------------------------------------------------------
[575]	17	#if defined key_dynspg_flt \|\| defined key_esopa
[508]	18	!!----------------------------------------------------------------------
[358]	19	!! 'key_dynspg_flt' filtered free surface
	20	!!----------------------------------------------------------------------
[1601]	21	!! dyn_spg_flt : update the momentum trend with the surface pressure gradient in the filtered free surface case
[508]	22	!! flt_rst : read/write the time-splitting restart fields in the ocean restart file
[358]	23	!!----------------------------------------------------------------------
	24	USE oce ! ocean dynamics and tracers
	25	USE dom_oce ! ocean space and time domain
	26	USE zdf_oce ! ocean vertical physics
[888]	27	USE sbc_oce ! surface boundary condition: ocean
[3294]	28	USE bdy_oce ! Lateral open boundary condition
[888]	29	USE sol_oce ! ocean elliptic solver
[719]	30	USE phycst ! physical constants
[888]	31	USE domvvl ! variable volume
[1683]	32	USE dynadv ! advection
[1601]	33	USE solmat ! matrix construction for elliptic solvers
[358]	34	USE solpcg ! preconditionned conjugate gradient solver
	35	USE solsor ! Successive Over-relaxation solver
[3294]	36	USE bdydyn ! ocean open boundary condition on dynamics
	37	USE bdyvol ! ocean open boundary condition (bdy_vol routine)
[2528]	38	USE cla ! cross land advection
[4990]	39	USE trd_oce ! trends: ocean variables
	40	USE trddyn ! trend manager: dynamics
	41	!
[888]	42	USE in_out_manager ! I/O manager
[358]	43	USE lib_mpp ! distributed memory computing library
[3294]	44	USE wrk_nemo ! Memory Allocation
[358]	45	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
	46	USE prtctl ! Print control
[508]	47	USE iom
[2528]	48	USE lib_fortran
[4990]	49	USE timing ! Timing
[2528]	50	#if defined key_agrif
	51	USE agrif_opa_interp
	52	#endif
[358]	53
[11738]	54	USE yomhook, ONLY: lhook, dr_hook
	55	USE parkind1, ONLY: jprb, jpim
	56
[358]	57	IMPLICIT NONE
	58	PRIVATE
	59
[1438]	60	PUBLIC dyn_spg_flt ! routine called by step.F90
	61	PUBLIC flt_rst ! routine called by istate.F90
[358]	62
	63	!! * Substitutions
	64	# include "domzgr_substitute.h90"
	65	# include "vectopt_loop_substitute.h90"
	66	!!----------------------------------------------------------------------
[2528]	67	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[888]	68	!! $Id$
[2715]	69	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[358]	70	!!----------------------------------------------------------------------
	71	CONTAINS
	72
	73	SUBROUTINE dyn_spg_flt( kt, kindic )
	74	!!----------------------------------------------------------------------
	75	!! * routine dyn_spg_flt *
	76	!!
	77	!! ** Purpose : Compute the now trend due to the surface pressure
	78	!! gradient in case of filtered free surface formulation and add
	79	!! it to the general trend of momentum equation.
	80	!!
	81	!! ** Method : Filtered free surface formulation. The surface
	82	!! pressure gradient is given by:
[1601]	83	!! spgu = 1/rau0 d/dx(ps) = 1/e1u di( sshn + btda )
	84	!! spgv = 1/rau0 d/dy(ps) = 1/e2v dj( sshn + btda )
[358]	85	!! where sshn is the free surface elevation and btda is the after
[1438]	86	!! time derivative of the free surface elevation
	87	!! -1- evaluate the surface presure trend (including the addi-
[358]	88	!! tional force) in three steps:
	89	!! a- compute the right hand side of the elliptic equation:
	90	!! gcb = 1/(e1t e2t) [ di(e2u spgu) + dj(e1v spgv) ]
	91	!! where (spgu,spgv) are given by:
	92	!! spgu = vertical sum[ e3u (ub+ 2 rdt ua ) ]
[2528]	93	!! - grav 2 rdt hu /e1u di[sshn + (emp-rnf)]
[358]	94	!! spgv = vertical sum[ e3v (vb+ 2 rdt va) ]
[2528]	95	!! - grav 2 rdt hv /e2v dj[sshn + (emp-rnf)]
[358]	96	!! and define the first guess from previous computation :
	97	!! zbtd = btda
	98	!! btda = 2 zbtd - btdb
	99	!! btdb = zbtd
	100	!! b- compute the relative accuracy to be reached by the
	101	!! iterative solver
	102	!! c- apply the solver by a call to sol... routine
[1438]	103	!! -2- compute and add the free surface pressure gradient inclu-
[358]	104	!! ding the additional force used to stabilize the equation.
	105	!!
	106	!! ** Action : - Update (ua,va) with the surf. pressure gradient trend
	107	!!
[4990]	108	!! References : Roullet and Madec, JGR, 2000.
[358]	109	!!---------------------------------------------------------------------
[1601]	110	INTEGER, INTENT(in ) :: kt ! ocean time-step index
	111	INTEGER, INTENT( out) :: kindic ! solver convergence flag (<0 if not converge)
[4990]	112	!
[2715]	113	INTEGER :: ji, jj, jk ! dummy loop indices
	114	REAL(wp) :: z2dt, z2dtg, zgcb, zbtd, ztdgu, ztdgv ! local scalars
[4990]	115	REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv
	116	REAL(wp), POINTER, DIMENSION(:,:) :: zpw
[11738]	117	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
	118	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
	119	REAL(KIND=jprb) :: zhook_handle
	120
	121	CHARACTER(LEN=*), PARAMETER :: RoutineName='DYN_SPG_FLT'
	122
	123	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
	124
[358]	125	!!----------------------------------------------------------------------
[508]	126	!
[3294]	127	IF( nn_timing == 1 ) CALL timing_start('dyn_spg_flt')
	128	!
[358]	129	IF( kt == nit000 ) THEN
	130	IF(lwp) WRITE(numout,*)
	131	IF(lwp) WRITE(numout,*) 'dyn_spg_flt : surface pressure gradient trend'
	132	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ (free surface constant volume case)'
	133
	134	! set to zero free surface specific arrays
[2715]	135	spgu(:,:) = 0._wp ! surface pressure gradient (i-direction)
	136	spgv(:,:) = 0._wp ! surface pressure gradient (j-direction)
[508]	137
	138	! read filtered free surface arrays in restart file
[1200]	139	! when using agrif, sshn, gcx have to be read in istate
[1601]	140	IF(.NOT. lk_agrif) CALL flt_rst( nit000, 'READ' ) ! read or initialize the following fields:
[1438]	141	! ! gcx, gcxb
[358]	142	ENDIF
	143
	144	! Local constant initialization
[1601]	145	z2dt = 2. * rdt ! time step: leap-frog
	146	IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt ! time step: Euler if restart from rest
	147	IF( neuler == 0 .AND. kt == nit000+1 ) CALL sol_mat( kt )
[358]	148	z2dtg = grav * z2dt
	149
[1683]	150	! Evaluate the masked next velocity (effect of the additional force not included)
	151	! ---------------------------------
	152	IF( lk_vvl ) THEN ! variable volume (surface pressure gradient already included in dyn_hpg)
	153	!
	154	IF( ln_dynadv_vec ) THEN ! vector form : applied on velocity
	155	DO jk = 1, jpkm1
	156	DO jj = 2, jpjm1
	157	DO ji = fs_2, fs_jpim1 ! vector opt.
	158	ua(ji,jj,jk) = ( ub(ji,jj,jk) + z2dt * ua(ji,jj,jk) ) * umask(ji,jj,jk)
	159	va(ji,jj,jk) = ( vb(ji,jj,jk) + z2dt * va(ji,jj,jk) ) * vmask(ji,jj,jk)
	160	END DO
[592]	161	END DO
	162	END DO
[1683]	163	!
	164	ELSE ! flux form : applied on thickness weighted velocity
	165	DO jk = 1, jpkm1
	166	DO jj = 2, jpjm1
	167	DO ji = fs_2, fs_jpim1 ! vector opt.
	168	ua(ji,jj,jk) = ( ub(ji,jj,jk) * fse3u_b(ji,jj,jk) &
	169	& + z2dt * ua(ji,jj,jk) * fse3u_n(ji,jj,jk) ) &
	170	& / fse3u_a(ji,jj,jk) * umask(ji,jj,jk)
	171	va(ji,jj,jk) = ( vb(ji,jj,jk) * fse3v_b(ji,jj,jk) &
	172	& + z2dt * va(ji,jj,jk) * fse3v_n(ji,jj,jk) ) &
	173	& / fse3v_a(ji,jj,jk) * vmask(ji,jj,jk)
	174	END DO
	175	END DO
	176	END DO
	177	!
	178	ENDIF
[7179]	179	IF( l_trddyn ) THEN ! Put here so code doesn't crash when doing KE trend but needs to be done properly
	180	CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv )
	181	ENDIF
[1683]	182	!
	183	ELSE ! fixed volume (add the surface pressure gradient + unweighted time stepping)
	184	!
	185	DO jj = 2, jpjm1 ! Surface pressure gradient (now)
[358]	186	DO ji = fs_2, fs_jpim1 ! vector opt.
[592]	187	spgu(ji,jj) = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj)
	188	spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj)
	189	END DO
	190	END DO
[1683]	191	DO jk = 1, jpkm1 ! unweighted time stepping
[592]	192	DO jj = 2, jpjm1
	193	DO ji = fs_2, fs_jpim1 ! vector opt.
[1438]	194	ua(ji,jj,jk) = ( ub(ji,jj,jk) + z2dt * ( ua(ji,jj,jk) + spgu(ji,jj) ) ) * umask(ji,jj,jk)
	195	va(ji,jj,jk) = ( vb(ji,jj,jk) + z2dt * ( va(ji,jj,jk) + spgv(ji,jj) ) ) * vmask(ji,jj,jk)
[592]	196	END DO
[358]	197	END DO
	198	END DO
[1438]	199	!
[4990]	200	IF( l_trddyn ) THEN ! temporary save of spg trends
	201	CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv )
	202	DO jk = 1, jpkm1 ! unweighted time stepping
	203	DO jj = 2, jpjm1
	204	DO ji = fs_2, fs_jpim1 ! vector opt.
	205	ztrdu(ji,jj,jk) = spgu(ji,jj) * umask(ji,jj,jk)
	206	ztrdv(ji,jj,jk) = spgv(ji,jj) * vmask(ji,jj,jk)
	207	END DO
	208	END DO
	209	END DO
	210	CALL trd_dyn( ztrdu, ztrdv, jpdyn_spgexp, kt )
	211	ENDIF
	212	!
[592]	213	ENDIF
	214
[911]	215	#if defined key_bdy
[3764]	216	IF( lk_bdy ) CALL bdy_dyn( kt ) ! Update velocities on each open boundary
	217	IF( lk_bdy ) CALL bdy_vol( kt ) ! Correction of the barotropic component velocity to control the volume of the system
[911]	218	#endif
[392]	219	#if defined key_agrif
[508]	220	CALL Agrif_dyn( kt ) ! Update velocities on each coarse/fine interfaces
[389]	221	#endif
[4147]	222	IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_dynspg( kt ) ! Cross Land Advection (update (ua,va))
[358]	223
	224	! compute the next vertically averaged velocity (effect of the additional force not included)
	225	! ---------------------------------------------
	226	DO jj = 2, jpjm1
	227	DO ji = fs_2, fs_jpim1 ! vector opt.
[4990]	228	spgu(ji,jj) = fse3u_a(ji,jj,1) * ua(ji,jj,1)
	229	spgv(ji,jj) = fse3v_a(ji,jj,1) * va(ji,jj,1)
[358]	230	END DO
	231	END DO
[4990]	232	DO jk = 2, jpkm1 ! vertical sum
	233	DO jj = 2, jpjm1
	234	DO ji = fs_2, fs_jpim1 ! vector opt.
	235	spgu(ji,jj) = spgu(ji,jj) + fse3u_a(ji,jj,jk) * ua(ji,jj,jk)
	236	spgv(ji,jj) = spgv(ji,jj) + fse3v_a(ji,jj,jk) * va(ji,jj,jk)
[358]	237	END DO
	238	END DO
[4990]	239	END DO
[358]	240
[4990]	241	DO jj = 2, jpjm1 ! transport: multiplied by the horizontal scale factor
[358]	242	DO ji = fs_2, fs_jpim1 ! vector opt.
	243	spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
	244	spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
	245	END DO
	246	END DO
[1601]	247	CALL lbc_lnk( spgu, 'U', -1. ) ! lateral boundary conditions
[358]	248	CALL lbc_lnk( spgv, 'V', -1. )
	249
[1438]	250	IF( lk_vvl ) CALL sol_mat( kt ) ! build the matrix at kt (vvl case only)
[592]	251
[358]	252	! Right hand side of the elliptic equation and first guess
[1601]	253	! --------------------------------------------------------
[358]	254	DO jj = 2, jpjm1
	255	DO ji = fs_2, fs_jpim1 ! vector opt.
	256	! Divergence of the after vertically averaged velocity
	257	zgcb = spgu(ji,jj) - spgu(ji-1,jj) &
	258	+ spgv(ji,jj) - spgv(ji,jj-1)
	259	gcb(ji,jj) = gcdprc(ji,jj) * zgcb
	260	! First guess of the after barotropic transport divergence
	261	zbtd = gcx(ji,jj)
	262	gcx (ji,jj) = 2. * zbtd - gcxb(ji,jj)
	263	gcxb(ji,jj) = zbtd
	264	END DO
	265	END DO
	266	! applied the lateral boundary conditions
[3609]	267	IF( nn_solv == 2 .AND. MAX( jpr2di, jpr2dj ) > 0 ) CALL lbc_lnk_e( gcb, c_solver_pt, 1., jpr2di, jpr2dj )
[358]	268
[392]	269	#if defined key_agrif
[413]	270	IF( .NOT. AGRIF_ROOT() ) THEN
[389]	271	! add contribution of gradient of after barotropic transport divergence
[508]	272	IF( nbondi == -1 .OR. nbondi == 2 ) gcb(3 ,:) = &
[1601]	273	& gcb(3 ,:) - z2dtg * z2dt * laplacu(2 ,:) * gcdprc(3 ,:) * hu(2 ,:) * e2u(2 ,:)
[508]	274	IF( nbondi == 1 .OR. nbondi == 2 ) gcb(nlci-2,:) = &
[1601]	275	& gcb(nlci-2,:) + z2dtg * z2dt * laplacu(nlci-2,:) * gcdprc(nlci-2,:) * hu(nlci-2,:) * e2u(nlci-2,:)
[508]	276	IF( nbondj == -1 .OR. nbondj == 2 ) gcb(: ,3) = &
[1601]	277	& gcb(:,3 ) - z2dtg * z2dt * laplacv(:,2 ) * gcdprc(:,3 ) * hv(:,2 ) * e1v(:,2 )
[508]	278	IF( nbondj == 1 .OR. nbondj == 2 ) gcb(:,nlcj-2) = &
[1601]	279	& gcb(:,nlcj-2) + z2dtg * z2dt * laplacv(:,nlcj-2) * gcdprc(:,nlcj-2) * hv(:,nlcj-2) * e1v(:,nlcj-2)
[413]	280	ENDIF
[389]	281	#endif
	282
	283
[358]	284	! Relative precision (computation on one processor)
	285	! ------------------
[1438]	286	rnorme =0.e0
[2528]	287	rnorme = GLOB_SUM( gcb(1:jpi,1:jpj) * gcdmat(1:jpi,1:jpj) * gcb(1:jpi,1:jpj) * bmask(:,:) )
[358]	288
	289	epsr = eps * eps * rnorme
	290	ncut = 0
[508]	291	! if rnorme is 0, the solution is 0, the solver is not called
[2715]	292	IF( rnorme == 0._wp ) THEN
	293	gcx(:,:) = 0._wp
	294	res = 0._wp
[358]	295	niter = 0
	296	ncut = 999
	297	ENDIF
	298
	299	! Evaluate the next transport divergence
	300	! --------------------------------------
	301	! Iterarive solver for the elliptic equation (except IF sol.=0)
	302	! (output in gcx with boundary conditions applied)
	303	kindic = 0
	304	IF( ncut == 0 ) THEN
[1601]	305	IF ( nn_solv == 1 ) THEN ; CALL sol_pcg( kindic ) ! diagonal preconditioned conjuguate gradient
	306	ELSEIF( nn_solv == 2 ) THEN ; CALL sol_sor( kindic ) ! successive-over-relaxation
[358]	307	ENDIF
	308	ENDIF
	309
	310	! Transport divergence gradient multiplied by z2dt
	311	! --------------------------------------------====
	312	DO jj = 2, jpjm1
	313	DO ji = fs_2, fs_jpim1 ! vector opt.
	314	! trend of Transport divergence gradient
[1601]	315	ztdgu = z2dtg * (gcx(ji+1,jj ) - gcx(ji,jj) ) / e1u(ji,jj)
	316	ztdgv = z2dtg * (gcx(ji ,jj+1) - gcx(ji,jj) ) / e2v(ji,jj)
[358]	317	! multiplied by z2dt
[4328]	318	#if defined key_bdy
[3765]	319	IF(lk_bdy) THEN
[911]	320	! caution : grad D = 0 along open boundaries
[3765]	321	spgu(ji,jj) = z2dt * ztdgu * bdyumask(ji,jj)
	322	spgv(ji,jj) = z2dt * ztdgv * bdyvmask(ji,jj)
	323	ELSE
	324	spgu(ji,jj) = z2dt * ztdgu
	325	spgv(ji,jj) = z2dt * ztdgv
	326	ENDIF
[358]	327	#else
	328	spgu(ji,jj) = z2dt * ztdgu
	329	spgv(ji,jj) = z2dt * ztdgv
	330	#endif
	331	END DO
	332	END DO
	333
[1876]	334	#if defined key_agrif
[413]	335	IF( .NOT. Agrif_Root() ) THEN
	336	! caution : grad D (fine) = grad D (coarse) at coarse/fine interface
[1601]	337	IF( nbondi == -1 .OR. nbondi == 2 ) spgu(2 ,:) = z2dtg * z2dt * laplacu(2 ,:) * umask(2 ,:,1)
	338	IF( nbondi == 1 .OR. nbondi == 2 ) spgu(nlci-2,:) = z2dtg * z2dt * laplacu(nlci-2,:) * umask(nlci-2,:,1)
	339	IF( nbondj == -1 .OR. nbondj == 2 ) spgv(:,2 ) = z2dtg * z2dt * laplacv(:,2 ) * vmask(: ,2,1)
	340	IF( nbondj == 1 .OR. nbondj == 2 ) spgv(:,nlcj-2) = z2dtg * z2dt * laplacv(:,nlcj-2) * vmask(:,nlcj-2,1)
[389]	341	ENDIF
[1876]	342	#endif
[4990]	343
	344	IF( l_trddyn ) THEN
	345	ztrdu(:,:,:) = ua(:,:,:) ! save the after velocity before the filtered SPG
	346	ztrdv(:,:,:) = va(:,:,:)
	347	!
	348	CALL wrk_alloc( jpi, jpj, zpw )
	349	!
	350	zpw(:,:) = - z2dt * gcx(:,:)
	351	CALL iom_put( "ssh_flt" , zpw ) ! output equivalent ssh modification due to implicit filter
	352	!
	353	! ! save surface pressure flux: -pw at z=0
	354	zpw(:,:) = - rau0 * grav * sshn(:,:) * wn(:,:,1) * tmask(:,:,1)
	355	CALL iom_put( "pw0_exp" , zpw )
	356	zpw(:,:) = wn(:,:,1)
	357	CALL iom_put( "w0" , zpw )
	358	zpw(:,:) = rau0 * z2dtg * gcx(:,:) * wn(:,:,1) * tmask(:,:,1)
	359	CALL iom_put( "pw0_flt" , zpw )
	360	!
	361	CALL wrk_dealloc( jpi, jpj, zpw )
	362	!
	363	ENDIF
	364
[1438]	365	! Add the trends multiplied by z2dt to the after velocity
	366	! -------------------------------------------------------
[358]	367	! ( c a u t i o n : (ua,va) here are the after velocity not the
	368	! trend, the leap-frog time stepping will not
[508]	369	! be done in dynnxt.F90 routine)
[358]	370	DO jk = 1, jpkm1
	371	DO jj = 2, jpjm1
	372	DO ji = fs_2, fs_jpim1 ! vector opt.
[1438]	373	ua(ji,jj,jk) = ( ua(ji,jj,jk) + spgu(ji,jj) ) * umask(ji,jj,jk)
	374	va(ji,jj,jk) = ( va(ji,jj,jk) + spgv(ji,jj) ) * vmask(ji,jj,jk)
[358]	375	END DO
	376	END DO
	377	END DO
	378
[4990]	379	IF( l_trddyn ) THEN ! save the explicit SPG trends for further diagnostics
	380	ztrdu(:,:,:) = ( ua(:,:,:) - ztrdu(:,:,:) ) / z2dt
	381	ztrdv(:,:,:) = ( va(:,:,:) - ztrdv(:,:,:) ) / z2dt
	382	CALL trd_dyn( ztrdu, ztrdv, jpdyn_spgflt, kt )
	383	!
	384	CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv )
	385	ENDIF
	386
	387	IF( lrst_oce ) CALL flt_rst( kt, 'WRITE' ) ! write filtered free surface arrays in restart file
[508]	388	!
[4990]	389	IF( nn_timing == 1 ) CALL timing_stop('dyn_spg_flt')
[3294]	390	!
[11738]	391	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
[358]	392	END SUBROUTINE dyn_spg_flt
	393
[508]	394
	395	SUBROUTINE flt_rst( kt, cdrw )
[2715]	396	!!---------------------------------------------------------------------
	397	!! * ROUTINE ts_rst *
	398	!!
	399	!! ** Purpose : Read or write filtered free surface arrays in restart file
	400	!!----------------------------------------------------------------------
[4990]	401	INTEGER , INTENT(in) :: kt ! ocean time-step
	402	CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag
[11738]	403	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
	404	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
	405	REAL(KIND=jprb) :: zhook_handle
	406
	407	CHARACTER(LEN=*), PARAMETER :: RoutineName='FLT_RST'
	408
	409	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
	410
[2715]	411	!!----------------------------------------------------------------------
	412	!
	413	IF( TRIM(cdrw) == 'READ' ) THEN
	414	IF( iom_varid( numror, 'gcx', ldstop = .FALSE. ) > 0 ) THEN
[508]	415	! Caution : extra-hallow
	416	! gcx and gcxb are defined as: DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj)
[9321]	417	IF(nn_timing == 2) CALL timing_start('iom_rstget')
[2715]	418	CALL iom_get( numror, jpdom_autoglo, 'gcx' , gcx (1:jpi,1:jpj) )
	419	CALL iom_get( numror, jpdom_autoglo, 'gcxb', gcxb(1:jpi,1:jpj) )
[9321]	420	IF(nn_timing == 2) CALL timing_stop('iom_rstget')
[2715]	421	IF( neuler == 0 ) gcxb(:,:) = gcx (:,:)
	422	ELSE
	423	gcx (:,:) = 0.e0
	424	gcxb(:,:) = 0.e0
	425	ENDIF
	426	ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN
[508]	427	! Caution : extra-hallow
	428	! gcx and gcxb are defined as: DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj)
[9321]	429	IF(nn_timing == 2) CALL timing_start('iom_rstput')
[2715]	430	CALL iom_rstput( kt, nitrst, numrow, 'gcx' , gcx (1:jpi,1:jpj) )
	431	CALL iom_rstput( kt, nitrst, numrow, 'gcxb', gcxb(1:jpi,1:jpj) )
[9321]	432	IF(nn_timing == 2) CALL timing_stop('iom_rstput')
[2715]	433	ENDIF
	434	!
[11738]	435	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
[508]	436	END SUBROUTINE flt_rst
	437
[358]	438	#else
	439	!!----------------------------------------------------------------------
	440	!! Default case : Empty module No standart free surface cst volume
	441	!!----------------------------------------------------------------------
	442	CONTAINS
	443	SUBROUTINE dyn_spg_flt( kt, kindic ) ! Empty routine
[11738]	444	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
	445	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
	446	REAL(KIND=jprb) :: zhook_handle
	447
	448	CHARACTER(LEN=*), PARAMETER :: RoutineName='DYN_SPG_FLT'
	449
	450	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
	451
[358]	452	WRITE(,) 'dyn_spg_flt: You should not have seen this print! error?', kt, kindic
[11738]	453	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
[358]	454	END SUBROUTINE dyn_spg_flt
[657]	455	SUBROUTINE flt_rst ( kt, cdrw ) ! Empty routine
	456	INTEGER , INTENT(in) :: kt ! ocean time-step
	457	CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag
[11738]	458	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
	459	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
	460	REAL(KIND=jprb) :: zhook_handle
	461
	462	CHARACTER(LEN=*), PARAMETER :: RoutineName='FLT_RST'
	463
	464	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
	465
[657]	466	WRITE(,) 'flt_rst: You should not have seen this print! error?', kt, cdrw
[11738]	467	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
[657]	468	END SUBROUTINE flt_rst
[358]	469	#endif
	470
	471	!!======================================================================
	472	END MODULE dynspg_flt

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_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90 @ 11738

Download in other formats: