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 trunk/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

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

Last change on this file since 4627 was 4627, checked in by davestorkey, 10 years ago

Bug fixes for sbcice_cice.F90 at NEMO 3.6 alpha. See ticket #1315.

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