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.

traqsr.F90 in NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/TRA – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/TRA/traqsr.F90 @ 11317

Last change on this file since 11317 was 11317, checked in by smasson, 5 years ago
dev_r10984_HPC-13 : improve error handling, see #2307 and #2285
Property svn:keywords set to `Id`
File size: 21.9 KB

Rev	Line
[3]	1	MODULE traqsr
	2	!!======================================================================
	3	!! * MODULE traqsr *
[6140]	4	!! Ocean physics: solar radiation penetration in the top ocean levels
[3]	5	!!======================================================================
[1423]	6	!! History : OPA ! 1990-10 (B. Blanke) Original code
	7	!! 7.0 ! 1991-11 (G. Madec)
	8	!! ! 1996-01 (G. Madec) s-coordinates
	9	!! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module
	10	!! - ! 2005-11 (G. Madec) zco, zps, sco coordinate
	11	!! 3.2 ! 2009-04 (G. Madec & NEMO team)
[6140]	12	!! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model
[6403]	13	!! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll
[6140]	14	!! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume
[3]	15	!!----------------------------------------------------------------------
[503]	16
	17	!!----------------------------------------------------------------------
[6140]	18	!! tra_qsr : temperature trend due to the penetration of solar radiation
	19	!! tra_qsr_init : initialization of the qsr penetration
[3]	20	!!----------------------------------------------------------------------
[6140]	21	USE oce ! ocean dynamics and active tracers
	22	USE phycst ! physical constants
	23	USE dom_oce ! ocean space and time domain
	24	USE sbc_oce ! surface boundary condition: ocean
	25	USE trc_oce ! share SMS/Ocean variables
[4990]	26	USE trd_oce ! trends: ocean variables
	27	USE trdtra ! trends manager: tracers
[6140]	28	!
	29	USE in_out_manager ! I/O manager
	30	USE prtctl ! Print control
[9019]	31	USE iom ! I/O library
[6140]	32	USE fldread ! read input fields
	33	USE restart ! ocean restart
	34	USE lib_mpp ! MPP library
	35	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
[3294]	36	USE timing ! Timing
[3]	37
	38	IMPLICIT NONE
	39	PRIVATE
	40
[2528]	41	PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T)
[5407]	42	PUBLIC tra_qsr_init ! routine called by nemogcm.F90
[3]	43
[4147]	44	! !!* Namelist namtra_qsr: penetrative solar radiation
	45	LOGICAL , PUBLIC :: ln_traqsr !: light absorption (qsr) flag
	46	LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag
	47	LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag
	48	LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag
	49	INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0)
	50	REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands)
	51	REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands)
	52	REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands)
[6140]	53	!
	54	INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m)
[5407]	55
[6140]	56	INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll
	57	INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data
	58	INTEGER, PARAMETER :: np_2BD = 3 ! 2 bands light penetration
	59	INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration
	60	!
	61	INTEGER :: nqsr ! user choice of the type of light penetration
	62	REAL(wp) :: xsi0r ! inverse of rn_si0
	63	REAL(wp) :: xsi1r ! inverse of rn_si1
	64	!
	65	REAL(wp) , DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption
[1423]	66	TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read)
[3]	67
	68	!! * Substitutions
	69	# include "vectopt_loop_substitute.h90"
	70	!!----------------------------------------------------------------------
[9598]	71	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
[888]	72	!! $Id$
[10068]	73	!! Software governed by the CeCILL license (see ./LICENSE)
[3]	74	!!----------------------------------------------------------------------
	75	CONTAINS
	76
	77	SUBROUTINE tra_qsr( kt )
	78	!!----------------------------------------------------------------------
	79	!! * ROUTINE tra_qsr *
	80	!!
	81	!! ** Purpose : Compute the temperature trend due to the solar radiation
[6140]	82	!! penetration and add it to the general temperature trend.
[3]	83	!!
[1423]	84	!! ** Method : The profile of the solar radiation within the ocean is defined
	85	!! through 2 wavebands (rn_si0,rn_si1) or 3 wavebands (RGB) and a ratio rn_abs
	86	!! Considering the 2 wavebands case:
	87	!! I(k) = Qsr( rn_absEXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) )
	88	!! The temperature trend associated with the solar radiation penetration
	89	!! is given by : zta = 1/e3t dk[ I ] / (rau0*Cp)
[3]	90	!! At the bottom, boudary condition for the radiation is no flux :
	91	!! all heat which has not been absorbed in the above levels is put
	92	!! in the last ocean level.
[6140]	93	!! The computation is only done down to the level where
	94	!! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) .
[3]	95	!!
	96	!! ** Action : - update ta with the penetrative solar radiation trend
[6140]	97	!! - send trend for further diagnostics (l_trdtra=T)
[1423]	98	!!
	99	!! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
	100	!! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516.
[6403]	101	!! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562
[503]	102	!!----------------------------------------------------------------------
	103	INTEGER, INTENT(in) :: kt ! ocean time-step
[2715]	104	!
[6140]	105	INTEGER :: ji, jj, jk ! dummy loop indices
	106	INTEGER :: irgb ! local integers
	107	REAL(wp) :: zchl, zcoef, z1_2 ! local scalars
	108	REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - -
[4161]	109	REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - -
[6140]	110	REAL(wp) :: zz0 , zz1 ! - -
[6403]	111	REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze
	112	REAL(wp) :: zlogc, zlogc2, zlogc3
[9019]	113	REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr
	114	REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt
	115	REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d
[3]	116	!!----------------------------------------------------------------------
[3294]	117	!
[9019]	118	IF( ln_timing ) CALL timing_start('tra_qsr')
[3294]	119	!
[3]	120	IF( kt == nit000 ) THEN
[503]	121	IF(lwp) WRITE(numout,*)
	122	IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation'
	123	IF(lwp) WRITE(numout,*) '~~~~~~~'
[3]	124	ENDIF
[6140]	125	!
	126	IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend
[9019]	127	ALLOCATE( ztrdt(jpi,jpj,jpk) )
[7753]	128	ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
[216]	129	ENDIF
[6140]	130	!
	131	! !-----------------------------------!
	132	! ! before qsr induced heat content !
	133	! !-----------------------------------!
	134	IF( kt == nit000 ) THEN !== 1st time step ==!
	135	!!gm case neuler not taken into account....
	136	IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN ! read in restart
	137	IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'
	138	z1_2 = 0.5_wp
[9367]	139	CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux
[2528]	140	ELSE ! No restart or restart not found: Euler forward time stepping
[6140]	141	z1_2 = 1._wp
[7753]	142	qsr_hc_b(:,:,:) = 0._wp
[2528]	143	ENDIF
[6140]	144	ELSE !== Swap of qsr heat content ==!
	145	z1_2 = 0.5_wp
[7753]	146	qsr_hc_b(:,:,:) = qsr_hc(:,:,:)
[2528]	147	ENDIF
[6140]	148	!
	149	! !--------------------------------!
	150	SELECT CASE( nqsr ) ! now qsr induced heat content !
	151	! !--------------------------------!
	152	!
	153	CASE( np_BIO ) !== bio-model fluxes ==!
	154	!
	155	DO jk = 1, nksr
[7753]	156	qsr_hc(:,:,jk) = r1_rau0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) )
[2528]	157	END DO
[6140]	158	!
	159	CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==!
	160	!
[9019]	161	ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , &
	162	& ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , &
	163	& ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) )
[6140]	164	!
	165	IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll
	166	CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step
[6403]	167	DO jk = 1, nksr + 1
	168	DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl
	169	DO ji = fs_2, fs_jpim1
	170	zchl = sf_chl(1)%fnow(ji,jj,1)
	171	zCtot = 40.6 * zchl**0.459
	172	zze = 568.2 * zCtot**(-0.746)
	173	IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293)
	174	zpsi = gdepw_n(ji,jj,jk) / zze
	175	!
	176	zlogc = LOG( zchl )
	177	zlogc2 = zlogc * zlogc
	178	zlogc3 = zlogc * zlogc * zlogc
	179	zCb = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3
	180	zCmax = 0.299 - 0.289 * zlogc + 0.579 * zlogc2
	181	zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3
	182	zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2
	183	zCze = 1.12 * (zchl)**0.803
	184	!
	185	zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) )
	186	END DO
	187	!
[3]	188	END DO
	189	END DO
[6140]	190	ELSE !* constant chrlorophyll
[6403]	191	DO jk = 1, nksr + 1
[7753]	192	zchl3d(:,:,jk) = 0.05
[6403]	193	ENDDO
[4161]	194	ENDIF
[1423]	195	!
[6140]	196	zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B
	197	DO jj = 2, jpjm1
	198	DO ji = fs_2, fs_jpim1
	199	ze0(ji,jj,1) = rn_abs * qsr(ji,jj)
	200	ze1(ji,jj,1) = zcoef * qsr(ji,jj)
	201	ze2(ji,jj,1) = zcoef * qsr(ji,jj)
	202	ze3(ji,jj,1) = zcoef * qsr(ji,jj)
	203	zea(ji,jj,1) = qsr(ji,jj)
	204	END DO
	205	END DO
	206	!
[6403]	207	DO jk = 2, nksr+1 !* interior equi-partition in R-G-B depending of vertical profile of Chl
[6140]	208	DO jj = 2, jpjm1
	209	DO ji = fs_2, fs_jpim1
[6403]	210	zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) )
	211	irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 )
	212	zekb(ji,jj) = rkrgb(1,irgb)
	213	zekg(ji,jj) = rkrgb(2,irgb)
	214	zekr(ji,jj) = rkrgb(3,irgb)
	215	END DO
	216	END DO
	217
	218	DO jj = 2, jpjm1
	219	DO ji = fs_2, fs_jpim1
[6140]	220	zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r )
	221	zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) )
	222	zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) )
	223	zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) )
	224	ze0(ji,jj,jk) = zc0
	225	ze1(ji,jj,jk) = zc1
	226	ze2(ji,jj,jk) = zc2
	227	ze3(ji,jj,jk) = zc3
	228	zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk)
[1423]	229	END DO
[6140]	230	END DO
	231	END DO
	232	!
	233	DO jk = 1, nksr !* now qsr induced heat content
	234	DO jj = 2, jpjm1
	235	DO ji = fs_2, fs_jpim1
	236	qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) )
[1423]	237	END DO
[6140]	238	END DO
	239	END DO
[187]	240	!
[9019]	241	DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d )
[6140]	242	!
	243	CASE( np_2BD ) !== 2-bands fluxes ==!
	244	!
	245	zz0 = rn_abs * r1_rau0_rcp ! surface equi-partition in 2-bands
	246	zz1 = ( 1. - rn_abs ) * r1_rau0_rcp
	247	DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m
	248	DO jj = 2, jpjm1
	249	DO ji = fs_2, fs_jpim1
	250	zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk )xsi0r ) + zz1 EXP( -gdepw_n(ji,jj,jk )*xsi1r )
	251	zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)xsi0r ) + zz1 EXP( -gdepw_n(ji,jj,jk+1)*xsi1r )
	252	qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )
[2528]	253	END DO
	254	END DO
	255	END DO
	256	!
[6140]	257	END SELECT
	258	!
	259	! !-----------------------------!
	260	DO jk = 1, nksr ! update to the temp. trend !
	261	DO jj = 2, jpjm1 !-----------------------------!
	262	DO ji = fs_2, fs_jpim1 ! vector opt.
	263	tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) &
	264	& + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk)
	265	END DO
	266	END DO
	267	END DO
	268	!
[9019]	269	! sea-ice: store the 1st ocean level attenuation coefficient
	270	DO jj = 2, jpjm1
	271	DO ji = fs_2, fs_jpim1 ! vector opt.
	272	IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) )
	273	ELSE ; fraqsr_1lev(ji,jj) = 1._wp
	274	ENDIF
[6140]	275	END DO
[9019]	276	END DO
[10425]	277	CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp )
[2528]	278	!
[6140]	279	IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution
[9019]	280	ALLOCATE( zetot(jpi,jpj,jpk) )
[7753]	281	zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero
[6140]	282	DO jk = nksr, 1, -1
[9019]	283	zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rau0_rcp
[6140]	284	END DO
	285	CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation
[9019]	286	DEALLOCATE( zetot )
[2528]	287	ENDIF
[6140]	288	!
	289	IF( lrst_oce ) THEN ! write in the ocean restart file
[9367]	290	IF( lwxios ) CALL iom_swap( cwxios_context )
	291	CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios )
	292	CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios )
	293	IF( lwxios ) CALL iom_swap( cxios_context )
[6140]	294	ENDIF
	295	!
[503]	296	IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics
[7753]	297	ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
[4990]	298	CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt )
[9019]	299	DEALLOCATE( ztrdt )
[3]	300	ENDIF
[457]	301	! ! print mean trends (used for debugging)
[2528]	302	IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' )
[503]	303	!
[9019]	304	IF( ln_timing ) CALL timing_stop('tra_qsr')
[3294]	305	!
[3]	306	END SUBROUTINE tra_qsr
	307
	308
	309	SUBROUTINE tra_qsr_init
	310	!!----------------------------------------------------------------------
	311	!! * ROUTINE tra_qsr_init *
	312	!!
	313	!! ** Purpose : Initialization for the penetrative solar radiation
	314	!!
	315	!! ** Method : The profile of solar radiation within the ocean is set
[1423]	316	!! from two length scale of penetration (rn_si0,rn_si1) and a ratio
[1601]	317	!! (rn_abs). These parameters are read in the namtra_qsr namelist. The
[3]	318	!! default values correspond to clear water (type I in Jerlov'
	319	!! (1968) classification.
	320	!! called by tra_qsr at the first timestep (nit000)
	321	!!
[1423]	322	!! ** Action : - initialize rn_si0, rn_si1 and rn_abs
[3]	323	!!
[503]	324	!! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
[3]	325	!!----------------------------------------------------------------------
[6140]	326	INTEGER :: ji, jj, jk ! dummy loop indices
	327	INTEGER :: ios, irgb, ierror, ioptio ! local integer
	328	REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars
	329	REAL(wp) :: zz1, zc2 , zc3, zchl ! - -
[2715]	330	!
[1423]	331	CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
	332	TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read
[2715]	333	!!
[9019]	334	NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, &
[2528]	335	& nn_chldta, rn_abs, rn_si0, rn_si1
[3]	336	!!----------------------------------------------------------------------
[3294]	337	!
[6140]	338	REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist
	339	READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901)
[11317]	340	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' )
[3294]	341	!
[6140]	342	REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration namelist
[4147]	343	READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 )
[11317]	344	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' )
[4624]	345	IF(lwm) WRITE ( numond, namtra_qsr )
[1423]	346	!
	347	IF(lwp) THEN ! control print
	348	WRITE(numout,*)
	349	WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation'
	350	WRITE(numout,*) '~~~~~~~~~~~~'
[1601]	351	WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration'
[6140]	352	WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb
	353	WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd
	354	WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio
	355	WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta
	356	WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs
	357	WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0
	358	WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1
	359	WRITE(numout,*)
[1423]	360	ENDIF
[6140]	361	!
	362	ioptio = 0 ! Parameter control
	363	IF( ln_qsr_rgb ) ioptio = ioptio + 1
	364	IF( ln_qsr_2bd ) ioptio = ioptio + 1
	365	IF( ln_qsr_bio ) ioptio = ioptio + 1
	366	!
	367	IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', &
	368	& ' 2 bands, 3 RGB bands or bio-model light penetration' )
	369	!
	370	IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB
	371	IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc
	372	IF( ln_qsr_2bd ) nqsr = np_2BD
	373	IF( ln_qsr_bio ) nqsr = np_BIO
	374	!
	375	! ! Initialisation
	376	xsi0r = 1._wp / rn_si0
	377	xsi1r = 1._wp / rn_si1
	378	!
	379	SELECT CASE( nqsr )
	380	!
	381	CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==!
	382	!
[9169]	383	IF(lwp) WRITE(numout,*) ' ==>>> R-G-B light penetration '
[6140]	384	!
	385	CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef.
	386	!
	387	nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction
	388	!
	389	IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
	390	!
	391	IF( nqsr == np_RGBc ) THEN ! Chl data : set sf_chl structure
[9169]	392	IF(lwp) WRITE(numout,*) ' ==>>> Chlorophyll read in a file'
[6140]	393	ALLOCATE( sf_chl(1), STAT=ierror )
	394	IF( ierror > 0 ) THEN
	395	CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN
	396	ENDIF
	397	ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) )
	398	IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) )
	399	! ! fill sf_chl with sn_chl and control print
	400	CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', &
[7646]	401	& 'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print )
[1448]	402	ENDIF
[6140]	403	IF( nqsr == np_RGB ) THEN ! constant Chl
[9169]	404	IF(lwp) WRITE(numout,*) ' ==>>> Constant Chlorophyll concentration = 0.05'
[6140]	405	ENDIF
[1448]	406	!
[6140]	407	CASE( np_2BD ) !== 2 bands light penetration ==!
[1448]	408	!
[9169]	409	IF(lwp) WRITE(numout,*) ' ==>>> 2 bands light penetration'
[1448]	410	!
[6140]	411	nksr = trc_oce_ext_lev( rn_si1, 100._wp ) ! level of light extinction
	412	IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
[1455]	413	!
[6140]	414	CASE( np_BIO ) !== BIO light penetration ==!
[1448]	415	!
[9169]	416	IF(lwp) WRITE(numout,*) ' ==>>> bio-model light penetration'
[7646]	417	IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' )
[1423]	418	!
[6140]	419	END SELECT
[503]	420	!
[7753]	421	qsr_hc(:,:,:) = 0._wp ! now qsr heat content set to zero where it will not be computed
[6140]	422	!
	423	! 1st ocean level attenuation coefficient (used in sbcssm)
[5407]	424	IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN
[9367]	425	CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios )
[5407]	426	ELSE
[7753]	427	fraqsr_1lev(:,:) = 1._wp ! default : no penetration
[5407]	428	ENDIF
	429	!
[9367]	430	IF( lwxios ) THEN
	431	CALL iom_set_rstw_var_active('qsr_hc_b')
	432	CALL iom_set_rstw_var_active('fraqsr_1lev')
	433	ENDIF
	434	!
[3]	435	END SUBROUTINE tra_qsr_init
	436
	437	!!======================================================================
	438	END MODULE traqsr

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

Download in other formats: