Context Navigation

sbcice_cice.F90 @ 4990

Last change on this file since 4990 was 4990, checked in by timgraham, 10 years ago

Merged branches/2014/dev_MERGE_2014 back onto the trunk as follows:

In the working copy of branch ran:
svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk@HEAD
1 conflict in LIM_SRC_3/limdiahsb.F90
Resolved by keeping the version from dev_MERGE_2014 branch
and commited at r4989

In working copy run:
svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
to switch working copy

Run:
svn merge --reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2014/dev_MERGE_2014
to merge the branch into the trunk - no conflicts at this stage.

File size: 43.8 KB

Line
1	MODULE sbcice_cice
2	!!======================================================================
3	!! * MODULE sbcice_cice *
4	!! To couple with sea ice model CICE (LANL)
5	!!=====================================================================
6	#if defined key_cice
7	!!----------------------------------------------------------------------
8	!! 'key_cice' : CICE sea-ice model
9	!!----------------------------------------------------------------------
10	!! sbc_ice_cice : sea-ice model time-stepping and update ocean sbc over ice-covered area
11	!!
12	!!
13	!!----------------------------------------------------------------------
14	USE oce ! ocean dynamics and tracers
15	USE dom_oce ! ocean space and time domain
16	USE domvvl
17	USE phycst, only : rcp, rau0, r1_rau0, rhosn, rhoic
18	USE in_out_manager ! I/O manager
19	USE iom, ONLY : iom_put,iom_use ! I/O manager library !!Joakim edit
20	USE lib_mpp ! distributed memory computing library
21	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
22	USE wrk_nemo ! work arrays
23	USE timing ! Timing
24	USE daymod ! calendar
25	USE fldread ! read input fields
26	USE sbc_oce ! Surface boundary condition: ocean fields
27	USE sbc_ice ! Surface boundary condition: ice fields
28	USE sbcblk_core ! Surface boundary condition: CORE bulk
29	USE sbccpl
30
31	USE ice_kinds_mod
32	USE ice_blocks
33	USE ice_domain
34	USE ice_domain_size
35	USE ice_boundary
36	USE ice_constants
37	USE ice_gather_scatter
38	USE ice_calendar, only: dt
39	USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen
40	# if defined key_cice4
41	USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, &
42	sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, &
43	fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, &
44	flatn_f,fsurfn_f,fcondtopn_f, &
45	uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, &
46	swvdr,swvdf,swidr,swidf
47	USE ice_therm_vertical, only: calc_Tsfc
48	#else
49	USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, &
50	sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, &
51	fresh_ai,fhocn_ai,fswthru_ai,frzmlt, &
52	flatn_f,fsurfn_f,fcondtopn_f, &
53	uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, &
54	swvdr,swvdf,swidr,swidf
55	USE ice_therm_shared, only: calc_Tsfc
56	#endif
57	USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf
58	USE ice_atmo, only: calc_strair
59
60	USE CICE_InitMod
61	USE CICE_RunMod
62	USE CICE_FinalMod
63
64	IMPLICIT NONE
65	PRIVATE
66
67	!! * Routine accessibility
68	PUBLIC cice_sbc_init ! routine called by sbc_init
69	PUBLIC cice_sbc_final ! routine called by sbc_final
70	PUBLIC sbc_ice_cice ! routine called by sbc
71
72	INTEGER :: ji_off
73	INTEGER :: jj_off
74
75	INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read
76	INTEGER , PARAMETER :: jp_snow = 1 ! index of snow file
77	INTEGER , PARAMETER :: jp_rain = 2 ! index of rain file
78	INTEGER , PARAMETER :: jp_sblm = 3 ! index of sublimation file
79	INTEGER , PARAMETER :: jp_top1 = 4 ! index of category 1 topmelt file
80	INTEGER , PARAMETER :: jp_top2 = 5 ! index of category 2 topmelt file
81	INTEGER , PARAMETER :: jp_top3 = 6 ! index of category 3 topmelt file
82	INTEGER , PARAMETER :: jp_top4 = 7 ! index of category 4 topmelt file
83	INTEGER , PARAMETER :: jp_top5 = 8 ! index of category 5 topmelt file
84	INTEGER , PARAMETER :: jp_bot1 = 9 ! index of category 1 botmelt file
85	INTEGER , PARAMETER :: jp_bot2 = 10 ! index of category 2 botmelt file
86	INTEGER , PARAMETER :: jp_bot3 = 11 ! index of category 3 botmelt file
87	INTEGER , PARAMETER :: jp_bot4 = 12 ! index of category 4 botmelt file
88	INTEGER , PARAMETER :: jp_bot5 = 13 ! index of category 5 botmelt file
89	TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read)
90
91	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), PRIVATE :: png ! local array used in sbc_cice_ice
92
93	!! * Substitutions
94	# include "domzgr_substitute.h90"
95
96	CONTAINS
97
98	INTEGER FUNCTION sbc_ice_cice_alloc()
99	!!----------------------------------------------------------------------
100	!! * FUNCTION sbc_ice_cice_alloc *
101	!!----------------------------------------------------------------------
102	ALLOCATE( png(jpi,jpj,jpnij), STAT=sbc_ice_cice_alloc )
103	IF( lk_mpp ) CALL mpp_sum ( sbc_ice_cice_alloc )
104	IF( sbc_ice_cice_alloc > 0 ) CALL ctl_warn('sbc_ice_cice_alloc: allocation of arrays failed.')
105	END FUNCTION sbc_ice_cice_alloc
106
107	SUBROUTINE sbc_ice_cice( kt, ksbc )
108	!!---------------------------------------------------------------------
109	!! * ROUTINE sbc_ice_cice *
110	!!
111	!! ** Purpose : update the ocean surface boundary condition via the
112	!! CICE Sea Ice Model time stepping
113	!!
114	!! ** Method : - Get any extra forcing fields for CICE
115	!! - Prepare forcing fields
116	!! - CICE model time stepping
117	!! - call the routine that computes mass and
118	!! heat fluxes at the ice/ocean interface
119	!!
120	!! ** Action : - time evolution of the CICE sea-ice model
121	!! - update all sbc variables below sea-ice:
122	!! utau, vtau, qns , qsr, emp , sfx
123	!!---------------------------------------------------------------------
124	INTEGER, INTENT(in) :: kt ! ocean time step
125	INTEGER, INTENT(in) :: ksbc ! surface forcing type
126	!!----------------------------------------------------------------------
127	!
128	IF( nn_timing == 1 ) CALL timing_start('sbc_ice_cice')
129	!
130	! !----------------------!
131	IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time-step only !
132	! !----------------------!
133
134	! Make sure any fluxes required for CICE are set
135	IF ( ksbc == jp_flx ) THEN
136	CALL cice_sbc_force(kt)
137	ELSE IF ( ksbc == jp_cpl ) THEN
138	CALL sbc_cpl_ice_flx( 1.0-fr_i )
139	ENDIF
140
141	CALL cice_sbc_in ( kt, ksbc )
142	CALL CICE_Run
143	CALL cice_sbc_out ( kt, ksbc )
144
145	IF ( ksbc == jp_cpl ) CALL cice_sbc_hadgam(kt+1)
146
147	ENDIF ! End sea-ice time step only
148	!
149	IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_cice')
150
151	END SUBROUTINE sbc_ice_cice
152
153	SUBROUTINE cice_sbc_init (ksbc)
154	!!---------------------------------------------------------------------
155	!! * ROUTINE cice_sbc_init *
156	!! ** Purpose: Initialise ice related fields for NEMO and coupling
157	!!
158	INTEGER, INTENT( in ) :: ksbc ! surface forcing type
159	REAL(wp), DIMENSION(:,:), POINTER :: ztmp1, ztmp2
160	REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar
161	INTEGER :: ji, jj, jl, jk ! dummy loop indices
162	!!---------------------------------------------------------------------
163
164	IF( nn_timing == 1 ) CALL timing_start('cice_sbc_init')
165	!
166	CALL wrk_alloc( jpi,jpj, ztmp1, ztmp2 )
167	!
168	IF(lwp) WRITE(numout,*)'cice_sbc_init'
169
170	ji_off = INT ( (jpiglo - nx_global) / 2 )
171	jj_off = INT ( (jpjglo - ny_global) / 2 )
172
173	#if defined key_nemocice_decomp
174	! Pass initial SST from NEMO to CICE so ice is initialised correctly if
175	! there is no restart file.
176	! Values from a CICE restart file would overwrite this
177	IF ( .NOT. ln_rstart ) THEN
178	CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.)
179	ENDIF
180	#endif
181
182	! Initialize CICE
183	CALL CICE_Initialize
184
185	! Do some CICE consistency checks
186	IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN
187	IF ( calc_strair .OR. calc_Tsfc ) THEN
188	CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' )
189	ENDIF
190	ELSEIF (ksbc == jp_core) THEN
191	IF ( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN
192	CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' )
193	ENDIF
194	ENDIF
195
196
197	! allocate sbc_ice and sbc_cice arrays
198	IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' )
199	IF( sbc_ice_cice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' )
200
201	! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart
202	IF( .NOT. ln_rstart ) THEN
203	tsn(:,:,:,jp_tem) = MAX (tsn(:,:,:,jp_tem),Tocnfrz)
204	tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem)
205	ENDIF
206
207	fr_iu(:,:)=0.0
208	fr_iv(:,:)=0.0
209
210	CALL cice2nemo(aice,fr_i, 'T', 1. )
211	IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN
212	DO jl=1,ncat
213	CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
214	ENDDO
215	ENDIF
216
217	! T point to U point
218	! T point to V point
219	DO jj=1,jpjm1
220	DO ji=1,jpim1
221	fr_iu(ji,jj)=0.5(fr_i(ji,jj)+fr_i(ji+1,jj))umask(ji,jj,1)
222	fr_iv(ji,jj)=0.5(fr_i(ji,jj)+fr_i(ji,jj+1))vmask(ji,jj,1)
223	ENDDO
224	ENDDO
225
226	CALL lbc_lnk ( fr_iu , 'U', 1. )
227	CALL lbc_lnk ( fr_iv , 'V', 1. )
228
229	! ! embedded sea ice
230	IF( nn_ice_embd /= 0 ) THEN ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass
231	CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
232	CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
233	snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) )
234	snwice_mass_b(:,:) = snwice_mass(:,:)
235	ELSE
236	snwice_mass (:,:) = 0.0_wp ! no mass exchanges
237	snwice_mass_b(:,:) = 0.0_wp ! no mass exchanges
238	ENDIF
239	IF( .NOT. ln_rstart ) THEN
240	IF( nn_ice_embd == 2 ) THEN ! full embedment (case 2) deplete the initial ssh below sea-ice area
241	sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0
242	sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0
243	#if defined key_vvl
244	! key_vvl necessary? clem: yes for compilation purpose
245	DO jk = 1,jpkm1 ! adjust initial vertical scale factors
246	fse3t_n(:,:,jk) = e3t_0(:,:,jk)( 1._wp + sshn(:,:)tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
247	fse3t_b(:,:,jk) = e3t_0(:,:,jk)( 1._wp + sshb(:,:)tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
248	ENDDO
249	fse3t_a(:,:,:) = fse3t_b(:,:,:)
250	! Reconstruction of all vertical scale factors at now and before time
251	! steps
252	! =============================================================================
253	! Horizontal scale factor interpolations
254	! --------------------------------------
255	CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' )
256	CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' )
257	CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' )
258	CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' )
259	CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' )
260	! Vertical scale factor interpolations
261	! ------------------------------------
262	CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' )
263	CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' )
264	CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' )
265	CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' )
266	CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' )
267	! t- and w- points depth
268	! ----------------------
269	fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1)
270	fsdepw_n(:,:,1) = 0.0_wp
271	fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:)
272	DO jk = 2, jpk
273	fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk)
274	fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1)
275	fsde3w_n(:,:,jk) = fsdept_n(:,:,jk ) - sshn (:,:)
276	END DO
277	#endif
278	ENDIF
279	ENDIF
280
281	CALL wrk_dealloc( jpi,jpj, ztmp1, ztmp2 )
282	!
283	IF( nn_timing == 1 ) CALL timing_stop('cice_sbc_init')
284	!
285	END SUBROUTINE cice_sbc_init
286
287
288	SUBROUTINE cice_sbc_in (kt, ksbc)
289	!!---------------------------------------------------------------------
290	!! * ROUTINE cice_sbc_in *
291	!! ** Purpose: Set coupling fields and pass to CICE
292	!!---------------------------------------------------------------------
293	INTEGER, INTENT(in ) :: kt ! ocean time step
294	INTEGER, INTENT(in ) :: ksbc ! surface forcing type
295
296	INTEGER :: ji, jj, jl ! dummy loop indices
297	REAL(wp), DIMENSION(:,:), POINTER :: ztmp, zpice
298	REAL(wp), DIMENSION(:,:,:), POINTER :: ztmpn
299	REAL(wp) :: zintb, zintn ! dummy argument
300	!!---------------------------------------------------------------------
301
302	IF( nn_timing == 1 ) CALL timing_start('cice_sbc_in')
303	!
304	CALL wrk_alloc( jpi,jpj, ztmp, zpice )
305	CALL wrk_alloc( jpi,jpj,ncat, ztmpn )
306
307	IF( kt == nit000 ) THEN
308	IF(lwp) WRITE(numout,*)'cice_sbc_in'
309	ENDIF
310
311	ztmp(:,:)=0.0
312
313	! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on
314	! the first time-step)
315
316	! forced and coupled case
317
318	IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN
319
320	ztmpn(:,:,:)=0.0
321
322	! x comp of wind stress (CI_1)
323	! U point to F point
324	DO jj=1,jpjm1
325	DO ji=1,jpi
326	ztmp(ji,jj) = 0.5 * ( fr_iu(ji,jj) * utau(ji,jj) &
327	+ fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1)
328	ENDDO
329	ENDDO
330	CALL nemo2cice(ztmp,strax,'F', -1. )
331
332	! y comp of wind stress (CI_2)
333	! V point to F point
334	DO jj=1,jpj
335	DO ji=1,jpim1
336	ztmp(ji,jj) = 0.5 * ( fr_iv(ji,jj) * vtau(ji,jj) &
337	+ fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1)
338	ENDDO
339	ENDDO
340	CALL nemo2cice(ztmp,stray,'F', -1. )
341
342	! Surface downward latent heat flux (CI_5)
343	IF (ksbc == jp_flx) THEN
344	DO jl=1,ncat
345	ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl)
346	ENDDO
347	ELSE
348	! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow
349	qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * Lsub
350	! End of temporary code
351	DO jj=1,jpj
352	DO ji=1,jpi
353	IF (fr_i(ji,jj).eq.0.0) THEN
354	DO jl=1,ncat
355	ztmpn(ji,jj,jl)=0.0
356	ENDDO
357	! This will then be conserved in CICE
358	ztmpn(ji,jj,1)=qla_ice(ji,jj,1)
359	ELSE
360	DO jl=1,ncat
361	ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj)
362	ENDDO
363	ENDIF
364	ENDDO
365	ENDDO
366	ENDIF
367	DO jl=1,ncat
368	CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. )
369
370	! GBM conductive flux through ice (CI_6)
371	! Convert to GBM
372	IF (ksbc == jp_flx) THEN
373	ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl)
374	ELSE
375	ztmp(:,:) = botmelt(:,:,jl)
376	ENDIF
377	CALL nemo2cice(ztmp,fcondtopn_f(:,:,jl,:),'T', 1. )
378
379	! GBM surface heat flux (CI_7)
380	! Convert to GBM
381	IF (ksbc == jp_flx) THEN
382	ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl)
383	ELSE
384	ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))
385	ENDIF
386	CALL nemo2cice(ztmp,fsurfn_f(:,:,jl,:),'T', 1. )
387	ENDDO
388
389	ELSE IF (ksbc == jp_core) THEN
390
391	! Pass CORE forcing fields to CICE (which will calculate heat fluxes etc itself)
392	! x comp and y comp of atmosphere surface wind (CICE expects on T points)
393	ztmp(:,:) = wndi_ice(:,:)
394	CALL nemo2cice(ztmp,uatm,'T', -1. )
395	ztmp(:,:) = wndj_ice(:,:)
396	CALL nemo2cice(ztmp,vatm,'T', -1. )
397	ztmp(:,:) = SQRT ( wndi_ice(:,:)2 + wndj_ice(:,:)2 )
398	CALL nemo2cice(ztmp,wind,'T', 1. ) ! Wind speed (m/s)
399	ztmp(:,:) = qsr_ice(:,:,1)
400	CALL nemo2cice(ztmp,fsw,'T', 1. ) ! Incoming short-wave (W/m^2)
401	ztmp(:,:) = qlw_ice(:,:,1)
402	CALL nemo2cice(ztmp,flw,'T', 1. ) ! Incoming long-wave (W/m^2)
403	ztmp(:,:) = tatm_ice(:,:)
404	CALL nemo2cice(ztmp,Tair,'T', 1. ) ! Air temperature (K)
405	CALL nemo2cice(ztmp,potT,'T', 1. ) ! Potential temp (K)
406	! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows
407	ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) )
408	! Constant (101000.) atm pressure assumed
409	CALL nemo2cice(ztmp,rhoa,'T', 1. ) ! Air density (kg/m^3)
410	ztmp(:,:) = qatm_ice(:,:)
411	CALL nemo2cice(ztmp,Qa,'T', 1. ) ! Specific humidity (kg/kg)
412	ztmp(:,:)=10.0
413	CALL nemo2cice(ztmp,zlvl,'T', 1. ) ! Atmos level height (m)
414
415	! May want to check all values are physically realistic (as in CICE routine
416	! prepare_forcing)?
417
418	! Divide shortwave into spectral bands (as in prepare_forcing)
419	ztmp(:,:)=qsr_ice(:,:,1)*frcvdr ! visible direct
420	CALL nemo2cice(ztmp,swvdr,'T', 1. )
421	ztmp(:,:)=qsr_ice(:,:,1)*frcvdf ! visible diffuse
422	CALL nemo2cice(ztmp,swvdf,'T', 1. )
423	ztmp(:,:)=qsr_ice(:,:,1)*frcidr ! near IR direct
424	CALL nemo2cice(ztmp,swidr,'T', 1. )
425	ztmp(:,:)=qsr_ice(:,:,1)*frcidf ! near IR diffuse
426	CALL nemo2cice(ztmp,swidf,'T', 1. )
427
428	ENDIF
429
430	! Snowfall
431	! Ensure fsnow is positive (as in CICE routine prepare_forcing)
432	IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit
433	ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0)
434	CALL nemo2cice(ztmp,fsnow,'T', 1. )
435
436	! Rainfall
437	IF( iom_use('precip') ) CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit
438	ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
439	CALL nemo2cice(ztmp,frain,'T', 1. )
440
441	! Freezing/melting potential
442	! Calculated over NEMO leapfrog timestep (hence 2*dt)
443	nfrzmlt(:,:)=rau0rcpfse3t_m(:,:)(Tocnfrz-sst_m(:,:))/(2.0dt)
444
445	ztmp(:,:) = nfrzmlt(:,:)
446	CALL nemo2cice(ztmp,frzmlt,'T', 1. )
447
448	! SST and SSS
449
450	CALL nemo2cice(sst_m,sst,'T', 1. )
451	CALL nemo2cice(sss_m,sss,'T', 1. )
452
453	! x comp and y comp of surface ocean current
454	! U point to F point
455	DO jj=1,jpjm1
456	DO ji=1,jpi
457	ztmp(ji,jj)=0.5(ssu_m(ji,jj)+ssu_m(ji,jj+1))fmask(ji,jj,1)
458	ENDDO
459	ENDDO
460	CALL nemo2cice(ztmp,uocn,'F', -1. )
461
462	! V point to F point
463	DO jj=1,jpj
464	DO ji=1,jpim1
465	ztmp(ji,jj)=0.5(ssv_m(ji,jj)+ssv_m(ji+1,jj))fmask(ji,jj,1)
466	ENDDO
467	ENDDO
468	CALL nemo2cice(ztmp,vocn,'F', -1. )
469
470	IF( nn_ice_embd == 2 ) THEN !== embedded sea ice: compute representative ice top surface ==!
471	!
472	! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1}
473	! = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1}
474	zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp
475	!
476	! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1}
477	! = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1})
478	zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp
479	!
480	zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rau0
481	!
482	!
483	ELSE !== non-embedded sea ice: use ocean surface for slope calculation ==!
484	zpice(:,:) = ssh_m(:,:)
485	ENDIF
486
487	! x comp and y comp of sea surface slope (on F points)
488	! T point to F point
489	DO jj=1,jpjm1
490	DO ji=1,jpim1
491	ztmp(ji,jj)=0.5 * ( (zpice(ji+1,jj )-zpice(ji,jj ))/e1u(ji,jj ) &
492	+ (zpice(ji+1,jj+1)-zpice(ji,jj+1))/e1u(ji,jj+1) ) &
493	* fmask(ji,jj,1)
494	ENDDO
495	ENDDO
496	CALL nemo2cice(ztmp,ss_tltx,'F', -1. )
497
498	! T point to F point
499	DO jj=1,jpjm1
500	DO ji=1,jpim1
501	ztmp(ji,jj)=0.5 * ( (zpice(ji ,jj+1)-zpice(ji ,jj))/e2v(ji ,jj) &
502	+ (zpice(ji+1,jj+1)-zpice(ji+1,jj))/e2v(ji+1,jj) ) &
503	* fmask(ji,jj,1)
504	ENDDO
505	ENDDO
506	CALL nemo2cice(ztmp,ss_tlty,'F', -1. )
507
508	CALL wrk_dealloc( jpi,jpj, ztmp )
509	CALL wrk_dealloc( jpi,jpj,ncat, ztmpn )
510	!
511	IF( nn_timing == 1 ) CALL timing_stop('cice_sbc_in')
512	!
513	END SUBROUTINE cice_sbc_in
514
515
516	SUBROUTINE cice_sbc_out (kt,ksbc)
517	!!---------------------------------------------------------------------
518	!! * ROUTINE cice_sbc_out *
519	!! ** Purpose: Get fields from CICE and set surface fields for NEMO
520	!!---------------------------------------------------------------------
521	INTEGER, INTENT( in ) :: kt ! ocean time step
522	INTEGER, INTENT( in ) :: ksbc ! surface forcing type
523
524	INTEGER :: ji, jj, jl ! dummy loop indices
525	REAL(wp), DIMENSION(:,:), POINTER :: ztmp1, ztmp2
526	!!---------------------------------------------------------------------
527
528	IF( nn_timing == 1 ) CALL timing_start('cice_sbc_out')
529	!
530	CALL wrk_alloc( jpi,jpj, ztmp1, ztmp2 )
531
532	IF( kt == nit000 ) THEN
533	IF(lwp) WRITE(numout,*)'cice_sbc_out'
534	ENDIF
535
536	! x comp of ocean-ice stress
537	CALL cice2nemo(strocnx,ztmp1,'F', -1. )
538	ss_iou(:,:)=0.0
539	! F point to U point
540	DO jj=2,jpjm1
541	DO ji=2,jpim1
542	ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1)
543	ENDDO
544	ENDDO
545	CALL lbc_lnk( ss_iou , 'U', -1. )
546
547	! y comp of ocean-ice stress
548	CALL cice2nemo(strocny,ztmp1,'F', -1. )
549	ss_iov(:,:)=0.0
550	! F point to V point
551
552	DO jj=1,jpjm1
553	DO ji=2,jpim1
554	ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1)
555	ENDDO
556	ENDDO
557	CALL lbc_lnk( ss_iov , 'V', -1. )
558
559	! x and y comps of surface stress
560	! Combine wind stress and ocean-ice stress
561	! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep]
562
563	utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:)
564	vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)
565
566	! Freshwater fluxes
567
568	IF (ksbc == jp_flx) THEN
569	! Note that emp from the forcing files is evap(1-aice)-(tprecip-aicesprecip)
570	! What we want here is evap(1-aice)-tprecip(1-aice) hence manipulation below
571	! Not ideal since aice won't be the same as in the atmosphere.
572	! Better to use evap and tprecip? (but for now don't read in evap in this case)
573	emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
574	ELSE IF (ksbc == jp_core) THEN
575	emp(:,:) = (1.0-fr_i(:,:))*emp(:,:)
576	ELSE IF (ksbc == jp_cpl) THEN
577	! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above)
578	! This is currently as required with the coupling fields from the UM atmosphere
579	emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:)
580	ENDIF
581
582	#if defined key_cice4
583	CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. )
584	CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. )
585	#else
586	CALL cice2nemo(fresh_ai,ztmp1,'T', 1. )
587	CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. )
588	#endif
589
590	! Check to avoid unphysical expression when ice is forming (ztmp1 negative)
591	! Otherwise we are effectively allowing ice of higher salinity than the ocean to form
592	! which has to be compensated for by the ocean salinity potentially going negative
593	! This check breaks conservation but seems reasonable until we have prognostic ice salinity
594	! Note the 1000.0 below is to convert from kg salt to g salt (needed for PSU)
595	WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0)
596	sfx(:,:)=ztmp2(:,:)*1000.0
597	emp(:,:)=emp(:,:)-ztmp1(:,:)
598	fmmflx(:,:) = ztmp1(:,:) !!Joakim edit
599
600	CALL lbc_lnk( emp , 'T', 1. )
601	CALL lbc_lnk( sfx , 'T', 1. )
602
603	! Solar penetrative radiation and non solar surface heat flux
604
605	! Scale qsr and qns according to ice fraction (bulk formulae only)
606
607	IF (ksbc == jp_core) THEN
608	qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:))
609	qns(:,:)=qns(:,:)*(1.0-fr_i(:,:))
610	ENDIF
611	! Take into account snow melting except for fully coupled when already in qns_tot
612	IF (ksbc == jp_cpl) THEN
613	qsr(:,:)= qsr_tot(:,:)
614	qns(:,:)= qns_tot(:,:)
615	ELSE
616	qns(:,:)= qns(:,:)-sprecip(:,:)Lfresh(1.0-fr_i(:,:))
617	ENDIF
618
619	! Now add in ice / snow related terms
620	! [fswthru will be zero unless running with calc_Tsfc=T in CICE]
621	#if defined key_cice4
622	CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. )
623	#else
624	CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. )
625	#endif
626	qsr(:,:)=qsr(:,:)+ztmp1(:,:)
627	CALL lbc_lnk( qsr , 'T', 1. )
628
629	DO jj=1,jpj
630	DO ji=1,jpi
631	nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0)
632	ENDDO
633	ENDDO
634
635	#if defined key_cice4
636	CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. )
637	#else
638	CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. )
639	#endif
640	qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:)
641
642	CALL lbc_lnk( qns , 'T', 1. )
643
644	! Prepare for the following CICE time-step
645
646	CALL cice2nemo(aice,fr_i,'T', 1. )
647	IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN
648	DO jl=1,ncat
649	CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
650	ENDDO
651	ENDIF
652
653	! T point to U point
654	! T point to V point
655	DO jj=1,jpjm1
656	DO ji=1,jpim1
657	fr_iu(ji,jj)=0.5(fr_i(ji,jj)+fr_i(ji+1,jj))umask(ji,jj,1)
658	fr_iv(ji,jj)=0.5(fr_i(ji,jj)+fr_i(ji,jj+1))vmask(ji,jj,1)
659	ENDDO
660	ENDDO
661
662	CALL lbc_lnk ( fr_iu , 'U', 1. )
663	CALL lbc_lnk ( fr_iv , 'V', 1. )
664
665	! ! embedded sea ice
666	IF( nn_ice_embd /= 0 ) THEN ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass
667	CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
668	CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
669	snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) )
670	snwice_mass_b(:,:) = snwice_mass(:,:)
671	snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt
672	ENDIF
673
674	! Release work space
675
676	CALL wrk_dealloc( jpi,jpj, ztmp1, ztmp2 )
677	!
678	IF( nn_timing == 1 ) CALL timing_stop('cice_sbc_out')
679	!
680	END SUBROUTINE cice_sbc_out
681
682
683	SUBROUTINE cice_sbc_hadgam( kt )
684	!!---------------------------------------------------------------------
685	!! * ROUTINE cice_sbc_hadgam *
686	!! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere
687	!!
688	!!
689	INTEGER, INTENT( in ) :: kt ! ocean time step
690	!!---------------------------------------------------------------------
691
692	INTEGER :: jl ! dummy loop index
693	INTEGER :: ierror
694
695	IF( nn_timing == 1 ) CALL timing_start('cice_sbc_hadgam')
696	!
697	IF( kt == nit000 ) THEN
698	IF(lwp) WRITE(numout,*)'cice_sbc_hadgam'
699	IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
700	ENDIF
701
702	! ! =========================== !
703	! ! Prepare Coupling fields !
704	! ! =========================== !
705
706	! x and y comp of ice velocity
707
708	CALL cice2nemo(uvel,u_ice,'F', -1. )
709	CALL cice2nemo(vvel,v_ice,'F', -1. )
710
711	! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out
712
713	! Snow and ice thicknesses (CO_2 and CO_3)
714
715	DO jl = 1,ncat
716	CALL cice2nemo(vsnon(:,:,jl,:),ht_s(:,:,jl),'T', 1. )
717	CALL cice2nemo(vicen(:,:,jl,:),ht_i(:,:,jl),'T', 1. )
718	ENDDO
719	!
720	IF( nn_timing == 1 ) CALL timing_stop('cice_sbc_hadgam')
721	!
722	END SUBROUTINE cice_sbc_hadgam
723
724
725	SUBROUTINE cice_sbc_final
726	!!---------------------------------------------------------------------
727	!! * ROUTINE cice_sbc_final *
728	!! ** Purpose: Finalize CICE
729	!!---------------------------------------------------------------------
730
731	IF(lwp) WRITE(numout,*)'cice_sbc_final'
732
733	CALL CICE_Finalize
734
735	END SUBROUTINE cice_sbc_final
736
737	SUBROUTINE cice_sbc_force (kt)
738	!!---------------------------------------------------------------------
739	!! * ROUTINE cice_sbc_force *
740	!! ** Purpose : Provide CICE forcing from files
741	!!
742	!!---------------------------------------------------------------------
743	!! ** Method : READ monthly flux file in NetCDF files
744	!!
745	!! snowfall
746	!! rainfall
747	!! sublimation rate
748	!! topmelt (category)
749	!! botmelt (category)
750	!!
751	!! History :
752	!!----------------------------------------------------------------------
753	!! * Modules used
754	USE iom
755
756	!! * arguments
757	INTEGER, INTENT( in ) :: kt ! ocean time step
758
759	INTEGER :: ierror ! return error code
760	INTEGER :: ifpr ! dummy loop index
761	!!
762	CHARACTER(len=100) :: cn_dir ! Root directory for location of CICE forcing files
763	TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read
764	TYPE(FLD_N) :: sn_snow, sn_rain, sn_sblm ! informations about the fields to be read
765	TYPE(FLD_N) :: sn_top1, sn_top2, sn_top3, sn_top4, sn_top5
766	TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5
767
768	!!
769	NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm, &
770	& sn_top1, sn_top2, sn_top3, sn_top4, sn_top5, &
771	& sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5
772	INTEGER :: ios
773	!!---------------------------------------------------------------------
774
775	! ! ====================== !
776	IF( kt == nit000 ) THEN ! First call kt=nit000 !
777	! ! ====================== !
778	! namsbc_cice is not yet in the reference namelist
779	! set file information (default values)
780	cn_dir = './' ! directory in which the model is executed
781
782	! (NB: frequency positive => hours, negative => months)
783	! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask
784	! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file
785	sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' )
786	sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' )
787	sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' )
788	sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' )
789	sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' )
790	sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' )
791	sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' )
792	sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' )
793	sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' )
794	sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' )
795	sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' )
796	sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' )
797	sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' )
798
799	REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist :
800	READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901)
801	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp )
802
803	REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run
804	READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 )
805	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp )
806	IF(lwm) WRITE ( numond, namsbc_cice )
807
808	! store namelist information in an array
809	slf_i(jp_snow) = sn_snow ; slf_i(jp_rain) = sn_rain ; slf_i(jp_sblm) = sn_sblm
810	slf_i(jp_top1) = sn_top1 ; slf_i(jp_top2) = sn_top2 ; slf_i(jp_top3) = sn_top3
811	slf_i(jp_top4) = sn_top4 ; slf_i(jp_top5) = sn_top5 ; slf_i(jp_bot1) = sn_bot1
812	slf_i(jp_bot2) = sn_bot2 ; slf_i(jp_bot3) = sn_bot3 ; slf_i(jp_bot4) = sn_bot4
813	slf_i(jp_bot5) = sn_bot5
814
815	! set sf structure
816	ALLOCATE( sf(jpfld), STAT=ierror )
817	IF( ierror > 0 ) THEN
818	CALL ctl_stop( 'cice_sbc_force: unable to allocate sf structure' ) ; RETURN
819	ENDIF
820
821	DO ifpr= 1, jpfld
822	ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) )
823	ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) )
824	END DO
825
826	! fill sf with slf_i and control print
827	CALL fld_fill( sf, slf_i, cn_dir, 'cice_sbc_force', 'flux formulation for CICE', 'namsbc_cice' )
828	!
829	ENDIF
830
831	CALL fld_read( kt, nn_fsbc, sf ) ! Read input fields and provides the
832	! ! input fields at the current time-step
833
834	! set the fluxes from read fields
835	sprecip(:,:) = sf(jp_snow)%fnow(:,:,1)
836	tprecip(:,:) = sf(jp_snow)%fnow(:,:,1)+sf(jp_rain)%fnow(:,:,1)
837	! May be better to do this conversion somewhere else
838	qla_ice(:,:,1) = -Lsub*sf(jp_sblm)%fnow(:,:,1)
839	topmelt(:,:,1) = sf(jp_top1)%fnow(:,:,1)
840	topmelt(:,:,2) = sf(jp_top2)%fnow(:,:,1)
841	topmelt(:,:,3) = sf(jp_top3)%fnow(:,:,1)
842	topmelt(:,:,4) = sf(jp_top4)%fnow(:,:,1)
843	topmelt(:,:,5) = sf(jp_top5)%fnow(:,:,1)
844	botmelt(:,:,1) = sf(jp_bot1)%fnow(:,:,1)
845	botmelt(:,:,2) = sf(jp_bot2)%fnow(:,:,1)
846	botmelt(:,:,3) = sf(jp_bot3)%fnow(:,:,1)
847	botmelt(:,:,4) = sf(jp_bot4)%fnow(:,:,1)
848	botmelt(:,:,5) = sf(jp_bot5)%fnow(:,:,1)
849
850	! control print (if less than 100 time-step asked)
851	IF( nitend-nit000 <= 100 .AND. lwp ) THEN
852	WRITE(numout,*)
853	WRITE(numout,*) ' read forcing fluxes for CICE OK'
854	CALL FLUSH(numout)
855	ENDIF
856
857	END SUBROUTINE cice_sbc_force
858
859	SUBROUTINE nemo2cice( pn, pc, cd_type, psgn)
860	!!---------------------------------------------------------------------
861	!! * ROUTINE nemo2cice *
862	!! ** Purpose : Transfer field in NEMO array to field in CICE array.
863	#if defined key_nemocice_decomp
864	!!
865	!! NEMO and CICE PE sub domains are identical, hence
866	!! there is no need to gather or scatter data from
867	!! one PE configuration to another.
868	#else
869	!! Automatically gather/scatter between
870	!! different processors and blocks
871	!! ** Method : A. Ensure all haloes are filled in NEMO field (pn)
872	!! B. Gather pn into global array (png)
873	!! C. Map png into CICE global array (pcg)
874	!! D. Scatter pcg to CICE blocks (pc) + update haloes
875	#endif
876	!!---------------------------------------------------------------------
877
878	CHARACTER(len=1), INTENT( in ) :: &
879	cd_type ! nature of pn grid-point
880	! ! = T or F gridpoints
881	REAL(wp), INTENT( in ) :: &
882	psgn ! control of the sign change
883	! ! =-1 , the sign is modified following the type of b.c. used
884	! ! = 1 , no sign change
885	REAL(wp), DIMENSION(jpi,jpj) :: pn
886	#if !defined key_nemocice_decomp
887	REAL(wp), DIMENSION(jpiglo,jpjglo) :: png2
888	REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
889	#endif
890	REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
891	INTEGER (int_kind) :: &
892	field_type, &! id for type of field (scalar, vector, angle)
893	grid_loc ! id for location on horizontal grid
894	! (center, NEcorner, Nface, Eface)
895
896	INTEGER :: ji, jj, jn ! dummy loop indices
897
898	! A. Ensure all haloes are filled in NEMO field (pn)
899
900	CALL lbc_lnk( pn , cd_type, psgn )
901
902	#if defined key_nemocice_decomp
903
904	! Copy local domain data from NEMO to CICE field
905	pc(:,:,1)=0.0
906	DO jj=2,ny_block-1
907	DO ji=2,nx_block-1
908	pc(ji,jj,1)=pn(ji-1+ji_off,jj-1+jj_off)
909	ENDDO
910	ENDDO
911
912	#else
913
914	! B. Gather pn into global array (png)
915
916	IF ( jpnij > 1) THEN
917	CALL mppsync
918	CALL mppgather (pn,0,png)
919	CALL mppsync
920	ELSE
921	png(:,:,1)=pn(:,:)
922	ENDIF
923
924	! C. Map png into CICE global array (pcg)
925
926	! Need to make sure this is robust to changes in NEMO halo rows....
927	! (may be OK but not 100% sure)
928
929	IF (nproc==0) THEN
930	! pcg(:,:)=0.0
931	DO jn=1,jpnij
932	DO jj=nldjt(jn),nlejt(jn)
933	DO ji=nldit(jn),nleit(jn)
934	png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn)
935	ENDDO
936	ENDDO
937	ENDDO
938	DO jj=1,ny_global
939	DO ji=1,nx_global
940	pcg(ji,jj)=png2(ji+ji_off,jj+jj_off)
941	ENDDO
942	ENDDO
943	ENDIF
944
945	#endif
946
947	SELECT CASE ( cd_type )
948	CASE ( 'T' )
949	grid_loc=field_loc_center
950	CASE ( 'F' )
951	grid_loc=field_loc_NEcorner
952	END SELECT
953
954	SELECT CASE ( NINT(psgn) )
955	CASE ( -1 )
956	field_type=field_type_vector
957	CASE ( 1 )
958	field_type=field_type_scalar
959	END SELECT
960
961	#if defined key_nemocice_decomp
962	! Ensure CICE halos are up to date
963	CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
964	#else
965	! D. Scatter pcg to CICE blocks (pc) + update halos
966	CALL scatter_global(pc, pcg, 0, distrb_info, grid_loc, field_type)
967	#endif
968
969	END SUBROUTINE nemo2cice
970
971	SUBROUTINE cice2nemo ( pc, pn, cd_type, psgn )
972	!!---------------------------------------------------------------------
973	!! * ROUTINE cice2nemo *
974	!! ** Purpose : Transfer field in CICE array to field in NEMO array.
975	#if defined key_nemocice_decomp
976	!!
977	!! NEMO and CICE PE sub domains are identical, hence
978	!! there is no need to gather or scatter data from
979	!! one PE configuration to another.
980	#else
981	!! Automatically deal with scatter/gather between
982	!! different processors and blocks
983	!! ** Method : A. Gather CICE blocks (pc) into global array (pcg)
984	!! B. Map pcg into NEMO global array (png)
985	!! C. Scatter png into NEMO field (pn) for each processor
986	!! D. Ensure all haloes are filled in pn
987	#endif
988	!!---------------------------------------------------------------------
989
990	CHARACTER(len=1), INTENT( in ) :: &
991	cd_type ! nature of pn grid-point
992	! ! = T or F gridpoints
993	REAL(wp), INTENT( in ) :: &
994	psgn ! control of the sign change
995	! ! =-1 , the sign is modified following the type of b.c. used
996	! ! = 1 , no sign change
997	REAL(wp), DIMENSION(jpi,jpj) :: pn
998
999	#if defined key_nemocice_decomp
1000	INTEGER (int_kind) :: &
1001	field_type, & ! id for type of field (scalar, vector, angle)
1002	grid_loc ! id for location on horizontal grid
1003	! (center, NEcorner, Nface, Eface)
1004	#else
1005	REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
1006	#endif
1007
1008	REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
1009
1010	INTEGER :: ji, jj, jn ! dummy loop indices
1011
1012
1013	#if defined key_nemocice_decomp
1014
1015	SELECT CASE ( cd_type )
1016	CASE ( 'T' )
1017	grid_loc=field_loc_center
1018	CASE ( 'F' )
1019	grid_loc=field_loc_NEcorner
1020	END SELECT
1021
1022	SELECT CASE ( NINT(psgn) )
1023	CASE ( -1 )
1024	field_type=field_type_vector
1025	CASE ( 1 )
1026	field_type=field_type_scalar
1027	END SELECT
1028
1029	CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
1030
1031
1032	pn(:,:)=0.0
1033	DO jj=1,jpjm1
1034	DO ji=1,jpim1
1035	pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1)
1036	ENDDO
1037	ENDDO
1038
1039	#else
1040
1041	! A. Gather CICE blocks (pc) into global array (pcg)
1042
1043	CALL gather_global(pcg, pc, 0, distrb_info)
1044
1045	! B. Map pcg into NEMO global array (png)
1046
1047	! Need to make sure this is robust to changes in NEMO halo rows....
1048	! (may be OK but not spent much time thinking about it)
1049	! Note that non-existent pcg elements may be used below, but
1050	! the lbclnk call on pn will replace these with sensible values
1051
1052	IF (nproc==0) THEN
1053	png(:,:,:)=0.0
1054	DO jn=1,jpnij
1055	DO jj=nldjt(jn),nlejt(jn)
1056	DO ji=nldit(jn),nleit(jn)
1057	png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off)
1058	ENDDO
1059	ENDDO
1060	ENDDO
1061	ENDIF
1062
1063	! C. Scatter png into NEMO field (pn) for each processor
1064
1065	IF ( jpnij > 1) THEN
1066	CALL mppsync
1067	CALL mppscatter (png,0,pn)
1068	CALL mppsync
1069	ELSE
1070	pn(:,:)=png(:,:,1)
1071	ENDIF
1072
1073	#endif
1074
1075	! D. Ensure all haloes are filled in pn
1076
1077	CALL lbc_lnk( pn , cd_type, psgn )
1078
1079	END SUBROUTINE cice2nemo
1080
1081	#else
1082	!!----------------------------------------------------------------------
1083	!! Default option Dummy module NO CICE sea-ice model
1084	!!----------------------------------------------------------------------
1085	CONTAINS
1086
1087	SUBROUTINE sbc_ice_cice ( kt, ksbc ) ! Dummy routine
1088	WRITE(,) 'sbc_ice_cice: You should not have seen this print! error?', kt
1089	END SUBROUTINE sbc_ice_cice
1090
1091	SUBROUTINE cice_sbc_init (ksbc) ! Dummy routine
1092	WRITE(,) 'cice_sbc_init: You should not have seen this print! error?'
1093	END SUBROUTINE cice_sbc_init
1094
1095	SUBROUTINE cice_sbc_final ! Dummy routine
1096	WRITE(,) 'cice_sbc_final: You should not have seen this print! error?'
1097	END SUBROUTINE cice_sbc_final
1098
1099	#endif
1100
1101	!!======================================================================
1102	END MODULE sbcice_cice

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

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

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90 @ 4990

Download in other formats: