Context Navigation

iscplrst.F90 @ 8668

Last change on this file since 8668 was 8668, checked in by andmirek, 7 years ago
#1953 change variable names to follow NEMO coding convention
File size: 21.1 KB

Rev	Line
[5790]	1	MODULE iscplrst
	2	!!======================================================================
[7646]	3	!! * MODULE iscplrst *
[5790]	4	!! Ocean forcing: update the restart file in case of ice sheet/ocean coupling
	5	!!=====================================================================
	6	!! History : NEMO ! 2015-01 P. Mathiot: original
	7	!!----------------------------------------------------------------------
	8
	9	!!----------------------------------------------------------------------
[5835]	10	!! iscpl_stp : step management
[5790]	11	!! iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet
	12	!!----------------------------------------------------------------------
	13	USE dom_oce ! ocean space and time domain
	14	USE domwri ! ocean space and time domain
	15	USE domvvl, ONLY : dom_vvl_interpol
	16	USE phycst ! physical constants
	17	USE sbc_oce ! surface boundary condition variables
	18	USE oce ! global tra/dyn variable
	19	USE in_out_manager ! I/O manager
	20	USE iom ! I/O module
	21	USE lib_mpp ! MPP library
	22	USE lib_fortran ! MPP library
	23	USE wrk_nemo ! Memory allocation
[5823]	24	USE lbclnk ! communication
	25	USE iscplini ! ice sheet coupling: initialisation
	26	USE iscplhsb ! ice sheet coupling: conservation
[8612]	27	USE iom_def, ONLY : lxios_read
[5790]	28
	29	IMPLICIT NONE
	30	PRIVATE
	31
[5823]	32	PUBLIC iscpl_stp ! step management
[5790]	33	!!
	34	!! * Substitutions
[5920]	35	# include "vectopt_loop_substitute.h90"
[5790]	36	!!----------------------------------------------------------------------
	37	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	38	!! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
	39	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	40	!!----------------------------------------------------------------------
	41	CONTAINS
	42
	43	SUBROUTINE iscpl_stp
	44	!!----------------------------------------------------------------------
	45	!! * ROUTINE iscpl_stp *
	46	!!
	47	!! ** Purpose : compute initialisation
	48	!! compute extrapolation of restart variable un, vn, tsn, sshn (wetting/drying)
	49	!! compute correction term if needed
	50	!!
	51	!!----------------------------------------------------------------------
[5945]	52	INTEGER :: inum0
[7646]	53	REAL(wp), DIMENSION(:,: ), POINTER :: zsmask_b
	54	REAL(wp), DIMENSION(:,:,:), POINTER :: ztmask_b, zumask_b, zvmask_b
	55	REAL(wp), DIMENSION(:,:,:), POINTER :: ze3t_b , ze3u_b , ze3v_b
	56	REAL(wp), DIMENSION(:,:,:), POINTER :: zdepw_b
[5945]	57	CHARACTER(20) :: cfile
[5823]	58	!!----------------------------------------------------------------------
[5790]	59
[7646]	60	CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before
	61	CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before
	62	CALL wrk_alloc(jpi,jpj,jpk, zdepw_b )
	63	CALL wrk_alloc(jpi,jpj, zsmask_b )
[5790]	64
	65
	66	!! get restart variable
[8668]	67	CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b, ldxios = lxios_read ) ! need to extrapolate T/S
	68	CALL iom_get( numror, jpdom_autoglo, 'umask' , zumask_b, ldxios = lxios_read ) ! need to correct barotropic velocity
	69	CALL iom_get( numror, jpdom_autoglo, 'vmask' , zvmask_b, ldxios = lxios_read ) ! need to correct barotropic velocity
	70	CALL iom_get( numror, jpdom_autoglo, 'smask' , zsmask_b, ldxios = lxios_read ) ! need to correct barotropic velocity
	71	CALL iom_get( numror, jpdom_autoglo, 'e3t_n' , ze3t_b(:,:,:), ldxios = lxios_read ) ! need to compute temperature correction
	72	CALL iom_get( numror, jpdom_autoglo, 'e3u_n' , ze3u_b(:,:,:), ldxios = lxios_read ) ! need to correct barotropic velocity
	73	CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b(:,:,:), ldxios = lxios_read ) ! need to correct barotropic velocity
	74	CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lxios_read ) ! need to interpol vertical profile (vvl)
[5790]	75
	76	!! read namelist
	77	CALL iscpl_init()
	78
	79	!! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl)
	80	CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b )
	81
	82	!! compute correction if conservation needed
	83	IF ( ln_hsb ) THEN
	84	IF( iscpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' )
	85	CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl)
	86	END IF
	87
	88	!! print mesh/mask
[7646]	89	IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file
[5790]	90
	91	IF ( ln_hsb ) THEN
	92	cfile='correction'
	93	cfile = TRIM( cfile )
	94	CALL iom_open ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib )
	95	CALL iom_rstput( 0, 0, inum0, 'vol_cor', hdiv_iscpl(:,:,:) )
	96	CALL iom_rstput( 0, 0, inum0, 'tem_cor', htsc_iscpl(:,:,:,jp_tem) )
	97	CALL iom_rstput( 0, 0, inum0, 'sal_cor', htsc_iscpl(:,:,:,jp_sal) )
	98	CALL iom_close ( inum0 )
	99	END IF
	100
[7646]	101	CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b )
	102	CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b )
	103	CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b )
	104	CALL wrk_dealloc(jpi,jpj, zsmask_b )
[5790]	105
[5802]	106	!! next step is an euler time step
	107	neuler = 0
[5835]	108
[5802]	109	!! set _b and _n variables equal
	110	tsb (:,:,:,:) = tsn (:,:,:,:)
[7646]	111	ub (:,:,:) = un (:,:,:)
	112	vb (:,:,:) = vn (:,:,:)
	113	sshb(:,:) = sshn(:,:)
[5835]	114
[5802]	115	!! set _b and _n vertical scale factor equal
[6074]	116	e3t_b (:,:,:) = e3t_n (:,:,:)
	117	e3u_b (:,:,:) = e3u_n (:,:,:)
	118	e3v_b (:,:,:) = e3v_n (:,:,:)
[5945]	119
[7646]	120	e3uw_b (:,:,:) = e3uw_n (:,:,:)
	121	e3vw_b (:,:,:) = e3vw_n (:,:,:)
	122	gdept_b(:,:,:) = gdept_n(:,:,:)
[6080]	123	gdepw_b(:,:,:) = gdepw_n(:,:,:)
[7646]	124	hu_b (:,:) = hu_n (:,:)
	125	hv_b (:,:) = hv_n (:,:)
	126	r1_hu_b(:,:) = r1_hu_n(:,:)
	127	r1_hv_b(:,:) = r1_hv_n(:,:)
[5790]	128	!
	129	END SUBROUTINE iscpl_stp
[7646]	130
	131
[5790]	132	SUBROUTINE iscpl_rst_interpol (ptmask_b, pumask_b, pvmask_b, psmask_b, pe3t_b, pe3u_b, pe3v_b, pdepw_b)
	133	!!----------------------------------------------------------------------
	134	!! * ROUTINE iscpl_rst_interpol *
	135	!!
	136	!! ** Purpose : compute new tn, sn, un, vn and sshn in case of evolving geometry of ice shelves
	137	!! compute 2d fields of heat, salt and volume correction
	138	!!
	139	!! ** Method : tn, sn : extrapolation from neigbourg cells
	140	!! un, vn : fill with 0 velocity and keep barotropic transport by modifing surface velocity or adjacent velocity
	141	!!----------------------------------------------------------------------
	142	REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: ptmask_b, pumask_b, pvmask_b !! mask before
	143	REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pe3t_b , pe3u_b , pe3v_b !! scale factor before
[5823]	144	REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before
[5790]	145	REAL(wp), DIMENSION(:,: ), INTENT(in ) :: psmask_b !! mask before
	146	!!
	147	INTEGER :: ji, jj, jk, iz !! loop index
	148	INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
	149	!!
	150	REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb
	151	REAL(wp):: zdz, zdzm1, zdzp1
	152	!!
	153	REAL(wp), DIMENSION(:,: ), POINTER :: zdmask , zdsmask, zvcorr, zucorr, zde3t
	154	REAL(wp), DIMENSION(:,: ), POINTER :: zbub , zbvb , zbun , zbvn
[5945]	155	REAL(wp), DIMENSION(:,: ), POINTER :: zssh0 , zssh1, zhu1, zhv1
[5790]	156	REAL(wp), DIMENSION(:,: ), POINTER :: zsmask0, zsmask1
	157	REAL(wp), DIMENSION(:,:,: ), POINTER :: ztmask0, ztmask1, ztrp
	158	REAL(wp), DIMENSION(:,:,: ), POINTER :: zwmaskn, zwmaskb, ztmp3d
	159	REAL(wp), DIMENSION(:,:,:,:), POINTER :: zts0
[5945]	160	!!----------------------------------------------------------------------
[5823]	161
	162	!! allocate variables
[5790]	163	CALL wrk_alloc(jpi,jpj,jpk,2, zts0 )
[5835]	164	CALL wrk_alloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp, ztmp3d )
[5790]	165	CALL wrk_alloc(jpi,jpj,jpk, zwmaskn, zwmaskb )
	166	CALL wrk_alloc(jpi,jpj, zsmask0, zsmask1 )
	167	CALL wrk_alloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t)
	168	CALL wrk_alloc(jpi,jpj, zbub , zbvb , zbun , zbvn )
[5945]	169	CALL wrk_alloc(jpi,jpj, zssh0 , zssh1, zhu1, zhv1 )
[5823]	170
[5790]	171	!! mask value to be sure
	172	tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:)
	173	tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:)
	174
	175	! compute wmask
	176	zwmaskn(:,:,1) = tmask (:,:,1)
	177	zwmaskb(:,:,1) = ptmask_b(:,:,1)
	178	DO jk = 2,jpk
	179	zwmaskn(:,:,jk) = tmask (:,:,jk) * tmask (:,:,jk-1)
	180	zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1)
	181	END DO
	182
	183	! compute new ssh if we open a full water column (average of the closest neigbourgs)
	184	sshb (:,:)=sshn(:,:)
	185	zssh0(:,:)=sshn(:,:)
[5802]	186	zsmask0(:,:) = psmask_b(:,:)
	187	zsmask1(:,:) = psmask_b(:,:)
[5823]	188	DO iz = 1,10 ! need to be tuned (configuration dependent) (OK for ISOMIP+)
[5790]	189	zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:)
[5920]	190	DO jj = 2,jpj-1
	191	DO ji = fs_2, fs_jpim1 ! vector opt.
[5790]	192	jip1=ji+1; jim1=ji-1;
	193	jjp1=jj+1; jjm1=jj-1;
	194	summsk=(zsmask0(jip1,jj)+zsmask0(jim1,jj)+zsmask0(ji,jjp1)+zsmask0(ji,jjm1))
[5945]	195	IF (zdsmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
[5820]	196	sshn(ji,jj)=( zssh0(jip1,jj)*zsmask0(jip1,jj) &
	197	& + zssh0(jim1,jj)*zsmask0(jim1,jj) &
	198	& + zssh0(ji,jjp1)*zsmask0(ji,jjp1) &
	199	& + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk
[5823]	200	zsmask1(ji,jj)=1._wp
[5790]	201	END IF
	202	END DO
	203	END DO
[5823]	204	CALL lbc_lnk(sshn,'T',1._wp)
	205	CALL lbc_lnk(zsmask1,'T',1._wp)
[5790]	206	zssh0 = sshn
	207	zsmask0 = zsmask1
	208	END DO
	209	sshn(:,:) = sshn(:,:) * ssmask(:,:)
	210
	211	!=============================================================================
[6075]	212	!PM: Is this needed since introduction of VVL by default?
	213	IF (.NOT.ln_linssh) THEN
[5820]	214	! Reconstruction of all vertical scale factors at now time steps
	215	! =============================================================================
	216	! Horizontal scale factor interpolations
	217	! --------------------------------------
[5790]	218	DO jk = 1,jpk
[5820]	219	DO jj=1,jpj
	220	DO ji=1,jpi
	221	IF (tmask(ji,jj,1) == 0._wp .OR. ptmask_b(ji,jj,1) == 0._wp) THEN
[8329]	222	e3t_n(ji,jj,jk) = e3t_0(ji,jj,jk) * ( 1._wp + sshn(ji,jj) / &
	223	& ( ht_0(ji,jj) + 1._wp - ssmask(ji,jj) ) * tmask(ji,jj,jk) )
[5820]	224	ENDIF
	225	END DO
	226	END DO
[5790]	227	END DO
	228
[6074]	229	CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
	230	CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
	231	CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )
[5790]	232
	233	! Vertical scale factor interpolations
	234	! ------------------------------------
[6074]	235	CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' )
	236	CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
	237	CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
[5790]	238
	239	! t- and w- points depth
	240	! ----------------------
[6074]	241	gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
	242	gdepw_n(:,:,1) = 0.0_wp
	243	gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
[5790]	244	DO jj = 1,jpj
	245	DO ji = 1,jpi
	246	DO jk = 2,mikt(ji,jj)-1
[6074]	247	gdept_n(ji,jj,jk) = gdept_0(ji,jj,jk)
	248	gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
	249	gde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj)
[5790]	250	END DO
[5945]	251	IF (mikt(ji,jj) > 1) THEN
[5790]	252	jk = mikt(ji,jj)
[6074]	253	gdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * e3w_n(ji,jj,jk)
	254	gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
	255	gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk ) - sshn (ji,jj)
[5790]	256	END IF
	257	DO jk = mikt(ji,jj)+1, jpk
[6074]	258	gdept_n(ji,jj,jk) = gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk)
	259	gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
	260	gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk ) - sshn (ji,jj)
[5790]	261	END DO
	262	END DO
	263	END DO
	264
[5823]	265	! t-, u- and v- water column thickness
	266	! ------------------------------------
[6075]	267	ht_n(:,:) = 0._wp ; hu_n(:,:) = 0._wp ; hv_n(:,:) = 0._wp
[5790]	268	DO jk = 1, jpkm1
[6074]	269	hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
	270	hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
	271	ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
[5790]	272	END DO
	273	! ! Inverse of the local depth
[6074]	274	r1_hu_n(:,:) = 1._wp / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) * ssumask(:,:)
	275	r1_hv_n(:,:) = 1._wp / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) * ssvmask(:,:)
[5790]	276
	277	END IF
	278
	279	!=============================================================================
	280	! compute velocity
	281	! compute velocity in order to conserve barotropic velocity (modification by poderation of the scale factor).
	282	ub(:,:,:)=un(:,:,:)
	283	vb(:,:,:)=vn(:,:,:)
	284	DO jk = 1,jpk
[5920]	285	DO jj = 1,jpj
	286	DO ji = 1,jpi
[6074]	287	un(ji,jj,jk) = ub(ji,jj,jk)pe3u_b(ji,jj,jk)pumask_b(ji,jj,jk)/e3u_n(ji,jj,jk)*umask(ji,jj,jk);
	288	vn(ji,jj,jk) = vb(ji,jj,jk)pe3v_b(ji,jj,jk)pvmask_b(ji,jj,jk)/e3v_n(ji,jj,jk)*vmask(ji,jj,jk);
[5790]	289	END DO
	290	END DO
	291	END DO
[5802]	292
[5790]	293	! compute new velocity if we close a cell (check barotropic velocity and change velocity over the water column)
	294	! compute barotropic velocity now and after
	295	ztrp(:,:,:) = ub(:,:,:)*pe3u_b(:,:,:);
	296	zbub(:,:) = SUM(ztrp,DIM=3)
	297	ztrp(:,:,:) = vb(:,:,:)*pe3v_b(:,:,:);
	298	zbvb(:,:) = SUM(ztrp,DIM=3)
[6074]	299	ztrp(:,:,:) = un(:,:,:)*e3u_n(:,:,:);
[5790]	300	zbun(:,:) = SUM(ztrp,DIM=3)
[6074]	301	ztrp(:,:,:) = vn(:,:,:)*e3v_n(:,:,:);
[5790]	302	zbvn(:,:) = SUM(ztrp,DIM=3)
[5802]	303
[5820]	304	! new water column
[5945]	305	zhu1=0.0_wp ;
	306	zhv1=0.0_wp ;
[5790]	307	DO jk = 1,jpk
[6074]	308	zhu1(:,:) = zhu1(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
	309	zhv1(:,:) = zhv1(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
[5790]	310	END DO
[5820]	311
	312	! compute correction
[5790]	313	zucorr = 0._wp
	314	zvcorr = 0._wp
[5920]	315	DO jj = 1,jpj
	316	DO ji = 1,jpi
[5945]	317	IF (zbun(ji,jj) /= zbub(ji,jj) .AND. zhu1(ji,jj) /= 0._wp ) THEN
	318	zucorr(ji,jj) = (zbun(ji,jj) - zbub(ji,jj))/zhu1(ji,jj)
[5790]	319	END IF
[5945]	320	IF (zbvn(ji,jj) /= zbvb(ji,jj) .AND. zhv1(ji,jj) /= 0._wp ) THEN
	321	zvcorr(ji,jj) = (zbvn(ji,jj) - zbvb(ji,jj))/zhv1(ji,jj)
[5790]	322	END IF
	323	END DO
	324	END DO
[5820]	325
	326	! update velocity
[5790]	327	DO jk = 1,jpk
	328	un(:,:,jk)=(un(:,:,jk) - zucorr(:,:))*umask(:,:,jk)
	329	vn(:,:,jk)=(vn(:,:,jk) - zvcorr(:,:))*vmask(:,:,jk)
	330	END DO
	331
	332	!=============================================================================
	333	! compute temp and salt
	334	! compute new tn and sn if we open a new cell
	335	tsb (:,:,:,:) = tsn(:,:,:,:)
	336	zts0(:,:,:,:) = tsn(:,:,:,:)
	337	ztmask1(:,:,:) = ptmask_b(:,:,:)
	338	ztmask0(:,:,:) = ptmask_b(:,:,:)
[5920]	339	DO iz = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case)
[5790]	340	DO jk = 1,jpk-1
	341	zdmask=tmask(:,:,jk)-ztmask0(:,:,jk);
[5920]	342	DO jj = 2,jpj-1
	343	DO ji = fs_2,fs_jpim1
[5790]	344	jip1=ji+1; jim1=ji-1;
	345	jjp1=jj+1; jjm1=jj-1;
[5820]	346	summsk= (ztmask0(jip1,jj ,jk)+ztmask0(jim1,jj ,jk)+ztmask0(ji ,jjp1,jk)+ztmask0(ji ,jjm1,jk))
[5945]	347	IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
[5820]	348	!! horizontal basic extrapolation
	349	tsn(ji,jj,jk,1)=( zts0(jip1,jj ,jk,1)*ztmask0(jip1,jj ,jk) &
	350	& +zts0(jim1,jj ,jk,1)*ztmask0(jim1,jj ,jk) &
	351	& +zts0(ji ,jjp1,jk,1)*ztmask0(ji ,jjp1,jk) &
	352	& +zts0(ji ,jjm1,jk,1)*ztmask0(ji ,jjm1,jk) ) / summsk
	353	tsn(ji,jj,jk,2)=( zts0(jip1,jj ,jk,2)*ztmask0(jip1,jj ,jk) &
	354	& +zts0(jim1,jj ,jk,2)*ztmask0(jim1,jj ,jk) &
	355	& +zts0(ji ,jjp1,jk,2)*ztmask0(ji ,jjp1,jk) &
	356	& +zts0(ji ,jjm1,jk,2)*ztmask0(ji ,jjm1,jk) ) / summsk
[5790]	357	ztmask1(ji,jj,jk)=1
[5945]	358	ELSEIF (zdmask(ji,jj) == 1._wp .AND. summsk == 0._wp) THEN
[5920]	359	!! vertical extrapolation if horizontal extrapolation failed
[5790]	360	jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1)
	361	summsk=(ztmask0(ji,jj,jkm1)+ztmask0(ji,jj,jkp1))
[5945]	362	IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp ) THEN
[5790]	363	tsn(ji,jj,jk,1)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) &
	364	& +zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1))/summsk
	365	tsn(ji,jj,jk,2)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) &
	366	& +zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1))/summsk
[5823]	367	ztmask1(ji,jj,jk)=1._wp
[5790]	368	END IF
	369	END IF
	370	END DO
	371	END DO
	372	END DO
[5823]	373
	374	CALL lbc_lnk(tsn(:,:,:,1),'T',1._wp)
	375	CALL lbc_lnk(tsn(:,:,:,2),'T',1._wp)
[5945]	376	CALL lbc_lnk(ztmask1, 'T',1._wp)
[5823]	377
	378	! update
[5790]	379	zts0(:,:,:,:) = tsn(:,:,:,:)
	380	ztmask0 = ztmask1
[5823]	381
[5790]	382	END DO
[5823]	383
	384	! mask new tsn field
[5790]	385	tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:)
	386	tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:)
	387
[5802]	388	! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask
[6075]	389	!PM: Is this IF needed since change to VVL by default
	390	IF (.NOT.ln_linssh) THEN
[5790]	391	DO jk = 2,jpk-1
	392	DO jj = 1,jpj
	393	DO ji = 1,jpi
[8329]	394	IF (zwmaskn(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND. &
	395	& (tmask(ji,jj,1)==0._wp .OR. ptmask_b(ji,jj,1)==0._wp) ) THEN
[5790]	396	!compute weight
[6074]	397	zdzp1 = MAX(0._wp,gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk+1))
	398	zdz = gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk )
	399	zdzm1 = MAX(0._wp,pdepw_b(ji,jj,jk ) - gdepw_n(ji,jj,jk ))
[5823]	400	IF (zdz .LT. 0._wp) THEN
[5820]	401	CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' )
[5790]	402	END IF
	403	tsn(ji,jj,jk,jp_tem) = ( zdzp1*tsb(ji,jj,jk+1,jp_tem) &
	404	& + zdz *tsb(ji,jj,jk ,jp_tem) &
[6074]	405	& + zdzm1*tsb(ji,jj,jk-1,jp_tem) )/e3t_n(ji,jj,jk)
[5790]	406	tsn(ji,jj,jk,jp_sal) = ( zdzp1*tsb(ji,jj,jk+1,jp_sal) &
	407	& + zdz *tsb(ji,jj,jk ,jp_sal) &
[6074]	408	& + zdzm1*tsb(ji,jj,jk-1,jp_sal) )/e3t_n(ji,jj,jk)
[5790]	409	END IF
	410	END DO
	411	END DO
	412	END DO
	413	END IF
	414
[5823]	415	! closed pool
	416	! -----------------------------------------------------------------------------------------
	417	! case we open a cell but no neigbour cells available to get an estimate of T and S
	418	WHERE (tmask(:,:,:) == 1._wp .AND. tsn(:,:,:,2) == 0._wp)
[5945]	419	tsn(:,:,:,2) = -99._wp ! Special value for closed pool (checking purpose in output.init)
[5823]	420	tmask(:,:,:) = 0._wp ! set mask to 0 to run
	421	umask(:,:,:) = 0._wp
	422	vmask(:,:,:) = 0._wp
[5790]	423	END WHERE
[5823]	424
	425	! set mbkt and mikt to 1 in thiese location
[5790]	426	WHERE (SUM(tmask,dim=3) == 0)
	427	mbkt(:,:)=1 ; mbku(:,:)=1 ; mbkv(:,:)=1
	428	mikt(:,:)=1 ; miku(:,:)=1 ; mikv(:,:)=1
	429	END WHERE
[5823]	430	! -------------------------------------------------------------------------------------------
[5790]	431	! compute new tn and sn if we close cell
	432	! nothing to do
[5802]	433	!
	434	! deallocation tmp arrays
[5790]	435	CALL wrk_dealloc(jpi,jpj,jpk,2, zts0 )
	436	CALL wrk_dealloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp )
	437	CALL wrk_dealloc(jpi,jpj,jpk, zwmaskn, zwmaskb , ztmp3d )
	438	CALL wrk_dealloc(jpi,jpj, zsmask0, zsmask1 )
	439	CALL wrk_dealloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t)
	440	CALL wrk_dealloc(jpi,jpj, zbub , zbvb , zbun , zbvn )
[5945]	441	CALL wrk_dealloc(jpi,jpj, zssh0 , zssh1 , zhu1 , zhv1 )
[7646]	442	!
[5790]	443	END SUBROUTINE iscpl_rst_interpol
	444
[7646]	445	!!======================================================================
[5790]	446	END MODULE iscplrst

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

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

Context Navigation

source: branches/2017/dev_r8600_xios_read/NEMOGCM/NEMO/OPA_SRC/DOM/iscplrst.F90 @ 8668

Download in other formats: