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.

sbcice_cice.F90 in NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/sbcice_cice.F90 @ 13630

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

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

Download in other formats: