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 branches/2014/dev_r4650_UKMO13_CICE_changes_take2/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/2014/dev_r4650_UKMO13_CICE_changes_take2/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90 @ 4881

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

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

Download in other formats: