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.

limwri_2.F90 in trunk/NEMOGCM/NEMO/LIM_SRC_2 – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/LIM_SRC_2/limwri_2.F90 @ 2730

Last change on this file since 2730 was 2715, checked in by rblod, 13 years ago
First attempt to put dynamic allocation on the trunk
Property svn:keywords set to `Id`
File size: 17.2 KB

Rev	Line
[821]	1	MODULE limwri_2
[3]	2	!!======================================================================
[821]	3	!! * MODULE limwri_2 *
[3]	4	!! Ice diagnostics : write ice output files
	5	!!======================================================================
[1482]	6	!! history : 2.0 ! 2003-08 (C. Ethe) original code
	7	!! 2.0 ! 2004-10 (C. Ethe ) 1D configuration
	8	!! - ! 2009-06 (B. Lemaire ) iom_put + lim_wri_state_2
[508]	9	!!-------------------------------------------------------------------
[821]	10	#if defined key_lim2
[3]	11	!!----------------------------------------------------------------------
[888]	12	!! 'key_lim2' LIM 2.0 sea-ice model
[3]	13	!!----------------------------------------------------------------------
[508]	14	!!----------------------------------------------------------------------
[821]	15	!! lim_wri_2 : write of the diagnostics variables in ouput file
	16	!! lim_wri_init_2 : initialization and namelist read
[1482]	17	!! lim_wri_state_2 : write for initial state or/and abandon:
	18	!! > output.init.nc (if ninist = 1 in namelist)
	19	!! > output.abort.nc
[3]	20	!!----------------------------------------------------------------------
[717]	21	USE phycst
[3]	22	USE dom_oce
[888]	23	USE sbc_oce
	24	USE sbc_ice
[821]	25	USE dom_ice_2
	26	USE ice_2
[888]	27
[2715]	28	USE dianam ! build name of file (routine)
[717]	29	USE lbclnk
[888]	30	USE in_out_manager
[2715]	31	USE lib_mpp ! MPP library
[1359]	32	USE iom
[888]	33	USE ioipsl
[3]	34
	35	IMPLICIT NONE
	36	PRIVATE
	37
[1482]	38	#if ! defined key_iomput
	39	PUBLIC lim_wri_2 ! called by sbc_ice_lim_2
	40	#endif
	41	PUBLIC lim_wri_state_2 ! called by dia_wri_state
[2715]	42	PUBLIC lim_wri_alloc_2 ! called by nemogcm.F90
[3]	43
[508]	44	INTEGER, PARAMETER :: jpnoumax = 40 ! maximum number of variable for ice output
	45	INTEGER :: noumef ! number of fields
	46	REAL(wp) , DIMENSION(jpnoumax) :: cmulti , & ! multiplicative constant
	47	& cadd ! additive constant
	48	CHARACTER(len = 35), DIMENSION(jpnoumax) :: titn ! title of the field
	49	CHARACTER(len = 8 ), DIMENSION(jpnoumax) :: nam ! name of the field
	50	CHARACTER(len = 8 ), DIMENSION(jpnoumax) :: uni ! unit of the field
	51	INTEGER , DIMENSION(jpnoumax) :: nc ! switch for saving field ( = 1 ) or not ( = 0 )
[3]	52
[508]	53	INTEGER :: nice, nhorid, ndim, niter, ndepid ! ????
[2715]	54	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex51 ! ????
[508]	55
[2715]	56	REAL(wp) :: epsi16 = 1.e-16_wp ! constant values
	57	REAL(wp) :: zzero = 0._wp ! - -
	58	REAL(wp) :: zone = 1._wp ! - -
[3]	59
[2715]	60	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcmo ! Workspace array for netcdf writer.
	61
	62
[888]	63	!! * Substitutions
	64	# include "vectopt_loop_substitute.h90"
[508]	65	!!----------------------------------------------------------------------
[2528]	66	!! NEMO/LIM2 3.3 , UCL - NEMO Consortium (2010)
[1156]	67	!! $Id$
[2528]	68	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[508]	69	!!----------------------------------------------------------------------
[3]	70	CONTAINS
[508]	71
[2715]	72	INTEGER FUNCTION lim_wri_alloc_2()
	73	!!-------------------------------------------------------------------
	74	!! * ROUTINE lim_wri_alloc_2 *
	75	!!-------------------------------------------------------------------
	76	ALLOCATE( ndex51(jpij), zcmo(jpi,jpj,jpnoumax), STAT=lim_wri_alloc_2)
	77	!
	78	IF( lk_mpp ) CALL mpp_sum ( lim_wri_alloc_2 )
	79	IF( lim_wri_alloc_2 /= 0 ) CALL ctl_warn('lim_wri_alloc_2: failed to allocate array ndex51')
	80	!
	81	END FUNCTION lim_wri_alloc_2
	82
	83
[1482]	84	#if ! defined key_iomput
	85	# if defined key_dimgout
[508]	86	!!----------------------------------------------------------------------
	87	!! 'key_dimgout' Direct Access file
	88	!!----------------------------------------------------------------------
[821]	89	# include "limwri_dimg_2.h90"
[1482]	90	# else
[821]	91	SUBROUTINE lim_wri_2( kt )
[3]	92	!!-------------------------------------------------------------------
[821]	93	!! * ROUTINE lim_wri_2 *
[508]	94	!!
	95	!! ** Purpose : write the sea-ice output file in NetCDF
	96	!!
	97	!! ** Method : computes the average of some variables and write
	98	!! it in the NetCDF ouput files
	99	!! CAUTION: the sea-ice time-step must be an integer fraction
	100	!! of a day
[3]	101	!!-------------------------------------------------------------------
[2715]	102	USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
	103	USE wrk_nemo, ONLY: zfield => wrk_2d_1
	104	!!
[508]	105	INTEGER, INTENT(in) :: kt ! number of iteration
[888]	106	!!
[508]	107	INTEGER :: ji, jj, jf ! dummy loop indices
	108	CHARACTER(len = 40) :: clhstnam, clop
[1310]	109	REAL(wp) :: zsto, zjulian, zout, & ! temporary scalars
[508]	110	& zindh, zinda, zindb, ztmu
	111	REAL(wp), DIMENSION(1) :: zdept
[3]	112	!!-------------------------------------------------------------------
[2715]	113
	114	IF( wrk_in_use(2, 1) ) THEN
	115	CALL ctl_stop('lim_wri_2 : requested workspace array unavailable') ; RETURN
	116	ENDIF
[1482]	117	!--------------------!
[888]	118	IF( kt == nit000 ) THEN ! Initialisation !
[508]	119	! !--------------------!
[2715]	120
[821]	121	CALL lim_wri_init_2
[508]	122
[3]	123	zsto = rdt_ice
[1312]	124	IF( ln_mskland ) THEN ; clop = "ave(only(x))" ! put 1.e+20 on land (very expensive!!)
	125	ELSE ; clop = "ave(x)" ! no use of the mask value (require less cpu time)
	126	ENDIF
[888]	127	zout = nwrite * rdt_ice / nn_fsbc
[1339]	128	niter = ( nit000 - 1 ) / nn_fsbc
[3]	129	zdept(1) = 0.
	130
[1310]	131	CALL ymds2ju ( nyear, nmonth, nday, rdt, zjulian )
	132	zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
[3]	133	CALL dia_nam ( clhstnam, nwrite, 'icemod' )
[508]	134	CALL histbeg ( clhstnam, jpi, glamt, jpj, gphit, &
[2528]	135	& 1, jpi, 1, jpj, niter, zjulian, rdt_ice, nhorid, nice , domain_id=nidom, snc4chunks=snc4set)
[1334]	136	CALL histvert( nice, "deptht", "Vertical T levels", "m", 1, zdept, ndepid, "down")
[3]	137	CALL wheneq ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim)
	138
[88]	139	DO jf = 1, noumef
[888]	140	IF( nc(jf) == 1 ) CALL histdef( nice, nam(jf), titn(jf), uni(jf), jpi, jpj &
	141	& , nhorid, 1, 1, 1, -99, 32, clop, zsto, zout )
[3]	142	END DO
[2528]	143	CALL histend( nice, snc4set )
[888]	144	!
[3]	145	ENDIF
[508]	146	! !--------------------!
	147	! ! Cumulate at kt !
	148	! !--------------------!
[3]	149
[888]	150	!-- Store instantaneous values in zcmo
[3]	151
[88]	152	zcmo(:,:, 1:jpnoumax ) = 0.e0
[3]	153	DO jj = 2 , jpjm1
[1347]	154	DO ji = 1 , jpim1 ! NO vector opt.
[3]	155	zindh = MAX( zzero , SIGN( zone , hicif(ji,jj) * (1.0 - frld(ji,jj) ) - 0.10 ) )
	156	zinda = MAX( zzero , SIGN( zone , ( 1.0 - frld(ji,jj) ) - 0.10 ) )
	157	zindb = zindh * zinda
	158	ztmu = MAX( 0.5 * zone , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) )
	159	zcmo(ji,jj,1) = hsnif (ji,jj)
	160	zcmo(ji,jj,2) = hicif (ji,jj)
	161	zcmo(ji,jj,3) = hicifp(ji,jj)
	162	zcmo(ji,jj,4) = frld (ji,jj)
	163	zcmo(ji,jj,5) = sist (ji,jj)
	164	zcmo(ji,jj,6) = fbif (ji,jj)
[1470]	165	zcmo(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj ) + u_ice(ji+1,jj ) * tmu(ji+1,jj ) &
	166	+ u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) &
[3]	167	/ ztmu
	168
[1470]	169	zcmo(ji,jj,8) = zindb * ( v_ice(ji,jj ) * tmu(ji,jj ) + v_ice(ji+1,jj ) * tmu(ji+1,jj ) &
	170	+ v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) &
[3]	171	/ ztmu
[888]	172	zcmo(ji,jj,9) = sst_m(ji,jj)
	173	zcmo(ji,jj,10) = sss_m(ji,jj)
	174	zcmo(ji,jj,11) = qns(ji,jj) + qsr(ji,jj)
	175	zcmo(ji,jj,12) = qsr(ji,jj)
	176	zcmo(ji,jj,13) = qns(ji,jj)
[3]	177	! See thersf for the coefficient
[888]	178	zcmo(ji,jj,14) = - emps(ji,jj) * rday * ( sss_m(ji,jj) + epsi16 ) / soce !!gm ???
[1469]	179	zcmo(ji,jj,15) = utau_ice(ji,jj)
	180	zcmo(ji,jj,16) = vtau_ice(ji,jj)
[1463]	181	zcmo(ji,jj,17) = qsr_ice(ji,jj,1)
	182	zcmo(ji,jj,18) = qns_ice(ji,jj,1)
[3]	183	zcmo(ji,jj,19) = sprecip(ji,jj)
	184	END DO
	185	END DO
	186	!
[508]	187	! Write the netcdf file
[3]	188	!
	189	niter = niter + 1
	190	DO jf = 1 , noumef
	191	DO jj = 1 , jpj
	192	DO ji = 1 , jpi
	193	zfield(ji,jj) = zcmo(ji,jj,jf) * cmulti(jf) + cadd(jf)
	194	END DO
	195	END DO
	196
[888]	197	IF( jf == 7 .OR. jf == 8 .OR. jf == 15 .OR. jf == 16 ) THEN
[3]	198	CALL lbc_lnk( zfield, 'T', -1. )
	199	ELSE
	200	CALL lbc_lnk( zfield, 'T', 1. )
	201	ENDIF
	202
[888]	203	IF( nc(jf) == 1 ) CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 )
[3]	204
	205	END DO
	206
[1334]	207	IF( ( nn_fsbc * niter ) >= nitend ) CALL histclo( nice )
[1359]	208
[2715]	209	IF( wrk_not_released(2, 1) ) CALL ctl_stop('lim_wri_2 : failed to release workspace array.')
	210	!
[821]	211	END SUBROUTINE lim_wri_2
[1482]	212
	213
[821]	214	SUBROUTINE lim_wri_init_2
[3]	215	!!-------------------------------------------------------------------
[821]	216	!! * ROUTINE lim_wri_init_2 *
[3]	217	!!
[508]	218	!! ** Purpose : intialisation of LIM sea-ice output
[3]	219	!!
	220	!! ** Method : Read the namicewri namelist and check the parameter
	221	!! values called at the first timestep (nit000)
	222	!!
	223	!! ** input : Namelist namicewri
	224	!!-------------------------------------------------------------------
	225	INTEGER :: nf ! ???
	226	TYPE FIELD
	227	CHARACTER(len = 35) :: ztitle
	228	CHARACTER(len = 8 ) :: zname
	229	CHARACTER(len = 8 ) :: zunit
	230	INTEGER :: znc
	231	REAL :: zcmulti
	232	REAL :: zcadd
	233	END TYPE FIELD
	234	TYPE(FIELD) :: &
	235	field_1 , field_2 , field_3 , field_4 , field_5 , field_6 , &
	236	field_7 , field_8 , field_9 , field_10, field_11, field_12, &
	237	field_13, field_14, field_15, field_16, field_17, field_18, &
	238	field_19
[88]	239	TYPE(FIELD) , DIMENSION(jpnoumax) :: zfield
[3]	240
	241	NAMELIST/namiceout/ noumef, &
	242	field_1 , field_2 , field_3 , field_4 , field_5 , field_6 , &
	243	field_7 , field_8 , field_9 , field_10, field_11, field_12, &
	244	field_13, field_14, field_15, field_16, field_17, field_18, &
	245	field_19
	246	!!-------------------------------------------------------------------
[2715]	247	!
	248	IF( lim_wri_alloc_2() /= 0 ) THEN ! allocate lim_wri arrrays
	249	CALL ctl_stop( 'STOP', 'lim_wri_init_2 : unable to allocate standard arrays' ) ; RETURN
	250	ENDIF
[3]	251
[888]	252	REWIND ( numnam_ice ) ! Read Namelist namicewri
[3]	253	READ ( numnam_ice , namiceout )
[508]	254
[888]	255	zfield( 1) = field_1
	256	zfield( 2) = field_2
	257	zfield( 3) = field_3
	258	zfield( 4) = field_4
	259	zfield( 5) = field_5
	260	zfield( 6) = field_6
	261	zfield( 7) = field_7
	262	zfield( 8) = field_8
	263	zfield( 9) = field_9
[3]	264	zfield(10) = field_10
	265	zfield(11) = field_11
	266	zfield(12) = field_12
	267	zfield(13) = field_13
	268	zfield(14) = field_14
	269	zfield(15) = field_15
	270	zfield(16) = field_16
	271	zfield(17) = field_17
	272	zfield(18) = field_18
	273	zfield(19) = field_19
	274
	275	DO nf = 1, noumef
	276	titn (nf) = zfield(nf)%ztitle
	277	nam (nf) = zfield(nf)%zname
	278	uni (nf) = zfield(nf)%zunit
	279	nc (nf) = zfield(nf)%znc
	280	cmulti(nf) = zfield(nf)%zcmulti
	281	cadd (nf) = zfield(nf)%zcadd
	282	END DO
	283
	284	IF(lwp) THEN
	285	WRITE(numout,*)
[821]	286	WRITE(numout,*) 'lim_wri_init_2 : Ice parameters for outputs'
	287	WRITE(numout,*) '~~~~~~~~~~~~~~'
[3]	288	WRITE(numout,*) ' number of fields to be stored noumef = ', noumef
	289	WRITE(numout,*) ' title name unit Saving (1/0) ', &
	290	& ' multiplicative constant additive constant '
	291	DO nf = 1 , noumef
	292	WRITE(numout,*) ' ', titn(nf), ' ', nam(nf),' ', uni(nf),' ', nc(nf),' ', cmulti(nf), &
[888]	293	& ' ', cadd(nf)
[3]	294	END DO
	295	ENDIF
[508]	296	!
[821]	297	END SUBROUTINE lim_wri_init_2
[3]	298
[1482]	299	# endif
	300	#endif
	301
	302	SUBROUTINE lim_wri_state_2( kt, kid, kh_i )
	303	!!---------------------------------------------------------------------
	304	!! * ROUTINE lim_wri_state_2 *
	305	!!
	306	!! ** Purpose : create a NetCDF file named cdfile_name which contains
	307	!! the instantaneous ice state and forcing fields for ice model
	308	!! Used to find errors in the initial state or save the last
	309	!! ocean state in case of abnormal end of a simulation
	310	!!
	311	!! History :
	312	!! 2.0 ! 2009-06 (B. Lemaire)
	313	!!----------------------------------------------------------------------
	314	INTEGER, INTENT( in ) :: kt ! ocean time-step index)
	315	INTEGER, INTENT( in ) :: kid , kh_i
	316	!!----------------------------------------------------------------------
	317
	318	CALL histdef( kid, "isnowthi", "Snow thickness" , "m" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	319	CALL histdef( kid, "iicethic", "Ice thickness" , "m" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	320	CALL histdef( kid, "iiceprod", "Ice produced" , "m/kt" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	321	CALL histdef( kid, "ileadfra", "Ice concentration" , "-" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	322	CALL histdef( kid, "iicetemp", "Ice temperature" , "K" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	323	CALL histdef( kid, "ioceflxb", "flux at ice base" , "w/m2" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	324	CALL histdef( kid, "iicevelu", "i-Ice speed (I-point)" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	325	CALL histdef( kid, "iicevelv", "j-Ice speed (I-point)" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	326	CALL histdef( kid, "isstempe", "Sea surface temperature" , "C" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	327	CALL histdef( kid, "isssalin", "Sea surface salinity" , "PSU" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	328	CALL histdef( kid, "iicestru", "i-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	329	CALL histdef( kid, "iicestrv", "j-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	330	CALL histdef( kid, "iicesflx", "Solar flux over ice" , "w/m2" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	331	CALL histdef( kid, "iicenflx", "Non-solar flux over ice" , "w/m2" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	332	CALL histdef( kid, "isnowpre", "Snow precipitation" , "kg/m2/s", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
	333
[2528]	334	CALL histend( kid, snc4set ) ! end of the file definition
[1482]	335
	336	CALL histwrite( kid, "isnowthi", kt, hsnif , jpi*jpj, (/1/) )
	337	CALL histwrite( kid, "iicethic", kt, hicif , jpi*jpj, (/1/) )
	338	CALL histwrite( kid, "iiceprod", kt, hicifp , jpi*jpj, (/1/) )
	339	CALL histwrite( kid, "ileadfra", kt, 1. - frld(:,:) , jpi*jpj, (/1/) )
	340	CALL histwrite( kid, "iicetemp", kt, sist(:,:) - rt0, jpi*jpj, (/1/) )
	341	CALL histwrite( kid, "ioceflxb", kt, fbif , jpi*jpj, (/1/) )
[1818]	342	CALL histwrite( kid, "iicevelu", kt, u_ice , jpi*jpj, (/1/) )
	343	CALL histwrite( kid, "iicevelv", kt, v_ice , jpi*jpj, (/1/) )
[1482]	344	CALL histwrite( kid, "isstempe", kt, sst_m , jpi*jpj, (/1/) )
	345	CALL histwrite( kid, "isssalin", kt, sss_m , jpi*jpj, (/1/) )
	346	CALL histwrite( kid, "iicestru", kt, utau_ice , jpi*jpj, (/1/) )
	347	CALL histwrite( kid, "iicestrv", kt, vtau_ice , jpi*jpj, (/1/) )
	348	CALL histwrite( kid, "iicesflx", kt, qsr_ice(:,:,1) , jpi*jpj, (/1/) )
	349	CALL histwrite( kid, "iicenflx", kt, qns_ice(:,:,1) , jpi*jpj, (/1/) )
	350	CALL histwrite( kid, "isnowpre", kt, sprecip , jpi*jpj, (/1/) )
	351
	352	END SUBROUTINE lim_wri_state_2
	353
[3]	354	#else
	355	!!----------------------------------------------------------------------
[821]	356	!! Default option : Empty module NO LIM 2.0 sea-ice model
[3]	357	!!----------------------------------------------------------------------
	358	CONTAINS
[821]	359	SUBROUTINE lim_wri_2 ! Empty routine
	360	END SUBROUTINE lim_wri_2
[3]	361	#endif
	362
	363	!!======================================================================
[821]	364	END MODULE limwri_2

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

Download in other formats: