source: NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90 @ 10763

Last change on this file since 10763 was 10763, checked in by jcastill, 23 months ago

Remove svn keywords properly

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