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.

sbcssr.F90 in branches/UKMO/dev_1d_bugfixes_tocommit/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/UKMO/dev_1d_bugfixes_tocommit/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90 @ 13191

Last change on this file since 13191 was 13191, checked in by jwhile, 4 years ago
Updates for 1d runnig
File size: 13.7 KB

Rev	Line
[888]	1	MODULE sbcssr
	2	!!======================================================================
	3	!! * MODULE sbcssr *
[1524]	4	!! Surface module : heat and fresh water fluxes a restoring term toward observed SST/SSS
[888]	5	!!======================================================================
[1524]	6	!! History : 3.0 ! 2006-06 (G. Madec) Original code
[1482]	7	!! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put
[888]	8	!!----------------------------------------------------------------------
	9
	10	!!----------------------------------------------------------------------
[3625]	11	!! sbc_ssr : add to sbc a restoring term toward SST/SSS climatology
[4990]	12	!! sbc_ssr_init : initialisation of surface restoring
[888]	13	!!----------------------------------------------------------------------
[3625]	14	USE oce ! ocean dynamics and tracers
	15	USE dom_oce ! ocean space and time domain
	16	USE sbc_oce ! surface boundary condition
	17	USE phycst ! physical constants
	18	USE sbcrnf ! surface boundary condition : runoffs
[4990]	19	!
[3625]	20	USE fldread ! read input fields
	21	USE iom ! I/O manager
	22	USE in_out_manager ! I/O manager
	23	USE lib_mpp ! distribued memory computing library
	24	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
	25	USE timing ! Timing
[13191]	26	USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
[11442]	27	USE stopack
	28	USE wrk_nemo ! Memory Allocation
[888]	29
	30	IMPLICIT NONE
	31	PRIVATE
	32
[3764]	33	PUBLIC sbc_ssr ! routine called in sbcmod
	34	PUBLIC sbc_ssr_init ! routine called in sbcmod
[888]	35
[2715]	36	REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s]
	37	REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2]
[1524]	38
[4147]	39	! !!* Namelist namsbc_ssr *
	40	INTEGER, PUBLIC :: nn_sstr ! SST/SSS restoring indicator
	41	INTEGER, PUBLIC :: nn_sssr ! SST/SSS restoring indicator
	42	REAL(wp) :: rn_dqdt ! restoring factor on SST and SSS
	43	REAL(wp) :: rn_deds ! restoring factor on SST and SSS
[13191]	44	LOGICAL :: ln_sssr_bnd ! flag to bound erp term
[4147]	45	REAL(wp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day]
[1524]	46
	47	REAL(wp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange
[1106]	48	TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sst ! structure of input SST (file informations, fields read)
	49	TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sss ! structure of input SSS (file informations, fields read)
[888]	50
	51	!! * Substitutions
	52	# include "domzgr_substitute.h90"
	53	!!----------------------------------------------------------------------
[2715]	54	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
[1156]	55	!! $Id$
[2715]	56	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[888]	57	!!----------------------------------------------------------------------
	58	CONTAINS
	59
	60	SUBROUTINE sbc_ssr( kt )
	61	!!---------------------------------------------------------------------
	62	!! * ROUTINE sbc_ssr *
	63	!!
	64	!! ** Purpose : Add to heat and/or freshwater fluxes a damping term
	65	!! toward observed SST and/or SSS.
	66	!!
	67	!! ** Method : - Read namelist namsbc_ssr
	68	!! - Read observed SST and/or SSS
	69	!! - at each nscb time step
	70	!! add a retroaction term on qns (nn_sstr = 1)
[3625]	71	!! add a damping term on sfx (nn_sssr = 1)
	72	!! add a damping term on emp (nn_sssr = 2)
[888]	73	!!---------------------------------------------------------------------
	74	INTEGER, INTENT(in ) :: kt ! ocean time step
	75	!!
	76	INTEGER :: ji, jj ! dummy loop indices
	77	REAL(wp) :: zerp ! local scalar for evaporation damping
	78	REAL(wp) :: zqrp ! local scalar for heat flux damping
[1554]	79	REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
[11442]	80	REAL(wp), POINTER, DIMENSION(:,:) :: rn_dqdt_s, zsrp
[888]	81	INTEGER :: ierror ! return error code
	82	!!
	83	CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
	84	TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read
	85	!!----------------------------------------------------------------------
[1524]	86	!
[3294]	87	IF( nn_timing == 1 ) CALL timing_start('sbc_ssr')
	88	!
[888]	89	IF( nn_sstr + nn_sssr /= 0 ) THEN
[1524]	90	!
	91	IF( nn_sstr == 1) CALL fld_read( kt, nn_fsbc, sf_sst ) ! Read SST data and provides it at kt
	92	IF( nn_sssr >= 1) CALL fld_read( kt, nn_fsbc, sf_sss ) ! Read SSS data and provides it at kt
	93	!
[888]	94	! ! ========================= !
	95	IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Add restoring term !
	96	! ! ========================= !
	97	!
[3625]	98	IF( nn_sstr == 1 ) THEN !* Temperature restoring term
[11442]	99
	100	CALL wrk_alloc( jpi, jpj, rn_dqdt_s )
	101	rn_dqdt_s(:,:) = rn_dqdt
	102
[13191]	103	#if defined key_traldf_c2d \|\| key_traldf_c3d
	104	IF( ln_stopack .AND. nn_spp_dqdt > 0 ) &
	105	& CALL spp_gen( kt, rn_dqdt_s, nn_spp_dqdt, rn_dqdt_sd, jk_spp_dqdt )
	106	#else
	107	IF ( ln_stopack .AND. nn_spp_dqdt > 0 ) &
	108	& CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
	109	'key_traldf_c2d or key_traldf_c3d')
	110	#endif
	111
[888]	112	DO jj = 1, jpj
	113	DO ji = 1, jpi
[11442]	114	zqrp = rn_dqdt_s(ji,jj) * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
[888]	115	qns(ji,jj) = qns(ji,jj) + zqrp
	116	qrp(ji,jj) = zqrp
	117	END DO
	118	END DO
[1482]	119	CALL iom_put( "qrp", qrp ) ! heat flux damping
[11442]	120	CALL wrk_dealloc( jpi, jpj, rn_dqdt_s )
[888]	121	ENDIF
	122	!
[3625]	123	IF( nn_sssr == 1 ) THEN !* Salinity damping term (salt flux only (sfx))
[11442]	124	CALL wrk_alloc( jpi, jpj, zsrp)
	125	zsrp(:,:) = rn_deds
[13191]	126	#if defined key_traldf_c2d \|\| key_traldf_c3d
[11442]	127	IF( ln_stopack .AND. nn_spp_dedt > 0 ) &
	128	& CALL spp_gen(kt, zsrp, nn_spp_dedt, rn_dedt_sd, jk_spp_deds )
[13191]	129	#else
	130	IF ( ln_stopack .AND. nn_spp_icealb > 0 ) &
	131	& CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
	132	'key_traldf_c2d or key_traldf_c3d')
	133	#endif
	134
	135
[888]	136	!CDIR COLLAPSE
	137	DO jj = 1, jpj
	138	DO ji = 1, jpi
[11442]	139	zerp = (zsrp(ji,jj)/rday) * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths
[13191]	140	& * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )
[3625]	141	sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux
	142	erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
[888]	143	END DO
	144	END DO
[1482]	145	CALL iom_put( "erp", erp ) ! freshwater flux damping
[11442]	146	CALL wrk_dealloc( jpi,jpj, zsrp )
[1601]	147	!
[3625]	148	ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
[11442]	149	CALL wrk_alloc( jpi, jpj, zsrp)
	150	zsrp(:,:) = rn_deds
[13191]	151	#if defined key_traldf_c2d \|\| key_traldf_c3d
[11442]	152	IF( ln_stopack .AND. nn_spp_dedt > 0 ) &
	153	& CALL spp_gen( kt, zsrp, nn_spp_dedt, rn_dedt_sd, jk_spp_deds )
[13191]	154	#else
	155	IF ( ln_stopack .AND. nn_spp_dedt > 0 ) &
	156	& CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
	157	'key_traldf_c2d or key_traldf_c3d')
	158	#endif
	159	zerp_bnd = rn_sssr_bnd / rday ! - -
[888]	160	!CDIR COLLAPSE
	161	DO jj = 1, jpj
[13191]	162	DO ji = 1, jpi
[11442]	163	zerp = (zsrp(ji,jj)/rday) * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths
[2528]	164	& * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) &
[3625]	165	& / MAX( sss_m(ji,jj), 1.e-20 )
[1554]	166	IF( ln_sssr_bnd ) zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
[3625]	167	emp(ji,jj) = emp (ji,jj) + zerp
	168	qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
	169	erp(ji,jj) = zerp
[888]	170	END DO
	171	END DO
[1482]	172	CALL iom_put( "erp", erp ) ! freshwater flux damping
[11442]	173	CALL wrk_dealloc( jpi,jpj,zsrp )
[888]	174	ENDIF
	175	!
	176	ENDIF
	177	!
	178	ENDIF
	179	!
[3294]	180	IF( nn_timing == 1 ) CALL timing_stop('sbc_ssr')
	181	!
[888]	182	END SUBROUTINE sbc_ssr
[3764]	183
[13191]	184
[3764]	185	SUBROUTINE sbc_ssr_init
	186	!!---------------------------------------------------------------------
	187	!! * ROUTINE sbc_ssr_init *
	188	!!
	189	!! ** Purpose : initialisation of surface damping term
	190	!!
	191	!! ** Method : - Read namelist namsbc_ssr
	192	!! - Read observed SST and/or SSS if required
	193	!!---------------------------------------------------------------------
	194	INTEGER :: ji, jj ! dummy loop indices
	195	REAL(wp) :: zerp ! local scalar for evaporation damping
	196	REAL(wp) :: zqrp ! local scalar for heat flux damping
	197	REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor
	198	REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
	199	INTEGER :: ierror ! return error code
	200	!!
	201	CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
	202	TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read
	203	NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
[4147]	204	INTEGER :: ios
[3764]	205	!!----------------------------------------------------------------------
	206	!
[13191]	207
	208	REWIND( numnam_ref ) ! Namelist namsbc_ssr in reference namelist :
[4147]	209	READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
	210	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp )
[3764]	211
[4147]	212	REWIND( numnam_cfg ) ! Namelist namsbc_ssr in configuration namelist :
	213	READ ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
	214	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp )
[4624]	215	IF(lwm) WRITE ( numond, namsbc_ssr )
[3764]	216
	217	IF(lwp) THEN !* control print
	218	WRITE(numout,*)
	219	WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
	220	WRITE(numout,*) '~~~~~~~ '
	221	WRITE(numout,*) ' Namelist namsbc_ssr :'
	222	WRITE(numout,*) ' SST restoring term (Yes=1) nn_sstr = ', nn_sstr
	223	WRITE(numout,*) ' SSS damping term (Yes=1, salt flux) nn_sssr = ', nn_sssr
	224	WRITE(numout,*) ' (Yes=2, volume flux) '
	225	WRITE(numout,*) ' dQ/dT (restoring magnitude on SST) rn_dqdt = ', rn_dqdt, ' W/m2/K'
	226	WRITE(numout,*) ' dE/dS (restoring magnitude on SST) rn_deds = ', rn_deds, ' mm/day'
	227	WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd
	228	WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
	229	ENDIF
	230	!
	231	! !* Allocate erp and qrp array
	232	ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
	233	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
	234	!
	235	IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays
	236	!
	237	ALLOCATE( sf_sst(1), STAT=ierror )
	238	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
	239	ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
	240	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
	241	!
	242	! fill sf_sst with sn_sst and control print
	243	CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )
	244	IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
	245	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
	246	!
	247	ENDIF
	248	!
	249	IF( nn_sssr >= 1 ) THEN !* set sf_sss structure & allocate arrays
	250	!
	251	ALLOCATE( sf_sss(1), STAT=ierror )
	252	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
	253	ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
	254	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
	255	!
	256	! fill sf_sss with sn_sss and control print
	257	CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )
	258	IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
	259	IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
	260	!
	261	ENDIF
	262	!
[13191]	263	! !* Initialize qrp and erp if no restoring
[3764]	264	IF( nn_sstr /= 1 ) qrp(:,:) = 0._wp
	265	IF( nn_sssr /= 1 .OR. nn_sssr /= 2 ) erp(:,:) = 0._wp
	266	!
	267	END SUBROUTINE sbc_ssr_init
[13191]	268
[888]	269	!!======================================================================
	270	END MODULE sbcssr

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

Download in other formats: