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.
Changeset 5630 for branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO – NEMO

Ignore:
Timestamp:
2015-07-23T18:05:51+02:00 (9 years ago)
Author:
dancopsey
Message:

Merged in revision 5518 of the trunk.

Location:
branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO
Files:
115 edited
6 copied

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90

    r5500 r5630  
    6767 
    6868   !!* Ice Rheology 
    69  
    70    LOGICAL , PUBLIC::  ltrcdm2dc_ice = .FALSE.              !: In case of Diurnal Cycle short wave, compute a Daily Mean short waves flux 
    71  
    7269# if defined key_lim2_vp 
    7370   !                                                      !!* VP rheology * 
    … …  
    115112   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qdtcn         !: energy from the ice to the ocean point (at a factor 2) 
    116113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   thcm          !: part of the solar energy used in the lead heat budget 
    117    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fstric_daymean!: Solar flux transmitted trough the ice, for day mean of qsr ( PISCES, with dirunal cycle ) 
     114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fstric_mean   !: Solar flux transmitted trough the ice, for day mean of qsr ( PISCES, with dirunal cycle ) 
    118115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fstric        !: Solar flux transmitted trough the ice 
    119116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ffltbif       !: linked with the max heat contained in brine pockets (?) 
    … …  
    175172         &     tbif  (jpi,jpj,jplayersp1)                           , STAT=ierr(5)) 
    176173 
    177       IF( ltrcdm2dc_ice ) ALLOCATE(fstric_daymean(jpi,jpj), STAT=ierr(6) ) 
    178  
    179174      !* moment used in the advection scheme 
    180175      ALLOCATE(sxice (jpi,jpj) , syice (jpi,jpj) , sxxice(jpi,jpj) ,     & 
    … …  
    203198   !!   Default option         Empty module        NO LIM 2.0 sea-ice model 
    204199   !!---------------------------------------------------------------------- 
    205    LOGICAL , PUBLIC::  ltrcdm2dc_ice = .FALSE.              !: In case of Diurnal Cycle short wave, compute a Daily Mean short waves flux 
    206200#endif 
    207201   !!----------------------------------------------------------------- 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/iceini_2.F90

    r5500 r5630  
    6060      ENDIF 
    6161      !                                 
    62       ! When Diurnal cycle, core bulk and LIM2  are activated,  
    63       ! a daily mean qsr is computed for tracer/biogeochemistery model                                 ! 
    64       IF( ltrcdm2dc )THEN  ; ltrcdm2dc_ice = .TRUE. 
    65       ELSE                 ; ltrcdm2dc_ice = .FALSE. 
    66       ENDIF 
    6762      !                                ! Allocate the ice arrays 
    6863      ierr =        ice_alloc_2    ()       ! ice variables 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/limsbc_2.F90

    r5500 r5630  
    4646   PUBLIC   lim_sbc_flx_2      ! called by sbc_ice_lim_2 
    4747   PUBLIC   lim_sbc_tau_2      ! called by sbc_ice_lim_2 
    48    PUBLIC   lim_bio_meanqsr_2  ! called by sbc_ice_lim_2 
    4948 
    5049   REAL(wp)  ::   r1_rdtice            ! = 1. / rdt_ice  
    … …  
    9796      !!              - fr_i    : ice fraction 
    9897      !!              - tn_ice  : sea-ice surface temperature 
    99       !!              - alb_ice : sea-ice albedo (lk_cpl=T) 
     98      !!              - alb_ice : sea-ice albedo (ln_cpl=T) 
    10099      !! 
    101100      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 
    … …  
    179178 
    180179            !   computation the solar flux at ocean surface 
    181             IF( lk_cpl ) THEN 
     180            IF( ln_cpl ) THEN 
    182181               zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) ) 
    183182            ELSE 
    … …  
    203202            ! mass flux at the ocean-atmosphere interface (open ocean fraction = leads area) 
    204203            !                                                  ! coupled mode:  
    205             IF( lk_cpl ) THEN 
     204            IF( ln_cpl ) THEN 
    206205               zemp = + emp_tot(ji,jj)                            &     ! net mass flux over the grid cell (ice+ocean area) 
    207206                  &   - emp_ice(ji,jj) * ( 1. - pfrld(ji,jj) )          ! minus the mass flux intercepted by sea-ice 
    … …  
    253252      !-----------------------------------------------! 
    254253 
    255       IF( lk_cpl) THEN 
     254      IF( ln_cpl) THEN 
    256255         tn_ice(:,:,1) = sist(:,:)          ! sea-ice surface temperature        
    257256         ht_i(:,:,1) = hicif(:,:) 
    … …  
    430429   END SUBROUTINE lim_sbc_tau_2 
    431430 
    432    SUBROUTINE lim_bio_meanqsr_2 
    433       !!--------------------------------------------------------------------- 
    434       !!                     ***  ROUTINE lim_bio_meanqsr 
    435       !! 
    436       !! ** Purpose :   provide daily qsr_mean for PISCES when  
    437       !!                analytic diurnal cycle is applied in physic 
    438       !! 
    439       !! ** Method  :   add part under ice 
    440       !! 
    441       !!--------------------------------------------------------------------- 
    442  
    443       qsr_mean(:,:) =  pfrld(:,:) * qsr_mean(:,:) + ( 1. - pfrld(:,:) ) * fstric_daymean(:,:) 
    444  
    445    END SUBROUTINE lim_bio_meanqsr_2 
    446431 
    447432   SUBROUTINE lim_sbc_init_2 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/limthd_2.F90

    r5500 r5630  
    114114      CALL wrk_alloc( jpi, jpj, jpk, zmsk ) 
    115115 
    116       IF( kt == nit000 )   CALL lim_thd_init_2  ! Initialization (first time-step only) 
     116      IF( kt == nit000 )   CALL lim_thd_init_2   ! Initialization (first time-step only) 
    117117    
    118118      !-------------------------------------------! 
    … …  
    137137      rdq_ice(:,:) = 0.e0   ! heat content associated with rdm_ice 
    138138      zmsk (:,:,:) = 0.e0 
    139       IF( ltrcdm2dc_ice  ) fstric_daymean (:,:) = 0.e0   ! part of solar radiation absorbing inside the ice 
    140139 
    141140      ! set to zero snow thickness smaller than epsi04 
    … …  
    217216                         
    218217            !  partial computation of the lead energy budget (qldif) 
    219             IF( lk_cpl ) THEN  
     218            IF( ln_cpl ) THEN  
    220219               qldif(ji,jj)   = tms(ji,jj) * rdt_ice                                                  & 
    221220                  &    * (   ( qsr_tot(ji,jj) - qsr_ice(ji,jj,1) * zfricp ) * ( 1.0 - thcm(ji,jj) )   & 
    … …  
    285284         CALL tab_2d_1d_2( nbpb, tbif_1d    (1:nbpb , 3 ), tbif(:,:,3)    , jpi, jpj, npb(1:nbpb) ) 
    286285         CALL tab_2d_1d_2( nbpb, qsr_ice_1d (1:nbpb)     , qsr_ice(:,:,1) , jpi, jpj, npb(1:nbpb) ) 
    287          IF( ltrcdm2dc_ice ) & 
    288          & CALL tab_2d_1d_2( nbpb, qsr_ice_mean_1d (1:nbpb), qsr_ice_mean(:,:,1), jpi, jpj, npb(1:nbpb) ) 
    289286         CALL tab_2d_1d_2( nbpb, fr1_i0_1d  (1:nbpb)     , fr1_i0         , jpi, jpj, npb(1:nbpb) ) 
    290287         CALL tab_2d_1d_2( nbpb, fr2_i0_1d  (1:nbpb)     , fr2_i0         , jpi, jpj, npb(1:nbpb) ) 
    291288         CALL tab_2d_1d_2( nbpb,  qns_ice_1d(1:nbpb)     ,  qns_ice(:,:,1), jpi, jpj, npb(1:nbpb) ) 
    292289         CALL tab_2d_1d_2( nbpb, dqns_ice_1d(1:nbpb)     , dqns_ice(:,:,1), jpi, jpj, npb(1:nbpb) ) 
    293          IF( .NOT. lk_cpl ) THEN  
     290         IF( .NOT. ln_cpl ) THEN  
    294291            CALL tab_2d_1d_2( nbpb, qla_ice_1d (1:nbpb)     ,  qla_ice(:,:,1), jpi, jpj, npb(1:nbpb) ) 
    295292            CALL tab_2d_1d_2( nbpb, dqla_ice_1d(1:nbpb)     , dqla_ice(:,:,1), jpi, jpj, npb(1:nbpb) ) 
    … …  
    336333         CALL tab_1d_2d_2( nbpb, qsr_ice(:,:,1), npb, qsr_ice_1d(1:nbpb)  , jpi, jpj ) 
    337334         CALL tab_1d_2d_2( nbpb, qns_ice(:,:,1), npb, qns_ice_1d(1:nbpb)  , jpi, jpj ) 
    338          IF( ltrcdm2dc_ice )THEN 
    339             CALL tab_1d_2d_2( nbpb, fstric_daymean     , npb, fstbif_daymean_1d (1:nbpb)  , jpi, jpj ) 
    340             CALL tab_1d_2d_2( nbpb, qsr_ice_mean(:,:,1), npb,    qsr_ice_mean_1d(1:nbpb)  , jpi, jpj ) 
    341          ENDIF 
    342          IF( .NOT. lk_cpl )   CALL tab_1d_2d_2( nbpb, qla_ice(:,:,1), npb, qla_ice_1d(1:nbpb)             , jpi, jpj ) 
     335         IF( .NOT. ln_cpl )   CALL tab_1d_2d_2( nbpb, qla_ice(:,:,1), npb, qla_ice_1d(1:nbpb), jpi, jpj ) 
    343336         ! 
    344337      ENDIF 
    … …  
    441434      IF( iom_use('qsr_ai_cea' ) )   CALL iom_put( 'qsr_ai_cea', qsr_ice(:,:,1) * ztmp(:,:) )   ! Solar flux over the ice     [W/m2] 
    442435      IF( iom_use('qns_ai_cea' ) )   CALL iom_put( 'qns_ai_cea', qns_ice(:,:,1) * ztmp(:,:) )   ! Non-solar flux over the ice [W/m2] 
    443       IF( iom_use('qla_ai_cea' ) .AND. .NOT. lk_cpl ) & 
     436      IF( iom_use('qla_ai_cea' ) .AND. .NOT. ln_cpl ) & 
    444437         &                           CALL iom_put( 'qla_ai_cea', qla_ice(:,:,1) * ztmp(:,:) )   ! Latent flux over the ice [W/m2] 
    445438      ! 
    … …  
    564557      IF(lwm) WRITE ( numoni, namicethd ) 
    565558 
    566       IF( lk_cpl .AND. parsub /= 0.0 )   CALL ctl_stop( 'In coupled mode, use parsub = 0. or send dqla' ) 
     559      IF( ln_cpl .AND. parsub /= 0.0 )   CALL ctl_stop( 'In coupled mode, use parsub = 0. or send dqla' ) 
    567560      ! 
    568561      IF(lwp) THEN                          ! control print 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/limthd_zdf_2.F90

    r5500 r5630  
    1818   USE ice_2 
    1919   USE limistate_2 
    20    USE sbc_oce, ONLY : lk_cpl 
     20   USE sbc_oce, ONLY : ln_cpl 
    2121   USE in_out_manager 
    2222   USE lib_mpp          ! MPP library 
    … …  
    273273       END DO 
    274274 
    275        IF( ltrcdm2dc_ice )THEN 
    276  
    277           DO ji = kideb , kiut 
    278              zihsn  = MAX( zzero , SIGN (zone , -h_snow_1d(ji) ) ) 
    279              zihic  = MAX( zzero , 1.0 - ( h_ice_1d(ji) / zhsu ) ) 
    280              zi0(ji)  = zihsn * ( fr1_i0_1d(ji) + zihic * fr2_i0_1d(ji) ) 
    281              zexp     = MIN( zone , EXP( -1.5 * ( h_ice_1d(ji) - zhsu ) ) ) 
    282              fstbif_daymean_1d(ji) = zi0(ji) * qsr_ice_mean_1d(ji) * zexp 
    283           END DO 
    284  
    285        ENDIF 
    286  
    287275       !-------------------------------------------------------------------------------- 
    288276       !  4. Computation of the surface temperature : determined by considering the  
    … …  
    337325       !----------------------------------------------------------------------   
    338326                      
    339        IF ( .NOT. lk_cpl ) THEN   ! duplicate the loop for performances issues 
     327       IF ( .NOT. ln_cpl ) THEN   ! duplicate the loop for performances issues 
    340328          DO ji = kideb, kiut 
    341329             sist_1d(ji) = MIN( ztsmlt(ji) , sist_1d(ji) ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_2/thd_ice_2.F90

    r5500 r5630  
    5555      fstbif_1d   ,     &  !:    "                  "      fstric 
    5656      fltbif_1d   ,     &  !:    "                  "      ffltbif 
    57       fstbif_daymean_1d, & !:    "                  " fstric_daymean 
    5857      fscbq_1d    ,     &  !:    "                  "      fscmcbq 
    5958      qsr_ice_1d  ,     &  !:    "                  "      qsr_ice 
    60       qsr_ice_mean_1d , &  !:    "                  "      qsr_ice_mean 
    6159      fr1_i0_1d   ,     &  !:    "                  "      fr1_i0 
    6260      fr2_i0_1d   ,     &  !:    "                  "      fr2_i0 
    … …  
    122120         &      tbif_1d(jpij, jplayersp1), Stat=ierr(4)) 
    123121         ! 
    124       IF( ltrcdm2dc_ice )ALLOCATE(fstbif_daymean_1d(jpij),qsr_ice_mean_1d(jpij),Stat=ierr(5)) 
    125          ! 
    126122      thd_ice_alloc_2 = MAXVAL(ierr) 
    127123      IF( thd_ice_alloc_2 /= 0 )   CALL ctl_warn('thd_ice_alloc_2: failed to allocate arrays') 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limadv.F90

    r5500 r5630  
    207207 
    208208      !-- Lateral boundary conditions 
    209       CALL lbc_lnk( psm , 'T',  1. )   ;   CALL lbc_lnk( ps0 , 'T',  1. ) 
    210       CALL lbc_lnk( psx , 'T', -1. )   ;   CALL lbc_lnk( psy , 'T', -1. )      ! caution gradient ==> the sign changes 
    211       CALL lbc_lnk( psxx, 'T',  1. )   ;   CALL lbc_lnk( psyy, 'T',  1. ) 
    212       CALL lbc_lnk( psxy, 'T',  1. ) 
     209      CALL lbc_lnk_multi( psm , 'T',  1., ps0 , 'T',  1.   & 
     210         &              , psx , 'T', -1., psy , 'T', -1.   &   ! caution gradient ==> the sign changes 
     211         &              , psxx, 'T',  1., psyy, 'T',  1.   & 
     212         &              , psxy, 'T',  1. ) 
    213213 
    214214      IF(ln_ctl) THEN 
    … …  
    393393 
    394394      !-- Lateral boundary conditions 
    395       CALL lbc_lnk( psm , 'T',  1. )   ;   CALL lbc_lnk( ps0 , 'T',  1. ) 
    396       CALL lbc_lnk( psx , 'T', -1. )   ;   CALL lbc_lnk( psy , 'T', -1. )      ! caution gradient ==> the sign changes 
    397       CALL lbc_lnk( psxx, 'T',  1. )   ;   CALL lbc_lnk( psyy, 'T',  1. ) 
    398       CALL lbc_lnk( psxy, 'T',  1. ) 
     395      CALL lbc_lnk_multi( psm , 'T',  1.,  ps0 , 'T',  1.   & 
     396         &              , psx , 'T', -1.,  psy , 'T', -1.   &   ! caution gradient ==> the sign changes 
     397         &              , psxx, 'T',  1.,  psyy, 'T',  1.   & 
     398         &              , psxy, 'T',  1. ) 
    399399 
    400400      IF(ln_ctl) THEN 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5500 r5630  
    1313   !!---------------------------------------------------------------------- 
    1414   !!   lim_hdf       : diffusion trend on sea-ice variable 
     15   !!   lim_hdf_init  : initialisation of diffusion trend on sea-ice variable 
    1516   !!---------------------------------------------------------------------- 
    1617   USE dom_oce        ! ocean domain 
    … …  
    2627   PRIVATE 
    2728 
    28    PUBLIC   lim_hdf     ! called by lim_trp 
     29   PUBLIC   lim_hdf         ! called by lim_trp 
     30   PUBLIC   lim_hdf_init    ! called by sbc_lim_init 
    2931 
    3032   LOGICAL  ::   linit = .TRUE.                             ! initialization flag (set to flase after the 1st call) 
     33   INTEGER  ::   nn_convfrq                                 !:  convergence check frequency of the Crant-Nicholson scheme 
    3134   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   efact   ! metric coefficient 
    3235 
    … …  
    121124         CALL lbc_lnk( zrlx, 'T', 1. )                   ! lateral boundary condition 
    122125         ! 
    123          zconv = 0._wp                                   ! convergence test 
    124          DO jj = 2, jpjm1 
    125             DO ji = fs_2, fs_jpim1 
    126                zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) )  ) 
    127             END DO 
    128          END DO 
    129          IF( lk_mpp )   CALL mpp_max( zconv )            ! max over the global domain 
     126         IF ( MOD( iter, nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
     127            zconv = 0._wp 
     128            DO jj = 2, jpjm1 
     129               DO ji = fs_2, fs_jpim1 
     130                  zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) )  ) 
     131               END DO 
     132            END DO 
     133            IF( lk_mpp )   CALL mpp_max( zconv )      ! max over the global domain 
     134         ENDIF 
    130135         ! 
    131136         ptab(:,:) = zrlx(:,:) 
    … …  
    162167   END SUBROUTINE lim_hdf 
    163168 
     169    
     170   SUBROUTINE lim_hdf_init 
     171      !!------------------------------------------------------------------- 
     172      !!                  ***  ROUTINE lim_hdf_init  *** 
     173      !! 
     174      !! ** Purpose : Initialisation of horizontal diffusion of sea-ice  
     175      !! 
     176      !! ** Method  : Read the namicehdf namelist 
     177      !! 
     178      !! ** input   : Namelist namicehdf 
     179      !!------------------------------------------------------------------- 
     180      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     181      NAMELIST/namicehdf/ nn_convfrq 
     182      !!------------------------------------------------------------------- 
     183      ! 
     184      IF(lwp) THEN 
     185         WRITE(numout,*) 
     186         WRITE(numout,*) 'lim_hdf : Ice horizontal diffusion' 
     187         WRITE(numout,*) '~~~~~~~' 
     188      ENDIF 
     189      ! 
     190      REWIND( numnam_ice_ref )              ! Namelist namicehdf in reference namelist : Ice horizontal diffusion 
     191      READ  ( numnam_ice_ref, namicehdf, IOSTAT = ios, ERR = 901) 
     192901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicehdf in reference namelist', lwp ) 
     193 
     194      REWIND( numnam_ice_cfg )              ! Namelist namicehdf in configuration namelist : Ice horizontal diffusion 
     195      READ  ( numnam_ice_cfg, namicehdf, IOSTAT = ios, ERR = 902 ) 
     196902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicehdf in configuration namelist', lwp ) 
     197      IF(lwm) WRITE ( numoni, namicehdf ) 
     198      ! 
     199      IF(lwp) THEN                          ! control print 
     200         WRITE(numout,*) 
     201         WRITE(numout,*)'   Namelist of ice parameters for ice horizontal diffusion computation ' 
     202         WRITE(numout,*)'      convergence check frequency of the Crant-Nicholson scheme   nn_convfrq   = ', nn_convfrq 
     203      ENDIF 
     204      ! 
     205   END SUBROUTINE lim_hdf_init 
    164206#else 
    165207   !!---------------------------------------------------------------------- 
    166208   !!   Default option          Dummy module           NO LIM sea-ice model 
    167209   !!---------------------------------------------------------------------- 
    168 CONTAINS 
    169    SUBROUTINE lim_hdf         ! Empty routine 
    170    END SUBROUTINE lim_hdf 
    171210#endif 
    172211 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r5500 r5630  
    117117 
    118118      ! basal temperature (considered at freezing point) 
    119       t_bo(:,:) = ( eos_fzp( tsn(:,:,1,jp_sal) ) + rt0 ) * tmask(:,:,1)  
     119      t_bo(:,:) = ( eos_fzp( sss_m(:,:) ) + rt0 ) * tmask(:,:,1)  
    120120 
    121121      IF( ln_iceini ) THEN 
    … …  
    127127      DO jj = 1, jpj                                       ! ice if sst <= t-freez + ttest 
    128128         DO ji = 1, jpi 
    129             IF( ( tsn(ji,jj,1,jp_tem)  - ( t_bo(ji,jj) - rt0 ) ) * tmask(ji,jj,1) >= rn_thres_sst ) THEN  
     129            IF( ( sst_m(ji,jj)  - ( t_bo(ji,jj) - rt0 ) ) * tmask(ji,jj,1) >= rn_thres_sst ) THEN  
    130130               zswitch(ji,jj) = 0._wp * tmask(ji,jj,1)    ! no ice 
    131131            ELSE                                                                                    

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limitd_th.F90

    r5500 r5630  
    9191      !!------------------------------------------------------------------ 
    9292 
    93       CALL wrk_alloc( jpi,jpj, zremap_flag )    ! integer 
    94       CALL wrk_alloc( jpi,jpj,jpl-1, zdonor )   ! integer 
     93      CALL wrk_alloc( jpi,jpj, zremap_flag ) 
     94      CALL wrk_alloc( jpi,jpj,jpl-1, zdonor ) 
    9595      CALL wrk_alloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_b, dummy_es ) 
    9696      CALL wrk_alloc( jpi,jpj,jpl-1, zdaice, zdvice )    
    9797      CALL wrk_alloc( jpi,jpj,jpl+1, zhbnew, kkstart = 0 )    
    9898      CALL wrk_alloc( (jpi+1)*(jpj+1), zvetamin, zvetamax )    
    99       CALL wrk_alloc( (jpi+1)*(jpj+1), nind_i, nind_j )   ! integer  
     99      CALL wrk_alloc( (jpi+1)*(jpj+1), nind_i, nind_j )  
    100100      CALL wrk_alloc( jpi,jpj, zhb0,zhb1,vt_i_init,vt_i_final,vt_s_init,vt_s_final,et_i_init,et_i_final,et_s_init,et_s_final ) 
    101101 
    … …  
    128128               rswitch           = MAX( 0.0, SIGN( 1.0, a_i(ji,jj,jl) - epsi10 ) )     !0 if no ice and 1 if yes 
    129129               ht_i(ji,jj,jl)    = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * rswitch 
    130                rswitch           = MAX( 0.0, SIGN( 1.0, a_i_b(ji,jj,jl) - epsi10) )    !0 if no ice and 1 if yes 
     130               rswitch           = MAX( 0.0, SIGN( 1.0, a_i_b(ji,jj,jl) - epsi10) ) 
    131131               zht_i_b(ji,jj,jl) = v_i_b(ji,jj,jl) / MAX( a_i_b(ji,jj,jl), epsi10 ) * rswitch 
    132                zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_b(ji,jj,jl)  
     132               IF( a_i(ji,jj,jl) > epsi10 )   zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_b(ji,jj,jl) ! clem: useless IF statement?  
    133133            END DO 
    134134         END DO 
    … …  
    172172            ! 
    173173            zhbnew(ii,ij,jl) = hi_max(jl) 
    174             IF ( a_i_b(ii,ij,jl) > epsi10 .AND. a_i_b(ii,ij,jl+1) > epsi10 ) THEN 
     174            IF    ( a_i_b(ii,ij,jl) > epsi10 .AND. a_i_b(ii,ij,jl+1) > epsi10 ) THEN 
    175175               !interpolate between adjacent category growth rates 
    176176               zslope           = ( zdhice(ii,ij,jl+1) - zdhice(ii,ij,jl) ) / ( zht_i_b(ii,ij,jl+1) - zht_i_b(ii,ij,jl) ) 
    177177               zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl) + zslope * ( hi_max(jl) - zht_i_b(ii,ij,jl) ) 
    178             ELSEIF ( a_i_b(ii,ij,jl) > epsi10) THEN 
     178            ELSEIF( a_i_b(ii,ij,jl) > epsi10) THEN 
    179179               zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl) 
    180             ELSEIF ( a_i_b(ii,ij,jl+1) > epsi10) THEN 
     180            ELSEIF( a_i_b(ii,ij,jl+1) > epsi10) THEN 
    181181               zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl+1) 
    182182            ENDIF 
    … …  
    187187            ii = nind_i(ji) 
    188188            ij = nind_j(ji) 
    189             IF( a_i(ii,ij,jl) > epsi10 .AND. ht_i(ii,ij,jl) >= zhbnew(ii,ij,jl) ) THEN 
     189 
     190            ! clem: we do not want ht_i to be too close to either HR or HL otherwise a division by nearly 0 is possible  
     191            ! in lim_itd_fitline in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 
     192            IF    ( a_i(ii,ij,jl  ) > epsi10 .AND. ht_i(ii,ij,jl  ) > ( zhbnew(ii,ij,jl) - epsi10 ) ) THEN 
    190193               zremap_flag(ii,ij) = 0 
    191             ELSEIF( a_i(ii,ij,jl+1) > epsi10 .AND. ht_i(ii,ij,jl+1) <= zhbnew(ii,ij,jl) ) THEN 
     194            ELSEIF( a_i(ii,ij,jl+1) > epsi10 .AND. ht_i(ii,ij,jl+1) < ( zhbnew(ii,ij,jl) + epsi10 ) ) THEN 
    192195               zremap_flag(ii,ij) = 0 
    193196            ENDIF 
    194197 
    195198            !- 4.3 Check that each zhbnew does not exceed maximal values hi_max   
     199            IF( zhbnew(ii,ij,jl) < hi_max(jl-1) ) zremap_flag(ii,ij) = 0 
    196200            IF( zhbnew(ii,ij,jl) > hi_max(jl+1) ) zremap_flag(ii,ij) = 0 
    197             IF( zhbnew(ii,ij,jl) < hi_max(jl-1) ) zremap_flag(ii,ij) = 0 
     201            ! clem bug: why is not the following instead? 
     202            !!IF( zhbnew(ii,ij,jl) < hi_max(jl-1) ) zremap_flag(ii,ij) = 0 
     203            !!IF( zhbnew(ii,ij,jl) > hi_max(jl  ) ) zremap_flag(ii,ij) = 0 
     204  
    198205         END DO 
    199206 
    … …  
    219226      DO jj = 1, jpj 
    220227         DO ji = 1, jpi 
    221             zhb0(ji,jj) = hi_max(0) ! 0eme 
    222             zhb1(ji,jj) = hi_max(1) ! 1er 
    223  
    224             zhbnew(ji,jj,klbnd-1) = 0._wp 
     228            zhb0(ji,jj) = hi_max(0) 
     229            zhb1(ji,jj) = hi_max(1) 
    225230 
    226231            IF( a_i(ji,jj,kubnd) > epsi10 ) THEN 
    227232               zhbnew(ji,jj,kubnd) = MAX( hi_max(kubnd-1), 3._wp * ht_i(ji,jj,kubnd) - 2._wp * zhbnew(ji,jj,kubnd-1) ) 
    228233            ELSE 
    229                zhbnew(ji,jj,kubnd) = hi_max(kubnd)   
    230                !!? clem bug: since hi_max(jpl)=99, this limit is very high  
    231                !!? but I think it is erased in fitline subroutine  
     234!clem bug               zhbnew(ji,jj,kubnd) = hi_max(kubnd)   
     235               zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) ! not used anyway 
     236            ENDIF 
     237 
     238            ! clem: we do not want ht_i_b to be too close to either HR or HL otherwise a division by nearly 0 is possible  
     239            ! in lim_itd_fitline in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 
     240            IF    ( zht_i_b(ji,jj,klbnd) < ( zhb0(ji,jj) + epsi10 ) )  THEN 
     241               zremap_flag(ji,jj) = 0 
     242            ELSEIF( zht_i_b(ji,jj,klbnd) > ( zhb1(ji,jj) - epsi10 ) )  THEN 
     243               zremap_flag(ji,jj) = 0 
    232244            ENDIF 
    233245 
    … …  
    248260 
    249261         IF( a_i(ii,ij,klbnd) > epsi10 ) THEN 
     262 
    250263            zdh0 = zdhice(ii,ij,klbnd) !decrease of ice thickness in the lower category 
    251             IF( zdh0 < 0.0 ) THEN !remove area from category 1 
     264 
     265            IF( zdh0 < 0.0 ) THEN      !remove area from category 1 
    252266               zdh0 = MIN( -zdh0, hi_max(klbnd) ) 
    253  
    254267               !Integrate g(1) from 0 to dh0 to estimate area melted 
    255268               zetamax = MIN( zdh0, hR(ii,ij,klbnd) ) - hL(ii,ij,klbnd) 
     269 
    256270               IF( zetamax > 0.0 ) THEN 
    257                   zx1  = zetamax 
    258                   zx2  = 0.5 * zetamax * zetamax  
    259                   zda0 = g1(ii,ij,klbnd) * zx2 + g0(ii,ij,klbnd) * zx1 !ice area removed 
    260                   ! Constrain new thickness <= ht_i 
    261                   zdamax = a_i(ii,ij,klbnd) * (1.0 - ht_i(ii,ij,klbnd) / zht_i_b(ii,ij,klbnd) ) ! zdamax > 0 
    262                   !ice area lost due to melting of thin ice 
    263                   zda0   = MIN( zda0, zdamax ) 
    264  
     271                  zx1    = zetamax 
     272                  zx2    = 0.5 * zetamax * zetamax  
     273                  zda0   = g1(ii,ij,klbnd) * zx2 + g0(ii,ij,klbnd) * zx1                        ! ice area removed 
     274                  zdamax = a_i(ii,ij,klbnd) * (1.0 - ht_i(ii,ij,klbnd) / zht_i_b(ii,ij,klbnd) ) ! Constrain new thickness <= ht_i                 
     275                  zda0   = MIN( zda0, zdamax )                                                  ! ice area lost due to melting  
     276                                                                                                !     of thin ice (zdamax > 0) 
    265277                  ! Remove area, conserving volume 
    266278                  ht_i(ii,ij,klbnd) = ht_i(ii,ij,klbnd) * a_i(ii,ij,klbnd) / ( a_i(ii,ij,klbnd) - zda0 ) 
    … …  
    269281               ENDIF 
    270282 
    271             ELSE ! if ice accretion ! a_i > epsi10; zdh0 > 0 
     283            ELSE ! if ice accretion zdh0 > 0 
     284               ! zhbnew was 0, and is shifted to the right to account for thin ice growth in openwater (F0 = f1) 
    272285               zhbnew(ii,ij,klbnd-1) = MIN( zdh0, hi_max(klbnd) )  
    273                ! zhbnew was 0, and is shifted to the right to account for thin ice 
    274                ! growth in openwater (F0 = f1) 
    275             ENDIF ! zdh0  
    276  
    277          ENDIF ! a_i > epsi10 
     286            ENDIF 
     287 
     288         ENDIF 
    278289 
    279290      END DO 
    … …  
    303314 
    304315            IF (zhbnew(ii,ij,jl) > hi_max(jl)) THEN ! transfer from jl to jl+1 
    305  
    306316               ! left and right integration limits in eta space 
    307317               zvetamin(ji) = MAX( hi_max(jl), hL(ii,ij,jl) ) - hL(ii,ij,jl) 
    308                zvetamax(ji) = MIN (zhbnew(ii,ij,jl), hR(ii,ij,jl) ) - hL(ii,ij,jl) 
     318               zvetamax(ji) = MIN( zhbnew(ii,ij,jl), hR(ii,ij,jl) ) - hL(ii,ij,jl) 
    309319               zdonor(ii,ij,jl) = jl 
    310320 
    311             ELSE  ! zhbnew(jl) <= hi_max(jl) ; transfer from jl+1 to jl 
    312  
     321            ELSE                                    ! zhbnew(jl) <= hi_max(jl) ; transfer from jl+1 to jl 
    313322               ! left and right integration limits in eta space 
    314323               zvetamin(ji) = 0.0 
    … …  
    316325               zdonor(ii,ij,jl) = jl + 1 
    317326 
    318             ENDIF  ! zhbnew(jl) > hi_max(jl) 
     327            ENDIF 
    319328 
    320329            zetamax = MAX( zvetamax(ji), zvetamin(ji) ) ! no transfer if etamax < etamin 
    … …  
    333342 
    334343         END DO 
    335       END DO ! jl klbnd -> kubnd - 1 
     344      END DO 
    336345 
    337346      !!---------------------------------------------------------------------------------------------- 
    … …  
    375384      ENDIF 
    376385 
    377       CALL wrk_dealloc( jpi,jpj, zremap_flag )    ! integer 
    378       CALL wrk_dealloc( jpi,jpj,jpl-1, zdonor )   ! integer 
     386      CALL wrk_dealloc( jpi,jpj, zremap_flag ) 
     387      CALL wrk_dealloc( jpi,jpj,jpl-1, zdonor ) 
    379388      CALL wrk_dealloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_b, dummy_es ) 
    380389      CALL wrk_dealloc( jpi,jpj,jpl-1, zdaice, zdvice )    
    381390      CALL wrk_dealloc( jpi,jpj,jpl+1, zhbnew, kkstart = 0 )    
    382391      CALL wrk_dealloc( (jpi+1)*(jpj+1), zvetamin, zvetamax )    
    383       CALL wrk_dealloc( (jpi+1)*(jpj+1), nind_i, nind_j )   ! integer  
     392      CALL wrk_dealloc( (jpi+1)*(jpj+1), nind_i, nind_j )  
    384393      CALL wrk_dealloc( jpi,jpj, zhb0,zhb1,vt_i_init,vt_i_final,vt_s_init,vt_s_final,et_i_init,et_i_final,et_s_init,et_s_final ) 
    385394 
    … …  
    406415      INTEGER , DIMENSION(jpi,jpj), INTENT(in   ) ::   zremap_flag  ! 
    407416      ! 
    408       INTEGER ::   ji,jj           ! horizontal indices 
     417      INTEGER  ::   ji,jj        ! horizontal indices 
    409418      REAL(wp) ::   zh13         ! HbL + 1/3 * (HbR - HbL) 
    410419      REAL(wp) ::   zh23         ! HbL + 2/3 * (HbR - HbL) 
    … …  
    413422      !!------------------------------------------------------------------ 
    414423      ! 
    415       ! 
    416424      DO jj = 1, jpj 
    417425         DO ji = 1, jpi 
    418426            ! 
    419427            IF( zremap_flag(ji,jj) == 1 .AND. a_i(ji,jj,num_cat) > epsi10   & 
    420                &                        .AND. hice(ji,jj)        > 0._wp     ) THEN 
     428               &                        .AND. hice(ji,jj)        > 0._wp ) THEN 
    421429 
    422430               ! Initialize hL and hR 
    423  
    424431               hL(ji,jj) = HbL(ji,jj) 
    425432               hR(ji,jj) = HbR(ji,jj) 
    426433 
    427434               ! Change hL or hR if hice falls outside central third of range 
    428  
    429435               zh13 = 1.0 / 3.0 * ( 2.0 * hL(ji,jj) + hR(ji,jj) ) 
    430436               zh23 = 1.0 / 3.0 * ( hL(ji,jj) + 2.0 * hR(ji,jj) ) 
    … …  
    435441 
    436442               ! Compute coefficients of g(eta) = g0 + g1*eta 
    437  
    438443               zdhr = 1._wp / (hR(ji,jj) - hL(ji,jj)) 
    439444               zwk1 = 6._wp * a_i(ji,jj,num_cat) * zdhr 
    … …  
    442447               g1(ji,jj) = 2._wp * zdhr * zwk1 * ( zwk2 - 0.5 ) 
    443448               ! 
    444             ELSE                   ! remap_flag = .false. or a_i < epsi10  
     449            ELSE  ! remap_flag = .false. or a_i < epsi10  
    445450               hL(ji,jj) = 0._wp 
    446451               hR(ji,jj) = 0._wp 
    447452               g0(ji,jj) = 0._wp 
    448453               g1(ji,jj) = 0._wp 
    449             ENDIF                  ! a_i > epsi10 
     454            ENDIF 
    450455            ! 
    451456         END DO 
    … …  
    471476 
    472477      INTEGER ::   ji, jj, jl, jl2, jl1, jk   ! dummy loop indices 
    473       INTEGER ::   ii, ij          ! indices when changing from 2D-1D is done 
     478      INTEGER ::   ii, ij                     ! indices when changing from 2D-1D is done 
    474479 
    475480      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zaTsfn 
    … …  
    484489      INTEGER, POINTER, DIMENSION(:) ::   nind_i, nind_j   ! compressed indices for i/j directions 
    485490 
    486       INTEGER ::   nbrem             ! number of cells with ice to transfer 
    487  
    488       LOGICAL ::   zdaice_negative         ! true if daice < -puny 
    489       LOGICAL ::   zdvice_negative         ! true if dvice < -puny 
    490       LOGICAL ::   zdaice_greater_aicen    ! true if daice > aicen 
    491       LOGICAL ::   zdvice_greater_vicen    ! true if dvice > vicen 
     491      INTEGER  ::   nbrem             ! number of cells with ice to transfer 
    492492      !!------------------------------------------------------------------ 
    493493 
    494494      CALL wrk_alloc( jpi,jpj,jpl, zaTsfn ) 
    495495      CALL wrk_alloc( jpi,jpj, zworka ) 
    496       CALL wrk_alloc( (jpi+1)*(jpj+1), nind_i, nind_j )   ! integer 
     496      CALL wrk_alloc( (jpi+1)*(jpj+1), nind_i, nind_j ) 
    497497 
    498498      !---------------------------------------------------------------------------------------------- 
    … …  
    504504      END DO 
    505505 
    506 !clem: I think the following is wrong (if enabled, it creates negative concentration/volume around -epsi10) 
    507 !      !---------------------------------------------------------------------------------------------- 
    508 !      ! 2) Check for daice or dvice out of range, allowing for roundoff error 
    509 !      !---------------------------------------------------------------------------------------------- 
    510 !      ! Note: zdaice < 0 or zdvice < 0 usually happens when category jl 
    511 !      ! has a small area, with h(n) very close to a boundary.  Then 
    512 !      ! the coefficients of g(h) are large, and the computed daice and 
    513 !      ! dvice can be in error. If this happens, it is best to transfer 
    514 !      ! either the entire category or nothing at all, depending on which 
    515 !      ! side of the boundary hice(n) lies. 
    516 !      !----------------------------------------------------------------- 
    517 !      DO jl = klbnd, kubnd-1 
    518 ! 
    519 !         zdaice_negative = .false. 
    520 !         zdvice_negative = .false. 
    521 !         zdaice_greater_aicen = .false. 
    522 !         zdvice_greater_vicen = .false. 
    523 ! 
    524 !         DO jj = 1, jpj 
    525 !            DO ji = 1, jpi 
    526 ! 
    527 !               IF (zdonor(ji,jj,jl) > 0) THEN 
    528 !                  jl1 = zdonor(ji,jj,jl) 
    529 ! 
    530 !                  IF (zdaice(ji,jj,jl) < 0.0) THEN 
    531 !                     IF (zdaice(ji,jj,jl) > -epsi10) THEN 
    532 !                        IF ( ( jl1 == jl   .AND. ht_i(ji,jj,jl1) >  hi_max(jl) ) .OR.  & 
    533 !                             ( jl1 == jl+1 .AND. ht_i(ji,jj,jl1) <= hi_max(jl) ) ) THEN 
    534 !                           zdaice(ji,jj,jl) = a_i(ji,jj,jl1)  ! shift entire category 
    535 !                           zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 
    536 !                        ELSE 
    537 !                           zdaice(ji,jj,jl) = 0.0 ! shift no ice 
    538 !                           zdvice(ji,jj,jl) = 0.0 
    539 !                        ENDIF 
    540 !                     ELSE 
    541 !                        zdaice_negative = .true. 
    542 !                     ENDIF 
    543 !                  ENDIF 
    544 ! 
    545 !                  IF (zdvice(ji,jj,jl) < 0.0) THEN 
    546 !                     IF (zdvice(ji,jj,jl) > -epsi10 ) THEN 
    547 !                        IF ( ( jl1 == jl   .AND. ht_i(ji,jj,jl1) >  hi_max(jl) ) .OR.  & 
    548 !                             ( jl1 == jl+1 .AND. ht_i(ji,jj,jl1) <= hi_max(jl) ) ) THEN 
    549 !                           zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 
    550 !                           zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    551 !                        ELSE 
    552 !                           zdaice(ji,jj,jl) = 0.0    ! shift no ice 
    553 !                           zdvice(ji,jj,jl) = 0.0 
    554 !                        ENDIF 
    555 !                    ELSE 
    556 !                       zdvice_negative = .true. 
    557 !                    ENDIF 
    558 !                 ENDIF 
    559 ! 
    560 !                  ! If daice is close to aicen, set daice = aicen. 
    561 !                  IF (zdaice(ji,jj,jl) > a_i(ji,jj,jl1) - epsi10 ) THEN 
    562 !                     IF (zdaice(ji,jj,jl) < a_i(ji,jj,jl1)+epsi10) THEN 
    563 !                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    564 !                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    565 !                    ELSE 
    566 !                       zdaice_greater_aicen = .true. 
    567 !                    ENDIF 
    568 !                  ENDIF 
    569 ! 
    570 !                  IF (zdvice(ji,jj,jl) > v_i(ji,jj,jl1)-epsi10) THEN 
    571 !                     IF (zdvice(ji,jj,jl) < v_i(ji,jj,jl1)+epsi10) THEN 
    572 !                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    573 !                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    574 !                     ELSE 
    575 !                        zdvice_greater_vicen = .true. 
    576 !                     ENDIF 
    577 !                  ENDIF 
    578 ! 
    579 !               ENDIF               ! donor > 0 
    580 !            END DO 
    581 !         END DO 
    582 ! 
    583 !      END DO 
    584 !clem 
    585506      !------------------------------------------------------------------------------- 
    586       ! 3) Transfer volume and energy between categories 
     507      ! 2) Transfer volume and energy between categories 
    587508      !------------------------------------------------------------------------------- 
    588509 
    … …  
    604525 
    605526            jl1 = zdonor(ii,ij,jl) 
    606             rswitch       = MAX( 0._wp , SIGN( 1._wp , v_i(ii,ij,jl1) - epsi20 ) ) 
    607             zworka(ii,ij) = zdvice(ii,ij,jl) / MAX( v_i(ii,ij,jl1), epsi20 ) * rswitch 
     527            rswitch       = MAX( 0._wp , SIGN( 1._wp , v_i(ii,ij,jl1) - epsi10 ) ) 
     528            zworka(ii,ij) = zdvice(ii,ij,jl) / MAX( v_i(ii,ij,jl1), epsi10 ) * rswitch 
    608529            IF( jl1 == jl) THEN   ;   jl2 = jl1+1 
    609530            ELSE                  ;   jl2 = jl  
    … …  
    613534            ! Ice areas 
    614535            !-------------- 
    615  
    616536            a_i(ii,ij,jl1) = a_i(ii,ij,jl1) - zdaice(ii,ij,jl) 
    617537            a_i(ii,ij,jl2) = a_i(ii,ij,jl2) + zdaice(ii,ij,jl) 
    … …  
    620540            ! Ice volumes 
    621541            !-------------- 
    622  
    623542            v_i(ii,ij,jl1) = v_i(ii,ij,jl1) - zdvice(ii,ij,jl)  
    624543            v_i(ii,ij,jl2) = v_i(ii,ij,jl2) + zdvice(ii,ij,jl) 
    … …  
    627546            ! Snow volumes 
    628547            !-------------- 
    629  
    630548            zdvsnow        = v_s(ii,ij,jl1) * zworka(ii,ij) 
    631549            v_s(ii,ij,jl1) = v_s(ii,ij,jl1) - zdvsnow 
    … …  
    635553            ! Snow heat content   
    636554            !-------------------- 
    637  
    638555            zdesnow            = e_s(ii,ij,1,jl1) * zworka(ii,ij) 
    639556            e_s(ii,ij,1,jl1)   = e_s(ii,ij,1,jl1) - zdesnow 
    … …  
    643560            ! Ice age  
    644561            !-------------- 
    645  
    646562            zdo_aice           = oa_i(ii,ij,jl1) * zdaice(ii,ij,jl) 
    647563            oa_i(ii,ij,jl1)    = oa_i(ii,ij,jl1) - zdo_aice 
    … …  
    651567            ! Ice salinity 
    652568            !-------------- 
    653  
    654569            zdsm_vice          = smv_i(ii,ij,jl1) * zworka(ii,ij) 
    655570            smv_i(ii,ij,jl1)   = smv_i(ii,ij,jl1) - zdsm_vice 
    … …  
    659574            ! Surface temperature 
    660575            !--------------------- 
    661  
    662576            zdaTsf             = t_su(ii,ij,jl1) * zdaice(ii,ij,jl) 
    663577            zaTsfn(ii,ij,jl1)  = zaTsfn(ii,ij,jl1) - zdaTsf 
    … …  
    710624      CALL wrk_dealloc( jpi,jpj,jpl, zaTsfn ) 
    711625      CALL wrk_dealloc( jpi,jpj, zworka ) 
    712       CALL wrk_dealloc( (jpi+1)*(jpj+1), nind_i, nind_j )   ! integer 
     626      CALL wrk_dealloc( (jpi+1)*(jpj+1), nind_i, nind_j ) 
    713627      ! 
    714628   END SUBROUTINE lim_itd_shiftice 
    … …  
    859773      ENDIF 
    860774      ! 
    861       CALL wrk_dealloc( jpi,jpj,jpl, zdonor )   ! interger 
     775      CALL wrk_dealloc( jpi,jpj,jpl, zdonor ) 
    862776      CALL wrk_dealloc( jpi,jpj,jpl, zdaice, zdvice ) 
    863777      CALL wrk_dealloc( jpi,jpj, vt_i_init, vt_i_final, vt_s_init, vt_s_final ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r5500 r5630  
    377377            END DO 
    378378         END DO 
    379          CALL lbc_lnk( v_ice1  , 'U', -1. )   ;   CALL lbc_lnk( u_ice2  , 'V', -1. )      ! lateral boundary cond. 
    380  
     379 
     380         CALL lbc_lnk_multi( v_ice1, 'U', -1., u_ice2, 'V', -1. )      ! lateral boundary cond. 
     381          
    381382         DO jj = k_j1+1, k_jpj-1 
    382383            DO ji = fs_2, fs_jpim1 
    … …  
    412413            END DO 
    413414         END DO 
    414          CALL lbc_lnk( zs1 , 'T', 1. )   ;   CALL lbc_lnk( zs2, 'T', 1. ) 
    415          CALL lbc_lnk( zs12, 'F', 1. ) 
    416  
     415 
     416         CALL lbc_lnk_multi( zs1 , 'T', 1., zs2, 'T', 1., zs12, 'F', 1. ) 
     417  
    417418         ! Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) 
    418419         DO jj = k_j1+1, k_jpj-1 
    … …  
    570571      END DO 
    571572 
    572       CALL lbc_lnk( u_ice(:,:), 'U', -1. )  
    573       CALL lbc_lnk( v_ice(:,:), 'V', -1. )  
     573      CALL lbc_lnk_multi( u_ice(:,:), 'U', -1., v_ice(:,:), 'V', -1. ) 
     574 
    574575#if defined key_agrif && defined key_lim2 
    575576      CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'U' ) 
    … …  
    595596      END DO 
    596597 
    597       CALL lbc_lnk( u_ice2(:,:), 'V', -1. )  
    598       CALL lbc_lnk( v_ice1(:,:), 'U', -1. ) 
     598      CALL lbc_lnk_multi( u_ice2(:,:), 'V', -1., v_ice1(:,:), 'U', -1. ) 
    599599 
    600600      ! Recompute delta, shear and div, inputs for mechanical redistribution  
    … …  
    643643 
    644644      ! Lateral boundary condition 
    645       CALL lbc_lnk( divu_i (:,:), 'T', 1. ) 
    646       CALL lbc_lnk( delta_i(:,:), 'T', 1. ) 
    647       ! CALL lbc_lnk( shear_i(:,:), 'F', 1. ) 
    648       CALL lbc_lnk( shear_i(:,:), 'T', 1. ) 
     645      CALL lbc_lnk_multi( divu_i (:,:), 'T', 1., delta_i(:,:), 'T', 1.,  shear_i(:,:), 'T', 1. ) 
    649646 
    650647      ! * Store the stress tensor for the next time step 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r5500 r5630  
    3030   USE sbc_oce          ! Surface boundary condition: ocean fields 
    3131   USE sbccpl 
    32    USE oce       , ONLY : fraqsr_1lev, sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 
     32   USE oce       , ONLY : sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 
    3333   USE albedo           ! albedo parameters 
    3434   USE lbclnk           ! ocean lateral boundary condition - MPP exchanges 
    … …  
    9494      !!              - fr_i    : ice fraction 
    9595      !!              - tn_ice  : sea-ice surface temperature 
    96       !!              - alb_ice : sea-ice albedo (lk_cpl=T) 
     96      !!              - alb_ice : sea-ice albedo (only useful in coupled mode) 
    9797      !! 
    9898      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 
    … …  
    101101      !!              The ref should be Rousset et al., 2015 
    102102      !!--------------------------------------------------------------------- 
    103       INTEGER, INTENT(in) ::   kt                                   ! number of iteration 
    104       INTEGER  ::   ji, jj, jl, jk                                  ! dummy loop indices 
    105       REAL(wp) ::   zemp                                            ! local scalars 
    106       REAL(wp) ::   zf_mass                                         ! Heat flux associated with mass exchange ice->ocean (W.m-2) 
    107       REAL(wp) ::   zfcm1                                           ! New solar flux received by the ocean 
     103      INTEGER, INTENT(in) ::   kt                                  ! number of iteration 
     104      INTEGER  ::   ji, jj, jl, jk                                 ! dummy loop indices 
     105      REAL(wp) ::   zqmass                                         ! Heat flux associated with mass exchange ice->ocean (W.m-2) 
     106      REAL(wp) ::   zqsr                                           ! New solar flux received by the ocean 
    108107      ! 
    109108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 2D/3D workspace 
    … …  
    111110 
    112111      ! make calls for heat fluxes before it is modified 
    113       IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr(:,:) * pfrld(:,:) )   !     solar flux at ocean surface 
    114       IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns(:,:) * pfrld(:,:) )   ! non-solar flux at ocean surface 
    115       IF( iom_use('qsr_ice') )   CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) !     solar flux at ice surface 
    116       IF( iom_use('qns_ice') )   CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) ! non-solar flux at ice surface 
    117       IF( iom_use('qtr_ice') )   CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) !     solar flux transmitted thru ice 
    118       IF( iom_use('qt_oce' ) )   CALL iom_put( "qt_oce"  , ( qsr(:,:) + qns(:,:) ) * pfrld(:,:) )   
    119       IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) ) * a_i_b(:,:,:), dim=3 ) ) 
     112      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
     113      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
     114      IF( iom_use('qsr_ice') )   CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux at ice surface 
     115      IF( iom_use('qns_ice') )   CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) ! non-solar flux at ice surface 
     116      IF( iom_use('qtr_ice') )   CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux transmitted thru ice 
     117      IF( iom_use('qt_oce' ) )   CALL iom_put( "qt_oce"  , ( qsr_oce(:,:) + qns_oce(:,:) ) * pfrld(:,:) + qemp_oce(:,:) )   
     118      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
     119         &                                                      * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 
     120      IF( iom_use('qemp_oce' ) )   CALL iom_put( "qemp_oce"  , qemp_oce(:,:) )   
     121      IF( iom_use('qemp_ice' ) )   CALL iom_put( "qemp_ice"  , qemp_ice(:,:) )   
    120122 
    121123      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
    … …  
    126128            !      heat flux at the ocean surface      ! 
    127129            !------------------------------------------! 
    128             ! Solar heat flux reaching the ocean = zfcm1 (W.m-2)  
     130            ! Solar heat flux reaching the ocean = zqsr (W.m-2)  
    129131            !--------------------------------------------------- 
    130             IF( lk_cpl ) THEN  
    131                !!! LIM2 version zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) ) 
    132                zfcm1 = qsr_tot(ji,jj) 
    133                DO jl = 1, jpl 
    134                   zfcm1 = zfcm1 + ( ftr_ice(ji,jj,jl) - qsr_ice(ji,jj,jl) ) * a_i_b(ji,jj,jl) 
    135                END DO 
    136             ELSE 
    137                !!! LIM2 version zqsr = pfrld(ji,jj) * qsr(ji,jj)  + ( 1.  - pfrld(ji,jj) ) * fstric(ji,jj) 
    138                zfcm1   = pfrld(ji,jj) * qsr(ji,jj) 
    139                DO jl = 1, jpl 
    140                   zfcm1   = zfcm1 + a_i_b(ji,jj,jl) * ftr_ice(ji,jj,jl) 
    141                END DO 
    142             ENDIF 
     132            zqsr = qsr_tot(ji,jj) 
     133            DO jl = 1, jpl 
     134               zqsr = zqsr - a_i_b(ji,jj,jl) * (  qsr_ice(ji,jj,jl) - ftr_ice(ji,jj,jl) )  
     135            END DO 
    143136 
    144137            ! Total heat flux reaching the ocean = hfx_out (W.m-2)  
    145138            !--------------------------------------------------- 
    146             zf_mass        = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 
    147             hfx_out(ji,jj) = hfx_out(ji,jj) + zf_mass + zfcm1 
     139            zqmass         = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 
     140            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    148141 
    149142            ! Add the residual from heat diffusion equation (W.m-2) 
    … …  
    153146            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    154147            !--------------------------------------------------- 
    155             qsr(ji,jj) = zfcm1                                       
    156             qns(ji,jj) = hfx_out(ji,jj) - zfcm1               
     148            qsr(ji,jj) = zqsr                                       
     149            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    157150 
    158151            !------------------------------------------! 
    … …  
    167160            !                     Even if i see Ice melting as a FW and SALT flux 
    168161            !         
    169             !  computing freshwater exchanges at the ice/ocean interface 
    170             IF( lk_cpl ) THEN  
    171                 zemp =   emp_tot(ji,jj)                                    &   ! net mass flux over grid cell 
    172                    &   - emp_ice(ji,jj) * ( 1._wp - pfrld(ji,jj) )         &   ! minus the mass flux intercepted by sea ice 
    173                    &   + sprecip(ji,jj) * ( pfrld(ji,jj) - pfrld(ji,jj)**rn_betas )   ! 
    174             ELSE 
    175                zemp =   emp(ji,jj)     *           pfrld(ji,jj)            &   ! evaporation over oceanic fraction 
    176                   &   - tprecip(ji,jj) * ( 1._wp - pfrld(ji,jj) )          &   ! all precipitation reach the ocean 
    177                   &   + sprecip(ji,jj) * ( 1._wp - pfrld(ji,jj)**rn_betas )       ! except solid precip intercepted by sea-ice 
    178             ENDIF 
    179  
    180162            ! mass flux from ice/ocean 
    181163            wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj)   & 
    … …  
    184166            ! mass flux at the ocean/ice interface 
    185167            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
    186             emp(ji,jj)    = zemp - wfx_ice(ji,jj) - wfx_snw(ji,jj)             ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
     168            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    187169             
    188170         END DO 
    … …  
    213195      tn_ice(:,:,:) = t_su(:,:,:)           ! Ice surface temperature                       
    214196 
    215       !------------------------------------------------! 
    216       !    Snow/ice albedo (only if sent to coupler)   ! 
    217       !------------------------------------------------! 
    218       IF( lk_cpl ) THEN          ! coupled case 
    219  
    220             CALL wrk_alloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 
    221  
    222             CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os )  ! cloud-sky and overcast-sky ice albedos 
    223  
    224             alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    225  
    226             CALL wrk_dealloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 
    227  
    228       ENDIF 
     197      !------------------------------------------------------------------------! 
     198      !    Snow/ice albedo (only if sent to coupler, useless in forced mode)   ! 
     199      !------------------------------------------------------------------------! 
     200      CALL wrk_alloc( jpi, jpj, jpl, zalb_cs, zalb_os )     
     201      CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os )  ! cloud-sky and overcast-sky ice albedos 
     202      alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     203      CALL wrk_dealloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 
    229204 
    230205      ! conservation test 
    … …  
    346321            sice_0(:,:) = 2._wp 
    347322         END WHERE 
    348       ENDIF 
    349        
    350       IF( .NOT. ln_rstart ) THEN 
    351          fraqsr_1lev(:,:) = 1._wp 
    352323      ENDIF 
    353324      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r5500 r5630  
    2222   USE phycst         ! physical constants 
    2323   USE dom_oce        ! ocean space and time domain variables 
    24    USE oce     , ONLY : fraqsr_1lev  
    2524   USE ice            ! LIM: sea-ice variables 
    2625   USE sbc_oce        ! Surface boundary condition: ocean fields 
    … …  
    2827   USE thd_ice        ! LIM thermodynamic sea-ice variables 
    2928   USE dom_ice        ! LIM sea-ice domain 
    30    USE domvvl         ! domain: variable volume level 
    3129   USE limthd_dif     ! LIM: thermodynamics, vertical diffusion 
    3230   USE limthd_dh      ! LIM: thermodynamics, ice and snow thickness variation 
    … …  
    5048   PRIVATE 
    5149 
    52    PUBLIC   lim_thd        ! called by limstp module 
    53    PUBLIC   lim_thd_init   ! called by sbc_lim_init 
     50   PUBLIC   lim_thd         ! called by limstp module 
     51   PUBLIC   lim_thd_init    ! called by sbc_lim_init 
    5452 
    5553   !! * Substitutions 
    … …  
    9290      REAL(wp), PARAMETER :: zch        = 0.0057_wp       ! heat transfer coefficient 
    9391      ! 
    94       REAL(wp), POINTER, DIMENSION(:,:) ::  zqsr, zqns 
    9592      !!------------------------------------------------------------------- 
    96       CALL wrk_alloc( jpi,jpj, zqsr, zqns ) 
    9793 
    9894      IF( nn_timing == 1 )  CALL timing_start('limthd') 
    … …  
    136132      ! 2) Partial computation of forcing for the thermodynamic sea ice model.      ! 
    137133      !-----------------------------------------------------------------------------! 
    138  
    139       !--- Ocean solar and non solar fluxes to be used in zqld 
    140       IF ( .NOT. lk_cpl ) THEN   ! --- forced case, fluxes to the lead are the same as over the ocean 
    141          ! 
    142          zqsr(:,:) = qsr(:,:)      ; zqns(:,:) = qns(:,:) 
    143          ! 
    144       ELSE                       ! --- coupled case, fluxes to the lead are total - intercepted 
    145          ! 
    146          zqsr(:,:) = qsr_tot(:,:)  ; zqns(:,:) = qns_tot(:,:) 
    147          ! 
    148          DO jl = 1, jpl 
    149             DO jj = 1, jpj 
    150                DO ji = 1, jpi 
    151                   zqsr(ji,jj) = zqsr(ji,jj) - qsr_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 
    152                   zqns(ji,jj) = zqns(ji,jj) - qns_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 
    153                END DO 
    154             END DO 
    155          END DO 
    156          ! 
    157       ENDIF 
    158  
    159134      DO jj = 1, jpj 
    160135         DO ji = 1, jpi 
    … …  
    167142            !           !  temperature and turbulent mixing (McPhee, 1992) 
    168143            ! 
    169  
    170144            ! --- Energy received in the lead, zqld is defined everywhere (J.m-2) --- ! 
    171             ! REMARK valid at least in forced mode from clem 
    172             ! precip is included in qns but not in qns_ice 
    173             IF ( lk_cpl ) THEN 
    174                zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    175                   &    (   zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj)               &   ! pfrld already included in coupled mode 
    176                   &    + ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *     &   ! heat content of precip 
    177                   &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )   & 
    178                   &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 ) ) 
    179             ELSE 
    180                zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    181                   &      ( pfrld(ji,jj) * ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) )    & 
    182                   &    + ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *             &  ! heat content of precip 
    183                   &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )           & 
    184                   &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 ) ) 
    185             ENDIF 
     145            zqld =  tmask(ji,jj,1) * rdt_ice *  & 
     146               &    ( pfrld(ji,jj) * qsr_oce(ji,jj) * frq_m(ji,jj) + pfrld(ji,jj) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
    186147 
    187148            ! --- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- ! 
    … …  
    210171            ! Net heat flux on top of ice-ocean [W.m-2] 
    211172            ! ----------------------------------------- 
    212             !     heat flux at the ocean surface + precip 
    213             !   + heat flux at the ice   surface  
    214             hfx_in(ji,jj) = hfx_in(ji,jj)                                                                                         &  
    215                ! heat flux above the ocean 
    216                &    +             pfrld(ji,jj)   * ( zqns(ji,jj) + zqsr(ji,jj) )                                                  & 
    217                ! latent heat of precip (note that precip is included in qns but not in qns_ice) 
    218                &    +   ( 1._wp - pfrld(ji,jj) ) * sprecip(ji,jj) * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )  & 
    219                &    +   ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 )          & 
    220                ! heat flux above the ice 
    221                &    +   SUM(    a_i_b(ji,jj,:)   * ( qns_ice(ji,jj,:) + qsr_ice(ji,jj,:) ) ) 
     173            hfx_in(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
    222174 
    223175            ! ----------------------------------------------------------------------------- 
    224             ! Net heat flux that is retroceded to the ocean or taken from the ocean [W.m-2] 
     176            ! Net heat flux on top of the ocean after ice thermo (1st step) [W.m-2] 
    225177            ! ----------------------------------------------------------------------------- 
    226178            !     First  step here              :  non solar + precip - qlead - qturb 
    227179            !     Second step in limthd_dh      :  heat remaining if total melt (zq_rema)  
    228180            !     Third  step in limsbc         :  heat from ice-ocean mass exchange (zf_mass) + solar 
    229             hfx_out(ji,jj) = hfx_out(ji,jj)                                                                                       &  
    230                ! Non solar heat flux received by the ocean 
    231                &    +        pfrld(ji,jj) * zqns(ji,jj)                                                                            & 
    232                ! latent heat of precip (note that precip is included in qns but not in qns_ice) 
    233                &    +      ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)       & 
    234                &         * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )  & 
    235                &    +      ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 )       & 
    236                ! heat flux taken from the ocean where there is open water ice formation 
    237                &    -      qlead(ji,jj) * r1_rdtice                                                                               & 
    238                ! heat flux taken from the ocean during bottom growth/melt (fhld should be 0 while bott growth) 
    239                &    -      at_i(ji,jj) * fhtur(ji,jj)                                                                             & 
    240                &    -      at_i(ji,jj) *  fhld(ji,jj) 
    241  
     181            hfx_out(ji,jj) =   pfrld(ji,jj) * qns_oce(ji,jj) + qemp_oce(ji,jj)  &  ! Non solar heat flux received by the ocean                
     182               &             - qlead(ji,jj) * r1_rdtice                         &  ! heat flux taken from the ocean where there is open water ice formation 
     183               &             - at_i(ji,jj) * fhtur(ji,jj)                       &  ! heat flux taken by turbulence 
     184               &             - at_i(ji,jj) *  fhld(ji,jj)                          ! heat flux taken during bottom growth/melt  
     185                                                                                   !    (fhld should be 0 while bott growth) 
    242186         END DO 
    243187      END DO 
    … …  
    412356      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    413357 
    414       CALL wrk_dealloc( jpi,jpj, zqsr, zqns ) 
    415  
    416358      !------------------------------------------------------------------------------| 
    417359      !  6) Transport of ice between thickness categories.                           | 
    … …  
    472414   END SUBROUTINE lim_thd  
    473415 
     416  
    474417   SUBROUTINE lim_thd_temp( kideb, kiut ) 
    475418      !!----------------------------------------------------------------------- 
    … …  
    570513         END DO 
    571514          
    572          CALL tab_2d_1d( nbpb, tatm_ice_1d(1:nbpb), tatm_ice(:,:)  , jpi, jpj, npb(1:nbpb) ) 
     515         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
    573516         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    574517         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    576519         CALL tab_2d_1d( nbpb, qns_ice_1d (1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    577520         CALL tab_2d_1d( nbpb, ftr_ice_1d (1:nbpb), ftr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    578          IF( .NOT. lk_cpl ) THEN 
    579             CALL tab_2d_1d( nbpb, qla_ice_1d (1:nbpb), qla_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    580             CALL tab_2d_1d( nbpb, dqla_ice_1d(1:nbpb), dqla_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
    581          ENDIF 
     521         CALL tab_2d_1d( nbpb, evap_ice_1d (1:nbpb), evap_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
    582522         CALL tab_2d_1d( nbpb, dqns_ice_1d(1:nbpb), dqns_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
    583523         CALL tab_2d_1d( nbpb, t_bo_1d     (1:nbpb), t_bo            , jpi, jpj, npb(1:nbpb) ) 
    … …  
    670610         CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 
    671611         CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 
    672                    
     612         !          
    673613      END SELECT 
    674614 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r5500 r5630  
    2929   PRIVATE 
    3030 
    31    PUBLIC   lim_thd_dh   ! called by lim_thd 
     31   PUBLIC   lim_thd_dh      ! called by lim_thd 
     32   PUBLIC   lim_thd_snwblow ! called in sbcblk/sbcclio/sbccpl and here 
     33 
     34   INTERFACE lim_thd_snwblow 
     35      MODULE PROCEDURE lim_thd_snwblow_1d, lim_thd_snwblow_2d 
     36   END INTERFACE 
    3237 
    3338   !!---------------------------------------------------------------------- 
    … …  
    7176      REAL(wp) ::   zfdum        
    7277      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    73       REAL(wp) ::   zcoeff       ! dummy argument for snowfall partitioning over ice and leads 
    74       REAL(wp) ::   zs_snic  ! snow-ice salinity 
     78      REAL(wp) ::   zs_snic      ! snow-ice salinity 
    7579      REAL(wp) ::   zswi1        ! switch for computation of bottom salinity 
    7680      REAL(wp) ::   zswi12       ! switch for computation of bottom salinity 
    … …  
    103107      REAL(wp), POINTER, DIMENSION(:) ::   zqh_s       ! total snow heat content (J.m-2) 
    104108      REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
     109      REAL(wp), POINTER, DIMENSION(:) ::   zsnw        ! distribution of snow after wind blowing 
    105110 
    106111      REAL(wp) :: zswitch_sal 
    … …  
    117122      END SELECT 
    118123 
    119       CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema ) 
     124      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    120125      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    121126      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
    122127      CALL wrk_alloc( jpij, nlay_i, icount ) 
    123        
     128        
    124129      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
    125130      dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp    
    126   
    127       zqprec (:) = 0._wp ; zq_su  (:) = 0._wp ; zq_bo  (:) = 0._wp ; zf_tt  (:) = 0._wp 
    128       zq_rema(:) = 0._wp 
    129  
    130       zdh_s_pre(:) = 0._wp 
    131       zdh_s_mel(:) = 0._wp 
    132       zdh_s_sub(:) = 0._wp 
    133       zqh_s    (:) = 0._wp       
    134       zqh_i    (:) = 0._wp    
    135  
    136       zh_i      (:,:) = 0._wp        
    137       zdeltah   (:,:) = 0._wp        
    138       icount    (:,:) = 0 
     131 
     132      zqprec   (:) = 0._wp ; zq_su    (:) = 0._wp ; zq_bo    (:) = 0._wp ; zf_tt(:) = 0._wp 
     133      zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp 
     134      zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 
     135      zqh_s    (:) = 0._wp ; zq_s     (:) = 0._wp      
     136 
     137      zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp        
     138      icount (:,:) = 0 
     139 
    139140 
    140141      ! Initialize enthalpy at nlay_i+1 
    … …  
    218219      ! Martin Vancoppenolle, December 2006 
    219220 
     221      CALL lim_thd_snwblow( 1. - at_i_1d(kideb:kiut), zsnw(kideb:kiut) ) ! snow distribution over ice after wind blowing 
     222 
    220223      zdeltah(:,:) = 0._wp 
    221224      DO ji = kideb, kiut 
    … …  
    224227         !----------- 
    225228         ! thickness change 
    226          zcoeff = ( 1._wp - ( 1._wp - at_i_1d(ji) )**rn_betas ) / at_i_1d(ji)  
    227          zdh_s_pre(ji) = zcoeff * sprecip_1d(ji) * rdt_ice * r1_rhosn 
    228          ! enthalpy of the precip (>0, J.m-3) (tatm_ice is now in K) 
    229          zqprec   (ji) = rhosn * ( cpic * ( rt0 - MIN( tatm_ice_1d(ji), rt0_snow) ) + lfus )    
     229         zdh_s_pre(ji) = zsnw(ji) * sprecip_1d(ji) * rdt_ice * r1_rhosn / at_i_1d(ji) 
     230         ! enthalpy of the precip (>0, J.m-3) 
     231         zqprec   (ji) = - qprec_ice_1d(ji)    
    230232         IF( sprecip_1d(ji) == 0._wp ) zqprec(ji) = 0._wp 
    231233         ! heat flux from snow precip (>0, W.m-2) 
    … …  
    280282      ! clem comment: ice should also sublimate 
    281283      zdeltah(:,:) = 0._wp 
    282       IF( lk_cpl ) THEN 
    283          ! coupled mode: sublimation already included in emp_ice (to do in limsbc_ice) 
    284          zdh_s_sub(:)      =  0._wp  
    285       ELSE 
    286          ! forced  mode: snow thickness change due to sublimation 
    287          DO ji = kideb, kiut 
    288             zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - qla_ice_1d(ji) / ( rhosn * lsub ) * rdt_ice ) 
    289             ! Heat flux by sublimation [W.m-2], < 0 
    290             !      sublimate first snow that had fallen, then pre-existing snow 
    291             zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
    292             hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
    293                &                              ) * a_i_1d(ji) * r1_rdtice 
    294             ! Mass flux by sublimation 
    295             wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_sub(ji) * r1_rdtice 
    296             ! new snow thickness 
    297             ht_s_1d(ji)    =  MAX( 0._wp , ht_s_1d(ji) + zdh_s_sub(ji) ) 
    298             ! update precipitations after sublimation and correct sublimation 
    299             zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1) 
    300             zdh_s_sub(ji) = zdh_s_sub(ji) - zdeltah(ji,1) 
    301          END DO 
    302       ENDIF 
    303  
     284      ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 
     285      ! forced  mode: snow thickness change due to sublimation 
     286      DO ji = kideb, kiut 
     287         zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
     288         ! Heat flux by sublimation [W.m-2], < 0 
     289         !      sublimate first snow that had fallen, then pre-existing snow 
     290         zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
     291         hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
     292            &                              ) * a_i_1d(ji) * r1_rdtice 
     293         ! Mass flux by sublimation 
     294         wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_sub(ji) * r1_rdtice 
     295         ! new snow thickness 
     296         ht_s_1d(ji)    =  MAX( 0._wp , ht_s_1d(ji) + zdh_s_sub(ji) ) 
     297         ! update precipitations after sublimation and correct sublimation 
     298         zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1) 
     299         zdh_s_sub(ji) = zdh_s_sub(ji) - zdeltah(ji,1) 
     300      END DO 
     301       
    304302      ! --- Update snow diags --- ! 
    305303      DO ji = kideb, kiut 
    … …  
    688686      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    689687       
    690       CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema ) 
     688      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    691689      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    692690      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    … …  
    695693      ! 
    696694   END SUBROUTINE lim_thd_dh 
     695 
     696 
     697   !!-------------------------------------------------------------------------- 
     698   !! INTERFACE lim_thd_snwblow 
     699   !! ** Purpose :   Compute distribution of precip over the ice 
     700   !!-------------------------------------------------------------------------- 
     701   SUBROUTINE lim_thd_snwblow_2d( pin, pout ) 
     702      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pin   ! previous fraction lead ( pfrld or (1. - a_i_b) ) 
     703      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout 
     704      pout = ( 1._wp - ( pin )**rn_betas ) 
     705   END SUBROUTINE lim_thd_snwblow_2d 
     706 
     707   SUBROUTINE lim_thd_snwblow_1d( pin, pout ) 
     708      REAL(wp), DIMENSION(:), INTENT(in   ) :: pin 
     709      REAL(wp), DIMENSION(:), INTENT(inout) :: pout 
     710      pout = ( 1._wp - ( pin )**rn_betas ) 
     711   END SUBROUTINE lim_thd_snwblow_1d 
     712 
    697713    
    698714#else 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90

    r5500 r5630  
    2424   USE wrk_nemo       ! work arrays 
    2525   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    26    USE sbc_oce, ONLY : lk_cpl 
    2726 
    2827   IMPLICIT NONE 
    … …  
    283282      END DO 
    284283 
    285       ! 
    286284      !------------------------------------------------------------------------------| 
    287285      !  3) Iterative procedure begins                                               | 
    … …  
    746744      !-------------------------------------------------------------------------! 
    747745      DO ji = kideb, kiut 
    748          ! forced mode only : update of latent heat fluxes (sublimation) (always >=0, upward flux)  
    749          IF( .NOT. lk_cpl) qla_ice_1d (ji) = MAX( 0._wp, qla_ice_1d (ji) + dqla_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) ) ) 
    750746         !                                ! surface ice conduction flux 
    751747         isnow(ji)       = 1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_1d(ji) ) ) 
    … …  
    760756 
    761757      ! --- diagnose the change in non-solar flux due to surface temperature change --- ! 
    762       IF ( ln_it_qnsice ) hfx_err_dif_1d(:) = hfx_err_dif_1d(:) - ( qns_ice_1d(:)  - zqns_ice_b(:) ) * a_i_1d(:)  
     758      IF ( ln_it_qnsice ) THEN 
     759         DO ji = kideb, kiut 
     760            hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( qns_ice_1d(ji)  - zqns_ice_b(ji) ) * a_i_1d(ji)  
     761         END DO 
     762      END IF 
    763763 
    764764      ! --- diag conservation imbalance on heat diffusion - PART 2 --- ! 
    … …  
    794794      CALL wrk_dealloc( jpij, numeqmin, numeqmax ) 
    795795      CALL wrk_dealloc( jpij, isnow, ztsub, ztsubit, zh_i, zh_s, zfsw ) 
    796       CALL wrk_dealloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zghe ) 
     796      CALL wrk_dealloc( jpij, zf, dzf, zqns_ice_b, zerrit, zdifcase, zftrice, zihic, zghe ) 
    797797      CALL wrk_dealloc( jpij,nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart = 0 ) 
    798798      CALL wrk_dealloc( jpij,nlay_s+1,           zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart = 0 ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

    r5500 r5630  
    178178      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    179179 
    180       ! for outputs 
     180      ! necessary calls (at least for coupling) 
    181181      CALL lim_var_glo2eqv 
    182182      CALL lim_var_agg(2) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r5500 r5630  
    6060      REAL(wp) ::  z1_365 
    6161      REAL(wp) ::  ztmp 
    62       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zoi, zei 
     62      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zoi, zei, zt_i, zt_s 
    6363      REAL(wp), POINTER, DIMENSION(:,:)   ::  z2d, z2da, z2db, zswi    ! 2D workspace 
    6464      !!------------------------------------------------------------------- 
    … …  
    6666      IF( nn_timing == 1 )  CALL timing_start('limwri') 
    6767 
    68       CALL wrk_alloc( jpi, jpj, jpl, zoi, zei ) 
     68      CALL wrk_alloc( jpi, jpj, jpl, zoi, zei, zt_i, zt_s ) 
    6969      CALL wrk_alloc( jpi, jpj     , z2d, z2da, z2db, zswi ) 
    7070 
    … …  
    176176      CALL iom_put( "utau_ice"    , utau_ice            )        ! wind stress over ice along i-axis at I-point 
    177177      CALL iom_put( "vtau_ice"    , vtau_ice            )        ! wind stress over ice along j-axis at I-point 
    178       CALL iom_put( "snowpre"     , sprecip             )        ! snow precipitation  
     178      CALL iom_put( "snowpre"     , sprecip * 86400.    )        ! snow precipitation  
    179179      CALL iom_put( "micesalt"    , smt_i               )        ! mean ice salinity 
    180180 
    … …  
    232232      CALL iom_put ('hfxdif'     , hfx_dif(:,:)         )   !   
    233233      CALL iom_put ('hfxopw'     , hfx_opw(:,:)         )   !   
    234       CALL iom_put ('hfxtur'     , fhtur(:,:) * at_i(:,:) ) ! turbulent heat flux at ice base  
     234      CALL iom_put ('hfxtur'     , fhtur(:,:) * SUM(a_i_b(:,:,:), dim=3) ) ! turbulent heat flux at ice base  
    235235      CALL iom_put ('hfxdhc'     , diag_heat(:,:)       )   ! Heat content variation in snow and ice  
    236236      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
    … …  
    243243      CALL iom_put( "snowthic_cat"     , ht_s        )        ! snow depth for categories 
    244244      CALL iom_put( "salinity_cat"     , sm_i        )        ! salinity for categories 
     245 
     246      ! ice temperature 
     247      IF ( iom_use( "icetemp_cat" ) ) THEN  
     248         zt_i(:,:,:) = SUM( t_i(:,:,:,:), dim=3 ) * r1_nlay_i 
     249         CALL iom_put( "icetemp_cat"   , zt_i - rt0  ) 
     250      ENDIF 
     251       
     252      ! snow temperature 
     253      IF ( iom_use( "snwtemp_cat" ) ) THEN  
     254         zt_s(:,:,:) = SUM( t_s(:,:,:,:), dim=3 ) * r1_nlay_s 
     255         CALL iom_put( "snwtemp_cat"   , zt_s - rt0  ) 
     256      ENDIF 
    245257 
    246258      ! Compute ice age 
    … …  
    280292      !     not yet implemented 
    281293       
    282       CALL wrk_dealloc( jpi, jpj, jpl, zoi, zei ) 
     294      CALL wrk_dealloc( jpi, jpj, jpl, zoi, zei, zt_i, zt_s ) 
    283295      CALL wrk_dealloc( jpi, jpj     , z2d, zswi, z2da, z2db ) 
    284296 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r5500 r5630  
    8989   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   fhld_1d       !: <==> the 2D  fhld 
    9090   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dqns_ice_1d   !: <==> the 2D  dqns_ice 
    91    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qla_ice_1d    !: <==> the 2D  qla_ice 
    92    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dqla_ice_1d   !: <==> the 2D  dqla_ice 
    93    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tatm_ice_1d   !: <==> the 2D  tatm_ice 
     91   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
     92   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
    9493   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    9594   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    153152         &      fhld_1d    (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d(jpij) ,  & 
    154153         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    155          &      dqns_ice_1d(jpij) , qla_ice_1d (jpij) , dqla_ice_1d(jpij) ,                     & 
    156          &      tatm_ice_1d(jpij) , i0         (jpij) ,                                         &   
     154         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
     155         &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
    157156         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    158157         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r5500 r5630  
    11MODULE domrea 
    2    !!====================================================================== 
    3    !!                       ***  MODULE domrea  *** 
    4    !! Ocean initialization : read the ocean domain meshmask file(s) 
    5    !!====================================================================== 
    6    !! History :  3.3  ! 2010-05  (C. Ethe)  Full reorganization of the off-line 
     2   !!============================================================================== 
     3   !!                       ***  MODULE domrea   *** 
     4   !! Ocean initialization : domain initialization 
     5   !!============================================================================== 
     6 
    77   !!---------------------------------------------------------------------- 
    8  
     8   !!   dom_init       : initialize the space and time domain 
     9   !!   dom_nam        : read and contral domain namelists 
     10   !!   dom_ctl        : control print for the ocean domain 
    911   !!---------------------------------------------------------------------- 
    10    !!   dom_rea        : read mesh and mask file(s) 
    11    !!                    nmsh = 1  :   mesh_mask file 
    12    !!                         = 2  :   mesh and mask file 
    13    !!                         = 3  :   mesh_hgr, mesh_zgr and mask 
    14    !!---------------------------------------------------------------------- 
     12   !! * Modules used 
     13   USE oce             !  
    1514   USE dom_oce         ! ocean space and time domain 
    16    USE dommsk          ! domain: masks 
     15   USE phycst          ! physical constants 
     16   USE in_out_manager  ! I/O manager 
     17   USE lib_mpp         ! distributed memory computing library 
     18 
     19   USE domstp          ! domain: set the time-step 
     20 
    1721   USE lbclnk          ! lateral boundary condition - MPP exchanges 
    1822   USE trc_oce         ! shared ocean/biogeochemical variables 
    19    USE lib_mpp  
    20    USE in_out_manager 
    2123   USE wrk_nemo   
    22  
     24    
    2325   IMPLICIT NONE 
    2426   PRIVATE 
    2527 
    26    PUBLIC   dom_rea    ! routine called by inidom.F90 
    27   !! * Substitutions 
     28   !! * Routine accessibility 
     29   PUBLIC dom_rea       ! called by opa.F90 
     30 
     31   !! * Substitutions 
    2832#  include "domzgr_substitute.h90" 
     33#  include "vectopt_loop_substitute.h90" 
    2934   !!---------------------------------------------------------------------- 
    3035   !! NEMO/OFF 3.3 , NEMO Consortium (2010) 
    3136   !! $Id$ 
    32    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     37   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3338   !!---------------------------------------------------------------------- 
     39 
    3440CONTAINS 
    3541 
    … …  
    3743      !!---------------------------------------------------------------------- 
    3844      !!                  ***  ROUTINE dom_rea  *** 
     45      !!                     
     46      !! ** Purpose :   Domain initialization. Call the routines that are  
     47      !!      required to create the arrays which define the space and time 
     48      !!      domain of the ocean model. 
     49      !! 
     50      !! ** Method  : 
     51      !!      - dom_stp: defined the model time step 
     52      !!      - dom_rea: read the meshmask file if nmsh=1 
     53      !! 
     54      !! History : 
     55      !!        !  90-10  (C. Levy - G. Madec)  Original code 
     56      !!        !  91-11  (G. Madec) 
     57      !!        !  92-01  (M. Imbard) insert time step initialization 
     58      !!        !  96-06  (G. Madec) generalized vertical coordinate  
     59      !!        !  97-02  (G. Madec) creation of domwri.F 
     60      !!        !  01-05  (E.Durand - G. Madec) insert closed sea 
     61      !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
     62      !!---------------------------------------------------------------------- 
     63      !! * Local declarations 
     64      INTEGER ::   jk                ! dummy loop argument 
     65      INTEGER ::   iconf = 0         ! temporary integers 
     66      !!---------------------------------------------------------------------- 
     67 
     68      IF(lwp) THEN 
     69         WRITE(numout,*) 
     70         WRITE(numout,*) 'dom_init : domain initialization' 
     71         WRITE(numout,*) '~~~~~~~~' 
     72      ENDIF 
     73 
     74      CALL dom_nam      ! read namelist ( namrun, namdom, namcla ) 
     75      CALL dom_zgr      ! Vertical mesh and bathymetry option 
     76      CALL dom_grd      ! Create a domain file 
     77 
     78     ! 
     79      ! - ML - Used in dom_vvl_sf_nxt and lateral diffusion routines 
     80      !        but could be usefull in many other routines 
     81      e12t    (:,:) = e1t(:,:) * e2t(:,:) 
     82      e1e2t   (:,:) = e1t(:,:) * e2t(:,:) 
     83      e12u    (:,:) = e1u(:,:) * e2u(:,:) 
     84      e12v    (:,:) = e1v(:,:) * e2v(:,:) 
     85      e12f    (:,:) = e1f(:,:) * e2f(:,:) 
     86      r1_e12t (:,:) = 1._wp    / e12t(:,:) 
     87      r1_e12u (:,:) = 1._wp    / e12u(:,:) 
     88      r1_e12v (:,:) = 1._wp    / e12v(:,:) 
     89      r1_e12f (:,:) = 1._wp    / e12f(:,:) 
     90      re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 
     91      re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 
     92      ! 
     93      hu(:,:) = 0._wp                          ! Ocean depth at U- and V-points 
     94      hv(:,:) = 0._wp 
     95      DO jk = 1, jpk 
     96         hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
     97         hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
     98      END DO 
     99      !                                        ! Inverse of the local depth 
     100      hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask(:,:,1) ) * umask(:,:,1) 
     101      hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask(:,:,1) ) * vmask(:,:,1) 
     102 
     103      CALL dom_stp      ! Time step 
     104      CALL dom_msk      ! Masks 
     105      CALL dom_ctl      ! Domain control 
     106 
     107   END SUBROUTINE dom_rea 
     108 
     109   SUBROUTINE dom_nam 
     110      !!---------------------------------------------------------------------- 
     111      !!                     ***  ROUTINE dom_nam  *** 
     112      !!                     
     113      !! ** Purpose :   read domaine namelists and print the variables. 
     114      !! 
     115      !! ** input   : - namrun namelist 
     116      !!              - namdom namelist 
     117      !!              - namcla namelist 
     118      !!---------------------------------------------------------------------- 
     119      USE ioipsl 
     120      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     121      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
     122         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
     123         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
     124         &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
     125      NAMELIST/namdom/ nn_bathy , rn_bathy, rn_e3zps_min, rn_e3zps_rat, nn_msh    , rn_hmin,   & 
     126         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,            & 
     127         &             rn_rdtmax, rn_rdth     , nn_baro     , nn_closea , ln_crs, & 
     128         &             jphgr_msh, & 
     129         &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & 
     130         &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & 
     131         &             ppa2, ppkth2, ppacr2 
     132      NAMELIST/namcla/ nn_cla 
     133#if defined key_netcdf4 
     134      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
     135#endif 
     136      !!---------------------------------------------------------------------- 
     137 
     138      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
     139      READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 
     140901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist', lwp ) 
     141 
     142      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
     143      READ  ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 
     144902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist', lwp ) 
     145      IF(lwm) WRITE ( numond, namrun ) 
     146      ! 
     147      IF(lwp) THEN                  ! control print 
     148         WRITE(numout,*) 
     149         WRITE(numout,*) 'dom_nam  : domain initialization through namelist read' 
     150         WRITE(numout,*) '~~~~~~~ ' 
     151         WRITE(numout,*) '   Namelist namrun'   
     152         WRITE(numout,*) '      job number                      nn_no      = ', nn_no 
     153         WRITE(numout,*) '      experiment name for output      cn_exp     = ', cn_exp 
     154         WRITE(numout,*) '      restart logical                 ln_rstart  = ', ln_rstart 
     155         WRITE(numout,*) '      control of time step            nn_rstctl  = ', nn_rstctl 
     156         WRITE(numout,*) '      number of the first time step   nn_it000   = ', nn_it000 
     157         WRITE(numout,*) '      number of the last time step    nn_itend   = ', nn_itend 
     158         WRITE(numout,*) '      initial calendar date aammjj    nn_date0   = ', nn_date0 
     159         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy   = ', nn_leapy 
     160         WRITE(numout,*) '      initial state output            nn_istate  = ', nn_istate 
     161         WRITE(numout,*) '      frequency of restart file       nn_stock   = ', nn_stock 
     162         WRITE(numout,*) '      frequency of output file        nn_write   = ', nn_write 
     163         WRITE(numout,*) '      multi file dimgout              ln_dimgnnn = ', ln_dimgnnn 
     164         WRITE(numout,*) '      mask land points                ln_mskland = ', ln_mskland 
     165         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta  = ', ln_cfmeta 
     166         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber 
     167         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz 
     168      ENDIF 
     169      no = nn_no                    ! conversion DOCTOR names into model names (this should disappear soon) 
     170      cexper = cn_exp 
     171      nrstdt = nn_rstctl 
     172      nit000 = nn_it000 
     173      nitend = nn_itend 
     174      ndate0 = nn_date0 
     175      nleapy = nn_leapy 
     176      ninist = nn_istate 
     177      nstock = nn_stock 
     178      nstocklist = nn_stocklist 
     179      nwrite = nn_write 
     180 
     181 
     182      !                             ! control of output frequency 
     183      IF ( nstock == 0 .OR. nstock > nitend ) THEN 
     184         WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 
     185         CALL ctl_warn( ctmp1 ) 
     186         nstock = nitend 
     187      ENDIF 
     188      IF ( nwrite == 0 ) THEN 
     189         WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 
     190         CALL ctl_warn( ctmp1 ) 
     191         nwrite = nitend 
     192      ENDIF 
     193 
     194      ! parameters correspondting to nit000 - 1 (as we start the step loop with a call to day) 
     195      ndastp = ndate0 - 1        ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
     196      adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
     197 
     198#if defined key_agrif 
     199      IF( Agrif_Root() ) THEN 
     200#endif 
     201      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     202      CASE (  1 )  
     203         CALL ioconf_calendar('gregorian') 
     204         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "gregorian", i.e. leap year' 
     205      CASE (  0 ) 
     206         CALL ioconf_calendar('noleap') 
     207         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "noleap", i.e. no leap year' 
     208      CASE ( 30 ) 
     209         CALL ioconf_calendar('360d') 
     210         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "360d", i.e. 360 days in a year' 
     211      END SELECT 
     212#if defined key_agrif 
     213      ENDIF 
     214#endif 
     215 
     216      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 
     217      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
     218903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist', lwp ) 
     219 
     220      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 
     221      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 
     222904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 
     223      IF(lwm) WRITE ( numond, namdom ) 
     224 
     225      IF(lwp) THEN 
     226         WRITE(numout,*)  
     227         WRITE(numout,*) '   Namelist namdom : space & time domain' 
     228         WRITE(numout,*) '      flag read/compute bathymetry      nn_bathy     = ', nn_bathy 
     229         WRITE(numout,*) '      Depth (if =0 bathy=jpkm1)         rn_bathy     = ', rn_bathy 
     230         WRITE(numout,*) '      min depth of the ocean    (>0) or    rn_hmin   = ', rn_hmin 
     231         WRITE(numout,*) '      minimum thickness of partial      rn_e3zps_min = ', rn_e3zps_min, ' (m)' 
     232         WRITE(numout,*) '         step level                     rn_e3zps_rat = ', rn_e3zps_rat 
     233         WRITE(numout,*) '      create mesh/mask file(s)          nn_msh       = ', nn_msh 
     234         WRITE(numout,*) '           = 0   no file created                 ' 
     235         WRITE(numout,*) '           = 1   mesh_mask                       ' 
     236         WRITE(numout,*) '           = 2   mesh and mask                   ' 
     237         WRITE(numout,*) '           = 3   mesh_hgr, msh_zgr and mask      ' 
     238         WRITE(numout,*) '      ocean time step                      rn_rdt    = ', rn_rdt 
     239         WRITE(numout,*) '      asselin time filter parameter        rn_atfp   = ', rn_atfp 
     240         WRITE(numout,*) '      time-splitting: nb of sub time-step  nn_baro   = ', nn_baro 
     241         WRITE(numout,*) '      acceleration of converge             nn_acc    = ', nn_acc 
     242         WRITE(numout,*) '        nn_acc=1: surface tracer rdt       rn_rdtmin = ', rn_rdtmin 
     243         WRITE(numout,*) '                  bottom  tracer rdt       rdtmax    = ', rn_rdtmax 
     244         WRITE(numout,*) '                  depth of transition      rn_rdth   = ', rn_rdth 
     245         WRITE(numout,*) '      suppression of closed seas (=0)      nn_closea = ', nn_closea 
     246         WRITE(numout,*) '      type of horizontal mesh jphgr_msh           = ', jphgr_msh 
     247         WRITE(numout,*) '      longitude of first raw and column T-point ppglam0 = ', ppglam0 
     248         WRITE(numout,*) '      latitude  of first raw and column T-point ppgphi0 = ', ppgphi0 
     249         WRITE(numout,*) '      zonal      grid-spacing (degrees) ppe1_deg        = ', ppe1_deg 
     250         WRITE(numout,*) '      meridional grid-spacing (degrees) ppe2_deg        = ', ppe2_deg 
     251         WRITE(numout,*) '      zonal      grid-spacing (degrees) ppe1_m          = ', ppe1_m 
     252         WRITE(numout,*) '      meridional grid-spacing (degrees) ppe2_m          = ', ppe2_m 
     253         WRITE(numout,*) '      ORCA r4, r2 and r05 coefficients  ppsur           = ', ppsur 
     254         WRITE(numout,*) '                                        ppa0            = ', ppa0 
     255         WRITE(numout,*) '                                        ppa1            = ', ppa1 
     256         WRITE(numout,*) '                                        ppkth           = ', ppkth 
     257         WRITE(numout,*) '                                        ppacr           = ', ppacr 
     258         WRITE(numout,*) '      Minimum vertical spacing ppdzmin                  = ', ppdzmin 
     259         WRITE(numout,*) '      Maximum depth pphmax                              = ', pphmax 
     260         WRITE(numout,*) '      Use double tanf function for vertical coordinates ldbletanh = ', ldbletanh 
     261         WRITE(numout,*) '      Double tanh function parameters ppa2              = ', ppa2 
     262         WRITE(numout,*) '                                      ppkth2            = ', ppkth2 
     263         WRITE(numout,*) '                                      ppacr2            = ', ppacr2 
     264      ENDIF 
     265 
     266      ntopo     = nn_bathy          ! conversion DOCTOR names into model names (this should disappear soon) 
     267      e3zps_min = rn_e3zps_min 
     268      e3zps_rat = rn_e3zps_rat 
     269      nmsh      = nn_msh 
     270      nacc      = nn_acc 
     271      atfp      = rn_atfp 
     272      rdt       = rn_rdt 
     273      rdtmin    = rn_rdtmin 
     274      rdtmax    = rn_rdtmin 
     275      rdth      = rn_rdth 
     276 
     277      REWIND( numnam_ref )              ! Namelist namcla in reference namelist : Cross land advection 
     278      READ  ( numnam_ref, namcla, IOSTAT = ios, ERR = 905) 
     279905   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcla in reference namelist', lwp ) 
     280 
     281      REWIND( numnam_cfg )              ! Namelist namcla in configuration namelist : Cross land advection 
     282      READ  ( numnam_cfg, namcla, IOSTAT = ios, ERR = 906 ) 
     283906   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcla in configuration namelist', lwp ) 
     284      IF(lwm) WRITE( numond, namcla ) 
     285 
     286      IF(lwp) THEN 
     287         WRITE(numout,*) 
     288         WRITE(numout,*) '   Namelist namcla' 
     289         WRITE(numout,*) '      cross land advection                 nn_cla    = ', nn_cla 
     290      ENDIF 
     291 
     292#if defined key_netcdf4 
     293      !                             ! NetCDF 4 case   ("key_netcdf4" defined) 
     294      REWIND( numnam_ref )              ! Namelist namnc4 in reference namelist : NETCDF 
     295      READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 
     296907   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwp ) 
     297 
     298      REWIND( numnam_cfg )              ! Namelist namnc4 in configuration namelist : NETCDF 
     299      READ  ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 
     300908   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist', lwp ) 
     301      IF(lwm) WRITE( numond, namnc4 ) 
     302      IF(lwp) THEN                        ! control print 
     303         WRITE(numout,*) 
     304         WRITE(numout,*) '   Namelist namnc4 - Netcdf4 chunking parameters' 
     305         WRITE(numout,*) '      number of chunks in i-dimension      nn_nchunks_i   = ', nn_nchunks_i 
     306         WRITE(numout,*) '      number of chunks in j-dimension      nn_nchunks_j   = ', nn_nchunks_j 
     307         WRITE(numout,*) '      number of chunks in k-dimension      nn_nchunks_k   = ', nn_nchunks_k 
     308         WRITE(numout,*) '      apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip 
     309      ENDIF 
     310 
     311      ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module) 
     312      ! Note the chunk size in the unlimited (time) dimension will be fixed at 1 
     313      snc4set%ni   = nn_nchunks_i 
     314      snc4set%nj   = nn_nchunks_j 
     315      snc4set%nk   = nn_nchunks_k 
     316      snc4set%luse = ln_nc4zip 
     317#else 
     318      snc4set%luse = .FALSE.        ! No NetCDF 4 case 
     319#endif 
     320      ! 
     321   END SUBROUTINE dom_nam 
     322 
     323   SUBROUTINE dom_zgr 
     324      !!---------------------------------------------------------------------- 
     325      !!                ***  ROUTINE dom_zgr  *** 
     326      !!                    
     327      !! ** Purpose :  set the depth of model levels and the resulting  
     328      !!      vertical scale factors. 
     329      !! 
     330      !! ** Method  : - reference 1D vertical coordinate (gdep._1d, e3._1d) 
     331      !!              - read/set ocean depth and ocean levels (bathy, mbathy) 
     332      !!              - vertical coordinate (gdep., e3.) depending on the  
     333      !!                coordinate chosen : 
     334      !!                   ln_zco=T   z-coordinate   
     335      !!                   ln_zps=T   z-coordinate with partial steps 
     336      !!                   ln_zco=T   s-coordinate  
     337      !! 
     338      !! ** Action  :   define gdep., e3., mbathy and bathy 
     339      !!---------------------------------------------------------------------- 
     340      INTEGER ::   ioptio = 0   ! temporary integer 
     341      INTEGER ::   ios 
     342      !! 
     343      NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 
     344      !!---------------------------------------------------------------------- 
     345 
     346      REWIND( numnam_ref )              ! Namelist namzgr in reference namelist : Vertical coordinate 
     347      READ  ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901 ) 
     348901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist', lwp ) 
     349 
     350      REWIND( numnam_cfg )              ! Namelist namzgr in configuration namelist : Vertical coordinate 
     351      READ  ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 ) 
     352902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp ) 
     353      IF(lwm) WRITE ( numond, namzgr ) 
     354 
     355      IF(lwp) THEN                     ! Control print 
     356         WRITE(numout,*) 
     357         WRITE(numout,*) 'dom_zgr : vertical coordinate' 
     358         WRITE(numout,*) '~~~~~~~' 
     359         WRITE(numout,*) '          Namelist namzgr : set vertical coordinate' 
     360         WRITE(numout,*) '             z-coordinate - full steps      ln_zco    = ', ln_zco 
     361         WRITE(numout,*) '             z-coordinate - partial steps   ln_zps    = ', ln_zps 
     362         WRITE(numout,*) '             s- or hybrid z-s-coordinate    ln_sco    = ', ln_sco 
     363         WRITE(numout,*) '             ice shelf cavity               ln_isfcav = ', ln_isfcav 
     364      ENDIF 
     365 
     366      ioptio = 0                       ! Check Vertical coordinate options 
     367      IF( ln_zco ) ioptio = ioptio + 1 
     368      IF( ln_zps ) ioptio = ioptio + 1 
     369      IF( ln_sco ) ioptio = ioptio + 1 
     370      IF( ln_isfcav ) ioptio = 33 
     371      IF ( ioptio /= 1  )   CALL ctl_stop( ' none or several vertical coordinate options used' ) 
     372      IF ( ioptio == 33 )   CALL ctl_stop( ' isf cavity with off line module not yet done    ' ) 
     373 
     374   END SUBROUTINE dom_zgr 
     375 
     376   SUBROUTINE dom_ctl 
     377      !!---------------------------------------------------------------------- 
     378      !!                     ***  ROUTINE dom_ctl  *** 
     379      !! 
     380      !! ** Purpose :   Domain control. 
     381      !! 
     382      !! ** Method  :   compute and print extrema of masked scale factors 
     383      !! 
     384      !! History : 
     385      !!   8.5  !  02-08  (G. Madec)    Original code 
     386      !!---------------------------------------------------------------------- 
     387      !! * Local declarations 
     388      INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 
     389      INTEGER, DIMENSION(2) ::   iloc      !  
     390      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
     391      !!---------------------------------------------------------------------- 
     392 
     393      ! Extrema of the scale factors 
     394 
     395      IF(lwp)WRITE(numout,*) 
     396      IF(lwp)WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 
     397      IF(lwp)WRITE(numout,*) '~~~~~~~' 
     398 
     399      IF (lk_mpp) THEN 
     400         CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 
     401         CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 
     402         CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 
     403         CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 
     404      ELSE 
     405         ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     406         ze2min = MINVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     407         ze1max = MAXVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     408         ze2max = MAXVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     409 
     410         iloc  = MINLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     411         iimi1 = iloc(1) + nimpp - 1 
     412         ijmi1 = iloc(2) + njmpp - 1 
     413         iloc  = MINLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     414         iimi2 = iloc(1) + nimpp - 1 
     415         ijmi2 = iloc(2) + njmpp - 1 
     416         iloc  = MAXLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     417         iima1 = iloc(1) + nimpp - 1 
     418         ijma1 = iloc(2) + njmpp - 1 
     419         iloc  = MAXLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     420         iima2 = iloc(1) + nimpp - 1 
     421         ijma2 = iloc(2) + njmpp - 1 
     422      ENDIF 
     423 
     424      IF(lwp) THEN 
     425         WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1 
     426         WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 
     427         WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 
     428         WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 
     429      ENDIF 
     430 
     431   END SUBROUTINE dom_ctl 
     432 
     433   SUBROUTINE dom_grd 
     434      !!---------------------------------------------------------------------- 
     435      !!                  ***  ROUTINE dom_grd  *** 
    39436      !!                    
    40437      !! ** Purpose :  Read the NetCDF file(s) which contain(s) all the 
    … …  
    344741      CALL wrk_dealloc( jpi, jpj, zmbk, zprt, zprw ) 
    345742      ! 
    346    END SUBROUTINE dom_rea 
     743   END SUBROUTINE dom_grd 
    347744 
    348745 
    … …  
    388785   END SUBROUTINE zgr_bot_level 
    389786 
     787   SUBROUTINE dom_msk 
     788      !!--------------------------------------------------------------------- 
     789      !!                 ***  ROUTINE dom_msk  *** 
     790      !! 
     791      !! ** Purpose :   Off-line case: defines the interior domain T-mask. 
     792      !! 
     793      !! ** Method  :   The interior ocean/land mask is computed from tmask 
     794      !!              setting to zero the duplicated row and lines due to 
     795      !!              MPP exchange halos, est-west cyclic and north fold 
     796      !!              boundary conditions. 
     797      !! 
     798      !! ** Action :   tmask_i  : interiorland/ocean mask at t-point 
     799      !!               tpol     : ??? 
     800      !!---------------------------------------------------------------------- 
     801      ! 
     802      INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
     803      INTEGER  ::   iif, iil, ijf, ijl       ! local integers 
     804      INTEGER, POINTER, DIMENSION(:,:) ::  imsk  
     805      ! 
     806      !!--------------------------------------------------------------------- 
     807       
     808      CALL wrk_alloc( jpi, jpj, imsk ) 
     809      ! 
     810      ! Interior domain mask (used for global sum) 
     811      ! -------------------- 
     812      ssmask(:,:)  = tmask(:,:,1) 
     813      tmask_i(:,:) = tmask(:,:,1) 
     814      iif = jpreci                        ! thickness of exchange halos in i-axis 
     815      iil = nlci - jpreci + 1 
     816      ijf = jprecj                        ! thickness of exchange halos in j-axis 
     817      ijl = nlcj - jprecj + 1 
     818      ! 
     819      tmask_i( 1 :iif,   :   ) = 0._wp    ! first columns 
     820      tmask_i(iil:jpi,   :   ) = 0._wp    ! last  columns (including mpp extra columns) 
     821      tmask_i(   :   , 1 :ijf) = 0._wp    ! first rows 
     822      tmask_i(   :   ,ijl:jpj) = 0._wp    ! last  rows (including mpp extra rows) 
     823      ! 
     824      !                                   ! north fold mask 
     825      tpol(1:jpiglo) = 1._wp 
     826      !                                 
     827      IF( jperio == 3 .OR. jperio == 4 )   tpol(jpiglo/2+1:jpiglo) = 0._wp    ! T-point pivot 
     828      IF( jperio == 5 .OR. jperio == 6 )   tpol(     1    :jpiglo) = 0._wp    ! F-point pivot 
     829      IF( jperio == 3 .OR. jperio == 4 ) THEN      ! T-point pivot: only half of the nlcj-1 row 
     830         IF( mjg(ijl-1) == jpjglo-1 ) THEN 
     831            DO ji = iif+1, iil-1 
     832               tmask_i(ji,ijl-1) = tmask_i(ji,ijl-1) * tpol(mig(ji)) 
     833            END DO 
     834         ENDIF 
     835      ENDIF  
     836      ! 
     837      ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 
     838      ! least 1 wet u point 
     839      DO jj = 1, jpjm1 
     840         DO ji = 1, fs_jpim1   ! vector loop 
     841            umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
     842            vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
     843         END DO 
     844         DO ji = 1, jpim1      ! NO vector opt. 
     845            fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
     846               &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
     847         END DO 
     848      END DO 
     849      CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
     850      CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
     851      CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
     852 
     853      ! 3. Ocean/land mask at wu-, wv- and w points  
     854      !---------------------------------------------- 
     855      wmask (:,:,1) = tmask(:,:,1) ! ???????? 
     856      wumask(:,:,1) = umask(:,:,1) ! ???????? 
     857      wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
     858      DO jk=2,jpk 
     859         wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 
     860         wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1)    
     861         wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 
     862      END DO 
     863      ! 
     864      IF( nprint == 1 .AND. lwp ) THEN    ! Control print 
     865         imsk(:,:) = INT( tmask_i(:,:) ) 
     866         WRITE(numout,*) ' tmask_i : ' 
     867         CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 
     868         WRITE (numout,*) 
     869         WRITE (numout,*) ' dommsk: tmask for each level' 
     870         WRITE (numout,*) ' ----------------------------' 
     871         DO jk = 1, jpk 
     872            imsk(:,:) = INT( tmask(:,:,jk) ) 
     873            WRITE(numout,*) 
     874            WRITE(numout,*) ' level = ',jk 
     875            CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 
     876         END DO 
     877      ENDIF 
     878      ! 
     879      CALL wrk_dealloc( jpi, jpj, imsk ) 
     880      ! 
     881   END SUBROUTINE dom_msk 
     882 
    390883   !!====================================================================== 
    391884END MODULE domrea 
     885 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r5500 r5630  
    264264      fr_i(:,:)        = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1)    ! Sea-ice fraction 
    265265      qsr (:,:)        = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1)    ! solar radiation 
    266       IF ( ln_dynrnf ) & 
     266      IF( ln_dynrnf ) & 
    267267      rnf (:,:)        = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1)    ! river runoffs  
    268268 
    … …  
    388388 
    389389      ! 
    390       IF ( ln_dynrnf ) THEN 
     390      IF( ln_dynrnf ) THEN 
    391391                jf_rnf = jfld + 1  ;  jfld  = jf_rnf 
    392392         slf_d(jf_rnf) = sn_rnf 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r5500 r5630  
    1818   USE c1d             ! 1D configuration 
    1919   USE domcfg          ! domain configuration               (dom_cfg routine) 
    20    USE domain          ! domain initialization             (dom_init routine) 
    21    USE istate          ! initial state setting          (istate_init routine) 
     20   USE domain          ! domain initialization from coordinate & bathymetry (dom_init routine) 
     21   USE domrea          ! domain initialization from mesh_mask            (dom_init routine) 
    2222   USE eosbn2          ! equation of state            (eos bn2 routine) 
    2323   !              ! ocean physics 
    … …  
    3434   USE trcstp          ! passive tracer time-stepping      (trc_stp routine) 
    3535   USE dtadyn          ! Lecture and interpolation of the dynamical fields 
    36    USE stpctl          ! time stepping control            (stp_ctl routine) 
    3736   !              ! I/O & MPP 
    3837   USE iom             ! I/O library 
    … …  
    9594      istp = nit000 
    9695      !  
    97       CALL iom_init( "nemo" )            ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
     96      CALL iom_init( cxios_context )            ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    9897      !  
    9998      DO WHILE ( istp <= nitend .AND. nstop == 0 )    ! time stepping 
    … …  
    108107      END DO 
    109108#if defined key_iomput 
    110       CALL iom_context_finalize( "nemo" ) ! needed for XIOS+AGRIF 
     109      CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 
    111110#endif 
    112111 
    … …  
    143142      INTEGER ::   ilocal_comm   ! local integer 
    144143      INTEGER ::   ios 
     144      LOGICAL ::   llexist 
    145145      CHARACTER(len=80), DIMENSION(16) ::   cltxt 
    146146      !! 
    … …  
    152152      !!---------------------------------------------------------------------- 
    153153      cltxt = '' 
     154      cxios_context = 'nemo' 
    154155      ! 
    155156      !                             ! Open reference namelist and configuration namelist files 
    … …  
    181182      !                             !--------------------------------------------! 
    182183#if defined key_iomput 
    183       CALL  xios_initialize( "nemo",return_comm=ilocal_comm ) 
    184       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
     184      CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) 
     185      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
    185186#else 
    186187      ilocal_comm = 0 
    187       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
     188      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
    188189#endif 
    189190 
    … …  
    268269      IF( lk_c1d        )   CALL     c1d_init   ! 1D column configuration 
    269270                            CALL     dom_cfg    ! Domain configuration 
    270                             CALL     dom_init   ! Domain 
     271      ! 
     272      INQUIRE( FILE='coordinates.nc', EXIST = llexist )   ! Check if coordinate file exist 
     273      ! 
     274      IF( llexist )  THEN  ;  CALL  dom_init   !  compute the grid from coordinates and bathymetry 
     275      ELSE                 ;  CALL  dom_rea    !  read grid from the meskmask 
     276      ENDIF 
    271277                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
    272278 
    … …  
    275281      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
    276282 
    277       !                                     ! Ocean physics 
    278283                            CALL     sbc_init   ! Forcings : surface module 
     284 
    279285#if ! defined key_degrad 
    280286                            CALL ldf_tra_init   ! Lateral ocean tracer physics 
    … …  
    282288      IF( lk_ldfslp )       CALL ldf_slp_init   ! slope of lateral mixing 
    283289 
    284       !                                     ! Active tracers 
    285290                            CALL tra_qsr_init   ! penetrative solar radiation qsr 
    286291      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme 
    287292 
    288                             CALL trc_nam_run  ! Needed to get restart parameters for passive tracers 
    289       IF( ln_rsttr ) THEN 
    290         neuler = 1   ! Set time-step indicator at nit000 (leap-frog) 
    291         CALL trc_rst_cal( nit000, 'READ' )   ! calendar 
    292       ELSE 
    293         neuler = 0                  ! Set time-step indicator at nit000 (euler) 
    294         CALL day_init               ! set calendar 
    295       ENDIF 
    296       !                                     ! Dynamics 
     293                            CALL trc_nam_run    ! Needed to get restart parameters for passive tracers 
     294                            CALL trc_rst_cal( nit000, 'READ' )   ! calendar 
    297295                            CALL dta_dyn_init   ! Initialization for the dynamics 
    298296 
    299       !                                     ! Passive tracers 
    300297                            CALL     trc_init   ! Passive tracers initialization 
    301       ! 
    302       ! Initialise diaptr as some variables are used in if statements later (in 
    303       ! various advection and diffusion routines. 
    304                             CALL dia_ptr_init 
    305       ! 
    306       IF(lwp) WRITE(numout,cform_aaa)       ! Flag AAAAAAA 
     298                            CALL dia_ptr_init   ! Initialise diaptr as some variables are used  
     299      !                                         ! in various advection and diffusion routines 
     300      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA 
    307301      ! 
    308302      IF( nn_timing == 1 )  CALL timing_stop( 'nemo_init') 
    … …  
    659653   END SUBROUTINE nemo_northcomms 
    660654#endif 
     655 
     656   SUBROUTINE istate_init 
     657      !!---------------------------------------------------------------------- 
     658      !!                   ***  ROUTINE istate_init  *** 
     659      !! 
     660      !! ** Purpose :   Initialization to zero of the dynamics and tracers. 
     661      !!---------------------------------------------------------------------- 
     662      ! 
     663      !     now fields         !     after fields      ! 
     664      un   (:,:,:)   = 0._wp   ;   ua(:,:,:) = 0._wp   ! 
     665      vn   (:,:,:)   = 0._wp   ;   va(:,:,:) = 0._wp   ! 
     666      wn   (:,:,:)   = 0._wp   !                       ! 
     667      hdivn(:,:,:)   = 0._wp   !                       ! 
     668      tsn  (:,:,:,:) = 0._wp   !                       ! 
     669      ! 
     670      rhd  (:,:,:) = 0.e0 
     671      rhop (:,:,:) = 0.e0 
     672      rn2  (:,:,:) = 0.e0 
     673      ! 
     674   END SUBROUTINE istate_init 
     675 
     676   SUBROUTINE stp_ctl( kt, kindic ) 
     677      !!---------------------------------------------------------------------- 
     678      !!                    ***  ROUTINE stp_ctl  *** 
     679      !! 
     680      !! ** Purpose :   Control the run 
     681      !! 
     682      !! ** Method  : - Save the time step in numstp 
     683      !! 
     684      !! ** Actions :   'time.step' file containing the last ocean time-step 
     685      !!---------------------------------------------------------------------- 
     686      INTEGER, INTENT(in   ) ::   kt      ! ocean time-step index 
     687      INTEGER, INTENT(inout) ::   kindic  ! indicator of solver convergence 
     688      !!---------------------------------------------------------------------- 
     689      ! 
     690      IF( kt == nit000 .AND. lwp ) THEN 
     691         WRITE(numout,*) 
     692         WRITE(numout,*) 'stp_ctl : time-stepping control' 
     693         WRITE(numout,*) '~~~~~~~' 
     694         ! open time.step file 
     695         CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     696      ENDIF 
     697      ! 
     698      IF(lwp) WRITE ( numstp, '(1x, i8)' )   kt      !* save the current time step in numstp 
     699      IF(lwp) REWIND( numstp )                       ! -------------------------- 
     700      ! 
     701   END SUBROUTINE stp_ctl 
    661702   !!====================================================================== 
    662703END MODULE nemogcm 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OOO_SRC/nemogcm.F90

    r5500 r5630  
    133133      ! 
    134134      cltxt = '' 
     135      cxios_context = 'nemo' 
    135136      ! 
    136137      !                             ! Open reference namelist and configuration namelist files 
    … …  
    162163#if defined key_iomput 
    163164      IF( Agrif_Root() ) THEN 
    164          IF( lk_cpl ) THEN 
     165         IF( lk_oasis ) THEN 
    165166            CALL cpl_init( ilocal_comm )                               ! nemo local communicator given by oasis 
    166167            CALL xios_initialize( "oceanx",local_comm=ilocal_comm )    ! send nemo communicator to xios 
    167168         ELSE 
    168             CALL  xios_initialize( "nemo",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
     169            CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
    169170         ENDIF 
    170171      ENDIF 
    171172      ENDIF 
    172       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
     173      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
    173174#else 
    174       IF( lk_cpl ) THEN 
     175      IF( lk_oasis ) THEN 
    175176         IF( Agrif_Root() ) THEN 
    176177            CALL cpl_init( ilocal_comm )                               ! nemo local communicator given by oasis 
    177178         ENDIF 
    178          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt) 
     179         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt) 
    179180      ELSE 
    180181         ilocal_comm = 0 
    181          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
     182         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
    182183      ENDIF 
    183184#endif 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r5500 r5630  
    154154      IF( lrst_oce       )   CALL rst_write( kstp )        ! write output ocean restart file 
    155155      ! 
     156#if defined key_iomput 
     157      IF( kstp == nitend .OR. indic < 0 )   CALL xios_context_finalize()   ! needed for XIOS 
     158      ! 
     159#endif 
    156160   END SUBROUTINE stp_c1d 
    157161 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    r5500 r5630  
    176176 
    177177     !open output file 
    178      IF( lwp ) THEN 
     178     IF( lwm ) THEN 
    179179        CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    180180        CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    … …  
    283283           DO jsec=1,nb_sec 
    284284 
    285               IF( lwp )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
     285              IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
    286286             
    287287              !nullify transports values after writing 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90

    r5500 r5630  
    5151      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    5252      !! 
    53       INTEGER :: inum             ! temporary logical unit 
    54       INTEGER :: ji, jj, jk, jt   ! dummy loop indices 
    55       INTEGER :: ii0, ii1, ij0, ij1 
    56       REAL(wp) ::   zarea, zvol, zwei 
    57       REAL(wp) ::  ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 
    58       REAL(wp) ::  zt, zs, zu   
    59       REAL(wp) ::  zsm0, zfwfnew 
     53      INTEGER  :: inum             ! temporary logical unit 
     54      INTEGER  :: ji, jj, jk, jt   ! dummy loop indices 
     55      INTEGER  :: ii0, ii1, ij0, ij1 
     56      INTEGER  :: isrow         ! index for ORCA1 starting row 
     57      REAL(wp) :: zarea, zvol, zwei 
     58      REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 
     59      REAL(wp) :: zt, zs, zu   
     60      REAL(wp) :: zsm0, zfwfnew 
    6061      IF( cp_cfg == "orca" .AND. jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 
    6162      !!---------------------------------------------------------------------- 
    … …  
    165166         CASE ( 1 )                                  !  ORCA_R1 configurations 
    166167            !                                        ! ======================= 
    167             ii0 = 283   ;   ii1 = 283 
    168             ij0 = 200   ;   ij1 = 200 
     168            ! This dirty section will be suppressed by simplification process: 
     169            ! all this will come back in input files 
     170            ! Currently these hard-wired indices relate to configuration with 
     171            ! extend grid (jpjglo=332) 
     172            isrow = 332 - jpjglo 
     173            ! 
     174            ii0 = 283           ;   ii1 = 283 
     175            ij0 = 241 - isrow   ;   ij1 = 241 - isrow 
    169176            !                                        ! ======================= 
    170177         CASE DEFAULT                                !    ORCA R05 or R025 
    … …  
    212219         CASE ( 1 )                                  !  ORCA_R1 configurations 
    213220            !                                        ! ======================= 
    214             ii0 = 282   ;   ii1 = 282 
    215             ij0 = 200   ;   ij1 = 200 
     221            ! This dirty section will be suppressed by simplification process: 
     222            ! all this will come back in input files 
     223            ! Currently these hard-wired indices relate to configuration with 
     224            ! extend grid (jpjglo=332) 
     225            isrow = 332 - jpjglo 
     226            ii0 = 282           ;   ii1 = 282 
     227            ij0 = 240 - isrow   ;   ij1 = 240 - isrow 
    216228            !                                        ! ======================= 
    217229         CASE DEFAULT                                !    ORCA R05 or R025 
    … …  
    259271         CASE ( 1 )                                  !  ORCA_R1 configurations 
    260272            !                                        ! ======================= 
    261             ii0 = 331   ;   ii1 = 331 
    262             ij0 = 176   ;   ij1 = 176 
     273            ! This dirty section will be suppressed by simplification process: 
     274            ! all this will come back in input files 
     275            ! Currently these hard-wired indices relate to configuration with 
     276            ! extend grid (jpjglo=332) 
     277            isrow = 332 - jpjglo 
     278            ii0 = 331           ;   ii1 = 331 
     279            ij0 = 215 - isrow   ;   ij1 = 215 - isrow 
    263280            !                                        ! ======================= 
    264281         CASE DEFAULT                                !    ORCA R05 or R025 
    … …  
    306323         CASE ( 1 )                                  !  ORCA_R1 configurations 
    307324            !                                        ! ======================= 
    308             ii0 = 297   ;   ii1 = 297  
    309             ij0 = 230   ;   ij1 = 230 
     325            ! This dirty section will be suppressed by simplification process: 
     326            ! all this will come back in input files 
     327            ! Currently these hard-wired indices relate to configuration with 
     328            ! extend grid (jpjglo=332) 
     329            isrow = 332 - jpjglo 
     330            ii0 = 297           ;   ii1 = 297 
     331            ij0 = 269 - isrow   ;   ij1 = 269 - isrow 
    310332            !                                        ! ======================= 
    311333         CASE DEFAULT                                !    ORCA R05 or R025 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90

    r5500 r5630  
    245245      CALL iom_put( "mldr10_3", zrho10_3     )   ! MLD delta rho(10m) = 0.03 
    246246      CALL iom_put( "pycndep" , zpycn        )   ! MLD delta rho equi. delta T(10m) = 0.2 
    247       CALL iom_put( "BLT"     , ztm2 - zpycn )   ! Barrier Layer Thickness 
    248247      CALL iom_put( "tinv"    , ztinv        )   ! max. temp. inv. (t10 ref)  
    249248      CALL iom_put( "depti"   , zdepinv      )   ! depth of max. temp. inv. (t10 ref)  

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r5500 r5630  
    4646   USE iom 
    4747   USE ioipsl 
     48   USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities      
     49 
    4850#if defined key_lim2 
    4951   USE limwri_2  
    … …  
    125127      !! 
    126128      INTEGER                      ::   ji, jj, jk              ! dummy loop indices 
     129      INTEGER                      ::   jkbot                   ! 
    127130      REAL(wp)                     ::   zztmp, zztmpx, zztmpy   !  
    128131      !! 
    … …  
    148151         CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
    149152      ENDIF 
     153 
     154      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
     155      if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    150156       
    151157      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    154160         DO jj = 1, jpj 
    155161            DO ji = 1, jpi 
    156                z2d(ji,jj) = tsn(ji,jj,MAX(mbathy(ji,jj),1),jp_tem) 
     162               jkbot = mbkt(ji,jj) 
     163               z2d(ji,jj) = tsn(ji,jj,jkbot,jp_tem) 
    157164            END DO 
    158165         END DO 
    … …  
    165172         DO jj = 1, jpj 
    166173            DO ji = 1, jpi 
    167                z2d(ji,jj) = tsn(ji,jj,MAX(mbathy(ji,jj),1),jp_sal) 
     174               jkbot = mbkt(ji,jj) 
     175               z2d(ji,jj) = tsn(ji,jj,jkbot,jp_sal) 
    168176            END DO 
    169177         END DO 
    170178         CALL iom_put( "sbs", z2d )                ! bottom salinity 
     179      ENDIF 
     180 
     181      IF ( iom_use("taubot") ) THEN                ! bottom stress 
     182         z2d(:,:) = 0._wp 
     183         DO jj = 2, jpjm1 
     184            DO ji = fs_2, fs_jpim1   ! vector opt. 
     185               zztmpx = (  bfrua(ji  ,jj) * un(ji  ,jj,mbku(ji  ,jj))  & 
     186                      &  + bfrua(ji-1,jj) * un(ji-1,jj,mbku(ji-1,jj))  )       
     187               zztmpy = (  bfrva(ji,  jj) * vn(ji,jj  ,mbkv(ji,jj  ))  & 
     188                      &  + bfrva(ji,jj-1) * vn(ji,jj-1,mbkv(ji,jj-1))  )  
     189               z2d(ji,jj) = rau0 * SQRT( zztmpx * zztmpx + zztmpy * zztmpy ) * tmask(ji,jj,1)  
     190               ! 
     191            ENDDO 
     192         ENDDO 
     193         CALL lbc_lnk( z2d, 'T', 1. ) 
     194         CALL iom_put( "taubot", z2d )            
    171195      ENDIF 
    172196          
    … …  
    176200         DO jj = 1, jpj 
    177201            DO ji = 1, jpi 
    178                z2d(ji,jj) = un(ji,jj,MAX(mbathy(ji,jj),1)) 
     202               jkbot = mbku(ji,jj) 
     203               z2d(ji,jj) = un(ji,jj,jkbot) 
    179204            END DO 
    180205         END DO 
    181206         CALL iom_put( "sbu", z2d )                ! bottom i-current 
    182207      ENDIF 
     208#if defined key_dynspg_ts 
     209      CALL iom_put(  "ubar", un_adv(:,:)      )    ! barotropic i-current 
     210#else 
     211      CALL iom_put(  "ubar", un_b(:,:)        )    ! barotropic i-current 
     212#endif 
    183213       
    184214      CALL iom_put( "voce", vn(:,:,:)         )    ! 3D j-current 
    … …  
    187217         DO jj = 1, jpj 
    188218            DO ji = 1, jpi 
    189                z2d(ji,jj) = vn(ji,jj,MAX(mbathy(ji,jj),1)) 
     219               jkbot = mbkv(ji,jj) 
     220               z2d(ji,jj) = vn(ji,jj,jkbot) 
    190221            END DO 
    191222         END DO 
    192223         CALL iom_put( "sbv", z2d )                ! bottom j-current 
     224      ENDIF 
     225#if defined key_dynspg_ts 
     226      CALL iom_put(  "vbar", vn_adv(:,:)      )    ! barotropic j-current 
     227#else 
     228      CALL iom_put(  "vbar", vn_b(:,:)        )    ! barotropic j-current 
     229#endif 
     230 
     231      CALL iom_put( "woce", wn )                   ! vertical velocity 
     232      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
     233         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
     234         z2d(:,:) = rau0 * e12t(:,:) 
     235         DO jk = 1, jpk 
     236            z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
     237         END DO 
     238         CALL iom_put( "w_masstr" , z3d )   
     239         IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    193240      ENDIF 
    194241 
    … …  
    593640         ENDIF 
    594641 
    595          IF( .NOT. lk_cpl ) THEN 
     642         IF( .NOT. ln_cpl ) THEN 
    596643            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    597644               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    602649         ENDIF 
    603650 
    604          IF( lk_cpl .AND. nn_ice <= 1 ) THEN 
     651         IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    605652            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    606653               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    625672#endif 
    626673 
    627          IF( lk_cpl .AND. nn_ice == 2 ) THEN 
     674         IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    628675            CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature"            , "K"      ,   &  ! tn_ice 
    629676               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    780827      ENDIF 
    781828 
    782       IF( .NOT. lk_cpl ) THEN 
     829      IF( .NOT. ln_cpl ) THEN 
    783830         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    784831         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    … …  
    786833         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    787834      ENDIF 
    788       IF( lk_cpl .AND. nn_ice <= 1 ) THEN 
     835      IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    789836         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    790837         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    … …  
    802849#endif 
    803850 
    804       IF( lk_cpl .AND. nn_ice == 2 ) THEN 
     851      IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    805852         CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT )   ! surf. ice temperature 
    806853         CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT )   ! ice albedo 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r5500 r5630  
    7272      !!---------------------------------------------------------------------- 
    7373      INTEGER ::   jc            ! dummy loop indices 
     74      INTEGER :: isrow           ! local index 
    7475      !!---------------------------------------------------------------------- 
    7576       
    … …  
    9192         CASE ( 1 )                                  ! ORCA_R1 configuration 
    9293            !                                        ! ======================= 
     94            ! This dirty section will be suppressed by simplification process: 
     95            ! all this will come back in input files 
     96            ! Currently these hard-wired indices relate to configuration with 
     97            ! extend grid (jpjglo=332) 
     98            isrow = 332 - jpjglo 
     99            ! 
    93100            ncsnr(1)   = 1    ; ncstt(1)   = 0           ! Caspian Sea 
    94             ncsi1(1)   = 332  ; ncsj1(1)   = 203 
    95             ncsi2(1)   = 344  ; ncsj2(1)   = 235 
     101            ncsi1(1)   = 332  ; ncsj1(1)   = 243 - isrow 
     102            ncsi2(1)   = 344  ; ncsj2(1)   = 275 - isrow 
    96103            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
    97104            !                                         

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r5500 r5630  
    136136      USE ioipsl 
    137137      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
     138         &             ln_rstdate,                                                                 & 
    138139         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
    139140         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    140          &             nn_write, ln_dimgnnn, ln_mskland  , ln_clobber   , nn_chunksz, nn_euler ,   & 
    141          &             ln_rstdate 
     141         &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
    142142      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin,   & 
    143143         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,                  & 
    … …  
    191191         WRITE(numout,*) '      multi file dimgout              ln_dimgnnn = ', ln_dimgnnn 
    192192         WRITE(numout,*) '      mask land points                ln_mskland = ', ln_mskland 
     193         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta  = ', ln_cfmeta 
    193194         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber 
    194195         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r5500 r5630  
    105105      REAL(wp) ::   zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg 
    106106      REAL(wp) ::   zphi1, zsin_alpha, zim05, zjm05 
     107      INTEGER  ::   isrow                ! index for ORCA1 starting row 
     108 
    107109      !!---------------------------------------------------------------------- 
    108110      ! 
    … …  
    159161         IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN    ! ORCA R1 configuration 
    160162            !                                             ! ===================== 
    161  
    162             ii0 = 281   ;   ii1 = 282        ! Gibraltar Strait (e2u = 20 km) 
    163             ij0 = 200   ;   ij1 = 200   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
     163            ! This dirty section will be suppressed by simplification process: all this will come back in input files 
     164            ! Currently these hard-wired indices relate to configuration with 
     165            ! extend grid (jpjglo=332) 
     166            ! which had a grid-size of 362x292. 
     167            !  
     168            isrow = 332 - jpjglo 
     169            ! 
     170            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u = 20 km) 
     171            ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
    164172            IF(lwp) WRITE(numout,*) 
    165173            IF(lwp) WRITE(numout,*) '             orca_r1: Gibraltar : e2u reduced to 20 km' 
    166174 
    167             ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
    168             ij0 = 208   ;   ij1 = 208   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
     175            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
     176            ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
    169177            IF(lwp) WRITE(numout,*) 
    170178            IF(lwp) WRITE(numout,*) '             orca_r1: Bhosporus : e2u reduced to 10 km' 
    171179 
    172             ii0 =  44   ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
    173             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
     180            ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
     181            ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
    174182            IF(lwp) WRITE(numout,*) 
    175183            IF(lwp) WRITE(numout,*) '             orca_r1: Lombok : e1v reduced to 10 km' 
    176184 
    177             ii0 =  48   ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
    178             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
     185            ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
     186            ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
    179187            IF(lwp) WRITE(numout,*) 
    180188            IF(lwp) WRITE(numout,*) '             orca_r1: Sumba : e1v reduced to 8 km' 
    181189 
    182             ii0 =  53   ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
    183             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
     190            ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
     191            ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
    184192            IF(lwp) WRITE(numout,*) 
    185193            IF(lwp) WRITE(numout,*) '             orca_r1: Ombai : e1v reduced to 13 km' 
    186194 
    187             ii0 =  56   ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
    188             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
     195            ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
     196            ij0 = 124 + isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
    189197            IF(lwp) WRITE(numout,*) 
    190198            IF(lwp) WRITE(numout,*) '             orca_r1: Timor Passage : e1v reduced to 20 km' 
    191199 
    192             ii0 =  55   ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
    193             ij0 = 141   ;   ij1 = 142   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
     200            ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
     201            ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
    194202            IF(lwp) WRITE(numout,*) 
    195203            IF(lwp) WRITE(numout,*) '             orca_r1: W Halmahera : e1v reduced to 30 km' 
    196204 
    197             ii0 =  58   ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
    198             ij0 = 141   ;   ij1 = 142   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
     205            ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
     206            ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
    199207            IF(lwp) WRITE(numout,*) 
    200208            IF(lwp) WRITE(numout,*) '             orca_r1: E Halmahera : e1v reduced to 50 km' 
    201  
    202             ! 
    203  
    204             ! 
    205             ! 
    206209            ! 
    207210            ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r5500 r5630  
    134134      INTEGER  ::   ijf, ijl, ij0, ij1       !   -       - 
    135135      INTEGER  ::   ios 
     136      INTEGER  ::   isrow                    ! index for ORCA1 starting row 
    136137      INTEGER , POINTER, DIMENSION(:,:) ::  imsk 
    137138      REAL(wp), POINTER, DIMENSION(:,:) ::  zwf 
    … …  
    401402      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN   ! ORCA R1 configuration 
    402403         !                                                 ! Increased lateral friction near of some straits 
     404         ! This dirty section will be suppressed by simplification process: 
     405         ! all this will come back in input files 
     406         ! Currently these hard-wired indices relate to configuration with 
     407         ! extend grid (jpjglo=332) 
     408         ! 
     409         isrow = 332 - jpjglo 
     410         ! 
    403411         IF(lwp) WRITE(numout,*) 
    404412         IF(lwp) WRITE(numout,*) '   orca_r1: increase friction near the following straits : ' 
    405413         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    406          ii0 = 283   ;   ii1 = 284        ! Gibraltar Strait  
    407          ij0 = 200   ;   ij1 = 200   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     414         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait  
     415         ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    408416 
    409417         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    410          ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait  
    411          ij0 = 208   ;   ij1 = 208   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     418         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait  
     419         ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    412420 
    413421         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    414          ii0 =  48   ;   ii1 =  48        ! Makassar Strait (Top)  
    415          ij0 = 149   ;   ij1 = 150   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     422         ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top)  
     423         ij0 = 149 + isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    416424 
    417425         IF(lwp) WRITE(numout,*) '      Lombok ' 
    418          ii0 =  44   ;   ii1 =  44        ! Lombok Strait  
    419          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     426         ii0 =  44           ;   ii1 =  44        ! Lombok Strait  
     427         ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    420428 
    421429         IF(lwp) WRITE(numout,*) '      Ombai ' 
    422          ii0 =  53   ;   ii1 =  53        ! Ombai Strait  
    423          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     430         ii0 =  53           ;   ii1 =  53        ! Ombai Strait  
     431         ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    424432 
    425433         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    426          ii0 =  56   ;   ii1 =  56        ! Timor Passage  
    427          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     434         ii0 =  56           ;   ii1 =  56        ! Timor Passage  
     435         ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    428436 
    429437         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    430          ii0 =  58   ;   ii1 =  58        ! West Halmahera Strait  
    431          ij0 = 141   ;   ij1 = 142   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     438         ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait  
     439         ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    432440 
    433441         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    434          ii0 =  55   ;   ii1 =  55        ! East Halmahera Strait  
    435          ij0 = 141   ;   ij1 = 142   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     442         ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait  
     443         ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    436444         ! 
    437445      ENDIF 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r5500 r5630  
    10391039      INTEGER ::   ji, jj, jk                                          ! dummy loop indices 
    10401040      INTEGER ::   ij0, ij1, ii0, ii1                                  ! dummy loop indices 
     1041      INTEGER ::   isrow                                               ! index for ORCA1 starting row 
    10411042      !! acc 
    10421043      !! Hmm with the time splitting these "fixes" seem to do more harm than good. Temporarily disabled for 
    … …  
    11221123      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN    ! ORCA R1 configuration 
    11231124         !                                             ! ===================== 
    1124          ! 
    1125          ii0 = 281   ;   ii1 = 282        ! Gibraltar Strait (e2u was modified) 
    1126          ij0 = 200   ;   ij1 = 200 
     1125         ! This dirty section will be suppressed by simplification process: 
     1126         ! all this will come back in input files 
     1127         ! Currently these hard-wired indices relate to configuration with 
     1128         ! extend grid (jpjglo=332) 
     1129         ! which had a grid-size of 362x292. 
     1130         isrow = 332 - jpjglo 
     1131         ! 
     1132         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u was modified) 
     1133         ij0 = 241 - isrow   ;   ij1 = 241 - isrow 
    11271134         DO jk = 1, jpkm1 
    11281135            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    11441151         END DO 
    11451152         ! 
    1146          ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait (e2u was modified) 
    1147          ij0 = 208   ;   ij1 = 208 
     1153         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u was modified) 
     1154         ij0 = 248 - isrow   ;   ij1 = 248 - isrow 
    11481155         DO jk = 1, jpkm1 
    11491156            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    11651172         END DO 
    11661173         ! 
    1167          ii0 =  44   ;   ii1 =  44        ! Lombok Strait (e1v was modified) 
    1168          ij0 = 124   ;   ij1 = 125 
     1174         ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v was modified) 
     1175         ij0 = 164 - isrow   ;   ij1 = 165 - isrow 
    11691176         DO jk = 1, jpkm1 
    11701177            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    11811188         END DO 
    11821189         ! 
    1183          ii0 =  48   ;   ii1 =  48        ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 
    1184          ij0 = 124   ;   ij1 = 125 
     1190         ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 
     1191         ij0 = 164 - isrow   ;   ij1 = 165 - isrow 
    11851192         DO jk = 1, jpkm1 
    11861193            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    11971204         END DO 
    11981205         ! 
    1199          ii0 =  53   ;   ii1 =  53        ! Ombai Strait (e1v was modified) 
    1200          ij0 = 124   ;   ij1 = 125 
     1206         ii0 =  53          ;   ii1 =  53        ! Ombai Strait (e1v was modified) 
     1207         ij0 = 164 - isrow  ;   ij1 = 165  - isrow   
    12011208         DO jk = 1, jpkm1 
    12021209            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    12131220         END DO 
    12141221         ! 
    1215          ii0 =  56   ;   ii1 =  56        ! Timor Passage (e1v was modified) 
    1216          ij0 = 124   ;   ij1 = 125 
     1222         ii0 =  56            ;   ii1 =  56        ! Timor Passage (e1v was modified) 
     1223         ij0 = 164 - isrow    ;   ij1 = 165  - isrow   
    12171224         DO jk = 1, jpkm1 
    12181225            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    12291236         END DO 
    12301237         ! 
    1231          ii0 =  55   ;   ii1 =  55        ! West Halmahera Strait (e1v was modified) 
    1232          ij0 = 141   ;   ij1 = 142 
     1238         ii0 =  55            ;   ii1 =  55        ! West Halmahera Strait (e1v was modified) 
     1239         ij0 = 181 - isrow    ;   ij1 = 182 - isrow   
    12331240         DO jk = 1, jpkm1 
    12341241            DO jj = mj0(ij0), mj1(ij1) 
    … …  
    12451252         END DO 
    12461253         ! 
    1247          ii0 =  58   ;   ii1 =  58        ! East Halmahera Strait (e1v was modified) 
    1248          ij0 = 141   ;   ij1 = 142 
     1254         ii0 =  58            ;   ii1 =  58        ! East Halmahera Strait (e1v was modified) 
     1255         ij0 = 181 - isrow    ;   ij1 = 182 - isrow   
    12491256         DO jk = 1, jpkm1 
    12501257            DO jj = mj0(ij0), mj1(ij1) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r5500 r5630  
    9898      ! 
    9999      CALL wrk_alloc( jpi  , jpj+2, zwu               ) 
    100       CALL wrk_alloc( jpi+4, jpj  , zwv, kjstart = -1 ) 
     100      CALL wrk_alloc( jpi+4, jpj  , zwv, kistart = -1 ) 
    101101      ! 
    102102      IF( kt == nit000 ) THEN 
    … …  
    237237      ! 
    238238      CALL wrk_dealloc( jpi  , jpj+2, zwu               ) 
    239       CALL wrk_dealloc( jpi+4, jpj  , zwv, kjstart = -1 ) 
     239      CALL wrk_dealloc( jpi+4, jpj  , zwv, kistart = -1 ) 
    240240      ! 
    241241      IF( nn_timing == 1 )  CALL timing_stop('div_cur') 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r5500 r5630  
    266266               ! Add volume filter correction: compatibility with tracer advection scheme 
    267267               ! => time filter + conservation correction (only at the first level) 
    268                fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
    269             ! 
     268               fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
     269                              &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
    270270            ENDIF 
    271271            ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r5500 r5630  
    462462      !                                         ! Include the IAU weighted SSH increment 
    463463      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
    464          zssh_frc(:,:) = zssh_frc(:,:) + ssh_iau(:,:) 
     464         zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 
    465465      ENDIF 
    466466#endif 
    … …  
    557557               END DO 
    558558            END DO 
    559             CALL lbc_lnk( zwx, 'U', 1._wp )    ;   CALL lbc_lnk( zwy, 'V', 1._wp ) 
     559            CALL lbc_lnk_multi( zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 
    560560            ! 
    561561            zhup2_e (:,:) = hu_0(:,:) + zwx(:,:)                ! Ocean depth at U- and V-points 
    … …  
    635635               END DO 
    636636            END DO 
    637             CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) 
     637            CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) 
    638638         ENDIF    
    639639         !                                  
    … …  
    803803         !                                                 !  ----------------------- 
    804804         ! 
    805          CALL lbc_lnk( ua_e  , 'U', -1._wp )               ! local domain boundaries  
    806          CALL lbc_lnk( va_e  , 'V', -1._wp ) 
     805         CALL lbc_lnk_multi( ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 
    807806 
    808807#if defined key_bdy   
    … …  
    859858            END DO 
    860859         END DO 
    861          CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) ! Boundary conditions 
     860         CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    862861      ENDIF 
    863862      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r5500 r5630  
    2121   USE domvvl          ! Variable volume 
    2222   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    23    USE iom             ! I/O library 
    2423   USE restart         ! only for lrst_oce 
    2524   USE in_out_manager  ! I/O manager 
    … …  
    3130   USE bdy_par          
    3231   USE bdydyn2d        ! bdy_ssh routine 
    33    USE iom 
    3432#if defined key_agrif 
    3533   USE agrif_opa_update 
    … …  
    137135      !                                           !           outputs            ! 
    138136      !                                           !------------------------------! 
    139       CALL iom_put( "ssh" , sshn )   ! sea surface height 
    140       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    141137      ! 
    142138      IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask, ovlap=1 ) 
    … …  
    228224#endif 
    229225      ! 
    230       !                                           !------------------------------! 
    231       !                                           !           outputs            ! 
    232       !                                           !------------------------------! 
    233       CALL iom_put( "woce", wn )   ! vertical velocity 
    234       IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
    235          CALL wrk_alloc( jpi, jpj, z2d )  
    236          CALL wrk_alloc( jpi, jpj, jpk, z3d )  
    237          ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    238          z2d(:,:) = rau0 * e12t(:,:) 
    239          DO jk = 1, jpk 
    240             z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
    241          END DO 
    242          CALL iom_put( "w_masstr" , z3d )   
    243          IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    244          CALL wrk_dealloc( jpi, jpj, z2d  )  
    245          CALL wrk_dealloc( jpi, jpj, jpk, z3d )  
    246       ENDIF 
    247       ! 
    248226      IF( nn_timing == 1 )  CALL timing_stop('wzv') 
    249227 
    … …  
    290268      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    291269         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
    292          IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) ) * ssmask(:,:) 
     270         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 
    293271         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    294272      ENDIF 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90

    r5526 r5630  
    233233      INTEGER ::   jn   ! dummy loop index 
    234234      INTEGER ::   ix_dim, iy_dim, ik_dim, in_dim 
    235       INTEGER                :: iyear, imonth, iday   
     235      INTEGER                :: iyear, imonth, iday 
    236236      REAL (wp)              :: zsec 
    237237      CHARACTER(len=256)     :: cl_path 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r5500 r5630  
    4545                                                       !:                  (T): 1 file per proc 
    4646   LOGICAL       ::   ln_mskland       !: mask land points in NetCDF outputs (costly: + ~15%) 
    47    LOGICAL       ::   ln_rstdate    = .FALSE.     !: Use calendar date rather than time-step in restart names 
     47   LOGICAL       ::   ln_rstdate    = .FALSE.     !: Use calendar date rather than time-step in restart names  
     48   LOGICAL       ::   ln_cfmeta        !: output additional data to netCDF files required for compliance with the CF metadata standard 
    4849   LOGICAL       ::   ln_clobber       !: clobber (overwrite) an existing file 
    4950   INTEGER       ::   nn_chunksz       !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) 
    … …  
    9091   INTEGER ::   nitrst                !: time step at which restart file should be written 
    9192   LOGICAL ::   lrst_oce              !: logical to control the oce restart write  
    92    INTEGER ::   numror, numrow        !: logical unit for cean restart (read and write) 
     93   INTEGER ::   numror = 0            !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 
     94   INTEGER ::   numrow                !: logical unit for ocean restart (write) 
     95   INTEGER ::   nrst_lst              !: number of restart to output next 
    9396   INTEGER ::   nrst_lst              !: number of restart to output next 
    9497 
    … …  
    149152   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. ln_ctl 
    150153   LOGICAL       ::   lsp_area = .TRUE.     !: to make a control print over a specific area 
     154   CHARACTER(lc) ::   cxios_context         !: context name used in xios 
    151155 
    152156   !!---------------------------------------------------------------------- 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r5500 r5630  
    6161#if defined key_iomput 
    6262   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 
    63    PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
     63   PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
    6464# endif 
    6565 
    … …  
    9898      CHARACTER(len=10) :: clname 
    9999      INTEGER           ::   ji 
    100       !!---------------------------------------------------------------------- 
     100      ! 
     101      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
     102      !!---------------------------------------------------------------------- 
     103 
     104      ALLOCATE( z_bnds(jpk,2) ) 
    101105 
    102106      clname = cdname 
    103107      IF( TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) 
    104 # if defined key_mpp_mpi 
    105108      CALL xios_context_initialize(TRIM(clname), mpi_comm_opa) 
    106 # else 
    107       CALL xios_context_initialize(TRIM(clname), 0) 
    108 # endif 
    109109      CALL iom_swap( cdname ) 
    110110 
    … …  
    121121      CALL set_scalar 
    122122 
    123       IF( TRIM(cdname) == "nemo" ) THEN   
     123      IF( TRIM(cdname) == TRIM(cxios_context) ) THEN   
    124124         CALL set_grid( "T", glamt, gphit )  
    125125         CALL set_grid( "U", glamu, gphiu ) 
    126126         CALL set_grid( "V", glamv, gphiv ) 
    127127         CALL set_grid( "W", glamt, gphit ) 
    128       ENDIF 
    129  
    130       IF( TRIM(cdname) == "nemo_crs" ) THEN   
     128         CALL set_grid_znl( gphit ) 
     129         ! 
     130         IF( ln_cfmeta ) THEN   ! Add additional grid metadata 
     131            CALL iom_set_domain_attr("grid_T", area = e12t(nldi:nlei, nldj:nlej)) 
     132            CALL iom_set_domain_attr("grid_U", area = e12u(nldi:nlei, nldj:nlej)) 
     133            CALL iom_set_domain_attr("grid_V", area = e12v(nldi:nlei, nldj:nlej)) 
     134            CALL iom_set_domain_attr("grid_W", area = e12t(nldi:nlei, nldj:nlej)) 
     135            CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 
     136            CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 
     137            CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 
     138            CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 
     139         ENDIF 
     140      ENDIF 
     141 
     142      IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN   
    131143         CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    132144         ! 
    … …  
    135147         CALL set_grid( "V", glamv_crs, gphiv_crs )  
    136148         CALL set_grid( "W", glamt_crs, gphit_crs )  
     149         CALL set_grid_znl( gphit_crs ) 
    137150          ! 
    138151         CALL dom_grid_glo   ! Return to parent grid domain 
    139       ENDIF 
    140  
     152         ! 
     153         IF( ln_cfmeta ) THEN   ! Add additional grid metadata 
     154            CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
     155            CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) 
     156            CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) 
     157            CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
     158            CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 
     159            CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) 
     160            CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) 
     161            CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 
     162         ENDIF 
     163      ENDIF 
    141164 
    142165      ! vertical grid definition 
    … …  
    145168      CALL iom_set_axis_attr( "depthv", gdept_1d ) 
    146169      CALL iom_set_axis_attr( "depthw", gdepw_1d ) 
     170 
     171      ! Add vertical grid bounds 
     172      z_bnds(:      ,1) = gdepw_1d(:) 
     173      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
     174      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     175      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
     176      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
     177      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
     178      z_bnds(:    ,2) = gdept_1d(:) 
     179      z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
     180      z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     181      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     182 
    147183# if defined key_floats 
    148184      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 
    … …  
    152188#endif 
    153189      CALL iom_set_axis_attr( "icbcla", class_num ) 
     190      CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 
     191      CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 
    154192       
    155193      ! automatic definitions of some of the xml attributs 
    … …  
    162200       
    163201      CALL xios_update_calendar(0) 
     202 
     203      DEALLOCATE( z_bnds ) 
     204 
    164205#endif 
    165206       
    … …  
    11071148 
    11081149   SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj,   & 
    1109       &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 
    1110       CHARACTER(LEN=*)                 , INTENT(in) ::   cdid 
    1111       INTEGER                , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj 
    1112       INTEGER                , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
    1113       INTEGER                , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj 
    1114       REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    1115       LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) ::   mask 
     1150      &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask,     & 
     1151      &                                    nvertex, bounds_lon, bounds_lat, area ) 
     1152      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1153      INTEGER                  , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj 
     1154      INTEGER                  , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
     1155      INTEGER                  , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 
     1156      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
     1157      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
     1158      LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    11161159 
    11171160      IF ( xios_is_valid_domain     (cdid) ) THEN 
    … …  
    11191162            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    11201163            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1121             &    lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 
     1164            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
     1165            &    bounds_lat=bounds_lat, area=area ) 
    11221166      ENDIF 
    11231167 
    … …  
    11261170            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    11271171            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1128             &    lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 
     1172            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
     1173            &    bounds_lat=bounds_lat, area=area ) 
    11291174      ENDIF 
    11301175      CALL xios_solve_inheritance() 
    … …  
    11331178 
    11341179 
    1135    SUBROUTINE iom_set_axis_attr( cdid, paxis ) 
     1180   SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 
    11361181      CHARACTER(LEN=*)      , INTENT(in) ::   cdid 
    1137       REAL(wp), DIMENSION(:), INTENT(in) ::   paxis 
    1138       IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=size(paxis),value=paxis ) 
    1139       IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis ) 
     1182      REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   paxis 
     1183      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
     1184      IF ( PRESENT(paxis) ) THEN 
     1185         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
     1186         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1187      ENDIF 
     1188      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
     1189      IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 
    11401190      CALL xios_solve_inheritance() 
    11411191   END SUBROUTINE iom_set_axis_attr 
    … …  
    12001250      CALL iom_swap( cdname )   ! swap to cdname context 
    12011251      CALL xios_update_calendar(kt) 
    1202       IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1252      IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    12031253      ! 
    12041254   END SUBROUTINE iom_setkt 
    … …  
    12101260         CALL iom_swap( cdname )   ! swap to cdname context 
    12111261         CALL xios_context_finalize() ! finalize the context 
    1212          IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1262         IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    12131263      ENDIF 
    12141264      ! 
    … …  
    12531303 
    12541304 
     1305   SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) 
     1306      !!---------------------------------------------------------------------- 
     1307      !!                   ***  ROUTINE set_grid_bounds  *** 
     1308      !! 
     1309      !! ** Purpose :   define horizontal grid corners 
     1310      !! 
     1311      !!---------------------------------------------------------------------- 
     1312      CHARACTER(LEN=1) , INTENT(in) :: cdgrd 
     1313      ! 
     1314      REAL(wp), DIMENSION(jpi,jpj), INTENT(in)           :: plon_cnr, plat_cnr  ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 
     1315      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt  ! Lat/lon coordinates of the point of cell (i,j) 
     1316      ! 
     1317      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:)   :: z_bnds      ! Lat/lon coordinates of the vertices of cell (i,j) 
     1318      REAL(wp), ALLOCATABLE, DIMENSION(:,:)       :: z_fld       ! Working array to determine where to rotate cells 
     1319      REAL(wp), ALLOCATABLE, DIMENSION(:,:)       :: z_rot       ! Lat/lon working array for rotation of cells 
     1320      ! 
     1321      INTEGER :: icnr, jcnr                                      ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 
     1322      !                                                          ! represents the bottom-left corner of cell (i,j) 
     1323      INTEGER :: ji, jj, jn, ni, nj 
     1324 
     1325      ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2)  ) 
     1326 
     1327      ! Offset of coordinate representing bottom-left corner 
     1328      SELECT CASE ( TRIM(cdgrd) ) 
     1329         CASE ('T', 'W') 
     1330            icnr = -1 ; jcnr = -1 
     1331         CASE ('U') 
     1332            icnr =  0 ; jcnr = -1 
     1333         CASE ('V') 
     1334            icnr = -1 ; jcnr =  0 
     1335      END SELECT 
     1336 
     1337      ni = nlei-nldi+1 ; nj = nlej-nldj+1  ! Dimensions of subdomain interior 
     1338 
     1339      z_fld(:,:) = 1._wp 
     1340      CALL lbc_lnk( z_fld, cdgrd, -1. )    ! Working array for location of northfold 
     1341 
     1342      ! Cell vertices that can be defined 
     1343      DO jj = 2, jpjm1 
     1344         DO ji = 2, jpim1 
     1345            z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left 
     1346            z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right 
     1347            z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 
     1348            z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr+1) ! Top-left 
     1349            z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left 
     1350            z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right 
     1351            z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 
     1352            z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr+1) ! Top-left 
     1353         END DO 
     1354      END DO 
     1355 
     1356      ! Cell vertices on boundries 
     1357      DO jn = 1, 4 
     1358         CALL lbc_lnk( z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 
     1359         CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 
     1360      END DO 
     1361 
     1362      ! Zero-size cells at closed boundaries if cell points provided, 
     1363      ! otherwise they are closed cells with unrealistic bounds 
     1364      IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 
     1365         IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 
     1366            DO jn = 1, 4        ! (West or jpni = 1), closed E-W 
     1367               z_bnds(jn,1,:,1) = plat_pnt(1,:)  ;  z_bnds(jn,1,:,2) = plon_pnt(1,:) 
     1368            END DO 
     1369         ENDIF 
     1370         IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 
     1371            DO jn = 1, 4        ! (East or jpni = 1), closed E-W 
     1372               z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:)  ;  z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 
     1373            END DO 
     1374         ENDIF 
     1375         IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 
     1376            DO jn = 1, 4        ! South or (jpnj = 1, not symmetric) 
     1377               z_bnds(jn,:,1,1) = plat_pnt(:,1)  ;  z_bnds(jn,:,1,2) = plon_pnt(:,1) 
     1378            END DO 
     1379         ENDIF 
     1380         IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio  < 3 ) THEN 
     1381            DO jn = 1, 4        ! (North or jpnj = 1), no north fold 
     1382               z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj)  ;  z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 
     1383            END DO 
     1384         ENDIF 
     1385      ENDIF 
     1386 
     1387      ! Rotate cells at the north fold 
     1388      IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN 
     1389         DO jj = 1, jpj 
     1390            DO ji = 1, jpi 
     1391               IF( z_fld(ji,jj) == -1. ) THEN 
     1392                  z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 
     1393                  z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 
     1394                  z_bnds(:,ji,jj,:) = z_rot(:,:) 
     1395               ENDIF 
     1396            END DO 
     1397         END DO 
     1398 
     1399      ! Invert cells at the symmetric equator 
     1400      ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 
     1401         DO ji = 1, jpi 
     1402            z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 
     1403            z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 
     1404            z_bnds(:,ji,1,:) = z_rot(:,:) 
     1405         END DO 
     1406      ENDIF 
     1407 
     1408      CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)),           & 
     1409                                               bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 
     1410 
     1411      DEALLOCATE( z_bnds, z_fld, z_rot )  
     1412 
     1413   END SUBROUTINE set_grid_bounds 
     1414 
     1415 
     1416   SUBROUTINE set_grid_znl( plat ) 
     1417      !!---------------------------------------------------------------------- 
     1418      !!                     ***  ROUTINE set_grid_znl  *** 
     1419      !! 
     1420      !! ** Purpose :   define grids for zonal mean 
     1421      !! 
     1422      !!---------------------------------------------------------------------- 
     1423      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plat 
     1424      ! 
     1425      REAL(wp), DIMENSION(:), ALLOCATABLE  ::   zlon 
     1426      INTEGER  :: ni,nj, ix, iy 
     1427 
     1428       
     1429      ni=nlei-nldi+1 ; nj=nlej-nldj+1            ! define zonal mean domain (jpj*jpk) 
     1430      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
     1431 
     1432      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1433      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1434      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1435         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1436      ! 
     1437      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1438      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1439      CALL iom_update_file_name('ptr') 
     1440      ! 
     1441   END SUBROUTINE set_grid_znl 
     1442 
    12551443   SUBROUTINE set_scalar 
    12561444      !!---------------------------------------------------------------------- 
    … …  
    12601448      !! 
    12611449      !!---------------------------------------------------------------------- 
    1262       REAL(wp), DIMENSION(1) ::   zz = 1. 
     1450      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    12631451      !!---------------------------------------------------------------------- 
    12641452      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
    12651453      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
     1454       
    12661455      zz=REAL(narea,wp) 
    12671456      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    … …  
    13371526      CALL set_mooring( zlonpira, zlatpira ) 
    13381527 
    1339       ! diaptr : zonal mean  
    1340       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    1341       CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
    1342       CALL iom_update_file_name('ptr') 
    1343       ! 
    13441528       
    13451529   END SUBROUTINE set_xmlatt 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r5500 r5630  
    2525   USE trdmxl_oce      ! ocean active mixed layer tracers trends variables 
    2626   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    27    USE sbc_ice, ONLY : lk_lim3 
    2827 
    2928   IMPLICIT NONE 
    … …  
    8685         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN  
    8786            ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    88             IF ( ln_rstdate ) THEN  
    89                CALL ju2ymds( fjulday + rdttra(1) / rday, iyear, imonth, iday, zsec )             
    90                WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday  
    91             ELSE  
    92                IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst  
    93                ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst  
    94                ENDIF 
     87            IF ( ln_rstdate ) THEN   
     88               CALL ju2ymds( fjulday + rdttra(1) / rday, iyear, imonth, iday, zsec )              
     89               WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday   
     90            ELSE   
     91               IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst   
     92               ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst   
    9593            ENDIF 
    9694            ! create the file 
    … …  
    143141                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , sshb      ) 
    144142                     ! 
    145       IF( lk_lim3 )  CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    146                      ! 
    147143                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un        )     ! now fields 
    148144                     CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vn        ) 
    … …  
    156152                     CALL iom_rstput( kt, nitrst, numrow, 'rhd'    , rhd       ) 
    157153#endif 
    158                   IF( lk_lim3 ) THEN 
    159                      CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev'  , fraqsr_1lev     ) !clem modif 
    160                   ENDIF 
    161154      IF( kt == nitrst ) THEN 
    162155         CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    … …  
    244237         CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    245238         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
    246          IF( lk_lim3 )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    247239      ELSE 
    248240         neuler = 0 
    … …  
    287279         ENDIF 
    288280 
    289          IF( lk_lim3 .AND. .NOT. lk_vvl ) THEN 
    290             DO jk = 1, jpk 
    291                fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    292             END DO 
    293          ENDIF 
    294  
    295       ENDIF 
    296       ! 
    297       IF( lk_lim3 ) THEN 
    298          CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev ) 
    299281      ENDIF 
    300282      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r5500 r5630  
    2222   USE lib_mpp          ! distributed memory computing library 
    2323 
     24 
     25   INTERFACE lbc_lnk_multi 
     26      MODULE PROCEDURE mpp_lnk_2d_9 
     27   END INTERFACE 
     28 
    2429   INTERFACE lbc_lnk 
    2530      MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 
    … …  
    3944 
    4045   PUBLIC lbc_lnk       ! ocean lateral boundary conditions 
     46   PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 
    4147   PUBLIC lbc_lnk_e 
    4248   PUBLIC lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5500 r5630  
    7171   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7272   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
     73   PUBLIC   mpp_lnk_2d_9  
    7374   PUBLIC   mppscatter, mppgather 
    7475   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    7879   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7980 
     81   TYPE arrayptr 
     82      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     83   END TYPE arrayptr 
     84    
    8085   !! * Interfaces 
    8186   !! define generic interface for these routine as they are called sometimes 
    … …  
    164169 
    165170 
    166    FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     171   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
    167172      !!---------------------------------------------------------------------- 
    168173      !!                  ***  routine mynode  *** 
    … …  
    171176      !!---------------------------------------------------------------------- 
    172177      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
     178      CHARACTER(len=*)             , INTENT(in   ) ::   ldname 
    173179      INTEGER                      , INTENT(in   ) ::   kumnam_ref     ! logical unit for reference namelist 
    174180      INTEGER                      , INTENT(in   ) ::   kumnam_cfg     ! logical unit for configuration namelist 
    … …  
    297303 
    298304      IF( mynode == 0 ) THEN 
    299         CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    300         WRITE(kumond, nammpp)       
     305         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     306         WRITE(kumond, nammpp)       
    301307      ENDIF 
    302308      ! 
    … …  
    510516      ! 
    511517   END SUBROUTINE mpp_lnk_3d 
     518 
     519   SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 
     520      !!---------------------------------------------------------------------- 
     521      !!                  ***  routine mpp_lnk_2d_multiple  *** 
     522      !! 
     523      !! ** Purpose :   Message passing management for multiple 2d arrays 
     524      !! 
     525      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     526      !!      between processors following neighboring subdomains. 
     527      !!            domain parameters 
     528      !!                    nlci   : first dimension of the local subdomain 
     529      !!                    nlcj   : second dimension of the local subdomain 
     530      !!                    nbondi : mark for "east-west local boundary" 
     531      !!                    nbondj : mark for "north-south local boundary" 
     532      !!                    noea   : number for local neighboring processors 
     533      !!                    nowe   : number for local neighboring processors 
     534      !!                    noso   : number for local neighboring processors 
     535      !!                    nono   : number for local neighboring processors 
     536      !! 
     537      !!---------------------------------------------------------------------- 
     538 
     539      INTEGER :: num_fields 
     540      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     541      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     542      !                                                               ! = T , U , V , F , W and I points 
     543      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     544      !                                                               ! =  1. , the sign is kept 
     545      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
     546      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
     547      !! 
     548      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     549      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     550      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     551      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     552 
     553      REAL(wp) ::   zland 
     554      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     555      ! 
     556      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
     557      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
     558 
     559      !!---------------------------------------------------------------------- 
     560 
     561      ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  & 
     562         &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   ) 
     563 
     564      ! 
     565      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     566      ELSE                         ;   zland = 0.e0      ! zero by default 
     567      ENDIF 
     568 
     569      ! 1. standard boundary treatment 
     570      ! ------------------------------ 
     571      ! 
     572      !First Array 
     573      DO ii = 1 , num_fields 
     574         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     575            ! 
     576            ! WARNING pt2d is defined only between nld and nle 
     577            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     578               pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 
     579               pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej) 
     580               pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej)  
     581            END DO 
     582            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     583               pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 
     584               pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     ) 
     585               pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej) 
     586            END DO 
     587            ! 
     588         ELSE                              ! standard close or cyclic treatment 
     589            ! 
     590            !                                   ! East-West boundaries 
     591            IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
     592               &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     593               pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west 
     594               pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east 
     595            ELSE                                     ! closed 
     596               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
     597                                                   pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
     598            ENDIF 
     599            !                                   ! North-South boundaries (always closed) 
     600               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
     601                                                   pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
     602            ! 
     603         ENDIF 
     604      END DO 
     605 
     606      ! 2. East and west directions exchange 
     607      ! ------------------------------------ 
     608      ! we play with the neigbours AND the row number because of the periodicity 
     609      ! 
     610      DO ii = 1 , num_fields 
     611         SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     612         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     613            iihom = nlci-nreci 
     614            DO jl = 1, jpreci 
     615               zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 
     616               zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 
     617            END DO 
     618         END SELECT 
     619      END DO 
     620      ! 
     621      !                           ! Migrations 
     622      imigr = jpreci * jpj 
     623      ! 
     624      SELECT CASE ( nbondi ) 
     625      CASE ( -1 ) 
     626         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 
     627         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
     628         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     629      CASE ( 0 ) 
     630         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
     631         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 
     632         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
     633         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
     634         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     635         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     636      CASE ( 1 ) 
     637         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
     638         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
     639         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     640      END SELECT 
     641      ! 
     642      !                           ! Write Dirichlet lateral conditions 
     643      iihom = nlci - jpreci 
     644      ! 
     645 
     646      DO ii = 1 , num_fields 
     647         SELECT CASE ( nbondi ) 
     648         CASE ( -1 ) 
     649            DO jl = 1, jpreci 
     650               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
     651            END DO 
     652         CASE ( 0 ) 
     653            DO jl = 1, jpreci 
     654               pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 
     655               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
     656            END DO 
     657         CASE ( 1 ) 
     658            DO jl = 1, jpreci 
     659               pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 
     660            END DO 
     661         END SELECT 
     662      END DO 
     663       
     664      ! 3. North and south directions 
     665      ! ----------------------------- 
     666      ! always closed : we play only with the neigbours 
     667      ! 
     668      !First Array 
     669      DO ii = 1 , num_fields 
     670         IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     671            ijhom = nlcj-nrecj 
     672            DO jl = 1, jprecj 
     673               zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 
     674               zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 
     675            END DO 
     676         ENDIF 
     677      END DO 
     678      ! 
     679      !                           ! Migrations 
     680      imigr = jprecj * jpi 
     681      ! 
     682      SELECT CASE ( nbondj ) 
     683      CASE ( -1 ) 
     684         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 
     685         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
     686         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     687      CASE ( 0 ) 
     688         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
     689         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 
     690         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
     691         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
     692         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     693         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     694      CASE ( 1 ) 
     695         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
     696         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
     697         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     698      END SELECT 
     699      ! 
     700      !                           ! Write Dirichlet lateral conditions 
     701      ijhom = nlcj - jprecj 
     702      ! 
     703 
     704      DO ii = 1 , num_fields 
     705         !First Array 
     706         SELECT CASE ( nbondj ) 
     707         CASE ( -1 ) 
     708            DO jl = 1, jprecj 
     709               pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 
     710            END DO 
     711         CASE ( 0 ) 
     712            DO jl = 1, jprecj 
     713               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 
     714               pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 
     715            END DO 
     716         CASE ( 1 ) 
     717            DO jl = 1, jprecj 
     718               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 
     719            END DO 
     720         END SELECT 
     721      END DO 
     722       
     723      ! 4. north fold treatment 
     724      ! ----------------------- 
     725      ! 
     726      DO ii = 1 , num_fields 
     727         !First Array 
     728         IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     729            ! 
     730            SELECT CASE ( jpni ) 
     731            CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     732            CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
     733            END SELECT 
     734            ! 
     735         ENDIF 
     736         ! 
     737      END DO 
     738       
     739      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     740      ! 
     741   END SUBROUTINE mpp_lnk_2d_multiple 
     742 
     743    
     744   SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 
     745      !!--------------------------------------------------------------------- 
     746      REAL(wp), DIMENSION(jpi,jpj), TARGET   ,   INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied 
     747      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points 
     748      REAL(wp)                    , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary 
     749      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
     750      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
     751      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     752      INTEGER                      , INTENT (inout):: num_fields  
     753      !!--------------------------------------------------------------------- 
     754      num_fields=num_fields+1 
     755      pt2d_array(num_fields)%pt2d=>pt2d 
     756      type_array(num_fields)=cd_type 
     757      psgn_array(num_fields)=psgn 
     758   END SUBROUTINE load_array 
     759    
     760    
     761   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     762      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     763      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     764      !!--------------------------------------------------------------------- 
     765      ! Second 2D array on which the boundary condition is applied 
     766      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
     767      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     768      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
     769      ! define the nature of ptab array grid-points 
     770      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     771      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     772      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     773      ! =-1 the sign change across the north fold boundary 
     774      REAL(wp)                                      , INTENT(in   ) ::   psgnA     
     775      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     776      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
     777      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     778      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     779      !! 
     780      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
     781      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
     782      !                                                         ! = T , U , V , F , W and I points 
     783      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     784      INTEGER :: num_fields 
     785      !!--------------------------------------------------------------------- 
     786 
     787      num_fields = 0 
     788 
     789      !! Load the first array 
     790      CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 
     791 
     792      !! Look if more arrays are added 
     793      IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
     794      IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
     795      IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
     796      IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
     797      IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
     798      IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
     799      IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
     800      IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
     801       
     802      CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 
     803   END SUBROUTINE mpp_lnk_2d_9 
    512804 
    513805 
    … …  
    31843476   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    31853477   INTEGER :: ncomm_ice 
     3478   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator 
    31863479   !!---------------------------------------------------------------------- 
    31873480CONTAINS 
    … …  
    31923485   END FUNCTION lib_mpp_alloc 
    31933486 
    3194    FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
     3487   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    31953488      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    31963489      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
     3490      CHARACTER(len=*) ::   ldname 
    31973491      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    3198       IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0 
     3492      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 
     3493      function_value = 0 
    31993494      IF( .FALSE. )   ldtxt(:) = 'never done' 
    3200       CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     3495      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    32013496   END FUNCTION mynode 
    32023497 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90

    r5500 r5630  
    140140      !!---------------------------------------------------------------------- 
    141141      USE ldftra_oce, ONLY:   aht0 
     142      USE iom 
    142143      ! 
    143144      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
    … …  
    150151      CHARACTER (len=15) ::   clexp 
    151152      INTEGER,     POINTER, DIMENSION(:,:)  :: icof 
    152       INTEGER, ALLOCATABLE, DIMENSION(:,:)  :: idata 
     153      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d  ! temporary array to read ahmcoef file 
    153154      !!---------------------------------------------------------------------- 
    154155      !                                 
    … …  
    232233         ! Read 2d integer array to specify western boundary increase in the 
    233234         ! ===================== equatorial strip (20N-20S) defined at t-points 
    234           
    235          ALLOCATE( idata(jpidta,jpjdta), STAT=ierror ) 
    236          IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_c2d_orca: unable to allocate idata array' ) 
    237235         ! 
    238          CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    239          READ(inum,9101) clexp, iim, ijm 
    240          READ(inum,'(/)') 
    241          ifreq = 40 
    242          il1 = 1 
    243          DO jn = 1, jpidta/ifreq+1 
    244             READ(inum,'(/)') 
    245             il2 = MIN( jpidta, il1+ifreq-1 ) 
    246             READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    247             READ(inum,'(/)') 
    248             DO jj = jpjdta, 1, -1 
    249                READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    250             END DO 
    251             il1 = il1 + ifreq 
    252          END DO 
    253  
    254          DO jj = 1, nlcj 
    255             DO ji = 1, nlci 
    256                icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    257             END DO 
    258          END DO 
    259          DO jj = nlcj+1, jpj 
    260             DO ji = 1, nlci 
    261                icof(ji,jj) = icof(ji,nlcj) 
    262             END DO 
    263          END DO 
    264          DO jj = 1, jpj 
    265             DO ji = nlci+1, jpi 
    266                icof(ji,jj) = icof(nlci,jj) 
    267             END DO 
    268          END DO 
    269  
    270 9101     FORMAT(1x,a15,2i8) 
    271 9201     FORMAT(3x,13(i3,12x)) 
    272 9202     FORMAT(i3,41i3) 
    273           
    274          DEALLOCATE(idata) 
     236         ALLOCATE( ztemp2d(jpi,jpj) ) 
     237         ztemp2d(:,:) = 0. 
     238         CALL iom_open ( 'ahmcoef.nc', inum ) 
     239         CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     240         icof(:,:)  = NINT(ztemp2d(:,:)) 
     241         CALL iom_close( inum ) 
     242         DEALLOCATE(ztemp2d) 
    275243 
    276244         ! Set ahm1 and ahm2  ( T- and F- points) (used for laplacian operator) 
    … …  
    369337      !!---------------------------------------------------------------------- 
    370338      USE ldftra_oce, ONLY:   aht0 
     339      USE iom 
    371340      ! 
    372341      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
    … …  
    380349      CHARACTER (len=15) ::   clexp 
    381350      INTEGER,     POINTER, DIMENSION(:,:)  :: icof 
    382       INTEGER, ALLOCATABLE, DIMENSION(:,:)  :: idata 
     351      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d  ! temporary array to read ahmcoef file 
    383352      !!---------------------------------------------------------------------- 
    384353      !                                 
    385354      CALL wrk_alloc( jpi   , jpj   , icof  ) 
    386355      !                                 
    387  
    388356      IF(lwp) WRITE(numout,*) 
    389357      IF(lwp) WRITE(numout,*) 'inildf: 2d eddy viscosity coefficient' 
    … …  
    464432         ! Read 2d integer array to specify western boundary increase in the 
    465433         ! ===================== equatorial strip (20N-20S) defined at t-points 
    466           
    467          ALLOCATE( idata(jpidta,jpjdta), STAT=ierror ) 
    468          IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_c2d_orca_R1: unable to allocate idata array' ) 
    469          ! 
    470          CALL ctl_opn( inum, 'ahmcoef', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL',   & 
    471             &           1, numout, lwp ) 
    472          REWIND inum 
    473          READ(inum,9101) clexp, iim, ijm 
    474          READ(inum,'(/)') 
    475          ifreq = 40 
    476          il1 = 1 
    477          DO jn = 1, jpidta/ifreq+1 
    478             READ(inum,'(/)') 
    479             il2 = MIN( jpidta, il1+ifreq-1 ) 
    480             READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    481             READ(inum,'(/)') 
    482             DO jj = jpjdta, 1, -1 
    483                READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    484             END DO 
    485             il1 = il1 + ifreq 
    486          END DO 
    487  
    488          DO jj = 1, nlcj 
    489             DO ji = 1, nlci 
    490                icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    491             END DO 
    492          END DO 
    493          DO jj = nlcj+1, jpj 
    494             DO ji = 1, nlci 
    495                icof(ji,jj) = icof(ji,nlcj) 
    496             END DO 
    497          END DO 
    498          DO jj = 1, jpj 
    499             DO ji = nlci+1, jpi 
    500                icof(ji,jj) = icof(nlci,jj) 
    501             END DO 
    502          END DO 
    503  
    504 9101     FORMAT(1x,a15,2i8) 
    505 9201     FORMAT(3x,13(i3,12x)) 
    506 9202     FORMAT(i3,41i3) 
    507           
    508          DEALLOCATE(idata) 
     434         ALLOCATE( ztemp2d(jpi,jpj) ) 
     435         ztemp2d(:,:) = 0. 
     436         CALL iom_open ( 'ahmcoef.nc', inum ) 
     437         CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     438         icof(:,:)  = NINT(ztemp2d(:,:)) 
     439         CALL iom_close( inum ) 
     440         DEALLOCATE(ztemp2d) 
    509441 
    510442         ! Set ahm1 and ahm2  ( T- and F- points) (used for laplacian operator) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90

    r5500 r5630  
    2727      !!---------------------------------------------------------------------- 
    2828      USE ldftra_oce, ONLY :   aht0 
     29      USE iom 
    2930      !! 
    3031      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
    … …  
    193194      !!---------------------------------------------------------------------- 
    194195      USE ldftra_oce, ONLY:   aht0 
     196      USE iom 
    195197      !! 
    196198      LOGICAL, INTENT(in) ::   ld_print   ! If true, output arrays on numout 
    … …  
    204206      CHARACTER (len=15) ::   clexp 
    205207      INTEGER , POINTER, DIMENSION(:,:)  :: icof 
    206       INTEGER , POINTER, DIMENSION(:,:)  :: idata 
    207208      REAL(wp), POINTER, DIMENSION(:  )  :: zcoef    
    208209      REAL(wp), POINTER, DIMENSION(:,:)  :: zahm0 
     210      ! 
     211      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ztemp2d  ! temporary array to read ahmcoef file 
    209212      !!---------------------------------------------------------------------- 
    210213      ! 
    211214      CALL wrk_alloc( jpi   , jpj   , icof  ) 
    212       CALL wrk_alloc( jpidta, jpjdta, idata ) 
    213215      CALL wrk_alloc( jpk   ,         zcoef ) 
    214216      CALL wrk_alloc( jpi   , jpj   , zahm0 ) 
    … …  
    221223      ! Read 2d integer array to specify western boundary increase in the 
    222224      ! ===================== equatorial strip (20N-20S) defined at t-points 
    223  
    224       CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    225       READ(inum,9101) clexp, iim, ijm 
    226       READ(inum,'(/)') 
    227       ifreq = 40 
    228       il1 = 1 
    229       DO jn = 1, jpidta/ifreq+1 
    230          READ(inum,'(/)') 
    231          il2 = MIN( jpidta, il1+ifreq-1 ) 
    232          READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    233          READ(inum,'(/)') 
    234          DO jj = jpjdta, 1, -1 
    235             READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    236          END DO 
    237          il1 = il1 + ifreq 
    238       END DO 
    239        
    240       DO jj = 1, nlcj 
    241          DO ji = 1, nlci 
    242             icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    243          END DO 
    244       END DO 
    245       DO jj = nlcj+1, jpj 
    246          DO ji = 1, nlci 
    247             icof(ji,jj) = icof(ji,nlcj) 
    248          END DO 
    249       END DO 
    250       DO jj = 1, jpj 
    251          DO ji = nlci+1, jpi 
    252             icof(ji,jj) = icof(nlci,jj) 
    253          END DO 
    254       END DO 
    255        
    256 9101  FORMAT(1x,a15,2i8) 
    257 9201  FORMAT(3x,13(i3,12x)) 
    258 9202  FORMAT(i3,41i3) 
    259        
     225      ALLOCATE( ztemp2d(jpi,jpj) ) 
     226      ztemp2d(:,:) = 0. 
     227      CALL iom_open ( 'ahmcoef.nc', inum ) 
     228      CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     229      icof(:,:)  = NINT(ztemp2d(:,:)) 
     230      CALL iom_close( inum ) 
     231      DEALLOCATE(ztemp2d) 
     232 
    260233      ! Set ahm1 and ahm2 
    261234      ! ================= 
    … …  
    455428      ! 
    456429      CALL wrk_dealloc( jpi   , jpj   , icof  ) 
    457       CALL wrk_dealloc( jpidta, jpjdta, idata ) 
    458430      CALL wrk_dealloc( jpk   ,         zcoef ) 
    459431      CALL wrk_dealloc( jpi   , jpj   , zahm0 ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r5500 r5630  
    1515   !!---------------------------------------------------------------------- 
    1616   !!---------------------------------------------------------------------- 
    17    !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3 
     17   !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3-MCT 
     18   !!   'key_oa3mct_v3'                 to be added for OASIS3-MCT version 3 
    1819   !!---------------------------------------------------------------------- 
    1920   !!   cpl_init     : initialization of coupled mode communication 
    … …  
    6162#endif 
    6263 
    63    INTEGER, PUBLIC, PARAMETER ::   nmaxfld=40        ! Maximum number of coupling fields 
     64   INTEGER                    ::   nrcv         ! total number of fields received  
     65   INTEGER                    ::   nsnd         ! total number of fields sent  
     66   INTEGER                    ::   ncplmodel    ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
     67   INTEGER, PUBLIC, PARAMETER ::   nmaxfld=50   ! Maximum number of coupling fields 
    6468   INTEGER, PUBLIC, PARAMETER ::   nmaxcat=5    ! Maximum number of coupling fields 
    6569   INTEGER, PUBLIC, PARAMETER ::   nmaxcpl=5    ! Maximum number of coupling fields 
    … …  
    8690CONTAINS 
    8791 
    88    SUBROUTINE cpl_init( kl_comm ) 
     92   SUBROUTINE cpl_init( cd_modname, kl_comm ) 
    8993      !!------------------------------------------------------------------- 
    9094      !!             ***  ROUTINE cpl_init  *** 
    … …  
    9599      !! ** Method  :   OASIS3 MPI communication  
    96100      !!-------------------------------------------------------------------- 
    97       INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model 
     101      CHARACTER(len = *), INTENT(in) ::   cd_modname   ! model name as set in namcouple file 
     102      INTEGER          , INTENT(out) ::   kl_comm      ! local communicator of the model 
    98103      !!-------------------------------------------------------------------- 
    99104 
    … …  
    104109      ! 1st Initialize the OASIS system for the application 
    105110      !------------------------------------------------------------------ 
    106       CALL oasis_init_comp ( ncomp_id, 'oceanx', nerror ) 
     111      CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) 
    107112      IF ( nerror /= OASIS_Ok ) & 
    108113         CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') 
    … …  
    144149      IF(lwp) WRITE(numout,*) 
    145150 
     151      ncplmodel = kcplmodel 
    146152      IF( kcplmodel > nmaxcpl ) THEN 
    147          CALL oasis_abort ( ncomp_id, 'cpl_define', 'kcplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN 
     153         CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN 
    148154      ENDIF 
     155 
     156      nrcv = krcv 
     157      IF( nrcv > nmaxfld ) THEN 
     158         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld')   ;   RETURN 
     159      ENDIF 
     160 
     161      nsnd = ksnd 
     162      IF( nsnd > nmaxfld ) THEN 
     163         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld')   ;   RETURN 
     164      ENDIF 
     165 
    149166      ! 
    150167      ! ... Define the shape for the area that excludes the halo 
    … …  
    400417 
    401418 
    402    INTEGER FUNCTION cpl_freq( kid )   
     419   INTEGER FUNCTION cpl_freq( cdfieldname )   
    403420      !!--------------------------------------------------------------------- 
    404421      !!              ***  ROUTINE cpl_freq  *** 
    … …  
    406423      !! ** Purpose : - send back the coupling frequency for a particular field 
    407424      !!---------------------------------------------------------------------- 
    408       INTEGER,INTENT(in) ::   kid   ! variable index 
    409       !! 
     425      CHARACTER(len = *), INTENT(in) ::   cdfieldname    ! field name as set in namcouple file 
     426      !! 
     427      INTEGER               :: id 
    410428      INTEGER               :: info 
    411429      INTEGER, DIMENSION(1) :: itmp 
     430      INTEGER               :: ji,jm     ! local loop index 
     431      INTEGER               :: mop 
    412432      !!---------------------------------------------------------------------- 
    413       CALL oasis_get_freqs(kid, 1, itmp, info) 
    414       cpl_freq = itmp(1) 
     433      cpl_freq = 0   ! defaut definition 
     434      id = -1        ! defaut definition 
     435      ! 
     436      DO ji = 1, nsnd 
     437         IF (ssnd(ji)%laction ) THEN 
     438            DO jm = 1, ncplmodel 
     439               IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN 
     440                  IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN 
     441                     id = ssnd(ji)%nid(1,jm) 
     442                     mop = OASIS_Out 
     443                  ENDIF 
     444               ENDIF 
     445            ENDDO 
     446         ENDIF 
     447      ENDDO 
     448      DO ji = 1, nrcv 
     449         IF (srcv(ji)%laction ) THEN 
     450            DO jm = 1, ncplmodel 
     451               IF( srcv(ji)%nid(1,jm) /= -1 ) THEN 
     452                  IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN 
     453                     id = srcv(ji)%nid(1,jm) 
     454                     mop = OASIS_In 
     455                  ENDIF 
     456               ENDIF 
     457            ENDDO 
     458         ENDIF 
     459      ENDDO 
     460      ! 
     461      IF( id /= -1 ) THEN 
     462#if defined key_oa3mct_v3 
     463         CALL oasis_get_freqs(id, mop, 1, itmp, info) 
     464#else 
     465         CALL oasis_get_freqs(id,      1, itmp, info) 
     466#endif 
     467         cpl_freq = itmp(1) 
     468      ENDIF 
    415469      ! 
    416470   END FUNCTION cpl_freq 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r5500 r5630  
    154154      IF( PRESENT(kit) )   ll_firstcall = ll_firstcall .and. kit == 1 
    155155 
    156       it_offset = 0 
     156      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc 
     157      ELSE                                      ;   it_offset = 0 
     158      ENDIF 
    157159      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    158160 
    … …  
    452454      ENDIF 
    453455      ! 
    454       it_offset = 0 
     456      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc 
     457      ELSE                                      ;   it_offset = 0 
     458      ENDIF 
    455459      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    456460      IF( PRESENT(kit) ) THEN   ;   it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 
    … …  
    10211025      INTEGER                           ::   ipk           ! temporary vertical dimension 
    10221026      CHARACTER (len=5)                 ::   aname 
    1023       INTEGER , DIMENSION(3)            ::   ddims 
     1027      INTEGER , DIMENSION(:), ALLOCATABLE ::   ddims 
    10241028      INTEGER , POINTER, DIMENSION(:,:) ::   data_src 
    10251029      REAL(wp), POINTER, DIMENSION(:,:) ::   data_tmp 
    … …  
    10441048 
    10451049      !! get dimensions 
     1050      IF ( SIZE(sd%fnow, 3) > 1 ) THEN 
     1051         ALLOCATE( ddims(4) ) 
     1052      ELSE 
     1053         ALLOCATE( ddims(3) ) 
     1054      ENDIF 
    10461055      id = iom_varid( inum, sd%clvar, ddims ) 
    10471056 
    … …  
    11401149         CALL ctl_stop( '    fld_weight : unable to read the file ' ) 
    11411150      ENDIF 
     1151 
     1152      DEALLOCATE (ddims ) 
    11421153 
    11431154      CALL wrk_dealloc( jpi,jpj, data_src )   ! integer 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5500 r5630  
    5858   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qns_ice        !: non solar heat flux over ice                  [W/m2] 
    5959   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice        !: solar heat flux over ice                      [W/m2] 
    60    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice_mean   !: daily mean solar heat flux over ice           [W/m2] 
    6160   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qla_ice        !: latent flux over ice                          [W/m2] 
    6261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dqla_ice       !: latent sensibility over ice                 [W/m2/K] 
    … …  
    6968   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr1_i0         !: Solar surface transmission parameter, thick ice  [-] 
    7069   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr2_i0         !: Solar surface transmission parameter, thin ice   [-] 
    71    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice        !: sublimation - precip over sea ice            [kg/m2] 
     70   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice        !: sublimation - precip over sea ice          [kg/m2/s] 
    7271 
    7372   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   topmelt            !: category topmelt 
    7473   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   botmelt            !: category botmelt 
     74 
     75#if defined  key_lim3 
     76   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   evap_ice       !: sublimation                              [kg/m2/s] 
     77   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   devap_ice      !: sublimation sensitivity                [kg/m2/s/K] 
     78   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qns_oce        !: non solar heat flux over ocean              [W/m2] 
     79   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qsr_oce        !: non solar heat flux over ocean              [W/m2] 
     80   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
     81   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
     84#endif 
     85#if defined key_lim3 || defined key_lim2 
     86   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndm_ice       !: wind speed module at T-point                 [m/s] 
     87#endif 
    7588 
    7689#if defined key_cice 
    … …  
    100113#endif 
    101114 
    102 #if defined key_lim3 || defined key_cice 
    103    ! not used with LIM2 
     115#if defined key_cice 
    104116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tatm_ice       !: air temperature [K] 
    105117#endif 
    … …  
    125137      ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) ,     & 
    126138         &      qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) ,     & 
    127          &      dqns_ice(jpi,jpj,jpl) , tn_ice  (jpi,jpj,jpl) ,     & 
    128          &      alb_ice (jpi,jpj,jpl) ,                             & 
    129          &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     ,     & 
     139         &      dqns_ice(jpi,jpj,jpl) , tn_ice  (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) ,   & 
     140         &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     , wndm_ice(jpi,jpj)     ,   & 
    130141         &      fr1_i0  (jpi,jpj)     , fr2_i0  (jpi,jpj)     ,     & 
    131 #if defined key_lim3 
    132          &      tatm_ice(jpi,jpj)     ,                             & 
    133 #endif 
    134142#if defined key_lim2 
    135143         &      a_i(jpi,jpj,jpl)      ,                             & 
     144#endif 
     145#if defined key_lim3 
     146         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
     147         &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
     148         &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
    136149#endif 
    137150         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 
    … …  
    145158                a_i(jpi,jpj,ncat)     , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 
    146159                STAT= ierr(1) ) 
    147       IF( lk_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
     160      IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
    148161         &                     v_ice(jpi,jpj)        , fr2_i0(jpi,jpj)       , alb_ice(jpi,jpj,1)    , & 
    149162         &                     emp_ice(jpi,jpj)      , qns_ice(jpi,jpj,1)    , dqns_ice(jpi,jpj,1)   , & 
    … …  
    152165#endif 
    153166         ! 
    154 #if defined key_lim2 
    155       IF( ltrcdm2dc_ice )   ALLOCATE( qsr_ice_mean (jpi,jpj,jpl), STAT=ierr(3) ) 
    156 #endif 
    157          ! 
    158167#if defined key_cice || defined key_lim2 
    159       IF( lk_cpl )   ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 
     168      IF( ln_cpl )   ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 
    160169#endif 
    161170 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r5500 r5630  
    3636   LOGICAL , PUBLIC ::   ln_blk_mfs     !: MFS  bulk formulation 
    3737#if defined key_oasis3 
    38    LOGICAL , PUBLIC ::   lk_cpl = .TRUE.  !: coupled formulation 
     38   LOGICAL , PUBLIC ::   lk_oasis = .TRUE.  !: OASIS used 
    3939#else 
    40    LOGICAL , PUBLIC ::   lk_cpl = .FALSE. !: coupled formulation 
    41 #endif 
     40   LOGICAL , PUBLIC ::   lk_oasis = .FALSE. !: OASIS unused 
     41#endif 
     42   LOGICAL , PUBLIC ::   ln_cpl         !: ocean-atmosphere coupled formulation 
     43   LOGICAL , PUBLIC ::   ln_mixcpl      !: ocean-atmosphere forced-coupled mixed formulation 
    4244   LOGICAL , PUBLIC ::   ln_dm2dc       !: Daily mean to Diurnal Cycle short wave (qsr) 
    4345   LOGICAL , PUBLIC ::   ln_rnf         !: runoffs / runoff mouths 
    … …  
    5052   !                                             !: =1 levitating ice with mass and salt exchange but no presure effect 
    5153   !                                             !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 
    52    INTEGER , PUBLIC :: nn_limflx        !: LIM3 Multi-category heat flux formulation 
     54   INTEGER , PUBLIC ::   nn_components  !: flag for sbc module (including sea-ice) coupling mode (see component definition below)  
     55   INTEGER , PUBLIC ::   nn_limflx      !: LIM3 Multi-category heat flux formulation 
    5356   !                                             !: =-1  Use of per-category fluxes 
    5457   !                                             !: = 0  Average per-category fluxes 
    … …  
    6972   !!           switch definition (improve readability) 
    7073   !!---------------------------------------------------------------------- 
    71    INTEGER , PUBLIC, PARAMETER ::   jp_gyre    = 0        !: GYRE analytical formulation 
    72    INTEGER , PUBLIC, PARAMETER ::   jp_ana     = 1        !: analytical      formulation 
    73    INTEGER , PUBLIC, PARAMETER ::   jp_flx     = 2        !: flux            formulation 
    74    INTEGER , PUBLIC, PARAMETER ::   jp_clio    = 3        !: CLIO bulk       formulation 
    75    INTEGER , PUBLIC, PARAMETER ::   jp_core    = 4        !: CORE bulk       formulation 
    76    INTEGER , PUBLIC, PARAMETER ::   jp_cpl     = 5        !: Coupled         formulation 
    77    INTEGER , PUBLIC, PARAMETER ::   jp_mfs     = 6        !: MFS  bulk       formulation 
     74   INTEGER , PUBLIC, PARAMETER ::   jp_gyre    = 0        !: GYRE analytical               formulation 
     75   INTEGER , PUBLIC, PARAMETER ::   jp_ana     = 1        !: analytical                    formulation 
     76   INTEGER , PUBLIC, PARAMETER ::   jp_flx     = 2        !: flux                          formulation 
     77   INTEGER , PUBLIC, PARAMETER ::   jp_clio    = 3        !: CLIO bulk                     formulation 
     78   INTEGER , PUBLIC, PARAMETER ::   jp_core    = 4        !: CORE bulk                     formulation 
     79   INTEGER , PUBLIC, PARAMETER ::   jp_purecpl = 5        !: Pure ocean-atmosphere Coupled formulation 
     80   INTEGER , PUBLIC, PARAMETER ::   jp_mfs     = 6        !: MFS  bulk                     formulation 
     81   INTEGER , PUBLIC, PARAMETER ::   jp_none    = 7        !: for OPA when doing coupling via SAS module 
    7882   INTEGER , PUBLIC, PARAMETER ::   jp_esopa   = -1       !: esopa test, ALL formulations 
    7983    
    8084   !!---------------------------------------------------------------------- 
     85   !!           component definition 
     86   !!---------------------------------------------------------------------- 
     87   INTEGER , PUBLIC, PARAMETER ::   jp_iam_nemo = 0      !: Initial single executable configuration  
     88                                                         !  (no internal OASIS coupling) 
     89   INTEGER , PUBLIC, PARAMETER ::   jp_iam_opa  = 1      !: Multi executable configuration - OPA component 
     90                                                         !  (internal OASIS coupling) 
     91   INTEGER , PUBLIC, PARAMETER ::   jp_iam_sas  = 2      !: Multi executable configuration - SAS component 
     92                                                         !  (internal OASIS coupling) 
     93   !!---------------------------------------------------------------------- 
    8194   !!              Ocean Surface Boundary Condition fields 
    8295   !!---------------------------------------------------------------------- 
     96   INTEGER , PUBLIC ::  ncpl_qsr_freq            !: qsr coupling frequency per days from atmosphere 
     97   ! 
    8398   LOGICAL , PUBLIC ::   lhftau = .FALSE.        !: HF tau used in TKE: mean(stress module) - module(mean stress) 
    84    LOGICAL , PUBLIC ::   ltrcdm2dc               !: In case of Diurnal Cycle short wave, compute a Daily Mean short waves flux 
    8599   !!                                   !!   now    ! before   !! 
    86100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau   , utau_b   !: sea surface i-stress (ocean referential)     [N/m2] 
    … …  
    90104   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wndm              !: wind speed module at T-point (=|U10m-Uoce|)  [m/s] 
    91105   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr               !: sea heat flux:     solar                     [W/m2] 
    92    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_mean          !: daily mean sea heat flux: solar              [W/m2] 
    93106   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns    , qns_b    !: sea heat flux: non solar                     [W/m2] 
    94107   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_tot           !: total     solar heat flux (over sea and ice) [W/m2] 
    … …  
    111124   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2           !: atmospheric pCO2                             [ppm] 
    112125#endif 
     126   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask          !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 
    113127 
    114128   !!---------------------------------------------------------------------- 
    … …  
    122136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
    123137   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3t_m     !: mean (nn_fsbc time-step) sea surface layer thickness       [m] 
     138   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frq_m     !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] 
    124139 
    125140   !! * Substitutions 
    … …  
    155170         &      atm_co2(jpi,jpj) ,                                        & 
    156171#endif 
    157          &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) ,                       & 
    158          &      ssv_m  (jpi,jpj) , sss_m  (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) ) 
     172         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) ,      & 
     173         &      ssv_m  (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) 
    159174         ! 
    160175#if defined key_vvl 
    161176      ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 
    162177#endif 
    163          ! 
    164       IF( ltrcdm2dc ) ALLOCATE( qsr_mean(jpi,jpj) , STAT=ierr(5) ) 
    165178         ! 
    166179      sbc_oce_alloc = MAXVAL( ierr ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5500 r5630  
    3434   USE albedo 
    3535   USE prtctl          ! Print control 
    36 #if defined key_lim3 
     36#if defined key_lim3  
    3737   USE ice 
    3838   USE sbc_ice         ! Surface boundary condition: ice fields 
     39   USE limthd_dh       ! for CALL lim_thd_snwblow 
    3940#elif defined key_lim2 
    4041   USE ice_2 
     42   USE sbc_ice         ! Surface boundary condition: ice fields 
     43   USE par_ice_2       ! Surface boundary condition: ice fields 
    4144#endif 
    4245 
    … …  
    4548 
    4649   PUBLIC sbc_blk_clio        ! routine called by sbcmod.F90  
    47    PUBLIC blk_ice_clio        ! routine called by sbcice_lim.F90  
     50#if defined key_lim2 || defined key_lim3 
     51   PUBLIC blk_ice_clio_tau    ! routine called by sbcice_lim.F90  
     52   PUBLIC blk_ice_clio_flx    ! routine called by sbcice_lim.F90  
     53#endif 
    4854 
    4955   INTEGER , PARAMETER ::   jpfld   = 7           ! maximum number of files to read  
    … …  
    378384         &     + sf(jp_prec)%fnow(:,:,1) * sf(jp_tair)%fnow(:,:,1) * zcprec   ! add    precip. heat content at Tair in Celcius 
    379385      qns(:,:) = qns(:,:) * tmask(:,:,1) 
     386#if defined key_lim3 
     387      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) 
     388      qsr_oce(:,:) = qsr(:,:) 
     389#endif 
    380390      ! NB: if sea-ice model, the snow precip are computed and the associated heat is added to qns (see blk_ice_clio) 
    381391 
    382       CALL iom_put( "qlw_oce",   zqlw )   ! output downward longwave  heat over the ocean 
    383       CALL iom_put( "qsb_oce", - zqsb )   ! output downward sensible  heat over the ocean 
    384       CALL iom_put( "qla_oce", - zqla )   ! output downward latent    heat over the ocean 
    385       CALL iom_put( "qns_oce",   qns  )   ! output downward non solar heat over the ocean 
     392      IF ( nn_ice == 0 ) THEN 
     393         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave  heat over the ocean 
     394         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible  heat over the ocean 
     395         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent    heat over the ocean 
     396         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
     397         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean 
     398         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
     399         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     400      ENDIF 
    386401 
    387402      IF(ln_ctl) THEN 
    … …  
    399414   END SUBROUTINE blk_oce_clio 
    400415 
    401  
    402    SUBROUTINE blk_ice_clio(  pst   , palb_cs, palb_os, palb,  & 
    403       &                      p_taui, p_tauj, p_qns , p_qsr,   & 
    404       &                      p_qla , p_dqns, p_dqla,          & 
    405       &                      p_tpr , p_spr ,                  & 
    406       &                      p_fr1 , p_fr2 , cd_grid, pdim  ) 
     416# if defined key_lim2 || defined key_lim3 
     417   SUBROUTINE blk_ice_clio_tau 
    407418      !!--------------------------------------------------------------------------- 
    408       !!                     ***  ROUTINE blk_ice_clio  *** 
     419      !!                     ***  ROUTINE blk_ice_clio_tau  *** 
     420      !!                  
     421      !!  ** Purpose :   Computation momentum flux at the ice-atm interface   
     422      !!          
     423      !!  ** Method  :   Read utau from a forcing file. Rearrange if C-grid 
     424      !! 
     425      !!---------------------------------------------------------------------- 
     426      REAL(wp) ::   zcoef 
     427      INTEGER  ::   ji, jj   ! dummy loop indices 
     428      !!--------------------------------------------------------------------- 
     429      ! 
     430      IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio_tau') 
     431 
     432      SELECT CASE( cp_ice_msh ) 
     433 
     434      CASE( 'C' )                          ! C-grid ice dynamics 
     435 
     436         zcoef  = cai / cao                         ! Change from air-sea stress to air-ice stress 
     437         utau_ice(:,:) = zcoef * utau(:,:) 
     438         vtau_ice(:,:) = zcoef * vtau(:,:) 
     439 
     440      CASE( 'I' )                          ! I-grid ice dynamics:  I-point (i.e. F-point lower-left corner) 
     441 
     442         zcoef  = 0.5_wp * cai / cao                ! Change from air-sea stress to air-ice stress 
     443         DO jj = 2, jpj         ! stress from ocean U- and V-points to ice U,V point 
     444            DO ji = 2, jpi   ! I-grid : no vector opt. 
     445               utau_ice(ji,jj) = zcoef * ( utau(ji-1,jj  ) + utau(ji-1,jj-1) ) 
     446               vtau_ice(ji,jj) = zcoef * ( vtau(ji  ,jj-1) + vtau(ji-1,jj-1) ) 
     447            END DO 
     448         END DO 
     449 
     450         CALL lbc_lnk( utau_ice(:,:), 'I', -1. )   ;   CALL lbc_lnk( vtau_ice(:,:), 'I', -1. )   ! I-point 
     451 
     452      END SELECT 
     453 
     454      IF(ln_ctl) THEN 
     455         CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice_clio: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') 
     456      ENDIF 
     457 
     458      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio_tau') 
     459 
     460   END SUBROUTINE blk_ice_clio_tau 
     461#endif 
     462 
     463# if defined key_lim2 || defined key_lim3 
     464   SUBROUTINE blk_ice_clio_flx(  ptsu , palb_cs, palb_os, palb ) 
     465      !!--------------------------------------------------------------------------- 
     466      !!                     ***  ROUTINE blk_ice_clio_flx *** 
    409467      !!                  
    410468      !!  ** Purpose :   Computation of the heat fluxes at ocean and snow/ice 
    … …  
    428486      !!                         to take into account solid precip latent heat flux 
    429487      !!---------------------------------------------------------------------- 
    430       REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   pst      ! ice surface temperature                   [Kelvin] 
     488      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   ptsu      ! ice surface temperature                   [Kelvin] 
    431489      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   palb_cs  ! ice albedo (clear    sky) (alb_ice_cs)         [-] 
    432490      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   palb_os  ! ice albedo (overcast sky) (alb_ice_os)         [-] 
    433491      REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   palb     ! ice albedo (actual value)                      [-] 
    434       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_taui   ! surface ice stress at I-point (i-component) [N/m2] 
    435       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_tauj   ! surface ice stress at I-point (j-component) [N/m2] 
    436       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qns    ! non solar heat flux over ice (T-point)      [W/m2] 
    437       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qsr    !     solar heat flux over ice (T-point)      [W/m2] 
    438       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qla    ! latent    heat flux over ice (T-point)      [W/m2] 
    439       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_dqns   ! non solar heat sensistivity  (T-point)      [W/m2] 
    440       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_dqla   ! latent    heat sensistivity  (T-point)      [W/m2] 
    441       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_tpr    ! total precipitation          (T-point)   [Kg/m2/s] 
    442       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_spr    ! solid precipitation          (T-point)   [Kg/m2/s] 
    443       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_fr1    ! 1sr fraction of qsr penetration in ice         [-] 
    444       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_fr2    ! 2nd fraction of qsr penetration in ice         [-] 
    445       CHARACTER(len=1), INTENT(in   )             ::   cd_grid  ! type of sea-ice grid ("C" or "B" grid) 
    446       INTEGER, INTENT(in   )                      ::   pdim     ! number of ice categories 
    447492      !! 
    448493      INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    449       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    450       !! 
    451       REAL(wp) ::   zcoef, zmt1, zmt2, zmt3, ztatm3     ! temporary scalars 
     494      !! 
     495      REAL(wp) ::   zmt1, zmt2, zmt3, ztatm3                    ! temporary scalars 
    452496      REAL(wp) ::   ztaevbk, zind1, zind2, zind3, ztamr         !    -         - 
    453497      REAL(wp) ::   zesi, zqsati, zdesidt                       !    -         - 
    … …  
    455499      REAL(wp) ::   zcshi, zclei, zrhovaclei, zrhovacshi        !    -         - 
    456500      REAL(wp) ::   ztice3, zticemb, zticemb2, zdqlw, zdqsb     !    -         - 
     501      REAL(wp) ::   z1_lsub                                     !    -         - 
    457502      !! 
    458503      REAL(wp), DIMENSION(:,:)  , POINTER ::   ztatm   ! Tair in Kelvin 
    … …  
    461506      REAL(wp), DIMENSION(:,:)  , POINTER ::   zrhoa   ! air density 
    462507      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw, z_qsb 
     508      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw 
    463509      !!--------------------------------------------------------------------- 
    464510      ! 
    465       IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio') 
     511      IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio_flx') 
    466512      ! 
    467513      CALL wrk_alloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
    468       CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb ) 
    469  
    470       ijpl  = pdim                           ! number of ice categories 
     514      CALL wrk_alloc( jpi,jpj, jpl, z_qlw, z_qsb ) 
     515 
    471516      zpatm = 101000.                        ! atmospheric pressure  (assumed constant  here) 
    472  
    473 #if defined key_lim3       
    474       tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1)   ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init 
    475 #endif 
    476       !                                                        ! surface ocean fluxes computed with CLIO bulk formulea 
    477       !------------------------------------! 
    478       !   momentum fluxes  (utau, vtau )   ! 
    479       !------------------------------------! 
    480  
    481       SELECT CASE( cd_grid ) 
    482       CASE( 'C' )                          ! C-grid ice dynamics 
    483          zcoef  = cai / cao                         ! Change from air-sea stress to air-ice stress 
    484          p_taui(:,:) = zcoef * utau(:,:) 
    485          p_tauj(:,:) = zcoef * vtau(:,:) 
    486       CASE( 'I' )                          ! I-grid ice dynamics:  I-point (i.e. F-point lower-left corner) 
    487          zcoef  = 0.5_wp * cai / cao                ! Change from air-sea stress to air-ice stress 
    488          DO jj = 2, jpj         ! stress from ocean U- and V-points to ice U,V point 
    489             DO ji = 2, jpi   ! I-grid : no vector opt. 
    490                p_taui(ji,jj) = zcoef * ( utau(ji-1,jj  ) + utau(ji-1,jj-1) ) 
    491                p_tauj(ji,jj) = zcoef * ( vtau(ji  ,jj-1) + vtau(ji-1,jj-1) ) 
    492             END DO 
    493          END DO 
    494          CALL lbc_lnk( p_taui(:,:), 'I', -1. )   ;   CALL lbc_lnk( p_tauj(:,:), 'I', -1. )   ! I-point 
    495       END SELECT 
    496  
    497  
     517      !-------------------------------------------------------------------------------- 
    498518      !  Determine cloud optical depths as a function of latitude (Chou et al., 1981). 
    499519      !  and the correction factor for taking into account  the effect of clouds  
    500       !------------------------------------------------------ 
     520      !-------------------------------------------------------------------------------- 
     521 
    501522!CDIR NOVERRCHK 
    502523!CDIR COLLAPSE 
    … …  
    525546            zmt2  = ( 272.0 - ztatm(ji,jj) ) / 38.0   ;   zind2 = MAX( 0.e0, SIGN( 1.e0, zmt2 ) ) 
    526547            zmt3  = ( 281.0 - ztatm(ji,jj) ) / 18.0   ;   zind3 = MAX( 0.e0, SIGN( 1.e0, zmt3 ) ) 
    527             p_spr(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday   &      ! rday = converte mm/day to kg/m2/s 
     548            sprecip(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday   &      ! rday = converte mm/day to kg/m2/s 
    528549               &         * (          zind1      &                   ! solid  (snow) precipitation [kg/m2/s] 
    529550               &            + ( 1.0 - zind1 ) * (          zind2   * ( 0.5 + zmt2 )   & 
    … …  
    535556            ! fraction of qsr_ice which is NOT absorbed in the thin surface layer 
    536557            ! and thus which penetrates inside the ice cover ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 ) 
    537             p_fr1(ji,jj) = 0.18  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1)  
    538             p_fr2(ji,jj) = 0.82  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1) 
    539          END DO 
    540       END DO 
    541       CALL iom_put( 'snowpre', p_spr )   ! Snow precipitation  
     558            fr1_i0(ji,jj) = 0.18  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1)  
     559            fr2_i0(ji,jj) = 0.82  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1) 
     560         END DO 
     561      END DO 
     562      CALL iom_put( 'snowpre', sprecip )   ! Snow precipitation  
    542563       
    543564      !-----------------------------------------------------------! 
    544565      !  snow/ice Shortwave radiation   (abedo already computed)  ! 
    545566      !-----------------------------------------------------------! 
    546       CALL blk_clio_qsr_ice( palb_cs, palb_os, p_qsr ) 
    547        
    548       DO jl = 1, ijpl 
     567      CALL blk_clio_qsr_ice( palb_cs, palb_os, qsr_ice ) 
     568       
     569      DO jl = 1, jpl 
    549570         palb(:,:,jl) = ( palb_cs(:,:,jl) * ( 1.e0 - sf(jp_ccov)%fnow(:,:,1) )   & 
    550571            &         +   palb_os(:,:,jl) * sf(jp_ccov)%fnow(:,:,1) ) 
    … …  
    552573 
    553574      !                                     ! ========================== ! 
    554       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
     575      DO jl = 1, jpl                       !  Loop over ice categories  ! 
    555576         !                                  ! ========================== ! 
    556577!CDIR NOVERRCHK 
    … …  
    566587               ztaevbk = ztatm3 * ztatm(ji,jj) * zcldeff * ( 0.39 - 0.05 * zevsqr(ji,jj) )  
    567588               ! 
    568                z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( pst(ji,jj,jl) - ztatm(ji,jj) ) )  
     589               z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) )  
    569590 
    570591               !---------------------------------------- 
    … …  
    573594 
    574595               ! vapour pressure at saturation of ice (tmask to avoid overflow in the exponential) 
    575                zesi =  611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( pst(ji,jj,jl) - rtt )/ ( pst(ji,jj,jl) - 7.66 ) ) 
     596               zesi =  611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( ptsu(ji,jj,jl) - rtt )/ ( ptsu(ji,jj,jl) - 7.66 ) ) 
    576597               ! humidity close to the ice surface (at saturation) 
    577598               zqsati   = ( 0.622 * zesi ) / ( zpatm - 0.378 * zesi ) 
    578599                
    579600               !  computation of intermediate values 
    580                zticemb  = pst(ji,jj,jl) - 7.66 
     601               zticemb  = ptsu(ji,jj,jl) - 7.66 
    581602               zticemb2 = zticemb * zticemb   
    582                ztice3   = pst(ji,jj,jl) * pst(ji,jj,jl) * pst(ji,jj,jl) 
     603               ztice3   = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 
    583604               zdesidt  = zesi * ( 9.5 * LOG( 10.0 ) * ( rtt - 7.66 )  / zticemb2 ) 
    584605                
    … …  
    593614             
    594615               !  sensible heat flux 
    595                z_qsb(ji,jj,jl) = zrhovacshi * ( pst(ji,jj,jl) - ztatm(ji,jj) ) 
     616               z_qsb(ji,jj,jl) = zrhovacshi * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) 
    596617             
    597618               !  latent heat flux  
    598                p_qla(ji,jj,jl) = MAX(  0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) )  ) 
     619               qla_ice(ji,jj,jl) = MAX(  0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) )  ) 
    599620               
    600621               !  sensitivity of non solar fluxes (dQ/dT) (long-wave, sensible and latent fluxes) 
    … …  
    603624               zdqla = zrhovaclei * ( zdesidt * ( zqsati * zqsati / ( zesi * zesi ) ) * ( zpatm / 0.622 ) )    
    604625               ! 
    605                p_dqla(ji,jj,jl) = zdqla                           ! latent flux sensitivity 
    606                p_dqns(ji,jj,jl) = -( zdqlw + zdqsb + zdqla )      !  total non solar sensitivity 
     626               dqla_ice(ji,jj,jl) = zdqla                           ! latent flux sensitivity 
     627               dqns_ice(ji,jj,jl) = -( zdqlw + zdqsb + zdqla )      !  total non solar sensitivity 
    607628            END DO 
    608629            ! 
    … …  
    616637      ! 
    617638!CDIR COLLAPSE 
    618       p_qns(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - p_qla (:,:,:)      ! Downward Non Solar flux 
    619 !CDIR COLLAPSE 
    620       p_tpr(:,:)   = sf(jp_prec)%fnow(:,:,1) / rday                     ! total precipitation [kg/m2/s] 
     639      qns_ice(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - qla_ice (:,:,:)      ! Downward Non Solar flux 
     640!CDIR COLLAPSE 
     641      tprecip(:,:)   = sf(jp_prec)%fnow(:,:,1) / rday                     ! total precipitation [kg/m2/s] 
    621642      ! 
    622643      ! ----------------------------------------------------------------------------- ! 
    … …  
    625646!CDIR COLLAPSE 
    626647      qns(:,:) = qns(:,:)                                                           &   ! update the non-solar heat flux with: 
    627          &     - p_spr(:,:) * lfus                                                  &   ! remove melting solid precip 
    628          &     + p_spr(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic &   ! add solid P at least below melting 
    629          &     - p_spr(:,:) * sf(jp_tair)%fnow(:,:,1)                        * rcp      ! remove solid precip. at Tair 
    630       ! 
     648         &     - sprecip(:,:) * lfus                                                  &   ! remove melting solid precip 
     649         &     + sprecip(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic &   ! add solid P at least below melting 
     650         &     - sprecip(:,:) * sf(jp_tair)%fnow(:,:,1)                        * rcp      ! remove solid precip. at Tair 
     651 
     652#if defined key_lim3 
     653      ! ----------------------------------------------------------------------------- ! 
     654      !    Distribute evapo, precip & associated heat over ice and ocean 
     655      ! ---------------=====--------------------------------------------------------- ! 
     656      CALL wrk_alloc( jpi,jpj, zevap, zsnw )  
     657 
     658      ! --- evaporation --- ! 
     659      z1_lsub = 1._wp / Lsub 
     660      evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
     661      devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
     662      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     663 
     664      ! --- evaporation minus precipitation --- ! 
     665      zsnw(:,:) = 0._wp 
     666      CALL lim_thd_snwblow( pfrld, zsnw )          ! snow redistribution by wind 
     667      emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * ( 1._wp - zsnw ) 
     668      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
     669      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 
     670 
     671      ! --- heat flux associated with emp --- ! 
     672      qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap 
     673         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip 
     674         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip 
     675         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     676      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only) 
     677         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     678 
     679      ! --- total solar and non solar fluxes --- ! 
     680      qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 
     681      qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
     682 
     683      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     684      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     685 
     686      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
     687#endif 
     688 
    631689!!gm : not necessary as all input data are lbc_lnk... 
    632       CALL lbc_lnk( p_fr1  (:,:) , 'T', 1. ) 
    633       CALL lbc_lnk( p_fr2  (:,:) , 'T', 1. ) 
    634       DO jl = 1, ijpl 
    635          CALL lbc_lnk( p_qns (:,:,jl) , 'T', 1. ) 
    636          CALL lbc_lnk( p_dqns(:,:,jl) , 'T', 1. ) 
    637          CALL lbc_lnk( p_qla (:,:,jl) , 'T', 1. ) 
    638          CALL lbc_lnk( p_dqla(:,:,jl) , 'T', 1. ) 
     690      CALL lbc_lnk( fr1_i0  (:,:) , 'T', 1. ) 
     691      CALL lbc_lnk( fr2_i0  (:,:) , 'T', 1. ) 
     692      DO jl = 1, jpl 
     693         CALL lbc_lnk( qns_ice (:,:,jl) , 'T', 1. ) 
     694         CALL lbc_lnk( dqns_ice(:,:,jl) , 'T', 1. ) 
     695         CALL lbc_lnk( qla_ice (:,:,jl) , 'T', 1. ) 
     696         CALL lbc_lnk( dqla_ice(:,:,jl) , 'T', 1. ) 
    639697      END DO 
    640698 
    641699!!gm : mask is not required on forcing 
    642       DO jl = 1, ijpl 
    643          p_qns (:,:,jl) = p_qns (:,:,jl) * tmask(:,:,1) 
    644          p_qla (:,:,jl) = p_qla (:,:,jl) * tmask(:,:,1) 
    645          p_dqns(:,:,jl) = p_dqns(:,:,jl) * tmask(:,:,1) 
    646          p_dqla(:,:,jl) = p_dqla(:,:,jl) * tmask(:,:,1) 
    647       END DO 
     700      DO jl = 1, jpl 
     701         qns_ice (:,:,jl) = qns_ice (:,:,jl) * tmask(:,:,1) 
     702         qla_ice (:,:,jl) = qla_ice (:,:,jl) * tmask(:,:,1) 
     703         dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * tmask(:,:,1) 
     704         dqla_ice(:,:,jl) = dqla_ice(:,:,jl) * tmask(:,:,1) 
     705      END DO 
     706 
     707      CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
     708      CALL wrk_dealloc( jpi,jpj, jpl  , z_qlw, z_qsb ) 
    648709 
    649710      IF(ln_ctl) THEN 
    650          CALL prt_ctl(tab3d_1=z_qsb  , clinfo1=' blk_ice_clio: z_qsb  : ', tab3d_2=z_qlw  , clinfo2=' z_qlw  : ', kdim=ijpl) 
    651          CALL prt_ctl(tab3d_1=p_qla  , clinfo1=' blk_ice_clio: z_qla  : ', tab3d_2=p_qsr  , clinfo2=' p_qsr  : ', kdim=ijpl) 
    652          CALL prt_ctl(tab3d_1=p_dqns , clinfo1=' blk_ice_clio: p_dqns : ', tab3d_2=p_qns  , clinfo2=' p_qns  : ', kdim=ijpl) 
    653          CALL prt_ctl(tab3d_1=p_dqla , clinfo1=' blk_ice_clio: p_dqla : ', tab3d_2=pst    , clinfo2=' pst    : ', kdim=ijpl) 
    654          CALL prt_ctl(tab2d_1=p_tpr  , clinfo1=' blk_ice_clio: p_tpr  : ', tab2d_2=p_spr  , clinfo2=' p_spr  : ') 
    655          CALL prt_ctl(tab2d_1=p_taui , clinfo1=' blk_ice_clio: p_taui : ', tab2d_2=p_tauj , clinfo2=' p_tauj : ') 
     711         CALL prt_ctl(tab3d_1=z_qsb  , clinfo1=' blk_ice_clio: z_qsb  : ', tab3d_2=z_qlw  , clinfo2=' z_qlw  : ', kdim=jpl) 
     712         CALL prt_ctl(tab3d_1=qla_ice  , clinfo1=' blk_ice_clio: z_qla  : ', tab3d_2=qsr_ice  , clinfo2=' qsr_ice  : ', kdim=jpl) 
     713         CALL prt_ctl(tab3d_1=dqns_ice , clinfo1=' blk_ice_clio: dqns_ice : ', tab3d_2=qns_ice  , clinfo2=' qns_ice  : ', kdim=jpl) 
     714         CALL prt_ctl(tab3d_1=dqla_ice , clinfo1=' blk_ice_clio: dqla_ice : ', tab3d_2=ptsu    , clinfo2=' ptsu    : ', kdim=jpl) 
     715         CALL prt_ctl(tab2d_1=tprecip  , clinfo1=' blk_ice_clio: tprecip  : ', tab2d_2=sprecip  , clinfo2=' sprecip  : ') 
    656716      ENDIF 
    657717 
    658       CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
    659       CALL wrk_dealloc( jpi,jpj,pdim, z_qlw, z_qsb ) 
    660       ! 
    661       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio') 
    662       ! 
    663    END SUBROUTINE blk_ice_clio 
    664  
     718      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio_flx') 
     719      ! 
     720   END SUBROUTINE blk_ice_clio_flx 
     721 
     722#endif 
    665723 
    666724   SUBROUTINE blk_clio_qsr_oce( pqsr_oce ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r5500 r5630  
    2222   !!   blk_oce_core    : computes momentum, heat and freshwater fluxes over ocean 
    2323   !!   blk_ice_core    : computes momentum, heat and freshwater fluxes over ice 
    24    !!   blk_bio_meanqsr : compute daily mean short wave radiation over the ocean 
    25    !!   blk_ice_meanqsr : compute daily mean short wave radiation over the ice 
    2624   !!   turb_core_2z    : Computes turbulent transfert coefficients 
    2725   !!   cd_neutral_10m  : Estimate of the neutral drag coefficient at 10m 
    … …  
    4644   USE sbc_ice         ! Surface boundary condition: ice fields 
    4745   USE lib_fortran     ! to use key_nosignedzero 
     46#if defined key_lim3 
     47   USE ice, ONLY       : u_ice, v_ice, jpl, pfrld, a_i_b 
     48   USE limthd_dh       ! for CALL lim_thd_snwblow 
     49#elif defined key_lim2 
     50   USE ice_2, ONLY     : u_ice, v_ice 
     51   USE par_ice_2 
     52#endif 
    4853 
    4954   IMPLICIT NONE 
    … …  
    5156 
    5257   PUBLIC   sbc_blk_core         ! routine called in sbcmod module 
    53    PUBLIC   blk_ice_core         ! routine called in sbc_ice_lim module 
    54    PUBLIC   blk_ice_meanqsr      ! routine called in sbc_ice_lim module 
     58#if defined key_lim2 || defined key_lim3 
     59   PUBLIC   blk_ice_core_tau     ! routine called in sbc_ice_lim module 
     60   PUBLIC   blk_ice_core_flx     ! routine called in sbc_ice_lim module 
     61#endif 
    5562   PUBLIC   turb_core_2z         ! routine calles in sbcblk_mfs module 
    5663 
    … …  
    195202      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    196203      IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce_core( kt, sf, sst_m, ssu_m, ssv_m ) 
    197  
    198       ! If diurnal cycle is activated, compute a daily mean short waves flux for biogeochemistery 
    199       IF( ltrcdm2dc )   CALL blk_bio_meanqsr 
    200204 
    201205#if defined key_cice 
    … …  
    302306      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask(:,:,1) 
    303307      ENDIF 
     308 
    304309      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask(:,:,1)   ! Long  Wave 
    305310      ! ----------------------------------------------------------------------------- ! 
    … …  
    376381      emp (:,:) = (  zevap(:,:)                                          &   ! mass flux (evap. - precip.) 
    377382         &         - sf(jp_prec)%fnow(:,:,1) * rn_pfac  ) * tmask(:,:,1) 
    378       qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar flux 
     383      ! 
     384      qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar  
    379385         &     - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus                         &   ! remove latent melting heat for solid precip 
    380386         &     - zevap(:,:) * pst(:,:) * rcp                                      &   ! remove evap heat content at SST 
    … …  
    384390         &     * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) 
    385391      ! 
    386       CALL iom_put( "qlw_oce",   zqlw )                 ! output downward longwave heat over the ocean 
    387       CALL iom_put( "qsb_oce", - zqsb )                 ! output downward sensible heat over the ocean 
    388       CALL iom_put( "qla_oce", - zqla )                 ! output downward latent   heat over the ocean 
    389       CALL iom_put( "qhc_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
    390       CALL iom_put( "qns_oce",   qns  )                 ! output downward non solar heat over the ocean 
     392#if defined key_lim3 
     393      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                ! non solar without emp (only needed by LIM3) 
     394      qsr_oce(:,:) = qsr(:,:) 
     395#endif 
     396      ! 
     397      IF ( nn_ice == 0 ) THEN 
     398         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave heat over the ocean 
     399         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible heat over the ocean 
     400         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent   heat over the ocean 
     401         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
     402         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean 
     403         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
     404         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     405      ENDIF 
    391406      ! 
    392407      IF(ln_ctl) THEN 
    … …  
    406421  
    407422    
    408    SUBROUTINE blk_ice_core(  pst   , pui   , pvi   , palb ,   & 
    409       &                      p_taui, p_tauj, p_qns , p_qsr,   & 
    410       &                      p_qla , p_dqns, p_dqla,          & 
    411       &                      p_tpr , p_spr ,                  & 
    412       &                      p_fr1 , p_fr2 , cd_grid, pdim  )  
    413       !!--------------------------------------------------------------------- 
    414       !!                     ***  ROUTINE blk_ice_core  *** 
     423#if defined key_lim2 || defined key_lim3 
     424   SUBROUTINE blk_ice_core_tau 
     425      !!--------------------------------------------------------------------- 
     426      !!                     ***  ROUTINE blk_ice_core_tau  *** 
    415427      !! 
    416428      !! ** Purpose :   provide the surface boundary condition over sea-ice 
    417429      !! 
    418       !! ** Method  :   compute momentum, heat and freshwater exchanged 
    419       !!                between atmosphere and sea-ice using CORE bulk 
    420       !!                formulea, ice variables and read atmmospheric fields. 
     430      !! ** Method  :   compute momentum using CORE bulk 
     431      !!                formulea, ice variables and read atmospheric fields. 
    421432      !!                NB: ice drag coefficient is assumed to be a constant 
    422       !!  
    423       !! caution : the net upward water flux has with mm/day unit 
    424       !!--------------------------------------------------------------------- 
    425       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pst      ! ice surface temperature (>0, =rt0 over land) [Kelvin] 
    426       REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pui      ! ice surface velocity (i- and i- components      [m/s] 
    427       REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pvi      !    at I-point (B-grid) or U & V-point (C-grid) 
    428       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   palb     ! ice albedo (all skies)                            [%] 
    429       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_taui   ! i- & j-components of surface ice stress        [N/m2] 
    430       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_tauj   !   at I-point (B-grid) or U & V-point (C-grid) 
    431       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qns    ! non solar heat flux over ice (T-point)         [W/m2] 
    432       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qsr    !     solar heat flux over ice (T-point)         [W/m2] 
    433       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qla    ! latent    heat flux over ice (T-point)         [W/m2] 
    434       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_dqns   ! non solar heat sensistivity  (T-point)         [W/m2] 
    435       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_dqla   ! latent    heat sensistivity  (T-point)         [W/m2] 
    436       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_tpr    ! total precipitation          (T-point)      [Kg/m2/s] 
    437       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_spr    ! solid precipitation          (T-point)      [Kg/m2/s] 
    438       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_fr1    ! 1sr fraction of qsr penetration in ice (T-point)  [%] 
    439       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_fr2    ! 2nd fraction of qsr penetration in ice (T-point)  [%] 
    440       CHARACTER(len=1)          , INTENT(in   ) ::   cd_grid  ! ice grid ( C or B-grid) 
    441       INTEGER                   , INTENT(in   ) ::   pdim     ! number of ice categories 
    442       !! 
    443       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    444       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    445       REAL(wp) ::   zst2, zst3 
    446       REAL(wp) ::   zcoef_wnorm, zcoef_wnorm2, zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
    447       REAL(wp) ::   zztmp                                        ! temporary variable 
    448       REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f                  ! relative wind module and components at F-point 
    449       REAL(wp) ::             zwndi_t , zwndj_t                  ! relative wind components at T-point 
    450       !! 
    451       REAL(wp), DIMENSION(:,:)  , POINTER ::   z_wnds_t          ! wind speed ( = | U10m - U_ice | ) at T-point 
    452       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
    453       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb             ! sensible  heat flux over ice 
    454       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw            ! long wave heat sensitivity over ice 
    455       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
    456       !!--------------------------------------------------------------------- 
    457       ! 
    458       IF( nn_timing == 1 )  CALL timing_start('blk_ice_core') 
    459       ! 
    460       CALL wrk_alloc( jpi,jpj, z_wnds_t ) 
    461       CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb, z_dqlw, z_dqsb )  
    462  
    463       ijpl  = pdim                            ! number of ice categories 
    464  
     433      !!--------------------------------------------------------------------- 
     434      INTEGER  ::   ji, jj    ! dummy loop indices 
     435      REAL(wp) ::   zcoef_wnorm, zcoef_wnorm2 
     436      REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f               ! relative wind module and components at F-point 
     437      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
     438      !!--------------------------------------------------------------------- 
     439      ! 
     440      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_tau') 
     441      ! 
    465442      ! local scalars ( place there for vector optimisation purposes) 
    466443      zcoef_wnorm  = rhoa * Cice 
    467444      zcoef_wnorm2 = rhoa * Cice * 0.5 
    468       zcoef_dqlw   = 4.0 * 0.95 * Stef 
    469       zcoef_dqla   = -Ls * Cice * 11637800. * (-5897.8) 
    470       zcoef_dqsb   = rhoa * cpa * Cice 
    471445 
    472446!!gm brutal.... 
    473       z_wnds_t(:,:) = 0.e0 
    474       p_taui  (:,:) = 0.e0 
    475       p_tauj  (:,:) = 0.e0 
     447      utau_ice  (:,:) = 0._wp 
     448      vtau_ice  (:,:) = 0._wp 
     449      wndm_ice  (:,:) = 0._wp 
    476450!!gm end 
    477451 
    478 #if defined key_lim3 
    479       tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1)   ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init 
    480 #endif 
    481452      ! ----------------------------------------------------------------------------- ! 
    482453      !    Wind components and module relative to the moving ocean ( U10m - U_ice )   ! 
    483454      ! ----------------------------------------------------------------------------- ! 
    484       SELECT CASE( cd_grid ) 
     455      SELECT CASE( cp_ice_msh ) 
    485456      CASE( 'I' )                  ! B-grid ice dynamics :   I-point (i.e. F-point with sea-ice indexation) 
    486457         !                           and scalar wind at T-point ( = | U10m - U_ice | ) (masked) 
    … …  
    489460               ! ... scalar wind at I-point (fld being at T-point) 
    490461               zwndi_f = 0.25 * (  sf(jp_wndi)%fnow(ji-1,jj  ,1) + sf(jp_wndi)%fnow(ji  ,jj  ,1)   & 
    491                   &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * pui(ji,jj) 
     462                  &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * u_ice(ji,jj) 
    492463               zwndj_f = 0.25 * (  sf(jp_wndj)%fnow(ji-1,jj  ,1) + sf(jp_wndj)%fnow(ji  ,jj  ,1)   & 
    493                   &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * pvi(ji,jj) 
     464                  &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * v_ice(ji,jj) 
    494465               zwnorm_f = zcoef_wnorm * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 
    495466               ! ... ice stress at I-point 
    496                p_taui(ji,jj) = zwnorm_f * zwndi_f 
    497                p_tauj(ji,jj) = zwnorm_f * zwndj_f 
     467               utau_ice(ji,jj) = zwnorm_f * zwndi_f 
     468               vtau_ice(ji,jj) = zwnorm_f * zwndj_f 
    498469               ! ... scalar wind at T-point (fld being at T-point) 
    499                zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  pui(ji,jj+1) + pui(ji+1,jj+1)   & 
    500                   &                                                    + pui(ji,jj  ) + pui(ji+1,jj  )  ) 
    501                zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  pvi(ji,jj+1) + pvi(ji+1,jj+1)   & 
    502                   &                                                    + pvi(ji,jj  ) + pvi(ji+1,jj  )  ) 
    503                z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     470               zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  u_ice(ji,jj+1) + u_ice(ji+1,jj+1)   & 
     471                  &                                                    + u_ice(ji,jj  ) + u_ice(ji+1,jj  )  ) 
     472               zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  v_ice(ji,jj+1) + v_ice(ji+1,jj+1)   & 
     473                  &                                                    + v_ice(ji,jj  ) + v_ice(ji+1,jj  )  ) 
     474               wndm_ice(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
    504475            END DO 
    505476         END DO 
    506          CALL lbc_lnk( p_taui  , 'I', -1. ) 
    507          CALL lbc_lnk( p_tauj  , 'I', -1. ) 
    508          CALL lbc_lnk( z_wnds_t, 'T',  1. ) 
     477         CALL lbc_lnk( utau_ice, 'I', -1. ) 
     478         CALL lbc_lnk( vtau_ice, 'I', -1. ) 
     479         CALL lbc_lnk( wndm_ice, 'T',  1. ) 
    509480         ! 
    510481      CASE( 'C' )                  ! C-grid ice dynamics :   U & V-points (same as ocean) 
    511482         DO jj = 2, jpj 
    512483            DO ji = fs_2, jpi   ! vect. opt. 
    513                zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pui(ji-1,jj  ) + pui(ji,jj) )  ) 
    514                zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pvi(ji  ,jj-1) + pvi(ji,jj) )  ) 
    515                z_wnds_t(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     484               zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  ) 
     485               zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  ) 
     486               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
    516487            END DO 
    517488         END DO 
    518489         DO jj = 2, jpjm1 
    519490            DO ji = fs_2, fs_jpim1   ! vect. opt. 
    520                p_taui(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji+1,jj  ) + z_wnds_t(ji,jj) )                          & 
    521                   &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * pui(ji,jj) ) 
    522                p_tauj(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji,jj+1  ) + z_wnds_t(ji,jj) )                          & 
    523                   &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * pvi(ji,jj) ) 
     491               utau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )                          & 
     492                  &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) ) 
     493               vtau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )                          & 
     494                  &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) ) 
    524495            END DO 
    525496         END DO 
    526          CALL lbc_lnk( p_taui  , 'U', -1. ) 
    527          CALL lbc_lnk( p_tauj  , 'V', -1. ) 
    528          CALL lbc_lnk( z_wnds_t, 'T',  1. ) 
     497         CALL lbc_lnk( utau_ice, 'U', -1. ) 
     498         CALL lbc_lnk( vtau_ice, 'V', -1. ) 
     499         CALL lbc_lnk( wndm_ice, 'T',  1. ) 
    529500         ! 
    530501      END SELECT 
     502 
     503      IF(ln_ctl) THEN 
     504         CALL prt_ctl(tab2d_1=utau_ice  , clinfo1=' blk_ice_core: utau_ice : ', tab2d_2=vtau_ice  , clinfo2=' vtau_ice : ') 
     505         CALL prt_ctl(tab2d_1=wndm_ice  , clinfo1=' blk_ice_core: wndm_ice : ') 
     506      ENDIF 
     507 
     508      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_tau') 
     509       
     510   END SUBROUTINE blk_ice_core_tau 
     511 
     512 
     513   SUBROUTINE blk_ice_core_flx( ptsu, palb ) 
     514      !!--------------------------------------------------------------------- 
     515      !!                     ***  ROUTINE blk_ice_core_flx  *** 
     516      !! 
     517      !! ** Purpose :   provide the surface boundary condition over sea-ice 
     518      !! 
     519      !! ** Method  :   compute heat and freshwater exchanged 
     520      !!                between atmosphere and sea-ice using CORE bulk 
     521      !!                formulea, ice variables and read atmmospheric fields. 
     522      !!  
     523      !! caution : the net upward water flux has with mm/day unit 
     524      !!--------------------------------------------------------------------- 
     525      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   ptsu          ! sea ice surface temperature 
     526      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   palb          ! ice albedo (all skies) 
     527      !! 
     528      INTEGER  ::   ji, jj, jl    ! dummy loop indices 
     529      REAL(wp) ::   zst2, zst3 
     530      REAL(wp) ::   zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
     531      REAL(wp) ::   zztmp, z1_lsub                               ! temporary variable 
     532      !! 
     533      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
     534      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb             ! sensible  heat flux over ice 
     535      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw            ! long wave heat sensitivity over ice 
     536      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
     537      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw       ! evaporation and snw distribution after wind blowing (LIM3) 
     538      !!--------------------------------------------------------------------- 
     539      ! 
     540      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_flx') 
     541      ! 
     542      CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb )  
     543 
     544      ! local scalars ( place there for vector optimisation purposes) 
     545      zcoef_dqlw   = 4.0 * 0.95 * Stef 
     546      zcoef_dqla   = -Ls * Cice * 11637800. * (-5897.8) 
     547      zcoef_dqsb   = rhoa * cpa * Cice 
    531548 
    532549      zztmp = 1. / ( 1. - albo ) 
    533550      !                                     ! ========================== ! 
    534       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
     551      DO jl = 1, jpl                        !  Loop over ice categories  ! 
    535552         !                                  ! ========================== ! 
    536553         DO jj = 1 , jpj 
    … …  
    539556               !      I   Radiative FLUXES   ! 
    540557               ! ----------------------------! 
    541                zst2 = pst(ji,jj,jl) * pst(ji,jj,jl) 
    542                zst3 = pst(ji,jj,jl) * zst2 
     558               zst2 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 
     559               zst3 = ptsu(ji,jj,jl) * zst2 
    543560               ! Short Wave (sw) 
    544                p_qsr(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
     561               qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
    545562               ! Long  Wave (lw) 
    546                z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
     563               z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
    547564               ! lw sensitivity 
    548565               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3                                                
    … …  
    554571               ! ... turbulent heat fluxes 
    555572               ! Sensible Heat 
    556                z_qsb(ji,jj,jl) = rhoa * cpa * Cice * z_wnds_t(ji,jj) * ( pst(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
     573               z_qsb(ji,jj,jl) = rhoa * cpa * Cice * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
    557574               ! Latent Heat 
    558                p_qla(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * z_wnds_t(ji,jj)   &                            
    559                   &                         * (  11637800. * EXP( -5897.8 / pst(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    560                ! Latent heat sensitivity for ice (Dqla/Dt) 
    561                IF( p_qla(ji,jj,jl) > 0._wp ) THEN 
    562                   p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) ) 
     575               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * wndm_ice(ji,jj)   &                            
     576                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
     577              ! Latent heat sensitivity for ice (Dqla/Dt) 
     578               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
     579                  dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) ) 
    563580               ELSE 
    564                   p_dqla(ji,jj,jl) = 0._wp 
     581                  dqla_ice(ji,jj,jl) = 0._wp 
    565582               ENDIF 
    566583 
    567584               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 
    568                z_dqsb(ji,jj,jl) = zcoef_dqsb * z_wnds_t(ji,jj) 
     585               z_dqsb(ji,jj,jl) = zcoef_dqsb * wndm_ice(ji,jj) 
    569586 
    570587               ! ----------------------------! 
    … …  
    572589               ! ----------------------------! 
    573590               ! Downward Non Solar flux 
    574                p_qns (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - p_qla (ji,jj,jl) 
     591               qns_ice (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) 
    575592               ! Total non solar heat flux sensitivity for ice 
    576                p_dqns(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + p_dqla(ji,jj,jl) ) 
     593               dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) 
    577594            END DO 
    578595            ! 
    … …  
    581598      END DO 
    582599      ! 
     600      tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s] 
     601      sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s] 
     602      CALL iom_put( 'snowpre', sprecip * 86400. )                  ! Snow precipitation 
     603      CALL iom_put( 'precip' , tprecip * 86400. )                  ! Total precipitation 
     604 
     605#if defined  key_lim3 
     606      CALL wrk_alloc( jpi,jpj, zevap, zsnw )  
     607 
     608      ! --- evaporation --- ! 
     609      z1_lsub = 1._wp / Lsub 
     610      evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
     611      devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
     612      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     613 
     614      ! --- evaporation minus precipitation --- ! 
     615      zsnw(:,:) = 0._wp 
     616      CALL lim_thd_snwblow( pfrld, zsnw )  ! snow distribution over ice after wind blowing  
     617      emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 
     618      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
     619      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 
     620 
     621      ! --- heat flux associated with emp --- ! 
     622      qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap at sst 
     623         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip at Tair 
     624         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip at min(Tair,Tsnow) 
     625         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     626      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only) 
     627         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     628 
     629      ! --- total solar and non solar fluxes --- ! 
     630      qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 
     631      qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
     632 
     633      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     634      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     635 
     636      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
     637#endif 
     638 
    583639      !-------------------------------------------------------------------- 
    584640      ! FRACTIONs of net shortwave radiation which is not absorbed in the 
    … …  
    586642      ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 ) 
    587643      ! 
    588       p_fr1(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 
    589       p_fr2(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    590       ! 
    591       p_tpr(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s] 
    592       p_spr(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s] 
    593       CALL iom_put( 'snowpre', p_spr * 86400. )                  ! Snow precipitation 
    594       CALL iom_put( 'precip' , p_tpr * 86400. )                  ! Total precipitation 
     644      fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 
     645      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
     646      ! 
    595647      ! 
    596648      IF(ln_ctl) THEN 
    597          CALL prt_ctl(tab3d_1=p_qla   , clinfo1=' blk_ice_core: p_qla  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb  : ', kdim=ijpl) 
    598          CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice_core: z_qlw  : ', tab3d_2=p_dqla  , clinfo2=' p_dqla : ', kdim=ijpl) 
    599          CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice_core: z_dqsb : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw : ', kdim=ijpl) 
    600          CALL prt_ctl(tab3d_1=p_dqns  , clinfo1=' blk_ice_core: p_dqns : ', tab3d_2=p_qsr   , clinfo2=' p_qsr  : ', kdim=ijpl) 
    601          CALL prt_ctl(tab3d_1=pst     , clinfo1=' blk_ice_core: pst    : ', tab3d_2=p_qns   , clinfo2=' p_qns  : ', kdim=ijpl) 
    602          CALL prt_ctl(tab2d_1=p_tpr   , clinfo1=' blk_ice_core: p_tpr  : ', tab2d_2=p_spr   , clinfo2=' p_spr  : ') 
    603          CALL prt_ctl(tab2d_1=p_taui  , clinfo1=' blk_ice_core: p_taui : ', tab2d_2=p_tauj  , clinfo2=' p_tauj : ') 
    604          CALL prt_ctl(tab2d_1=z_wnds_t, clinfo1=' blk_ice_core: z_wnds_t : ') 
    605       ENDIF 
    606  
    607       CALL wrk_dealloc( jpi,jpj,   z_wnds_t ) 
    608       CALL wrk_dealloc( jpi,jpj,   pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 
    609       ! 
    610       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core') 
    611       ! 
    612    END SUBROUTINE blk_ice_core 
    613  
    614  
    615    SUBROUTINE blk_bio_meanqsr 
    616       !!--------------------------------------------------------------------- 
    617       !!                     ***  ROUTINE blk_bio_meanqsr 
    618       !!                      
    619       !! ** Purpose :   provide daily qsr_mean for PISCES when 
    620       !!                analytic diurnal cycle is applied in physic 
    621       !!                 
    622       !! ** Method  :   add part where there is no ice 
    623       !!  
    624       !!--------------------------------------------------------------------- 
    625       IF( nn_timing == 1 )  CALL timing_start('blk_bio_meanqsr') 
    626       ! 
    627       qsr_mean(:,:) = (1. - albo ) *  sf(jp_qsr)%fnow(:,:,1) 
    628       ! 
    629       IF( nn_timing == 1 )  CALL timing_stop('blk_bio_meanqsr') 
    630       ! 
    631    END SUBROUTINE blk_bio_meanqsr 
    632   
    633   
    634    SUBROUTINE blk_ice_meanqsr( palb, p_qsr_mean, pdim ) 
    635       !!--------------------------------------------------------------------- 
    636       !! 
    637       !! ** Purpose :   provide the daily qsr_mean over sea_ice for PISCES when 
    638       !!                analytic diurnal cycle is applied in physic 
    639       !! 
    640       !! ** Method  :   compute qsr 
    641       !!  
    642       !!--------------------------------------------------------------------- 
    643       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   palb       ! ice albedo (clear sky) (alb_ice_cs)               [%] 
    644       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qsr_mean !     solar heat flux over ice (T-point)         [W/m2] 
    645       INTEGER                   , INTENT(in   ) ::   pdim       ! number of ice categories 
    646       ! 
    647       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    648       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    649       REAL(wp) ::   zztmp         ! temporary variable 
    650       !!--------------------------------------------------------------------- 
    651       IF( nn_timing == 1 )  CALL timing_start('blk_ice_meanqsr') 
    652       ! 
    653       ijpl  = pdim                            ! number of ice categories 
    654       zztmp = 1. / ( 1. - albo ) 
    655       !                                     ! ========================== ! 
    656       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
    657          !                                  ! ========================== ! 
    658          DO jj = 1 , jpj 
    659             DO ji = 1, jpi 
    660                   p_qsr_mean(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr_mean(ji,jj) 
    661             END DO 
    662          END DO 
    663       END DO 
    664       ! 
    665       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_meanqsr') 
    666       ! 
    667    END SUBROUTINE blk_ice_meanqsr   
    668  
     649         CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice_core: qla_ice  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb    : ', kdim=jpl) 
     650         CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice_core: z_qlw    : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) 
     651         CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice_core: z_dqsb   : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw   : ', kdim=jpl) 
     652         CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice_core: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice  : ', kdim=jpl) 
     653         CALL prt_ctl(tab3d_1=ptsu    , clinfo1=' blk_ice_core: ptsu     : ', tab3d_2=qns_ice , clinfo2=' qns_ice  : ', kdim=jpl) 
     654         CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice_core: tprecip  : ', tab2d_2=sprecip , clinfo2=' sprecip  : ') 
     655      ENDIF 
     656 
     657      CALL wrk_dealloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 
     658      ! 
     659      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_flx') 
     660       
     661   END SUBROUTINE blk_ice_core_flx 
     662#endif 
    669663 
    670664   SUBROUTINE turb_core_2z( zt, zu, sst, T_zt, q_sat, q_zt, dU,    & 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r5500 r5630  
    2121   USE sbc_oce         ! Surface boundary condition: ocean fields 
    2222   USE sbc_ice         ! Surface boundary condition: ice fields 
     23   USE sbcapr 
    2324   USE sbcdcy          ! surface boundary condition: diurnal cycle 
    2425   USE phycst          ! physical constants 
    … …  
    3233   USE cpl_oasis3      ! OASIS3 coupling 
    3334   USE geo2ocean       !  
    34    USE oce   , ONLY : tsn, un, vn 
     35   USE oce   , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 
    3536   USE albedo          ! 
    3637   USE in_out_manager  ! I/O manager 
    … …  
    4041   USE timing          ! Timing 
    4142   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     43   USE eosbn2 
     44   USE sbcrnf   , ONLY : l_rnfcpl 
    4245#if defined key_cpl_carbon_cycle 
    4346   USE p4zflx, ONLY : oce_co2 
    … …  
    4649   USE ice_domain_size, only: ncat 
    4750#endif 
     51#if defined key_lim3 
     52   USE limthd_dh       ! for CALL lim_thd_snwblow 
     53#endif 
     54 
    4855   IMPLICIT NONE 
    4956   PRIVATE 
    50 !EM XIOS-OASIS-MCT compliance 
     57 
    5158   PUBLIC   sbc_cpl_init       ! routine called by sbcmod.F90 
    5259   PUBLIC   sbc_cpl_rcv        ! routine called by sbc_ice_lim(_2).F90 
    … …  
    8996   INTEGER, PARAMETER ::   jpr_topm   = 32            ! topmeltn 
    9097   INTEGER, PARAMETER ::   jpr_botm   = 33            ! botmeltn 
    91    INTEGER, PARAMETER ::   jprcv      = 33            ! total number of fields received 
    92  
    93    INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction  
     98   INTEGER, PARAMETER ::   jpr_sflx   = 34            ! salt flux 
     99   INTEGER, PARAMETER ::   jpr_toce   = 35            ! ocean temperature 
     100   INTEGER, PARAMETER ::   jpr_soce   = 36            ! ocean salinity 
     101   INTEGER, PARAMETER ::   jpr_ocx1   = 37            ! ocean current on grid 1 
     102   INTEGER, PARAMETER ::   jpr_ocy1   = 38            ! 
     103   INTEGER, PARAMETER ::   jpr_ssh    = 39            ! sea surface height 
     104   INTEGER, PARAMETER ::   jpr_fice   = 40            ! ice fraction           
     105   INTEGER, PARAMETER ::   jpr_e3t1st = 41            ! first T level thickness  
     106   INTEGER, PARAMETER ::   jpr_fraqsr = 42            ! fraction of solar net radiation absorbed in the first ocean level 
     107   INTEGER, PARAMETER ::   jprcv      = 42            ! total number of fields received 
     108 
     109   INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction sent to the atmosphere 
    94110   INTEGER, PARAMETER ::   jps_toce   =  2            ! ocean temperature 
    95111   INTEGER, PARAMETER ::   jps_tice   =  3            ! ice   temperature 
    … …  
    106122   INTEGER, PARAMETER ::   jps_ivz1   = 14            ! 
    107123   INTEGER, PARAMETER ::   jps_co2    = 15 
    108    INTEGER, PARAMETER ::   jpsnd      = 15            ! total number of fields sended 
     124   INTEGER, PARAMETER ::   jps_soce   = 16            ! ocean salinity 
     125   INTEGER, PARAMETER ::   jps_ssh    = 17            ! sea surface height 
     126   INTEGER, PARAMETER ::   jps_qsroce = 18            ! Qsr above the ocean 
     127   INTEGER, PARAMETER ::   jps_qnsoce = 19            ! Qns above the ocean 
     128   INTEGER, PARAMETER ::   jps_oemp   = 20            ! ocean freshwater budget (evap - precip) 
     129   INTEGER, PARAMETER ::   jps_sflx   = 21            ! salt flux 
     130   INTEGER, PARAMETER ::   jps_otx1   = 22            ! 2 atmosphere-ocean stress components on grid 1 
     131   INTEGER, PARAMETER ::   jps_oty1   = 23            !  
     132   INTEGER, PARAMETER ::   jps_rnf    = 24            ! runoffs 
     133   INTEGER, PARAMETER ::   jps_taum   = 25            ! wind stress module 
     134   INTEGER, PARAMETER ::   jps_fice2  = 26            ! ice fraction sent to OPA (by SAS when doing SAS-OPA coupling) 
     135   INTEGER, PARAMETER ::   jps_e3t1st = 27            ! first level depth (vvl) 
     136   INTEGER, PARAMETER ::   jps_fraqsr = 28            ! fraction of solar net radiation absorbed in the first ocean level 
     137   INTEGER, PARAMETER ::   jpsnd      = 28            ! total number of fields sended 
    109138 
    110139   !                                                         !!** namelist namsbc_cpl ** 
    … …  
    125154   LOGICAL     ::   ln_usecplmask          !  use a coupling mask file to merge data received from several models 
    126155                                           !   -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 
    127  
    128    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: xcplmask 
    129  
    130156   TYPE ::   DYNARR      
    131157      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   z3    
    … …  
    139165 
    140166   !! Substitution 
     167#  include "domzgr_substitute.h90" 
    141168#  include "vectopt_loop_substitute.h90" 
    142169   !!---------------------------------------------------------------------- 
    … …  
    161188      ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) )  ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 
    162189#endif 
    163       ALLOCATE( xcplmask(jpi,jpj,nn_cplmodel) , STAT=ierr(3) ) 
     190      ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 
    164191      ! 
    165192      sbc_cpl_alloc = MAXVAL( ierr ) 
    … …  
    182209      !!              * initialise the OASIS coupler 
    183210      !!---------------------------------------------------------------------- 
    184       INTEGER, INTENT(in) ::   k_ice    ! ice management in the sbc (=0/1/2/3) 
     211      INTEGER, INTENT(in) ::   k_ice       ! ice management in the sbc (=0/1/2/3) 
    185212      !! 
    186213      INTEGER ::   jn   ! dummy loop index 
    … …  
    216243         WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' 
    217244         WRITE(numout,*)'~~~~~~~~~~~~' 
     245      ENDIF 
     246      IF( lwp .AND. ln_cpl ) THEN                        ! control print 
    218247         WRITE(numout,*)'  received fields (mutiple ice categogies)' 
    219248         WRITE(numout,*)'      10m wind module                 = ', TRIM(sn_rcv_w10m%cldes  ), ' (', TRIM(sn_rcv_w10m%clcat  ), ')' 
    … …  
    359388      srcv(jpr_oemp)%clname = 'OOEvaMPr'      ! ocean water budget = ocean Evap - ocean precip 
    360389      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
     390      CASE( 'none'          )       ! nothing to do 
    361391      CASE( 'oce only'      )   ;   srcv(                                 jpr_oemp   )%laction = .TRUE.  
    362392      CASE( 'conservative'  ) 
    … …  
    370400      !                                                      !     Runoffs & Calving     !    
    371401      !                                                      ! ------------------------- ! 
    372       srcv(jpr_rnf   )%clname = 'O_Runoff'   ;   IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' )   srcv(jpr_rnf)%laction = .TRUE. 
    373 ! This isn't right - really just want ln_rnf_emp changed 
    374 !                                                 IF( TRIM( sn_rcv_rnf%cldes ) == 'climato' )   THEN   ;   ln_rnf = .TRUE. 
    375 !                                                 ELSE                                                 ;   ln_rnf = .FALSE. 
    376 !                                                 ENDIF 
     402      srcv(jpr_rnf   )%clname = 'O_Runoff' 
     403      IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN 
     404         srcv(jpr_rnf)%laction = .TRUE. 
     405         l_rnfcpl              = .TRUE.                      ! -> no need to read runoffs in sbcrnf 
     406         ln_rnf                = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas 
     407         IF(lwp) WRITE(numout,*) 
     408         IF(lwp) WRITE(numout,*) '   runoffs received from oasis -> force ln_rnf = ', ln_rnf 
     409      ENDIF 
     410      ! 
    377411      srcv(jpr_cal   )%clname = 'OCalving'   ;   IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE. 
    378412 
    … …  
    384418      srcv(jpr_qnsmix)%clname = 'O_QnsMix' 
    385419      SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) 
     420      CASE( 'none'          )       ! nothing to do 
    386421      CASE( 'oce only'      )   ;   srcv(               jpr_qnsoce   )%laction = .TRUE. 
    387422      CASE( 'conservative'  )   ;   srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. 
    … …  
    399434      srcv(jpr_qsrmix)%clname = 'O_QsrMix' 
    400435      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) 
     436      CASE( 'none'          )       ! nothing to do 
    401437      CASE( 'oce only'      )   ;   srcv(               jpr_qsroce   )%laction = .TRUE. 
    402438      CASE( 'conservative'  )   ;   srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. 
    … …  
    414450      ! 
    415451      ! non solar sensitivity mandatory for LIM ice model 
    416       IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4) & 
     452      IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) & 
    417453         CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 
    418454      ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique 
    … …  
    447483         srcv(jpr_topm:jpr_botm)%laction = .TRUE. 
    448484      ENDIF 
    449  
    450       ! Allocate all parts of frcv used for received fields 
     485      !                                                      ! ------------------------------- ! 
     486      !                                                      !   OPA-SAS coupling - rcv by opa !    
     487      !                                                      ! ------------------------------- ! 
     488      srcv(jpr_sflx)%clname = 'O_SFLX' 
     489      srcv(jpr_fice)%clname = 'RIceFrc' 
     490      ! 
     491      IF( nn_components == jp_iam_opa ) THEN    ! OPA coupled to SAS via OASIS: force received field by OPA (sent by SAS) 
     492         srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     493         srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling 
     494         srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling 
     495         srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE. 
     496         srcv(jpr_otx1)%clgrid = 'U'        ! oce components given at U-point 
     497         srcv(jpr_oty1)%clgrid = 'V'        !           and           V-point 
     498         ! Vectors: change of sign at north fold ONLY if on the local grid 
     499         srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1. 
     500         sn_rcv_tau%clvgrd = 'U,V' 
     501         sn_rcv_tau%clvor = 'local grid' 
     502         sn_rcv_tau%clvref = 'spherical' 
     503         sn_rcv_emp%cldes = 'oce only' 
     504         ! 
     505         IF(lwp) THEN                        ! control print 
     506            WRITE(numout,*) 
     507            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  ' 
     508            WRITE(numout,*)'               OPA component  ' 
     509            WRITE(numout,*) 
     510            WRITE(numout,*)'  received fields from SAS component ' 
     511            WRITE(numout,*)'                  ice cover ' 
     512            WRITE(numout,*)'                  oce only EMP  ' 
     513            WRITE(numout,*)'                  salt flux  ' 
     514            WRITE(numout,*)'                  mixed oce-ice solar flux  ' 
     515            WRITE(numout,*)'                  mixed oce-ice non solar flux  ' 
     516            WRITE(numout,*)'                  wind stress U,V on local grid and sperical coordinates ' 
     517            WRITE(numout,*)'                  wind stress module' 
     518            WRITE(numout,*) 
     519         ENDIF 
     520      ENDIF 
     521      !                                                      ! -------------------------------- ! 
     522      !                                                      !   OPA-SAS coupling - rcv by sas  !    
     523      !                                                      ! -------------------------------- ! 
     524      srcv(jpr_toce  )%clname = 'I_SSTSST' 
     525      srcv(jpr_soce  )%clname = 'I_SSSal' 
     526      srcv(jpr_ocx1  )%clname = 'I_OCurx1' 
     527      srcv(jpr_ocy1  )%clname = 'I_OCury1' 
     528      srcv(jpr_ssh   )%clname = 'I_SSHght' 
     529      srcv(jpr_e3t1st)%clname = 'I_E3T1st'    
     530      srcv(jpr_fraqsr)%clname = 'I_FraQsr'    
     531      ! 
     532      IF( nn_components == jp_iam_sas ) THEN 
     533         IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     534         IF( .NOT. ln_cpl ) srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling 
     535         IF( .NOT. ln_cpl ) srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling 
     536         srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE. 
     537         srcv( jpr_e3t1st )%laction = lk_vvl 
     538         srcv(jpr_ocx1)%clgrid = 'U'        ! oce components given at U-point 
     539         srcv(jpr_ocy1)%clgrid = 'V'        !           and           V-point 
     540         ! Vectors: change of sign at north fold ONLY if on the local grid 
     541         srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1. 
     542         ! Change first letter to couple with atmosphere if already coupled OPA 
     543         ! this is nedeed as each variable name used in the namcouple must be unique: 
     544         ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere 
     545         DO jn = 1, jprcv 
     546            IF ( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) 
     547         END DO 
     548         ! 
     549         IF(lwp) THEN                        ! control print 
     550            WRITE(numout,*) 
     551            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  ' 
     552            WRITE(numout,*)'               SAS component  ' 
     553            WRITE(numout,*) 
     554            IF( .NOT. ln_cpl ) THEN 
     555               WRITE(numout,*)'  received fields from OPA component ' 
     556            ELSE 
     557               WRITE(numout,*)'  Additional received fields from OPA component : ' 
     558            ENDIF 
     559            WRITE(numout,*)'               sea surface temperature (Celcius) ' 
     560            WRITE(numout,*)'               sea surface salinity '  
     561            WRITE(numout,*)'               surface currents '  
     562            WRITE(numout,*)'               sea surface height '  
     563            WRITE(numout,*)'               thickness of first ocean T level '         
     564            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level' 
     565            WRITE(numout,*) 
     566         ENDIF 
     567      ENDIF 
     568       
     569      ! =================================================== ! 
     570      ! Allocate all parts of frcv used for received fields ! 
     571      ! =================================================== ! 
    451572      DO jn = 1, jprcv 
    452573         IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) 
    … …  
    454575      ! Allocate taum part of frcv which is used even when not received as coupling field 
    455576      IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) 
     577      ! Allocate w10m part of frcv which is used even when not received as coupling field 
     578      IF ( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) 
     579      ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field 
     580      IF ( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) 
     581      IF ( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) 
    456582      ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. 
    457583      IF( k_ice /= 0 ) THEN 
    … …  
    477603      ssnd(jps_tmix)%clname = 'O_TepMix' 
    478604      SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 
    479       CASE( 'none'         )       ! nothing to do 
    480       CASE( 'oce only'             )   ;   ssnd(   jps_toce            )%laction = .TRUE. 
    481       CASE( 'weighted oce and ice' ) 
     605      CASE( 'none'                                 )       ! nothing to do 
     606      CASE( 'oce only'                             )   ;   ssnd( jps_toce )%laction = .TRUE. 
     607      CASE( 'oce and ice' , 'weighted oce and ice' ) 
    482608         ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 
    483609         IF ( TRIM( sn_snd_temp%clcat ) == 'yes' )  ssnd(jps_tice)%nct = jpl 
    484       CASE( 'mixed oce-ice'        )   ;   ssnd(   jps_tmix            )%laction = .TRUE. 
     610      CASE( 'mixed oce-ice'                        )   ;   ssnd( jps_tmix )%laction = .TRUE. 
    485611      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) 
    486612      END SELECT 
    487       
     613            
    488614      !                                                      ! ------------------------- ! 
    489615      !                                                      !          Albedo           ! 
    … …  
    492618      ssnd(jps_albmix)%clname = 'O_AlbMix' 
    493619      SELECT CASE( TRIM( sn_snd_alb%cldes ) ) 
    494       CASE( 'none'          )       ! nothing to do 
    495       CASE( 'weighted ice'  )   ;  ssnd(jps_albice)%laction = .TRUE. 
    496       CASE( 'mixed oce-ice' )   ;  ssnd(jps_albmix)%laction = .TRUE. 
     620      CASE( 'none'                 )     ! nothing to do 
     621      CASE( 'ice' , 'weighted ice' )   ; ssnd(jps_albice)%laction = .TRUE. 
     622      CASE( 'mixed oce-ice'        )   ; ssnd(jps_albmix)%laction = .TRUE. 
    497623      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) 
    498624      END SELECT 
    … …  
    518644         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 
    519645      ENDIF 
    520  
     646       
    521647      SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 
    522648      CASE( 'none'         )       ! nothing to do 
    … …  
    525651         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 
    526652            ssnd(jps_hice:jps_hsnw)%nct = jpl 
    527          ELSE 
    528             IF ( jpl > 1 ) THEN 
    529 CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' ) 
    530             ENDIF 
    531653         ENDIF 
    532654      CASE ( 'weighted ice and snow' )  
    … …  
    567689      !                                                      ! ------------------------- ! 
    568690      ssnd(jps_co2)%clname = 'O_CO2FLX' ;  IF( TRIM(sn_snd_co2%cldes) == 'coupled' )    ssnd(jps_co2 )%laction = .TRUE. 
     691 
     692      !                                                      ! ------------------------------- ! 
     693      !                                                      !   OPA-SAS coupling - snd by opa !    
     694      !                                                      ! ------------------------------- ! 
     695      ssnd(jps_ssh   )%clname = 'O_SSHght'  
     696      ssnd(jps_soce  )%clname = 'O_SSSal'  
     697      ssnd(jps_e3t1st)%clname = 'O_E3T1st'    
     698      ssnd(jps_fraqsr)%clname = 'O_FraQsr' 
     699      ! 
     700      IF( nn_components == jp_iam_opa ) THEN 
     701         ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     702         ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE. 
     703         ssnd( jps_e3t1st )%laction = lk_vvl 
     704         ! vector definition: not used but cleaner... 
     705         ssnd(jps_ocx1)%clgrid  = 'U'        ! oce components given at U-point 
     706         ssnd(jps_ocy1)%clgrid  = 'V'        !           and           V-point 
     707         sn_snd_crt%clvgrd = 'U,V' 
     708         sn_snd_crt%clvor = 'local grid' 
     709         sn_snd_crt%clvref = 'spherical' 
     710         ! 
     711         IF(lwp) THEN                        ! control print 
     712            WRITE(numout,*) 
     713            WRITE(numout,*)'  sent fields to SAS component ' 
     714            WRITE(numout,*)'               sea surface temperature (T before, Celcius) ' 
     715            WRITE(numout,*)'               sea surface salinity '  
     716            WRITE(numout,*)'               surface currents U,V on local grid and spherical coordinates'  
     717            WRITE(numout,*)'               sea surface height '  
     718            WRITE(numout,*)'               thickness of first ocean T level '         
     719            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level' 
     720            WRITE(numout,*) 
     721         ENDIF 
     722      ENDIF 
     723      !                                                      ! ------------------------------- ! 
     724      !                                                      !   OPA-SAS coupling - snd by sas !    
     725      !                                                      ! ------------------------------- ! 
     726      ssnd(jps_sflx  )%clname = 'I_SFLX'      
     727      ssnd(jps_fice2 )%clname = 'IIceFrc' 
     728      ssnd(jps_qsroce)%clname = 'I_QsrOce'    
     729      ssnd(jps_qnsoce)%clname = 'I_QnsOce'    
     730      ssnd(jps_oemp  )%clname = 'IOEvaMPr'  
     731      ssnd(jps_otx1  )%clname = 'I_OTaux1'    
     732      ssnd(jps_oty1  )%clname = 'I_OTauy1'    
     733      ssnd(jps_rnf   )%clname = 'I_Runoff'    
     734      ssnd(jps_taum  )%clname = 'I_TauMod'    
     735      ! 
     736      IF( nn_components == jp_iam_sas ) THEN 
     737         IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     738         ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE. 
     739         ! 
     740         ! Change first letter to couple with atmosphere if already coupled with sea_ice 
     741         ! this is nedeed as each variable name used in the namcouple must be unique: 
     742         ! for example O_SSTSST sent by OPA to SAS and therefore S_SSTSST sent by SAS to the Atmosphere 
     743         DO jn = 1, jpsnd 
     744            IF ( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname)) 
     745         END DO 
     746         ! 
     747         IF(lwp) THEN                        ! control print 
     748            WRITE(numout,*) 
     749            IF( .NOT. ln_cpl ) THEN 
     750               WRITE(numout,*)'  sent fields to OPA component ' 
     751            ELSE 
     752               WRITE(numout,*)'  Additional sent fields to OPA component : ' 
     753            ENDIF 
     754            WRITE(numout,*)'                  ice cover ' 
     755            WRITE(numout,*)'                  oce only EMP  ' 
     756            WRITE(numout,*)'                  salt flux  ' 
     757            WRITE(numout,*)'                  mixed oce-ice solar flux  ' 
     758            WRITE(numout,*)'                  mixed oce-ice non solar flux  ' 
     759            WRITE(numout,*)'                  wind stress U,V components' 
     760            WRITE(numout,*)'                  wind stress module' 
     761         ENDIF 
     762      ENDIF 
     763 
    569764      ! 
    570765      ! ================================ ! 
    … …  
    572767      ! ================================ ! 
    573768 
    574       CALL cpl_define(jprcv, jpsnd,nn_cplmodel)             
     769      CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 
     770       
    575771      IF (ln_usecplmask) THEN  
    576772         xcplmask(:,:,:) = 0. 
    … …  
    582778         xcplmask(:,:,:) = 1. 
    583779      ENDIF 
    584       ! 
    585       IF( ln_dm2dc .AND. ( cpl_freq( jpr_qsroce ) + cpl_freq( jpr_qsrmix ) /= 86400 ) )   & 
     780      xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 
     781      ! 
     782      ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) 
     783      IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 )   & 
    586784         &   CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 
     785      ncpl_qsr_freq = 86400 / ncpl_qsr_freq 
    587786 
    588787      CALL wrk_dealloc( jpi,jpj, zacs, zaos ) 
    … …  
    638837      !!                        emp          upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case) 
    639838      !!---------------------------------------------------------------------- 
    640       INTEGER, INTENT(in) ::   kt       ! ocean model time step index 
    641       INTEGER, INTENT(in) ::   k_fsbc   ! frequency of sbc (-> ice model) computation  
    642       INTEGER, INTENT(in) ::   k_ice    ! ice management in the sbc (=0/1/2/3) 
    643       !! 
    644       LOGICAL ::    llnewtx, llnewtau      ! update wind stress components and module?? 
     839      INTEGER, INTENT(in)           ::   kt          ! ocean model time step index 
     840      INTEGER, INTENT(in)           ::   k_fsbc      ! frequency of sbc (-> ice model) computation  
     841      INTEGER, INTENT(in)           ::   k_ice       ! ice management in the sbc (=0/1/2/3) 
     842 
     843      !! 
     844      LOGICAL  ::   llnewtx, llnewtau      ! update wind stress components and module?? 
    645845      INTEGER  ::   ji, jj, jn             ! dummy loop indices 
    646846      INTEGER  ::   isec                   ! number of seconds since nit000 (assuming rdttra did not change since nit000) 
    … …  
    650850      REAL(wp) ::   zcdrag = 1.5e-3        ! drag coefficient 
    651851      REAL(wp) ::   zzx, zzy               ! temporary variables 
    652       REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty  
     852      REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty, zmsk, zemp, zqns, zqsr 
    653853      !!---------------------------------------------------------------------- 
    654854      ! 
    655855      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_rcv') 
    656856      ! 
    657       CALL wrk_alloc( jpi,jpj, ztx, zty ) 
    658       !                                                 ! Receive all the atmos. fields (including ice information) 
    659       isec = ( kt - nit000 ) * NINT( rdttra(1) )             ! date of exchanges 
    660       DO jn = 1, jprcv                                       ! received fields sent by the atmosphere 
    661          IF( srcv(jn)%laction )   CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask, nrcvinfo(jn) ) 
     857      CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
     858      ! 
     859      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
     860      ! 
     861      !                                                      ! ======================================================= ! 
     862      !                                                      ! Receive all the atmos. fields (including ice information) 
     863      !                                                      ! ======================================================= ! 
     864      isec = ( kt - nit000 ) * NINT( rdttra(1) )                ! date of exchanges 
     865      DO jn = 1, jprcv                                          ! received fields sent by the atmosphere 
     866         IF( srcv(jn)%laction )   CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) ) 
    662867      END DO 
    663868 
    … …  
    719924         ! 
    720925      ENDIF 
    721        
    722926      !                                                      ! ========================= ! 
    723927      !                                                      !    wind stress module     !   (taum) 
    … …  
    748952         ENDIF 
    749953      ENDIF 
    750        
     954      ! 
    751955      !                                                      ! ========================= ! 
    752956      !                                                      !      10 m wind speed      !   (wndm) 
    … …  
    761965!CDIR NOVERRCHK 
    762966               DO ji = 1, jpi  
    763                   wndm(ji,jj) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
     967                  frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
    764968               END DO 
    765969            END DO 
    766970         ENDIF 
    767       ELSE 
    768          IF ( nrcvinfo(jpr_w10m) == OASIS_Rcv ) wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 
    769971      ENDIF 
    770972 
    … …  
    773975      IF( MOD( kt-1, k_fsbc ) == 0 ) THEN 
    774976         ! 
    775          utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 
    776          vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 
    777          taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 
     977         IF( ln_mixcpl ) THEN 
     978            utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:) 
     979            vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:) 
     980            taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:) 
     981            wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:) 
     982         ELSE 
     983            utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 
     984            vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 
     985            taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 
     986            wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 
     987         ENDIF 
    778988         CALL iom_put( "taum_oce", taum )   ! output wind stress module 
    779989         !   
    … …  
    781991 
    782992#if defined key_cpl_carbon_cycle 
    783       !                                                              ! atmosph. CO2 (ppm) 
     993      !                                                      ! ================== ! 
     994      !                                                      ! atmosph. CO2 (ppm) ! 
     995      !                                                      ! ================== ! 
    784996      IF( srcv(jpr_co2)%laction )   atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 
    785997#endif 
    786998 
     999      !  Fields received by SAS when OASIS coupling 
     1000      !  (arrays no more filled at sbcssm stage) 
     1001      !                                                      ! ================== ! 
     1002      !                                                      !        SSS         ! 
     1003      !                                                      ! ================== ! 
     1004      IF( srcv(jpr_soce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1005         sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1) 
     1006         CALL iom_put( 'sss_m', sss_m ) 
     1007      ENDIF 
     1008      !                                                
     1009      !                                                      ! ================== ! 
     1010      !                                                      !        SST         ! 
     1011      !                                                      ! ================== ! 
     1012      IF( srcv(jpr_toce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1013         sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 
     1014         IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN    ! make sure that sst_m is the potential temperature 
     1015            sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 
     1016         ENDIF 
     1017      ENDIF 
     1018      !                                                      ! ================== ! 
     1019      !                                                      !        SSH         ! 
     1020      !                                                      ! ================== ! 
     1021      IF( srcv(jpr_ssh )%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1022         ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) 
     1023         CALL iom_put( 'ssh_m', ssh_m ) 
     1024      ENDIF 
     1025      !                                                      ! ================== ! 
     1026      !                                                      !  surface currents  ! 
     1027      !                                                      ! ================== ! 
     1028      IF( srcv(jpr_ocx1)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
     1030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1031         CALL iom_put( 'ssu_m', ssu_m ) 
     1032      ENDIF 
     1033      IF( srcv(jpr_ocy1)%laction ) THEN 
     1034         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
     1035         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1036         CALL iom_put( 'ssv_m', ssv_m ) 
     1037      ENDIF 
     1038      !                                                      ! ======================== ! 
     1039      !                                                      !  first T level thickness ! 
     1040      !                                                      ! ======================== ! 
     1041      IF( srcv(jpr_e3t1st )%laction ) THEN                   ! received by sas in case of opa <-> sas coupling 
     1042         e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) 
     1043         CALL iom_put( 'e3t_m', e3t_m(:,:) ) 
     1044      ENDIF 
     1045      !                                                      ! ================================ ! 
     1046      !                                                      !  fraction of solar net radiation ! 
     1047      !                                                      ! ================================ ! 
     1048      IF( srcv(jpr_fraqsr)%laction ) THEN                    ! received by sas in case of opa <-> sas coupling 
     1049         frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) 
     1050         CALL iom_put( 'frq_m', frq_m ) 
     1051      ENDIF 
     1052       
    7871053      !                                                      ! ========================= ! 
    788       IF( k_ice <= 1 ) THEN                                  !  heat & freshwater fluxes ! (Ocean only case) 
     1054      IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN   !  heat & freshwater fluxes ! (Ocean only case) 
    7891055         !                                                   ! ========================= ! 
    7901056         ! 
    7911057         !                                                       ! total freshwater fluxes over the ocean (emp) 
    792          SELECT CASE( TRIM( sn_rcv_emp%cldes ) )                                    ! evaporation - precipitation 
    793          CASE( 'conservative' ) 
    794             emp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 
    795          CASE( 'oce only', 'oce and ice' ) 
    796             emp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 
    797          CASE default 
    798             CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 
    799          END SELECT 
     1058         IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN 
     1059            SELECT CASE( TRIM( sn_rcv_emp%cldes ) )                                    ! evaporation - precipitation 
     1060            CASE( 'conservative' ) 
     1061               zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 
     1062            CASE( 'oce only', 'oce and ice' ) 
     1063               zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 
     1064            CASE default 
     1065               CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 
     1066            END SELECT 
     1067         ELSE 
     1068            zemp(:,:) = 0._wp 
     1069         ENDIF 
    8001070         ! 
    8011071         !                                                        ! runoffs and calving (added in emp) 
    802          IF( srcv(jpr_rnf)%laction )   emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    803          IF( srcv(jpr_cal)%laction )   emp(:,:) = emp(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    804          ! 
    805 !!gm :  this seems to be internal cooking, not sure to need that in a generic interface  
    806 !!gm                                       at least should be optional... 
    807 !!         IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN     ! add to the total freshwater budget 
    808 !!            ! remove negative runoff 
    809 !!            zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )  
    810 !!            zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 
    811 !!            IF( lk_mpp )   CALL mpp_sum( zcumulpos )   ! sum over the global domain 
    812 !!            IF( lk_mpp )   CALL mpp_sum( zcumulneg )  
    813 !!            IF( zcumulpos /= 0. ) THEN                 ! distribute negative runoff on positive runoff grid points 
    814 !!               zcumulneg = 1.e0 + zcumulneg / zcumulpos 
    815 !!               frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 
    816 !!            ENDIF      
    817 !!            ! add runoff to e-p  
    818 !!            emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    819 !!         ENDIF 
    820 !!gm  end of internal cooking 
     1072         IF( srcv(jpr_rnf)%laction )     rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1073         IF( srcv(jpr_cal)%laction )     zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1074          
     1075         IF( ln_mixcpl ) THEN   ;   emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) 
     1076         ELSE                   ;   emp(:,:) =                              zemp(:,:) 
     1077         ENDIF 
    8211078         ! 
    8221079         !                                                       ! non solar heat flux over the ocean (qns) 
    823          IF( srcv(jpr_qnsoce)%laction )   qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
    824          IF( srcv(jpr_qnsmix)%laction )   qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1080         IF(      srcv(jpr_qnsoce)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1081         ELSE IF( srcv(jpr_qnsmix)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1082         ELSE                                       ;   zqns(:,:) = 0._wp 
     1083         END IF 
    8251084         ! update qns over the free ocean with: 
    826          qns(:,:) =  qns(:,:) - emp(:,:) * sst_m(:,:) * rcp            ! remove heat content due to mass flux (assumed to be at SST) 
    827          IF( srcv(jpr_snow  )%laction )   THEN 
    828               qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus    ! energy for melting solid precipitation over the free ocean 
     1085         IF( nn_components /= jp_iam_opa ) THEN 
     1086            zqns(:,:) =  zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp         ! remove heat content due to mass flux (assumed to be at SST) 
     1087            IF( srcv(jpr_snow  )%laction ) THEN 
     1088               zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus    ! energy for melting solid precipitation over the free ocean 
     1089            ENDIF 
     1090         ENDIF 
     1091         IF( ln_mixcpl ) THEN   ;   qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) 
     1092         ELSE                   ;   qns(:,:) =                              zqns(:,:) 
    8291093         ENDIF 
    8301094 
    8311095         !                                                       ! solar flux over the ocean          (qsr) 
    832          IF( srcv(jpr_qsroce)%laction )   qsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 
    833          IF( srcv(jpr_qsrmix)%laction )   qsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 
    834          IF( ln_dm2dc )   qsr(:,:) = sbc_dcy( qsr )                           ! modify qsr to include the diurnal cycle 
     1096         IF     ( srcv(jpr_qsroce)%laction ) THEN   ;   zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 
     1097         ELSE IF( srcv(jpr_qsrmix)%laction ) then   ;   zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1098         ELSE                                       ;   zqsr(:,:) = 0._wp 
     1099         ENDIF 
     1100         IF( ln_dm2dc .AND. ln_cpl )   zqsr(:,:) = sbc_dcy( zqsr )   ! modify qsr to include the diurnal cycle 
     1101         IF( ln_mixcpl ) THEN   ;   qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:) 
     1102         ELSE                   ;   qsr(:,:) =                              zqsr(:,:) 
     1103         ENDIF 
    8351104         ! 
    836    
    837       ENDIF 
    838       ! 
    839       CALL wrk_dealloc( jpi,jpj, ztx, zty ) 
     1105         ! salt flux over the ocean (received by opa in case of opa <-> sas coupling) 
     1106         IF( srcv(jpr_sflx )%laction )   sfx(:,:) = frcv(jpr_sflx  )%z3(:,:,1) 
     1107         ! Ice cover  (received by opa in case of opa <-> sas coupling) 
     1108         IF( srcv(jpr_fice )%laction )   fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1) 
     1109         ! 
     1110 
     1111      ENDIF 
     1112      ! 
     1113      CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
    8401114      ! 
    8411115      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_rcv') 
    … …  
    9341208            ! 
    9351209         ENDIF 
    936  
    9371210         !                                                      ! ======================= ! 
    9381211         !                                                      !     put on ice grid     ! 
    … …  
    10561329    
    10571330 
    1058    SUBROUTINE sbc_cpl_ice_flx( p_frld  , palbi   , psst    , pist    ) 
     1331   SUBROUTINE sbc_cpl_ice_flx( p_frld, palbi, psst, pist ) 
    10591332      !!---------------------------------------------------------------------- 
    10601333      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    … …  
    10981371      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    10991372      ! optional arguments, used only in 'mixed oce-ice' case 
    1100       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   palbi   ! all skies ice albedo  
    1101       REAL(wp), INTENT(in   ), DIMENSION(:,:  ), OPTIONAL ::   psst    ! sea surface temperature     [Celsius] 
    1102       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   pist    ! ice surface temperature     [Kelvin] 
    1103       ! 
    1104       INTEGER ::   jl   ! dummy loop index 
    1105       REAL(wp), POINTER, DIMENSION(:,:) ::   zcptn, ztmp, zicefr 
     1373      REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   palbi      ! all skies ice albedo  
     1374      REAL(wp), INTENT(in   ), DIMENSION(:,:  ), OPTIONAL ::   psst       ! sea surface temperature     [Celsius] 
     1375      REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   pist       ! ice surface temperature     [Kelvin] 
     1376      ! 
     1377      INTEGER ::   jl         ! dummy loop index 
     1378      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
     1379      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
     1380      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
     1381      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
    11061382      !!---------------------------------------------------------------------- 
    11071383      ! 
    11081384      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    11091385      ! 
    1110       CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr ) 
    1111  
     1386      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1387      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1388 
     1389      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    11121390      zicefr(:,:) = 1.- p_frld(:,:) 
    11131391      zcptn(:,:) = rcp * sst_m(:,:) 
    … …  
    11171395      !                                                      ! ========================= ! 
    11181396      ! 
    1119       !                                                           ! total Precipitations - total Evaporation (emp_tot) 
    1120       !                                                           ! solid precipitation  - sublimation       (emp_ice) 
    1121       !                                                           ! solid Precipitation                      (sprecip) 
     1397      !                                                           ! total Precipitation - total Evaporation (emp_tot) 
     1398      !                                                           ! solid precipitation - sublimation       (emp_ice) 
     1399      !                                                           ! solid Precipitation                     (sprecip) 
     1400      !                                                           ! liquid + solid Precipitation            (tprecip) 
    11221401      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    11231402      CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1124          sprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                 ! May need to ensure positive here 
    1125          tprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + sprecip (:,:) ! May need to ensure positive here 
    1126          emp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - tprecip(:,:) 
    1127          emp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
     1403         zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1404         ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 
     1405         zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1406         zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    11281407            CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
    11291408         IF( iom_use('hflx_rain_cea') )   & 
    … …  
    11361415            CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    11371416      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    1138          emp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1139          emp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
    1140          sprecip(:,:) = - frcv(jpr_semp)%z3(:,:,1) + frcv(jpr_ievp)%z3(:,:,1) 
     1417         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
     1418         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1419         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
     1420         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    11411421      END SELECT 
     1422 
     1423      IF( iom_use('subl_ai_cea') )   & 
     1424         CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
     1425      !    
     1426      !                                                           ! runoffs and calving (put in emp_tot) 
     1427      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1428      IF( srcv(jpr_cal)%laction ) THEN  
     1429         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1430         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1431      ENDIF 
     1432 
     1433      IF( ln_mixcpl ) THEN 
     1434         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1435         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1436         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1437         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1438      ELSE 
     1439         emp_tot(:,:) =                                  zemp_tot(:,:) 
     1440         emp_ice(:,:) =                                  zemp_ice(:,:) 
     1441         sprecip(:,:) =                                  zsprecip(:,:) 
     1442         tprecip(:,:) =                                  ztprecip(:,:) 
     1443      ENDIF 
    11421444 
    11431445         CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
    … …  
    11461448      IF( iom_use('snow_ai_cea') )   & 
    11471449         CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
    1148       IF( iom_use('subl_ai_cea') )   & 
    1149          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1150       !    
    1151       !                                                           ! runoffs and calving (put in emp_tot) 
    1152       IF( srcv(jpr_rnf)%laction ) THEN  
    1153          emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    1154             CALL iom_put( 'runoffs'      , frcv(jpr_rnf)%z3(:,:,1)              )   ! rivers 
    1155          IF( iom_use('hflx_rnf_cea') )   & 
    1156             CALL iom_put( 'hflx_rnf_cea' , frcv(jpr_rnf)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from rivers 
    1157       ENDIF 
    1158       IF( srcv(jpr_cal)%laction ) THEN  
    1159          emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    1160          CALL iom_put( 'calving', frcv(jpr_cal)%z3(:,:,1) ) 
    1161       ENDIF 
    1162       ! 
    1163 !!gm :  this seems to be internal cooking, not sure to need that in a generic interface  
    1164 !!gm                                       at least should be optional... 
    1165 !!       ! remove negative runoff                            ! sum over the global domain 
    1166 !!       zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )  
    1167 !!       zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 
    1168 !!       IF( lk_mpp )   CALL mpp_sum( zcumulpos ) 
    1169 !!       IF( lk_mpp )   CALL mpp_sum( zcumulneg )  
    1170 !!       IF( zcumulpos /= 0. ) THEN                          ! distribute negative runoff on positive runoff grid points 
    1171 !!          zcumulneg = 1.e0 + zcumulneg / zcumulpos 
    1172 !!          frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 
    1173 !!       ENDIF      
    1174 !!       emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1)   ! add runoff to e-p  
    1175 !! 
    1176 !!gm  end of internal cooking 
    11771450 
    11781451      !                                                      ! ========================= ! 
    … …  
    11801453      !                                                      ! ========================= ! 
    11811454      CASE( 'oce only' )                                     ! the required field is directly provided 
    1182          qns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1455         zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    11831456      CASE( 'conservative' )                                      ! the required fields are directly provided 
    1184          qns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1457         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    11851458         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    1186             qns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
     1459            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    11871460         ELSE 
    11881461            ! Set all category values equal for the moment 
    11891462            DO jl=1,jpl 
    1190                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1463               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    11911464            ENDDO 
    11921465         ENDIF 
    11931466      CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1194          qns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1467         zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    11951468         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    11961469            DO jl=1,jpl 
    1197                qns_tot(:,:   ) = qns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)    
    1198                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 
     1470               zqns_tot(:,:   ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)    
     1471               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 
    11991472            ENDDO 
    12001473         ELSE 
    12011474            qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    12021475            DO jl=1,jpl 
    1203                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1476               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1477               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    12041478            ENDDO 
    12051479         ENDIF 
    12061480      CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
    12071481! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    1208          qns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    1209          qns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
     1482         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1483         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    12101484            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    12111485            &                                                   +          pist(:,:,1)   * zicefr(:,:) ) ) 
    12121486      END SELECT 
    1213       ztmp(:,:) = p_frld(:,:) * sprecip(:,:) * lfus 
    1214       qns_tot(:,:) = qns_tot(:,:)                         &            ! qns_tot update over free ocean with: 
    1215          &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    1216          &          - (  emp_tot(:,:)                     &            ! remove the heat content of mass flux (assumed to be at SST) 
    1217          &             - emp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
    1218       IF( iom_use('hflx_snow_cea') )   & 
    1219          CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    12201487!!gm 
    1221 !!    currently it is taken into account in leads budget but not in the qns_tot, and thus not in  
     1488!!    currently it is taken into account in leads budget but not in the zqns_tot, and thus not in  
    12221489!!    the flux that enter the ocean.... 
    12231490!!    moreover 1 - it is not diagnose anywhere....  
    … …  
    12281495      IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    12291496         ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1230          qns_tot(:,:) = qns_tot(:,:) - ztmp(:,:) 
     1497         zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    12311498         IF( iom_use('hflx_cal_cea') )   & 
    12321499            CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    12331500      ENDIF 
     1501 
     1502      ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
     1503      IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
     1504 
     1505#if defined key_lim3 
     1506      CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1507 
     1508      ! --- evaporation --- ! 
     1509      ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
     1510      ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
     1511      !                 but it is incoherent WITH the ice model   
     1512      DO jl=1,jpl 
     1513         evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
     1514      ENDDO 
     1515      zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
     1516 
     1517      ! --- evaporation minus precipitation --- ! 
     1518      emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
     1519 
     1520      ! --- non solar flux over ocean --- ! 
     1521      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1522      zqns_oce = 0._wp 
     1523      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
     1524 
     1525      ! --- heat flux associated with emp --- ! 
     1526      zsnw(:,:) = 0._wp 
     1527      CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
     1528      zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
     1529         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
     1530         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
     1531      qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1532         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1533 
     1534      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1535      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
     1536 
     1537      ! --- total non solar flux --- ! 
     1538      zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1539 
     1540      ! --- in case both coupled/forced are active, we must mix values --- !  
     1541      IF( ln_mixcpl ) THEN 
     1542         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) 
     1543         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
     1544         DO jl=1,jpl 
     1545            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1546         ENDDO 
     1547         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
     1548         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
     1549!!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1550      ELSE 
     1551         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
     1552         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
     1553         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
     1554         qprec_ice(:,:)   = zqprec_ice(:,:) 
     1555         qemp_oce (:,:)   = zqemp_oce (:,:) 
     1556      ENDIF 
     1557 
     1558      CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1559#else 
     1560 
     1561      ! clem: this formulation is certainly wrong... but better than it was... 
     1562      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
     1563         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
     1564         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
     1565         &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1566 
     1567     IF( ln_mixcpl ) THEN 
     1568         qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1569         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) +  zqns_tot(:,:)* zmsk(:,:) 
     1570         DO jl=1,jpl 
     1571            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1572         ENDDO 
     1573      ELSE 
     1574         qns_tot(:,:  ) = zqns_tot(:,:  ) 
     1575         qns_ice(:,:,:) = zqns_ice(:,:,:) 
     1576      ENDIF 
     1577 
     1578#endif 
    12341579 
    12351580      !                                                      ! ========================= ! 
    … …  
    12371582      !                                                      ! ========================= ! 
    12381583      CASE( 'oce only' ) 
    1239          qsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 
     1584         zqsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 
    12401585      CASE( 'conservative' ) 
    1241          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1586         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    12421587         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 
    1243             qsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 
     1588            zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 
    12441589         ELSE 
    12451590            ! Set all category values equal for the moment 
    12461591            DO jl=1,jpl 
    1247                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
     1592               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    12481593            ENDDO 
    12491594         ENDIF 
    1250          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    1251          qsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 
     1595         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1596         zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 
    12521597      CASE( 'oce and ice' ) 
    1253          qsr_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
     1598         zqsr_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
    12541599         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 
    12551600            DO jl=1,jpl 
    1256                qsr_tot(:,:   ) = qsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)    
    1257                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 
     1601               zqsr_tot(:,:   ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)    
     1602               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 
    12581603            ENDDO 
    12591604         ELSE 
    12601605            qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    12611606            DO jl=1,jpl 
    1262                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
     1607               zqsr_tot(:,:   ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
     1608               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    12631609            ENDDO 
    12641610         ENDIF 
    12651611      CASE( 'mixed oce-ice' ) 
    1266          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1612         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    12671613! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    12681614!       Create solar heat flux over ice using incoming solar heat flux and albedos 
    12691615!       ( see OASIS3 user guide, 5th edition, p39 ) 
    1270          qsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   & 
     1616         zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   & 
    12711617            &            / (  1.- ( albedo_oce_mix(:,:  ) * p_frld(:,:)       & 
    12721618            &                     + palbi         (:,:,1) * zicefr(:,:) ) ) 
    12731619      END SELECT 
    1274       IF( ln_dm2dc ) THEN   ! modify qsr to include the diurnal cycle 
    1275          qsr_tot(:,:  ) = sbc_dcy( qsr_tot(:,:  ) ) 
     1620      IF( ln_dm2dc .AND. ln_cpl ) THEN   ! modify qsr to include the diurnal cycle 
     1621         zqsr_tot(:,:  ) = sbc_dcy( zqsr_tot(:,:  ) ) 
    12761622         DO jl=1,jpl 
    1277             qsr_ice(:,:,jl) = sbc_dcy( qsr_ice(:,:,jl) ) 
     1623            zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) 
    12781624         ENDDO 
     1625      ENDIF 
     1626 
     1627#if defined key_lim3 
     1628      CALL wrk_alloc( jpi,jpj, zqsr_oce )  
     1629      ! --- solar flux over ocean --- ! 
     1630      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1631      zqsr_oce = 0._wp 
     1632      WHERE( p_frld /= 0._wp )  zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:) 
     1633 
     1634      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
     1635      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
     1636 
     1637      CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
     1638#endif 
     1639 
     1640      IF( ln_mixcpl ) THEN 
     1641         qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1642         qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) +  zqsr_tot(:,:)* zmsk(:,:) 
     1643         DO jl=1,jpl 
     1644            qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) +  zqsr_ice(:,:,jl)* zmsk(:,:) 
     1645         ENDDO 
     1646      ELSE 
     1647         qsr_tot(:,:  ) = zqsr_tot(:,:  ) 
     1648         qsr_ice(:,:,:) = zqsr_ice(:,:,:) 
    12791649      ENDIF 
    12801650 
    … …  
    12841654      CASE ('coupled') 
    12851655         IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN 
    1286             dqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 
     1656            zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 
    12871657         ELSE 
    12881658            ! Set all category values equal for the moment 
    12891659            DO jl=1,jpl 
    1290                dqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 
     1660               zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 
    12911661            ENDDO 
    12921662         ENDIF 
    12931663      END SELECT 
    1294  
     1664       
     1665      IF( ln_mixcpl ) THEN 
     1666         DO jl=1,jpl 
     1667            dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:) 
     1668         ENDDO 
     1669      ELSE 
     1670         dqns_ice(:,:,:) = zdqns_ice(:,:,:) 
     1671      ENDIF 
     1672       
    12951673      !                                                      ! ========================= ! 
    12961674      SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) )             !    topmelt and botmelt    ! 
    … …  
    13081686      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    13091687 
    1310       CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr ) 
     1688      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1689      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
    13111690      ! 
    13121691      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    13281707      INTEGER ::   ji, jj, jl   ! dummy loop indices 
    13291708      INTEGER ::   isec, info   ! local integer 
     1709      REAL(wp) ::   zumax, zvmax 
    13301710      REAL(wp), POINTER, DIMENSION(:,:)   ::   zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 
    13311711      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztmp3, ztmp4    
    … …  
    13441724      !                                                      ! ------------------------- ! 
    13451725      IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN 
    1346          SELECT CASE( sn_snd_temp%cldes) 
    1347          CASE( 'oce only'             )   ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0 
    1348          CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)    
    1349             SELECT CASE( sn_snd_temp%clcat ) 
    1350             CASE( 'yes' )    
    1351                ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1352             CASE( 'no' ) 
    1353                ztmp3(:,:,:) = 0.0 
     1726          
     1727         IF ( nn_components == jp_iam_opa ) THEN 
     1728            ztmp1(:,:) = tsn(:,:,1,jp_tem)   ! send temperature as it is (potential or conservative) -> use of ln_useCT on the received part 
     1729         ELSE 
     1730            ! we must send the surface potential temperature  
     1731            IF( ln_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     1732            ELSE                    ;   ztmp1(:,:) = tsn(:,:,1,jp_tem) 
     1733            ENDIF 
     1734            ! 
     1735            SELECT CASE( sn_snd_temp%cldes) 
     1736            CASE( 'oce only'             )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0 
     1737            CASE( 'oce and ice'          )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0 
     1738               SELECT CASE( sn_snd_temp%clcat ) 
     1739               CASE( 'yes' )    
     1740                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) 
     1741               CASE( 'no' ) 
     1742                  WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1743                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1744                  ELSEWHERE 
     1745                     ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     1746                  END WHERE 
     1747               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1748               END SELECT 
     1749            CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)    
     1750               SELECT CASE( sn_snd_temp%clcat ) 
     1751               CASE( 'yes' )    
     1752                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1753               CASE( 'no' ) 
     1754                  ztmp3(:,:,:) = 0.0 
     1755                  DO jl=1,jpl 
     1756                     ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1757                  ENDDO 
     1758               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1759               END SELECT 
     1760            CASE( 'mixed oce-ice'        )    
     1761               ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)  
    13541762               DO jl=1,jpl 
    1355                   ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1763                  ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    13561764               ENDDO 
    1357             CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1765            CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    13581766            END SELECT 
    1359          CASE( 'mixed oce-ice'        )    
    1360             ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)  
    1361             DO jl=1,jpl 
    1362                ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    1363             ENDDO 
    1364          CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    1365          END SELECT 
     1767         ENDIF 
    13661768         IF( ssnd(jps_toce)%laction )   CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
    13671769         IF( ssnd(jps_tice)%laction )   CALL cpl_snd( jps_tice, isec, ztmp3, info ) 
    … …  
    13721774      !                                                      ! ------------------------- ! 
    13731775      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1374          ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1776         SELECT CASE( sn_snd_alb%cldes ) 
     1777         CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1778         CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1779         CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1780         END SELECT 
    13751781         CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    13761782      ENDIF 
    … …  
    13851791      !                                                      !  Ice fraction & Thickness !  
    13861792      !                                                      ! ------------------------- ! 
    1387       ! Send ice fraction field  
     1793      ! Send ice fraction field to atmosphere 
    13881794      IF( ssnd(jps_fice)%laction ) THEN 
    13891795         SELECT CASE( sn_snd_thick%clcat ) 
    … …  
    13921798         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
    13931799         END SELECT 
    1394          CALL cpl_snd( jps_fice, isec, ztmp3, info ) 
     1800         IF( ssnd(jps_fice)%laction )   CALL cpl_snd( jps_fice, isec, ztmp3, info ) 
     1801      ENDIF 
     1802       
     1803      ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling) 
     1804      IF( ssnd(jps_fice2)%laction ) THEN 
     1805         ztmp3(:,:,1) = fr_i(:,:) 
     1806         IF( ssnd(jps_fice2)%laction )   CALL cpl_snd( jps_fice2, isec, ztmp3, info ) 
    13951807      ENDIF 
    13961808 
    … …  
    14131825            END SELECT 
    14141826         CASE( 'ice and snow'         )    
    1415             ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
    1416             ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     1827            SELECT CASE( sn_snd_thick%clcat ) 
     1828            CASE( 'yes' ) 
     1829               ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
     1830               ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     1831            CASE( 'no' ) 
     1832               WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1833                  ztmp3(:,:,1) = SUM( ht_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1834                  ztmp4(:,:,1) = SUM( ht_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1835               ELSEWHERE 
     1836                 ztmp3(:,:,1) = 0. 
     1837                 ztmp4(:,:,1) = 0. 
     1838               END WHERE 
     1839            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
     1840            END SELECT 
    14171841         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 
    14181842         END SELECT 
    … …  
    14401864         !                                                              i-1  i   i 
    14411865         !                                                               i      i+1 (for I) 
    1442          SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
    1443          CASE( 'oce only'             )      ! C-grid ==> T 
    1444             DO jj = 2, jpjm1 
    1445                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1446                   zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
    1447                   zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
    1448                END DO 
    1449             END DO 
    1450          CASE( 'weighted oce and ice' )    
    1451             SELECT CASE ( cp_ice_msh ) 
    1452             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1866         IF( nn_components == jp_iam_opa ) THEN 
     1867            zotx1(:,:) = un(:,:,1)   
     1868            zoty1(:,:) = vn(:,:,1)   
     1869         ELSE         
     1870            SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
     1871            CASE( 'oce only'             )      ! C-grid ==> T 
    14531872               DO jj = 2, jpjm1 
    14541873                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    1455                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1456                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
    1457                      zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    1458                      zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1874                     zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
     1875                     zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
    14591876                  END DO 
    14601877               END DO 
    1461             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
    1462                DO jj = 2, jpjm1 
    1463                   DO ji = 2, jpim1   ! NO vector opt. 
    1464                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1465                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
    1466                      zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
    1467                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1468                      zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
    1469                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1878            CASE( 'weighted oce and ice' )    
     1879               SELECT CASE ( cp_ice_msh ) 
     1880               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1881                  DO jj = 2, jpjm1 
     1882                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     1883                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1884                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
     1885                        zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     1886                        zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1887                     END DO 
    14701888                  END DO 
    1471                END DO 
    1472             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
    1473                DO jj = 2, jpjm1 
    1474                   DO ji = 2, jpim1   ! NO vector opt. 
    1475                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1476                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
    1477                      zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
    1478                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1479                      zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
    1480                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1889               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
     1890                  DO jj = 2, jpjm1 
     1891                     DO ji = 2, jpim1   ! NO vector opt. 
     1892                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1893                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
     1894                        zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
     1895                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1896                        zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
     1897                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1898                     END DO 
    14811899                  END DO 
    1482                END DO 
     1900               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
     1901                  DO jj = 2, jpjm1 
     1902                     DO ji = 2, jpim1   ! NO vector opt. 
     1903                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1904                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
     1905                        zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
     1906                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1907                        zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
     1908                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1909                     END DO 
     1910                  END DO 
     1911               END SELECT 
     1912               CALL lbc_lnk( zitx1, 'T', -1. )   ;   CALL lbc_lnk( zity1, 'T', -1. ) 
     1913            CASE( 'mixed oce-ice'        ) 
     1914               SELECT CASE ( cp_ice_msh ) 
     1915               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1916                  DO jj = 2, jpjm1 
     1917                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     1918                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
     1919                           &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     1920                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
     1921                           &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1922                     END DO 
     1923                  END DO 
     1924               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
     1925                  DO jj = 2, jpjm1 
     1926                     DO ji = 2, jpim1   ! NO vector opt. 
     1927                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
     1928                           &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
     1929                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1930                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
     1931                           &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
     1932                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1933                     END DO 
     1934                  END DO 
     1935               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
     1936                  DO jj = 2, jpjm1 
     1937                     DO ji = 2, jpim1   ! NO vector opt. 
     1938                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
     1939                           &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
     1940                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1941                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
     1942                           &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
     1943                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1944                     END DO 
     1945                  END DO 
     1946               END SELECT 
    14831947            END SELECT 
    1484             CALL lbc_lnk( zitx1, 'T', -1. )   ;   CALL lbc_lnk( zity1, 'T', -1. ) 
    1485          CASE( 'mixed oce-ice'        ) 
    1486             SELECT CASE ( cp_ice_msh ) 
    1487             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
    1488                DO jj = 2, jpjm1 
    1489                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    1490                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
    1491                         &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    1492                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
    1493                         &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
    1494                   END DO 
    1495                END DO 
    1496             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
    1497                DO jj = 2, jpjm1 
    1498                   DO ji = 2, jpim1   ! NO vector opt. 
    1499                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
    1500                         &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
    1501                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1502                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    1503                         &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
    1504                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1505                   END DO 
    1506                END DO 
    1507             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
    1508                DO jj = 2, jpjm1 
    1509                   DO ji = 2, jpim1   ! NO vector opt. 
    1510                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
    1511                         &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
    1512                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1513                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    1514                         &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
    1515                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1516                   END DO 
    1517                END DO 
    1518             END SELECT 
    1519          END SELECT 
    1520          CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. )   ;   CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
     1948            CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. )   ;   CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
     1949            ! 
     1950         ENDIF 
    15211951         ! 
    15221952         ! 
    … …  
    15581988      ENDIF 
    15591989      ! 
     1990      ! 
     1991      !  Fields sent by OPA to SAS when doing OPA<->SAS coupling 
     1992      !                                                        ! SSH 
     1993      IF( ssnd(jps_ssh )%laction )  THEN 
     1994         !                          ! removed inverse barometer ssh when Patm 
     1995         !                          forcing is used (for sea-ice dynamics) 
     1996         IF( ln_apr_dyn ) THEN   ;   ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 
     1997         ELSE                    ;   ztmp1(:,:) = sshn(:,:) 
     1998         ENDIF 
     1999         CALL cpl_snd( jps_ssh   , isec, RESHAPE ( ztmp1            , (/jpi,jpj,1/) ), info ) 
     2000 
     2001      ENDIF 
     2002      !                                                        ! SSS 
     2003      IF( ssnd(jps_soce  )%laction )  THEN 
     2004         CALL cpl_snd( jps_soce  , isec, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info ) 
     2005      ENDIF 
     2006      !                                                        ! first T level thickness  
     2007      IF( ssnd(jps_e3t1st )%laction )  THEN 
     2008         CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( fse3t_n(:,:,1)   , (/jpi,jpj,1/) ), info ) 
     2009      ENDIF 
     2010      !                                                        ! Qsr fraction 
     2011      IF( ssnd(jps_fraqsr)%laction )  THEN 
     2012         CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) 
     2013      ENDIF 
     2014      ! 
     2015      !  Fields sent by SAS to OPA when OASIS coupling 
     2016      !                                                        ! Solar heat flux 
     2017      IF( ssnd(jps_qsroce)%laction )  CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) 
     2018      IF( ssnd(jps_qnsoce)%laction )  CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) 
     2019      IF( ssnd(jps_oemp  )%laction )  CALL cpl_snd( jps_oemp  , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) 
     2020      IF( ssnd(jps_sflx  )%laction )  CALL cpl_snd( jps_sflx  , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) 
     2021      IF( ssnd(jps_otx1  )%laction )  CALL cpl_snd( jps_otx1  , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) 
     2022      IF( ssnd(jps_oty1  )%laction )  CALL cpl_snd( jps_oty1  , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) 
     2023      IF( ssnd(jps_rnf   )%laction )  CALL cpl_snd( jps_rnf   , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) 
     2024      IF( ssnd(jps_taum  )%laction )  CALL cpl_snd( jps_taum  , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) 
     2025 
    15602026      CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 
    15612027      CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    r5500 r5630  
    138138         IF      ( ksbc == jp_flx ) THEN 
    139139            CALL cice_sbc_force(kt) 
    140          ELSE IF ( ksbc == jp_cpl ) THEN 
     140         ELSE IF ( ksbc == jp_purecpl ) THEN 
    141141            CALL sbc_cpl_ice_flx( 1.0-fr_i  ) 
    142142         ENDIF 
    … …  
    146146         CALL cice_sbc_out ( kt, ksbc ) 
    147147 
    148          IF ( ksbc == jp_cpl )  CALL cice_sbc_hadgam(kt+1) 
     148         IF ( ksbc == jp_purecpl )  CALL cice_sbc_hadgam(kt+1) 
    149149 
    150150      ENDIF                                          ! End sea-ice time step only 
    … …  
    187187 
    188188! Do some CICE consistency checks 
    189       IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 
     189      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 
    190190         IF ( calc_strair .OR. calc_Tsfc ) THEN 
    191191            CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) 
    … …  
    212212 
    213213      CALL cice2nemo(aice,fr_i, 'T', 1. ) 
    214       IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 
     214      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 
    215215         DO jl=1,ncat 
    216216            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) 
    … …  
    319319! forced and coupled case  
    320320 
    321       IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 
     321      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 
    322322 
    323323         ztmpn(:,:,:)=0.0 
    … …  
    509509      CALL nemo2cice(ztmp,ss_tlty,'F', -1. ) 
    510510 
    511       CALL wrk_dealloc( jpi,jpj, ztmp ) 
     511      CALL wrk_dealloc( jpi,jpj, ztmp, zpice ) 
    512512      CALL wrk_dealloc( jpi,jpj,ncat, ztmpn ) 
    513513      ! 
    … …  
    587587      ELSE IF (ksbc == jp_core) THEN 
    588588         emp(:,:)  = (1.0-fr_i(:,:))*emp(:,:)         
    589       ELSE IF (ksbc == jp_cpl) THEN 
     589      ELSE IF (ksbc == jp_purecpl) THEN 
    590590! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above)  
    591591! This is currently as required with the coupling fields from the UM atmosphere 
    … …  
    623623      ENDIF 
    624624! Take into account snow melting except for fully coupled when already in qns_tot 
    625       IF (ksbc == jp_cpl) THEN 
     625      IF (ksbc == jp_purecpl) THEN 
    626626         qsr(:,:)= qsr_tot(:,:) 
    627627         qns(:,:)= qns_tot(:,:) 
    … …  
    658658 
    659659      CALL cice2nemo(aice,fr_i,'T', 1. ) 
    660       IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 
     660      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 
    661661         DO jl=1,ncat 
    662662            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r5500 r5630  
    105105         fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
    106106 
    107          IF( lk_cpl )   a_i(:,:,1) = fr_i(:,:)          
     107         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)          
    108108 
    109109         ! Flux and ice fraction computation 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r5500 r5630  
    3737   USE limdyn          ! Ice dynamics 
    3838   USE limtrp          ! Ice transport 
     39   USE limhdf          ! Ice horizontal diffusion 
    3940   USE limthd          ! Ice thermodynamics 
    4041   USE limitd_me       ! Mechanics on ice thickness distribution 
    … …  
    110111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    111112      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
     113      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    112114      !!---------------------------------------------------------------------- 
    113115 
    114116      IF( nn_timing == 1 )  CALL timing_start('sbc_ice_lim') 
    115117 
    116       IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only 
    117          !-----------------------!                                            
    118          ! --- Bulk Formulae --- !                                            
    119          !-----------------------! 
    120          u_oce(:,:) = ssu_m(:,:) * umask(:,:,1)      ! mean surface ocean current at ice velocity point 
    121          v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1)      ! (C-grid dynamics :  U- & V-points as the ocean) 
     118      !-----------------------! 
     119      ! --- Ice time step --- ! 
     120      !-----------------------! 
     121      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
     122 
     123         ! mean surface ocean current at ice velocity point (C-grid dynamics :  U- & V-points as the ocean) 
     124         u_oce(:,:) = ssu_m(:,:) * umask(:,:,1) 
     125         v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1) 
    122126          
    123127         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    124128         t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
    125          !                                                                                       
    126          ! Ice albedo 
    127          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    128          CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os )  ! cloud-sky and overcast-sky ice albedos 
    129  
    130          ! CORE and COUPLED bulk formulations 
    131          SELECT CASE( kblk ) 
    132          CASE( jp_core , jp_cpl ) 
    133  
    134             ! albedo depends on cloud fraction because of non-linear spectral effects 
    135             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    136             ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    137             ! (zalb_ice) is computed within the bulk routine 
    138              
    139          END SELECT 
    140129          
    141130         ! Mask sea ice surface temperature (set to rt0 over land) 
    142131         DO jl = 1, jpl 
    143132            t_su(:,:,jl) = t_su(:,:,jl) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
    144          END DO 
    145       
    146          ! Bulk formulae  - provides the following fields: 
    147          ! utau_ice, vtau_ice : surface ice stress                     (U- & V-points)   [N/m2] 
     133         END DO      
     134         ! 
     135         !------------------------------------------------!                                            
     136         ! --- Dynamical coupling with the atmosphere --- !                                            
     137         !------------------------------------------------! 
     138         ! It provides the following fields: 
     139         ! utau_ice, vtau_ice : surface ice stress (U- & V-points)   [N/m2] 
     140         !----------------------------------------------------------------- 
     141         SELECT CASE( kblk ) 
     142         CASE( jp_clio    )   ;   CALL blk_ice_clio_tau                         ! CLIO bulk formulation             
     143         CASE( jp_core    )   ;   CALL blk_ice_core_tau                         ! CORE bulk formulation 
     144         CASE( jp_purecpl )   ;   CALL sbc_cpl_ice_tau( utau_ice , vtau_ice )   ! Coupled   formulation 
     145         END SELECT 
     146          
     147         IF( ln_mixcpl) THEN   ! Case of a mixed Bulk/Coupled formulation 
     148            CALL wrk_alloc( jpi,jpj    , zutau_ice, zvtau_ice) 
     149            CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
     150            utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     151            vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     152            CALL wrk_dealloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     153         ENDIF 
     154 
     155         !-------------------------------------------------------! 
     156         ! --- ice dynamics and transport (except in 1D case) ---! 
     157         !-------------------------------------------------------! 
     158         numit = numit + nn_fsbc                  ! Ice model time step 
     159         !                                                    
     160         CALL sbc_lim_bef                         ! Store previous ice values 
     161         CALL sbc_lim_diag0                       ! set diag of mass, heat and salt fluxes to 0 
     162         CALL lim_rst_opn( kt )                   ! Open Ice restart file 
     163         ! 
     164         IF( .NOT. lk_c1d ) THEN 
     165            ! 
     166            CALL lim_dyn( kt )                    ! Ice dynamics    ( rheology/dynamics )    
     167            ! 
     168            CALL lim_trp( kt )                    ! Ice transport   ( Advection/diffusion ) 
     169            ! 
     170            IF( nn_monocat /= 2 ) CALL lim_itd_me ! Mechanical redistribution ! (ridging/rafting) 
     171            ! 
     172#if defined key_bdy 
     173            CALL bdy_ice_lim( kt )                ! bdy ice thermo  
     174            IF( ln_icectl )       CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 
     175#endif 
     176            ! 
     177            CALL lim_update1( kt )                ! Corrections 
     178            ! 
     179         ENDIF 
     180          
     181         ! previous lead fraction and ice volume for flux calculations 
     182         CALL sbc_lim_bef                         
     183         CALL lim_var_glo2eqv                     ! ht_i and ht_s for ice albedo calculation 
     184         CALL lim_var_agg(1)                      ! at_i for coupling (via pfrld)  
     185         pfrld(:,:)   = 1._wp - at_i(:,:) 
     186         phicif(:,:)  = vt_i(:,:) 
     187          
     188         !------------------------------------------------------!                                            
     189         ! --- Thermodynamical coupling with the atmosphere --- !                                            
     190         !------------------------------------------------------! 
     191         ! It provides the following fields: 
    148192         ! qsr_ice , qns_ice  : solar & non solar heat flux over ice   (T-point)         [W/m2] 
    149193         ! qla_ice            : latent heat flux over ice              (T-point)         [W/m2] 
    … …  
    151195         ! tprecip , sprecip  : total & solid precipitation            (T-point)         [Kg/m2/s] 
    152196         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    153          ! 
     197         !---------------------------------------------------------------------------------------- 
     198         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     199         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
     200 
    154201         SELECT CASE( kblk ) 
    155202         CASE( jp_clio )                                       ! CLIO bulk formulation 
    156             CALL blk_ice_clio( t_su , zalb_cs    , zalb_os    , zalb_ice  ,               & 
    157                &                      utau_ice   , vtau_ice   , qns_ice   , qsr_ice   ,   & 
    158                &                      qla_ice    , dqns_ice   , dqla_ice  ,               & 
    159                &                      tprecip    , sprecip    ,                           & 
    160                &                      fr1_i0     , fr2_i0     , cp_ice_msh, jpl  ) 
    161             !          
    162             IF( nn_limflx /= 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    163                &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    164  
     203            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
     204            ! (zalb_ice) is computed within the bulk routine 
     205            CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
     206            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     207            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    165208         CASE( jp_core )                                       ! CORE bulk formulation 
    166             CALL blk_ice_core( t_su , u_ice     , v_ice     , zalb_ice   ,               & 
    167                &                      utau_ice  , vtau_ice  , qns_ice    , qsr_ice   ,   & 
    168                &                      qla_ice   , dqns_ice  , dqla_ice   ,               & 
    169                &                      tprecip   , sprecip   ,                            & 
    170                &                      fr1_i0    , fr2_i0    , cp_ice_msh, jpl ) 
    171                ! 
    172             IF( nn_limflx /= 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    173                &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    174             ! 
    175          CASE ( jp_cpl ) 
    176              
    177             CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 
    178  
     209            ! albedo depends on cloud fraction because of non-linear spectral effects 
     210            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     211            CALL blk_ice_core_flx( t_su, zalb_ice ) 
     212            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     213            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     214         CASE ( jp_purecpl ) 
     215            ! albedo depends on cloud fraction because of non-linear spectral effects 
     216            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     217                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     218            ! clem: evap_ice is forced to 0 in coupled mode for now  
     219            !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
     220            evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
     221            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    179222         END SELECT 
    180           
    181          !------------------------------! 
    182          ! --- LIM-3 main time-step --- ! 
    183          !------------------------------! 
    184          numit = numit + nn_fsbc                     ! Ice model time step 
    185          !                                                    
    186          CALL sbc_lim_bef                   ! Store previous ice values 
    187  
    188          CALL sbc_lim_diag0                 ! set diag of mass, heat and salt fluxes to 0 
    189           
    190          CALL lim_rst_opn( kt )             ! Open Ice restart file 
    191          ! 
    192          ! ---------------------------------------------- 
    193          ! ice dynamics and transport (except in 1D case) 
    194          ! ---------------------------------------------- 
    195          IF( .NOT. lk_c1d ) THEN 
    196              
    197             CALL lim_dyn( kt )              ! Ice dynamics    ( rheology/dynamics ) 
    198              
    199             CALL lim_trp( kt )              ! Ice transport   ( Advection/diffusion ) 
    200              
    201             IF( nn_monocat /= 2 ) CALL lim_itd_me  ! Mechanical redistribution ! (ridging/rafting) 
    202  
    203 #if defined key_bdy 
    204             CALL bdy_ice_lim( kt )         ! bdy ice thermo  
    205             IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 
    206 #endif 
    207             CALL lim_update1( kt ) 
    208              
    209          ENDIF 
    210           
    211          CALL sbc_lim_bef                  ! Store previous ice values 
    212   
    213          ! ---------------------------------------------- 
    214          ! ice thermodynamics 
    215          ! ---------------------------------------------- 
    216          CALL lim_var_agg(1) 
    217           
    218          ! previous lead fraction and ice volume for flux calculations 
    219          pfrld(:,:)   = 1._wp - at_i(:,:) 
    220          phicif(:,:)  = vt_i(:,:) 
    221           
    222          SELECT CASE( kblk ) 
    223          CASE ( jp_cpl ) 
    224             CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
    225             IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    226                &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    227             ! Latent heat flux is forced to 0 in coupled: it is included in qns (non-solar heat flux) 
    228             qla_ice  (:,:,:) = 0._wp 
    229             dqla_ice (:,:,:) = 0._wp 
    230          END SELECT 
    231          ! 
    232          CALL lim_thd( kt )                         ! Ice thermodynamics  
    233           
     223         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     224 
     225         !----------------------------! 
     226         ! --- ice thermodynamics --- ! 
     227         !----------------------------! 
     228         CALL lim_thd( kt )                         ! Ice thermodynamics       
     229         ! 
    234230         CALL lim_update2( kt )                     ! Corrections 
    235231         ! 
    … …  
    237233         ! 
    238234         IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
    239           
     235         ! 
    240236         CALL lim_wri( 1 )                          ! Ice outputs  
    241           
     237         ! 
    242238         IF( kt == nit000 .AND. ln_rstart )   & 
    243239            &             CALL iom_close( numrir )  ! close input ice restart file 
    … …  
    247243         IF( ln_icectl )  CALL lim_ctl( kt )        ! alerts in case of model crash 
    248244         ! 
    249          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    250          ! 
    251245      ENDIF   ! End sea-ice time step only 
    252246 
    253       !--------------------------------! 
    254       ! --- at all ocean time step --- ! 
    255       !--------------------------------! 
    256       ! Update surface ocean stresses (only in ice-dynamic case) 
    257       !    otherwise the atm.-ocean stresses are used everywhere 
     247      !-------------------------! 
     248      ! --- Ocean time step --- ! 
     249      !-------------------------! 
     250      ! Update surface ocean stresses (only in ice-dynamic case) otherwise the atm.-ocean stresses are used everywhere 
    258251      IF( ln_limdyn )     CALL lim_sbc_tau( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    259252!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    260253      ! 
    261       IF( nn_timing == 1 )  CALL timing_stop('sbc_ice_lim') 
     254      IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_lim') 
    262255      ! 
    263256   END SUBROUTINE sbc_ice_lim 
    … …  
    300293      ! 
    301294      CALL lim_itd_init                ! ice thickness distribution initialization 
     295      ! 
     296      CALL lim_hdf_init                ! set ice horizontal diffusion computation parameters 
    302297      ! 
    303298      CALL lim_thd_init                ! set ice thermodynics parameters 
    … …  
    475470 
    476471    
    477    SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice,   & 
    478          &                          pdqn_ice, pqla_ice, pdql_ice, k_limflx ) 
     472   SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_limflx ) 
    479473      !!--------------------------------------------------------------------- 
    480474      !!                  ***  ROUTINE ice_lim_flx  *** 
    … …  
    494488      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqsr_ice   ! net solar flux 
    495489      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdqn_ice   ! non solar flux sensitivity 
    496       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqla_ice   ! latent heat flux 
    497       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdql_ice   ! latent heat flux sensitivity 
     490      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pevap_ice  ! sublimation 
     491      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdevap_ice ! sublimation sensitivity 
    498492      ! 
    499493      INTEGER  ::   jl      ! dummy loop index 
    … …  
    504498      REAL(wp), POINTER, DIMENSION(:,:) :: z_qsr_m   ! Mean solar heat flux over all categories 
    505499      REAL(wp), POINTER, DIMENSION(:,:) :: z_qns_m   ! Mean non solar heat flux over all categories 
    506       REAL(wp), POINTER, DIMENSION(:,:) :: z_qla_m   ! Mean latent heat flux over all categories 
     500      REAL(wp), POINTER, DIMENSION(:,:) :: z_evap_m  ! Mean sublimation over all categories 
    507501      REAL(wp), POINTER, DIMENSION(:,:) :: z_dqn_m   ! Mean d(qns)/dT over all categories 
    508       REAL(wp), POINTER, DIMENSION(:,:) :: z_dql_m   ! Mean d(qla)/dT over all categories 
     502      REAL(wp), POINTER, DIMENSION(:,:) :: z_devap_m ! Mean d(evap)/dT over all categories 
    509503      !!---------------------------------------------------------------------- 
    510504 
    … …  
    514508      SELECT CASE( k_limflx )                              !==  averaged on all ice categories  ==! 
    515509      CASE( 0 , 1 ) 
    516          CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 
    517          ! 
    518          z_qns_m(:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 
    519          z_qsr_m(:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 
    520          z_dqn_m(:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 
    521          z_qla_m(:,:) = fice_ice_ave ( pqla_ice (:,:,:) ) 
    522          z_dql_m(:,:) = fice_ice_ave ( pdql_ice (:,:,:) ) 
     510         CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 
     511         ! 
     512         z_qns_m  (:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 
     513         z_qsr_m  (:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 
     514         z_dqn_m  (:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 
     515         z_evap_m (:,:) = fice_ice_ave ( pevap_ice (:,:,:) ) 
     516         z_devap_m(:,:) = fice_ice_ave ( pdevap_ice (:,:,:) ) 
    523517         DO jl = 1, jpl 
    524             pdqn_ice(:,:,jl) = z_dqn_m(:,:) 
    525             pdql_ice(:,:,jl) = z_dql_m(:,:) 
     518            pdqn_ice  (:,:,jl) = z_dqn_m(:,:) 
     519            pdevap_ice(:,:,jl) = z_devap_m(:,:) 
    526520         END DO 
    527521         ! 
    528522         DO jl = 1, jpl 
    529             pqns_ice(:,:,jl) = z_qns_m(:,:) 
    530             pqsr_ice(:,:,jl) = z_qsr_m(:,:) 
    531             pqla_ice(:,:,jl) = z_qla_m(:,:) 
     523            pqns_ice (:,:,jl) = z_qns_m(:,:) 
     524            pqsr_ice (:,:,jl) = z_qsr_m(:,:) 
     525            pevap_ice(:,:,jl) = z_evap_m(:,:) 
    532526         END DO 
    533527         ! 
    534          CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 
     528         CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 
    535529      END SELECT 
    536530 
    … …  
    542536         ztem_m(:,:) = fice_ice_ave ( ptn_ice  (:,:,:) )  
    543537         DO jl = 1, jpl 
    544             pqns_ice(:,:,jl) = pqns_ice(:,:,jl) + pdqn_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 
    545             pqla_ice(:,:,jl) = pqla_ice(:,:,jl) + pdql_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 
    546             pqsr_ice(:,:,jl) = pqsr_ice(:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )  
     538            pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice  (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 
     539            pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 
     540            pqsr_ice (:,:,jl) = pqsr_ice (:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )  
    547541         END DO 
    548542         ! 
    … …  
    593587      wfx_spr(:,:) = 0._wp   ;    
    594588       
    595       hfx_in (:,:) = 0._wp   ;   hfx_out(:,:) = 0._wp 
    596589      hfx_thd(:,:) = 0._wp   ;    
    597590      hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
    … …  
    610603       
    611604   END SUBROUTINE sbc_lim_diag0 
    612        
     605 
     606      
    613607   FUNCTION fice_cell_ave ( ptab ) 
    614608      !!-------------------------------------------------------------------------- 
    … …  
    620614       
    621615      fice_cell_ave (:,:) = 0.0_wp 
    622        
    623616      DO jl = 1, jpl 
    624617         fice_cell_ave (:,:) = fice_cell_ave (:,:) + a_i (:,:,jl) * ptab (:,:,jl) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r5500 r5630  
    101101      REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice  ! mean ice albedo 
    102102      REAL(wp), DIMENSION(:,:,:), POINTER :: zsist     ! ice surface temperature (K) 
     103      REAL(wp), DIMENSION(:,:  ), POINTER :: zutau_ice, zvtau_ice  
    103104      !!---------------------------------------------------------------------- 
    104  
    105       CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    106105 
    107106      IF( kt == nit000 ) THEN 
    … …  
    124123         &*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) + 1 
    125124# endif 
     125 
     126         CALL wrk_alloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     127         CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
     128 
    126129         !  Bulk Formulea ! 
    127130         !----------------! 
    … …  
    132135               DO ji = 2, jpi   ! NO vector opt. possible 
    133136                  u_oce(ji,jj) = 0.5_wp * ( ssu_m(ji-1,jj  ) * umask(ji-1,jj  ,1) & 
    134                      &           + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 
     137                     &                    + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 
    135138                  v_oce(ji,jj) = 0.5_wp * ( ssv_m(ji  ,jj-1) * vmask(ji  ,jj-1,1) & 
    136                      &           + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 
     139                     &                    + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 
    137140               END DO 
    138141            END DO 
    … …  
    158161 
    159162         SELECT CASE( ksbc ) 
    160          CASE( jp_core , jp_cpl )   ! CORE and COUPLED bulk formulations 
     163         CASE( jp_core , jp_purecpl )   ! CORE and COUPLED bulk formulations 
    161164 
    162165            ! albedo depends on cloud fraction because of non-linear spectral effects 
    … …  
    182185         SELECT CASE( ksbc ) 
    183186         CASE( jp_clio )           ! CLIO bulk formulation 
    184             CALL blk_ice_clio( zsist, zalb_cs    , zalb_os    , zalb_ice   ,            & 
    185                &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
    186                &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
    187                &                      tprecip    , sprecip    ,                         & 
    188                &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
     187!           CALL blk_ice_clio( zsist, zalb_cs    , zalb_os    , zalb_ice   ,            & 
     188!              &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
     189!              &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
     190!              &                      tprecip    , sprecip    ,                         & 
     191!              &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
     192            CALL blk_ice_clio_tau 
     193            CALL blk_ice_clio_flx( zsist, zalb_cs, zalb_os, zalb_ice ) 
    189194 
    190195         CASE( jp_core )           ! CORE bulk formulation 
    191             CALL blk_ice_core( zsist, u_ice      , v_ice      , zalb_ice   ,            & 
    192                &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
    193                &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
    194                &                      tprecip    , sprecip    ,                         & 
    195                &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
    196             IF( ltrcdm2dc_ice )   CALL blk_ice_meanqsr( zalb_ice, qsr_ice_mean, jpl ) 
    197  
    198          CASE( jp_cpl )            ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 
     196            CALL blk_ice_core_tau 
     197            CALL blk_ice_core_flx( zsist, zalb_ice ) 
     198 
     199         CASE( jp_purecpl )            ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 
    199200            CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 
    200201         END SELECT 
     202          
     203         IF( ln_mixcpl) THEN 
     204            CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
     205            utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     206            vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     207         ENDIF 
    201208 
    202209         CALL iom_put( 'utau_ice', utau_ice )     ! Wind stress over ice along i-axis at I-point 
    … …  
    228235         END IF 
    229236         !                                             ! Ice surface fluxes in coupled mode  
    230          IF( ksbc == jp_cpl )   THEN 
     237         IF( ln_cpl ) THEN   ! pure coupled and mixed forced-coupled configurations 
    231238            a_i(:,:,1)=fr_i 
    232239            CALL sbc_cpl_ice_flx( frld,                                              & 
    233240            !                                optional arguments, used only in 'mixed oce-ice' case 
    234             &                                             palbi = zalb_ice, psst = sst_m, pist = zsist ) 
     241            &                                             palbi=zalb_ice, psst=sst_m, pist=zsist ) 
    235242            sprecip(:,:) = - emp_ice(:,:)   ! Ugly patch, WARNING, in coupled mode, sublimation included in snow (parsub = 0.) 
    236243         ENDIF 
    237244                           CALL lim_thd_2      ( kt )      ! Ice thermodynamics  
    238245                           CALL lim_sbc_flx_2  ( kt )      ! update surface ocean mass, heat & salt fluxes  
    239 #if defined key_top 
    240         IF( ltrcdm2dc_ice )CALL lim_bio_meanqsr_2 
    241 #endif 
    242246 
    243247         IF(  .NOT. lk_mpp )THEN 
    … …  
    253257         IF( .NOT. Agrif_Root() )   CALL agrif_update_lim2( kt ) 
    254258# endif 
     259         ! 
     260         CALL wrk_dealloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     261         CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    255262         ! 
    256263      ENDIF                                    ! End sea-ice time step only 
    … …  
    264271      IF( ln_limdyn    )   CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    265272      ! 
    266       CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    267       ! 
    268273   END SUBROUTINE sbc_ice_lim_2 
    269274 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r5500 r5630  
    2424   USE phycst           ! physical constants 
    2525   USE sbc_oce          ! Surface boundary condition: ocean fields 
     26   USE trc_oce          ! shared ocean-passive tracers variables 
    2627   USE sbc_ice          ! Surface boundary condition: ice fields 
    2728   USE sbcdcy           ! surface boundary condition: diurnal cycle 
    … …  
    3839   USE sbcice_cice      ! surface boundary condition: CICE    sea-ice model 
    3940   USE sbccpl           ! surface boundary condition: coupled florulation 
     41   USE cpl_oasis3       ! OASIS routines for coupling 
    4042   USE sbcssr           ! surface boundary condition: sea surface restoring 
    4143   USE sbcrnf           ! surface boundary condition: runoffs 
    … …  
    5153   USE timing           ! Timing 
    5254   USE sbcwave          ! Wave module 
     55   USE bdy_par          ! Require lk_bdy 
    5356 
    5457   IMPLICIT NONE 
    … …  
    8386      INTEGER ::   icpt   ! local integer 
    8487      !! 
    85       NAMELIST/namsbc/ nn_fsbc   , ln_ana    , ln_flx,  ln_blk_clio, ln_blk_core,           & 
    86          &             ln_blk_mfs, ln_apr_dyn, nn_ice,  nn_ice_embd, ln_dm2dc   , ln_rnf,   & 
    87          &             ln_ssr    ,  nn_isf , nn_fwb    , ln_cdgw , ln_wave , ln_sdw, nn_lsm, nn_limflx 
     88      NAMELIST/namsbc/ nn_fsbc   , ln_ana    , ln_flx, ln_blk_clio, ln_blk_core, ln_mixcpl,   & 
     89         &             ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc   , ln_rnf   ,   & 
     90         &             ln_ssr    , nn_isf    , nn_fwb, ln_cdgw    , ln_wave    , ln_sdw   ,   & 
     91         &             nn_lsm    , nn_limflx , nn_components, ln_cpl 
    8892      INTEGER  ::   ios 
     93      INTEGER  ::   ierr, ierr0, ierr1, ierr2, ierr3, jpm 
     94      LOGICAL  ::   ll_purecpl 
    8995      !!---------------------------------------------------------------------- 
    9096 
    … …  
    114120          nn_ice      =   0 
    115121      ENDIF 
    116       
     122 
    117123      IF(lwp) THEN               ! Control print 
    118124         WRITE(numout,*) '        Namelist namsbc (partly overwritten with CPP key setting)' 
    … …  
    124130         WRITE(numout,*) '              CORE bulk  formulation                     ln_blk_core = ', ln_blk_core 
    125131         WRITE(numout,*) '              MFS  bulk  formulation                     ln_blk_mfs  = ', ln_blk_mfs 
    126          WRITE(numout,*) '              coupled    formulation (T if key_oasis3)   lk_cpl      = ', lk_cpl 
     132         WRITE(numout,*) '              ocean-atmosphere coupled formulation       ln_cpl      = ', ln_cpl 
     133         WRITE(numout,*) '              forced-coupled mixed formulation           ln_mixcpl   = ', ln_mixcpl 
     134         WRITE(numout,*) '              OASIS coupling (with atm or sas)           lk_oasis    = ', lk_oasis 
     135         WRITE(numout,*) '              components of your executable              nn_components = ', nn_components 
    127136         WRITE(numout,*) '              Multicategory heat flux formulation (LIM3) nn_limflx   = ', nn_limflx 
    128137         WRITE(numout,*) '           Misc. options of sbc : ' 
    … …  
    151160      END SELECT 
    152161      ! 
    153 #if defined key_top && ! defined key_offline 
    154       ltrcdm2dc = (ln_dm2dc .AND. ln_blk_core .AND. nn_ice==2) 
    155       IF( ltrcdm2dc )THEN 
    156          IF(lwp)THEN 
    157             WRITE(numout,*)"analytical diurnal cycle, core bulk formulation and LIM2 use: " 
    158             WRITE(numout,*)"Diurnal cycle on physics but not in passive tracers" 
    159          ENDIF 
    160       ENDIF 
    161 #else  
    162       ltrcdm2dc =  .FALSE. 
    163 #endif 
    164  
    165       ! 
     162      IF ( nn_components /= jp_iam_nemo .AND. .NOT. lk_oasis )   & 
     163         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) 
     164      IF ( nn_components == jp_iam_opa .AND. ln_cpl )   & 
     165         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) 
     166      IF ( nn_components == jp_iam_opa .AND. ln_mixcpl )   & 
     167         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) 
     168      IF ( ln_cpl .AND. .NOT. lk_oasis )    & 
     169         &      CALL ctl_stop( 'STOP', 'sbc_init : OASIS-coupled atmosphere model, but key_oasis3 disabled' ) 
     170      IF( ln_mixcpl .AND. .NOT. lk_oasis )    & 
     171         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires the cpp key key_oasis3' ) 
     172      IF( ln_mixcpl .AND. .NOT. ln_cpl )    & 
     173         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires ln_cpl = T' ) 
     174      IF( ln_mixcpl .AND. nn_components /= jp_iam_nemo )    & 
     175         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) is not yet working with sas-opa coupling via oasis' ) 
     176 
    166177      !                              ! allocate sbc arrays 
    167178      IF( sbc_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_oce arrays' ) 
    168179 
    169180      !                          ! Checks: 
    170       IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths  
    171          ln_rnf_mouth  = .false.                       
    172          IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_rnf arrays' ) 
    173          nkrnf         = 0 
    174          rnf     (:,:) = 0.0_wp 
    175          rnf_b   (:,:) = 0.0_wp 
    176          rnfmsk  (:,:) = 0.0_wp 
    177          rnfmsk_z(:)   = 0.0_wp 
    178       ENDIF 
    179181      IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
    180182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    … …  
    182184         fwfisf_b(:,:) = 0.0_wp 
    183185      END IF 
    184       IF( nn_ice == 0  )   fr_i(:,:) = 0.e0        ! no ice in the domain, ice fraction is always zero 
     186      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    185187 
    186188      sfx(:,:) = 0.0_wp                            ! the salt flux due to freezing/melting will be computed (i.e. will be non-zero)  
    … …  
    192194 
    193195      !                                            ! restartability    
    194       IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
    195           MOD( nstock             , nn_fsbc) /= 0 ) THEN  
    196          WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
    197             &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
    198          CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
    199       ENDIF 
    200       ! 
    201       IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 )   & 
    202          &  CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 
    203       ! 
    204       IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. lk_cpl ) )   & 
     196      IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. ln_cpl ) )   & 
    205197         &   CALL ctl_stop( 'LIM sea-ice model requires a bulk formulation or coupled configuration' ) 
    206       IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. lk_cpl ) )   & 
    207          &   CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or lk_cpl' ) 
     198      IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. ln_cpl ) )   & 
     199         &   CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or ln_cpl' ) 
    208200      IF( nn_ice == 4 .AND. lk_agrif )   & 
    209201         &   CALL ctl_stop( 'CICE sea-ice model not currently available with AGRIF' ) 
    … …  
    212204      IF( ( nn_ice /= 3 ) .AND. ( nn_limflx >= 0 ) )   & 
    213205         &   WRITE(numout,*) 'The nn_limflx>=0 option has no effect if sea ice model is not LIM3' 
    214       IF( ( nn_ice == 3 ) .AND. ( lk_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) )   & 
     206      IF( ( nn_ice == 3 ) .AND. ( ln_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) )   & 
    215207         &   CALL ctl_stop( 'The chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 
    216       IF( ( nn_ice == 3 ) .AND. ( .NOT. lk_cpl ) .AND. ( nn_limflx == 2 ) )   & 
     208      IF( ( nn_ice == 3 ) .AND. ( .NOT. ln_cpl ) .AND. ( nn_limflx == 2 ) )   & 
    217209         &   CALL ctl_stop( 'The chosen nn_limflx for LIM3 in forced mode cannot be 2' ) 
    218210 
    219211      IF( ln_dm2dc )   nday_qsr = -1   ! initialisation flag 
    220212 
    221       IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) )   & 
     213      IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) .AND. nn_components /= jp_iam_opa )   & 
    222214         &   CALL ctl_stop( 'diurnal cycle into qsr field from daily values requires a flux or core-bulk formulation' ) 
    223215       
    224       IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) )  < 8 ) )   & 
    225          &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
    226  
    227216      IF ( ln_wave ) THEN 
    228217      !Activated wave module but neither drag nor stokes drift activated 
    … …  
    238227         & asked coupling with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ') 
    239228      ENDIF  
    240        
    241229      !                          ! Choice of the Surface Boudary Condition (set nsbc) 
     230      ll_purecpl = ln_cpl .AND. .NOT. ln_mixcpl 
     231      ! 
    242232      icpt = 0 
    243       IF( ln_ana          ) THEN   ;   nsbc = jp_ana    ; icpt = icpt + 1   ;   ENDIF       ! analytical      formulation 
    244       IF( ln_flx          ) THEN   ;   nsbc = jp_flx    ; icpt = icpt + 1   ;   ENDIF       ! flux            formulation 
    245       IF( ln_blk_clio     ) THEN   ;   nsbc = jp_clio   ; icpt = icpt + 1   ;   ENDIF       ! CLIO bulk       formulation 
    246       IF( ln_blk_core     ) THEN   ;   nsbc = jp_core   ; icpt = icpt + 1   ;   ENDIF       ! CORE bulk       formulation 
    247       IF( ln_blk_mfs      ) THEN   ;   nsbc = jp_mfs    ; icpt = icpt + 1   ;   ENDIF       ! MFS  bulk       formulation 
    248       IF( lk_cpl          ) THEN   ;   nsbc = jp_cpl    ; icpt = icpt + 1   ;   ENDIF       ! Coupled         formulation 
    249       IF( cp_cfg == 'gyre') THEN   ;   nsbc = jp_gyre                       ;   ENDIF       ! GYRE analytical formulation 
    250       IF( lk_esopa        )            nsbc = jp_esopa                                      ! esopa test, ALL formulations 
     233      IF( ln_ana          ) THEN   ;   nsbc = jp_ana     ; icpt = icpt + 1   ;   ENDIF       ! analytical           formulation 
     234      IF( ln_flx          ) THEN   ;   nsbc = jp_flx     ; icpt = icpt + 1   ;   ENDIF       ! flux                 formulation 
     235      IF( ln_blk_clio     ) THEN   ;   nsbc = jp_clio    ; icpt = icpt + 1   ;   ENDIF       ! CLIO bulk            formulation 
     236      IF( ln_blk_core     ) THEN   ;   nsbc = jp_core    ; icpt = icpt + 1   ;   ENDIF       ! CORE bulk            formulation 
     237      IF( ln_blk_mfs      ) THEN   ;   nsbc = jp_mfs     ; icpt = icpt + 1   ;   ENDIF       ! MFS  bulk            formulation 
     238      IF( ll_purecpl      ) THEN   ;   nsbc = jp_purecpl ; icpt = icpt + 1   ;   ENDIF       ! Pure Coupled         formulation 
     239      IF( cp_cfg == 'gyre') THEN   ;   nsbc = jp_gyre                        ;   ENDIF       ! GYRE analytical      formulation 
     240      IF( nn_components == jp_iam_opa )   & 
     241         &                  THEN   ;   nsbc = jp_none    ; icpt = icpt + 1   ;   ENDIF       ! opa coupling via SAS module 
     242      IF( lk_esopa        )            nsbc = jp_esopa                                       ! esopa test, ALL formulations 
    251243      ! 
    252244      IF( icpt /= 1 .AND. .NOT.lk_esopa ) THEN 
    … …  
    259251      IF(lwp) THEN 
    260252         WRITE(numout,*) 
    261          IF( nsbc == jp_esopa )   WRITE(numout,*) '              ESOPA test All surface boundary conditions' 
    262          IF( nsbc == jp_gyre  )   WRITE(numout,*) '              GYRE analytical formulation' 
    263          IF( nsbc == jp_ana   )   WRITE(numout,*) '              analytical formulation' 
    264          IF( nsbc == jp_flx   )   WRITE(numout,*) '              flux formulation' 
    265          IF( nsbc == jp_clio  )   WRITE(numout,*) '              CLIO bulk formulation' 
    266          IF( nsbc == jp_core  )   WRITE(numout,*) '              CORE bulk formulation' 
    267          IF( nsbc == jp_cpl   )   WRITE(numout,*) '              coupled formulation' 
    268          IF( nsbc == jp_mfs   )   WRITE(numout,*) '              MFS Bulk formulation' 
    269       ENDIF 
    270       ! 
     253         IF( nsbc == jp_esopa   )   WRITE(numout,*) '              ESOPA test All surface boundary conditions' 
     254         IF( nsbc == jp_gyre    )   WRITE(numout,*) '              GYRE analytical formulation' 
     255         IF( nsbc == jp_ana     )   WRITE(numout,*) '              analytical formulation' 
     256         IF( nsbc == jp_flx     )   WRITE(numout,*) '              flux formulation' 
     257         IF( nsbc == jp_clio    )   WRITE(numout,*) '              CLIO bulk formulation' 
     258         IF( nsbc == jp_core    )   WRITE(numout,*) '              CORE bulk formulation' 
     259         IF( nsbc == jp_purecpl )   WRITE(numout,*) '              pure coupled formulation' 
     260         IF( nsbc == jp_mfs     )   WRITE(numout,*) '              MFS Bulk formulation' 
     261         IF( nsbc == jp_none    )   WRITE(numout,*) '              OPA coupled to SAS via oasis' 
     262         IF( ln_mixcpl          )   WRITE(numout,*) '              + forced-coupled mixed formulation' 
     263         IF( nn_components/= jp_iam_nemo )  & 
     264            &                       WRITE(numout,*) '              + OASIS coupled SAS' 
     265      ENDIF 
     266      ! 
     267      IF( lk_oasis )   CALL sbc_cpl_init (nn_ice)   ! OASIS initialisation. must be done before: (1) first time step 
     268      !                                                     !                                            (2) the use of nn_fsbc 
     269 
     270!     nn_fsbc initialization if OPA-SAS coupling via OASIS 
     271!     sas model time step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly 
     272      IF ( nn_components /= jp_iam_nemo ) THEN 
     273 
     274         IF ( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) 
     275         IF ( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) 
     276         ! 
     277         IF(lwp)THEN 
     278            WRITE(numout,*) 
     279            WRITE(numout,*)"   OPA-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc 
     280            WRITE(numout,*) 
     281         ENDIF 
     282      ENDIF 
     283 
     284      IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
     285          MOD( nstock             , nn_fsbc) /= 0 ) THEN  
     286         WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
     287            &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     288         CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     289      ENDIF 
     290      ! 
     291      IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 )   & 
     292         &  CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 
     293      ! 
     294      IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) )  < 8 ) )   & 
     295         &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
     296 
    271297                               CALL sbc_ssm_init               ! Sea-surface mean fields initialisation 
    272298      ! 
    273299      IF( ln_ssr           )   CALL sbc_ssr_init               ! Sea-Surface Restoring initialisation 
    274300      ! 
     301                               CALL sbc_rnf_init               ! Runof initialisation 
     302      ! 
    275303      IF( nn_ice == 3      )   CALL sbc_lim_init               ! LIM3 initialisation 
    276304 
    277305      IF( nn_ice == 4      )   CALL cice_sbc_init( nsbc )      ! CICE initialisation 
    278       ! 
    279       IF( nsbc   == jp_cpl )   CALL sbc_cpl_init (nn_ice)      ! OASIS initialisation. must be done before first time step 
    280  
     306       
    281307   END SUBROUTINE sbc_init 
    282308 
    … …  
    318344      !                                            ! ---------------------------------------- ! 
    319345      ! 
    320       IF( ln_apr_dyn ) CALL sbc_apr( kt )                ! atmospheric pressure provided at kt+0.5*nn_fsbc 
     346      IF ( .NOT. lk_bdy ) then 
     347         IF( ln_apr_dyn ) CALL sbc_apr( kt )                ! atmospheric pressure provided at kt+0.5*nn_fsbc 
     348      ENDIF 
    321349                                                         ! (caution called before sbc_ssm) 
    322350      ! 
    323       CALL sbc_ssm( kt )                                 ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 
    324       !                                                  ! averaged over nf_sbc time-step 
     351      IF( nn_components /= jp_iam_sas )   CALL sbc_ssm( kt )   ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 
     352      !                                                        ! averaged over nf_sbc time-step 
    325353 
    326354      IF (ln_wave) CALL sbc_wave( kt ) 
    … …  
    333361      CASE( jp_flx   )   ;   CALL sbc_flx     ( kt )                    ! flux formulation 
    334362      CASE( jp_clio  )   ;   CALL sbc_blk_clio( kt )                    ! bulk formulation : CLIO for the ocean 
    335       CASE( jp_core  )   ;   CALL sbc_blk_core( kt )                    ! bulk formulation : CORE for the ocean 
    336       CASE( jp_cpl   )   ;   CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! coupled formulation 
     363      CASE( jp_core  )    
     364         IF( nn_components == jp_iam_sas ) & 
     365            &                CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: SAS receiving fields from OPA  
     366                             CALL sbc_blk_core( kt )                    ! bulk formulation : CORE for the ocean 
     367                                                                        ! from oce: sea surface variables (sst_m, sss_m,  ssu_m,  ssv_m) 
     368      CASE( jp_purecpl )  ;  CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! pure coupled formulation 
     369                                                                        ! 
    337370      CASE( jp_mfs   )   ;   CALL sbc_blk_mfs ( kt )                    ! bulk formulation : MFS for the ocean 
     371      CASE( jp_none  )  
     372         IF( nn_components == jp_iam_opa ) & 
     373                             CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: OPA receiving fields from SAS 
    338374      CASE( jp_esopa )                                 
    339375                             CALL sbc_ana     ( kt )                    ! ESOPA, test ALL the formulations 
    … …  
    345381      END SELECT 
    346382 
     383      IF( ln_mixcpl )        CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! forced-coupled mixed formulation after forcing 
     384 
     385 
    347386      !                                            !==  Misc. Options  ==! 
    348387       
    … …  
    367406      !                                                           ! (update freshwater fluxes) 
    368407!RBbug do not understand why see ticket 667 
    369       !clem-bugsal CALL lbc_lnk( emp, 'T', 1. ) 
     408!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 
     409      CALL lbc_lnk( emp, 'T', 1. ) 
    370410      ! 
    371411      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    … …  
    408448         ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b'  , qsr  ) 
    409449         CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp  ) 
    410          CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 
     450         CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx ) 
    411451      ENDIF 
    412452 
    … …  
    423463         CALL iom_put( "qns"   , qns        )                   ! solar heat flux 
    424464         CALL iom_put( "qsr"   ,       qsr  )                   ! solar heat flux 
    425          IF( nn_ice > 0 )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction  
     465         IF( nn_ice > 0 .OR. nn_components == jp_iam_opa )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction  
    426466         CALL iom_put( "taum"  , taum       )                   ! wind stress module  
    427467         CALL iom_put( "wspd"  , wndm       )                   ! wind speed  module over free ocean or leads in presence of sea-ice 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r5500 r5630  
    3232 
    3333   PUBLIC   sbc_rnf       ! routine call in sbcmod module 
    34    PUBLIC   sbc_rnf_div   ! routine called in sshwzv module 
     34   PUBLIC   sbc_rnf_div   ! routine called in divcurl module 
    3535   PUBLIC   sbc_rnf_alloc ! routine call in sbcmod module 
    3636   PUBLIC   sbc_rnf_init  ! (PUBLIC for TAM) 
    3737   !                                                     !!* namsbc_rnf namelist * 
    38    CHARACTER(len=100), PUBLIC ::   cn_dir          !: Root directory for location of ssr files 
    39    LOGICAL           , PUBLIC ::   ln_rnf_depth    !: depth       river runoffs attribute specified in a file 
    40    LOGICAL           , PUBLIC ::   ln_rnf_tem      !: temperature river runoffs attribute specified in a file 
     38   CHARACTER(len=100)         ::   cn_dir          !: Root directory for location of rnf files 
     39   LOGICAL                    ::   ln_rnf_depth      !: depth       river runoffs attribute specified in a file 
     40   LOGICAL                    ::   ln_rnf_depth_ini  !: depth       river runoffs  computed at the initialisation 
     41   REAL(wp)                   ::   rn_rnf_max        !: maximum value of the runoff climatologie ( ln_rnf_depth_ini = .true ) 
     42   REAL(wp)                   ::   rn_dep_max        !: depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) 
     43   INTEGER                    ::   nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) 
     44   LOGICAL                    ::   ln_rnf_tem      !: temperature river runoffs attribute specified in a file 
    4145   LOGICAL           , PUBLIC ::   ln_rnf_sal      !: salinity    river runoffs attribute specified in a file 
    42    LOGICAL           , PUBLIC ::   ln_rnf_emp      !: runoffs into a file to be read or already into precipitation 
    4346   TYPE(FLD_N)       , PUBLIC ::   sn_rnf          !: information about the runoff file to be read 
    44    TYPE(FLD_N)       , PUBLIC ::   sn_cnf          !: information about the runoff mouth file to be read 
     47   TYPE(FLD_N)               ::   sn_cnf          !: information about the runoff mouth file to be read 
    4548   TYPE(FLD_N)                ::   sn_s_rnf        !: information about the salinities of runoff file to be read 
    4649   TYPE(FLD_N)                ::   sn_t_rnf        !: information about the temperatures of runoff file to be read 
    4750   TYPE(FLD_N)                ::   sn_dep_rnf      !: information about the depth which river inflow affects 
    4851   LOGICAL           , PUBLIC ::   ln_rnf_mouth    !: specific treatment in mouths vicinity 
    49    REAL(wp)          , PUBLIC ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
     52   REAL(wp)                  ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5053   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    51    REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)                   ::   rn_rfact        !: multiplicative factor for runoff 
     55 
     56   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    5257 
    5358   INTEGER , PUBLIC  ::   nkrnf = 0         !: nb of levels over which Kz is increased at river mouths 
    … …  
    5863   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s]    
    5964 
    60    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    61    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    62    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
     65   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
     66   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
     67   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    6368  
    6469   !! * Substitutions   
    … …  
    105110      CALL wrk_alloc( jpi,jpj, ztfrz) 
    106111 
    107       ! 
    108       IF( kt == nit000 )   CALL sbc_rnf_init                           ! Read namelist and allocate structures 
    109  
    110112      !                                            ! ---------------------------------------- ! 
    111113      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    … …  
    116118      ENDIF 
    117119 
    118       !                                                   !-------------------! 
    119       IF( .NOT. ln_rnf_emp ) THEN                         !   Update runoff   ! 
    120          !                                                !-------------------! 
    121          ! 
    122                              CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt 
    123          IF( ln_rnf_tem  )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    124          IF( ln_rnf_sal  )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    125          ! 
    126          ! Runoff reduction only associated to the ORCA2_LIM configuration 
    127          ! when reading the NetCDF file runoff_1m_nomask.nc 
    128          IF( cp_cfg == 'orca' .AND. jp_cfg == 2 )   THEN 
    129             WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    130                sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
     120      !                                            !-------------------! 
     121      !                                            !   Update runoff   ! 
     122      !                                            !-------------------! 
     123      ! 
     124      IF( .NOT. l_rnfcpl )   CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt 
     125      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
     126      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
     127      ! 
     128      ! Runoff reduction only associated to the ORCA2_LIM configuration 
     129      ! when reading the NetCDF file runoff_1m_nomask.nc 
     130      IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
     131         WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
     132            sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
     133         END WHERE 
     134      ENDIF 
     135      ! 
     136      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
     137         ! 
     138         IF( .NOT. l_rnfcpl )   rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt 
     139         ! 
     140         !                                                     ! set temperature & salinity content of runoffs 
     141         IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
     142            rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     143            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature 
     144               rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    131145            END WHERE 
    132          ENDIF 
    133          ! 
    134          IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
    135             ! 
    136             rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt 
    137             ! 
    138             !                                                     ! set temperature & salinity content of runoffs 
    139             IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
    140                rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    141                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature 
    142                    rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    143                END WHERE 
    144                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg 
    145                    ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 
    146                    rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 
    147                END WHERE 
    148             ELSE                                                        ! use SST as runoffs temperature 
    149                rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    150             ENDIF 
    151             !                                                           ! use runoffs salinity data 
    152             IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    153             !                                                           ! else use S=0 for runoffs (done one for all in the init) 
    154             IF ( ANY( rnf(:,:) < 0._wp ) ) z_err=1 
    155             IF(lk_mpp) CALL mpp_sum(z_err) 
    156             IF( z_err > 0 ) CALL ctl_stop( 'sbc_rnf : negative runnoff values exist' ) 
    157             ! 
    158             CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
    159          ENDIF 
    160          ! 
    161       ENDIF 
    162       ! 
     146            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg 
     147               ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 
     148               rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 
     149            END WHERE 
     150         ELSE                                                        ! use SST as runoffs temperature 
     151            rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
     152         ENDIF 
     153         !                                                           ! use runoffs salinity data 
     154         IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     155         !                                                           ! else use S=0 for runoffs (done one for all in the init) 
     156         CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
     157      ENDIF 
     158      ! 
     159      !                                                ! ---------------------------------------- ! 
    163160      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    164161         !                                             ! ---------------------------------------- ! 
    … …  
    171168         ELSE                                                   !* no restart: set from nit000 values 
    172169            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    173              rnf_b    (:,:  ) = rnf    (:,:  ) 
    174              rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     170            rnf_b    (:,:  ) = rnf    (:,:  ) 
     171            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
    175172         ENDIF 
    176173      ENDIF 
    … …  
    186183         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 
    187184      ENDIF 
     185      ! 
    188186      CALL wrk_dealloc( jpi,jpj, ztfrz) 
    189187      ! 
    … …  
    211209      zfact = 0.5_wp 
    212210      ! 
    213       IF( ln_rnf_depth ) THEN      !==   runoff distributed over several levels   ==! 
     211      IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN      !==   runoff distributed over several levels   ==! 
    214212         IF( lk_vvl ) THEN             ! variable volume case 
    215213            DO jj = 1, jpj                   ! update the depth over which runoffs are distributed 
    … …  
    255253      !!---------------------------------------------------------------------- 
    256254      CHARACTER(len=32) ::   rn_dep_file   ! runoff file name 
    257       INTEGER           ::   ji, jj, jk    ! dummy loop indices 
     255      INTEGER           ::   ji, jj, jk, jm    ! dummy loop indices 
    258256      INTEGER           ::   ierror, inum  ! temporary integer 
    259257      INTEGER           ::   ios           ! Local integer output status for namelist read 
    260       ! 
    261       NAMELIST/namsbc_rnf/ cn_dir, ln_rnf_emp, ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   & 
     258      INTEGER           ::   nbrec         ! temporary integer 
     259      REAL(wp)          ::   zacoef   
     260      REAL(wp), DIMENSION(12)                 :: zrec             ! times records 
     261      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zrnfcl     
     262      REAL(wp), DIMENSION(:,:  ), ALLOCATABLE :: zrnf 
     263      ! 
     264      NAMELIST/namsbc_rnf/ cn_dir            , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   & 
    262265         &                 sn_rnf, sn_cnf    , sn_s_rnf    , sn_t_rnf  , sn_dep_rnf,   & 
    263          &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact 
    264       !!---------------------------------------------------------------------- 
     266         &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact,     & 
     267         &                 ln_rnf_depth_ini  , rn_dep_max  , rn_rnf_max, nn_rnf_depth_file 
     268      !!---------------------------------------------------------------------- 
     269      ! 
     270      !                                         !==  allocate runoff arrays 
     271      IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
     272      ! 
     273      IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths  
     274         ln_rnf_mouth  = .FALSE.                   ! default definition needed for example by sbc_ssr or by tra_adv_muscl 
     275         nkrnf         = 0 
     276         rnf     (:,:) = 0.0_wp 
     277         rnf_b   (:,:) = 0.0_wp 
     278         rnfmsk  (:,:) = 0.0_wp 
     279         rnfmsk_z(:)   = 0.0_wp 
     280         RETURN 
     281      ENDIF 
    265282      ! 
    266283      !                                   ! ============ 
    … …  
    283300         WRITE(numout,*) '~~~~~~~ ' 
    284301         WRITE(numout,*) '   Namelist namsbc_rnf' 
    285          WRITE(numout,*) '      runoff in a file to be read                ln_rnf_emp   = ', ln_rnf_emp 
    286302         WRITE(numout,*) '      specific river mouths treatment            ln_rnf_mouth = ', ln_rnf_mouth 
    287303         WRITE(numout,*) '      river mouth additional Kz                  rn_avt_rnf   = ', rn_avt_rnf 
    … …  
    289305         WRITE(numout,*) '      multiplicative factor for runoff           rn_rfact     = ', rn_rfact 
    290306      ENDIF 
    291       ! 
    292307      !                                   ! ================== 
    293308      !                                   !   Type of runoff 
    294309      !                                   ! ================== 
    295       !                                         !==  allocate runoff arrays 
    296       IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
    297       ! 
    298       IF( ln_rnf_emp ) THEN                     !==  runoffs directly provided in the precipitations  ==! 
    299          IF(lwp) WRITE(numout,*) 
    300          IF(lwp) WRITE(numout,*) '          runoffs directly provided in the precipitations' 
    301          IF( ln_rnf_depth .OR. ln_rnf_tem .OR. ln_rnf_sal ) THEN 
    302            CALL ctl_warn( 'runoffs already included in precipitations, so runoff (T,S, depth) attributes will not be used' ) 
    303            ln_rnf_depth = .FALSE.   ;   ln_rnf_tem = .FALSE.   ;   ln_rnf_sal = .FALSE. 
    304          ENDIF 
    305          ! 
    306       ELSE                                      !==  runoffs read in a file : set sf_rnf structure  ==! 
    307          ! 
     310      ! 
     311      IF( .NOT. l_rnfcpl ) THEN                     
    308312         ALLOCATE( sf_rnf(1), STAT=ierror )         ! Create sf_rnf structure (runoff inflow) 
    309313         IF(lwp) WRITE(numout,*) 
    … …  
    314318         ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1)   ) 
    315319         IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) 
    316          !                                          ! fill sf_rnf with the namelist (sn_rnf) and control print 
    317320         CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf' ) 
    318          ! 
    319          IF( ln_rnf_tem ) THEN                      ! Create (if required) sf_t_rnf structure 
    320             IF(lwp) WRITE(numout,*) 
    321             IF(lwp) WRITE(numout,*) '          runoffs temperatures read in a file' 
    322             ALLOCATE( sf_t_rnf(1), STAT=ierror  ) 
    323             IF( ierror > 0 ) THEN 
    324                CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' )   ;   RETURN 
    325             ENDIF 
    326             ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   ) 
    327             IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 
    328             CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 
    329          ENDIF 
    330          ! 
    331          IF( ln_rnf_sal  ) THEN                     ! Create (if required) sf_s_rnf and sf_t_rnf structures 
    332             IF(lwp) WRITE(numout,*) 
    333             IF(lwp) WRITE(numout,*) '          runoffs salinities read in a file' 
    334             ALLOCATE( sf_s_rnf(1), STAT=ierror  ) 
    335             IF( ierror > 0 ) THEN 
    336                CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' )   ;   RETURN 
    337             ENDIF 
    338             ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   ) 
    339             IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 
    340             CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 
    341          ENDIF 
    342          ! 
    343          IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file 
    344             IF(lwp) WRITE(numout,*) 
    345             IF(lwp) WRITE(numout,*) '          runoffs depth read in a file' 
    346             rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
    347             IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year  
    348                IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month  
    349             ENDIF  
    350             CALL iom_open ( rn_dep_file, inum )                           ! open file 
    351             CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array 
    352             CALL iom_close( inum )                                        ! close file 
    353             ! 
    354             nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
    355             DO jj = 1, jpj 
    356                DO ji = 1, jpi 
    357                   IF( h_rnf(ji,jj) > 0._wp ) THEN 
    358                      jk = 2 
    359                      DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    360                      nk_rnf(ji,jj) = jk 
    361                   ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1 
    362                   ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
    363                   ELSE 
    364                      CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
    365                      WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 
    366                   ENDIF 
     321      ENDIF 
     322      ! 
     323      IF( ln_rnf_tem ) THEN                      ! Create (if required) sf_t_rnf structure 
     324         IF(lwp) WRITE(numout,*) 
     325         IF(lwp) WRITE(numout,*) '          runoffs temperatures read in a file' 
     326         ALLOCATE( sf_t_rnf(1), STAT=ierror  ) 
     327         IF( ierror > 0 ) THEN 
     328            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' )   ;   RETURN 
     329         ENDIF 
     330         ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   ) 
     331         IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 
     332         CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 
     333      ENDIF 
     334      ! 
     335      IF( ln_rnf_sal  ) THEN                     ! Create (if required) sf_s_rnf and sf_t_rnf structures 
     336         IF(lwp) WRITE(numout,*) 
     337         IF(lwp) WRITE(numout,*) '          runoffs salinities read in a file' 
     338         ALLOCATE( sf_s_rnf(1), STAT=ierror  ) 
     339         IF( ierror > 0 ) THEN 
     340            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' )   ;   RETURN 
     341         ENDIF 
     342         ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   ) 
     343         IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 
     344         CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 
     345      ENDIF 
     346      ! 
     347      IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file 
     348         IF(lwp) WRITE(numout,*) 
     349         IF(lwp) WRITE(numout,*) '          runoffs depth read in a file' 
     350         rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
     351         IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year  
     352            IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month  
     353         ENDIF 
     354         CALL iom_open ( rn_dep_file, inum )                           ! open file 
     355         CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array 
     356         CALL iom_close( inum )                                        ! close file 
     357         ! 
     358         nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
     359         DO jj = 1, jpj 
     360            DO ji = 1, jpi 
     361               IF( h_rnf(ji,jj) > 0._wp ) THEN 
     362                  jk = 2 
     363                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 
     364                  END DO 
     365                  nk_rnf(ji,jj) = jk 
     366               ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1 
     367               ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
     368               ELSE 
     369                  CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
     370                  WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 
     371               ENDIF 
     372            END DO 
     373         END DO 
     374         DO jj = 1, jpj                                ! set the associated depth 
     375            DO ji = 1, jpi 
     376               h_rnf(ji,jj) = 0._wp 
     377               DO jk = 1, nk_rnf(ji,jj) 
     378                  h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
    367379               END DO 
    368380            END DO 
    369             DO jj = 1, jpj                                ! set the associated depth 
    370                DO ji = 1, jpi 
    371                   h_rnf(ji,jj) = 0._wp 
    372                   DO jk = 1, nk_rnf(ji,jj) 
    373                      h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
     381         END DO 
     382         ! 
     383      ELSE IF( ln_rnf_depth_ini ) THEN           ! runoffs applied at the surface 
     384         ! 
     385         IF(lwp) WRITE(numout,*) 
     386         IF(lwp) WRITE(numout,*) '    depth of runoff computed once from max value of runoff' 
     387         IF(lwp) WRITE(numout,*) '    max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max 
     388         IF(lwp) WRITE(numout,*) '    depth over which runoffs is spread                        rn_dep_max = ', rn_dep_max 
     389         IF(lwp) WRITE(numout,*) '     create (=1) a runoff depth file or not (=0)      nn_rnf_depth_file  = ', nn_rnf_depth_file 
     390 
     391         CALL iom_open( TRIM( sn_rnf%clname ), inum )    !  open runoff file 
     392         CALL iom_gettime( inum, zrec, kntime=nbrec) 
     393         ALLOCATE( zrnfcl(jpi,jpj,nbrec) )     ;      ALLOCATE( zrnf(jpi,jpj) ) 
     394         DO jm = 1, nbrec 
     395            CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,jm), jm ) 
     396         END DO 
     397         CALL iom_close( inum ) 
     398         zrnf(:,:) = MAXVAL( zrnfcl(:,:,:), DIM=3 )   !  maximum value in time 
     399         DEALLOCATE( zrnfcl ) 
     400         ! 
     401         h_rnf(:,:) = 1. 
     402         ! 
     403         zacoef = rn_dep_max / rn_rnf_max            ! coef of linear relation between runoff and its depth (150m for max of runoff) 
     404         ! 
     405         WHERE( zrnf(:,:) > 0._wp )  h_rnf(:,:) = zacoef * zrnf(:,:)   ! compute depth for all runoffs 
     406         ! 
     407         DO jj = 1, jpj                     ! take in account min depth of ocean rn_hmin 
     408            DO ji = 1, jpi 
     409               IF( zrnf(ji,jj) > 0._wp ) THEN 
     410                  jk = mbkt(ji,jj) 
     411                  h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) 
     412               ENDIF 
     413            END DO 
     414         END DO 
     415         ! 
     416         nk_rnf(:,:) = 0                       ! number of levels on which runoffs are distributed 
     417         DO jj = 1, jpj 
     418            DO ji = 1, jpi 
     419               IF( zrnf(ji,jj) > 0._wp ) THEN 
     420                  jk = 2 
     421                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 
    374422                  END DO 
     423                  nk_rnf(ji,jj) = jk 
     424               ELSE 
     425                  nk_rnf(ji,jj) = 1 
     426               ENDIF 
     427            END DO 
     428         END DO 
     429         ! 
     430         DEALLOCATE( zrnf ) 
     431         ! 
     432         DO jj = 1, jpj                                ! set the associated depth 
     433            DO ji = 1, jpi 
     434               h_rnf(ji,jj) = 0._wp 
     435               DO jk = 1, nk_rnf(ji,jj) 
     436                  h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
    375437               END DO 
    376438            END DO 
    377          ELSE                                       ! runoffs applied at the surface 
    378             nk_rnf(:,:) = 1 
    379             h_rnf (:,:) = fse3t(:,:,1) 
    380          ENDIF 
    381          ! 
     439         END DO 
     440         ! 
     441         IF( nn_rnf_depth_file == 1 ) THEN      !  save  output nb levels for runoff 
     442            IF(lwp) WRITE(numout,*) '              create runoff depht file' 
     443            CALL iom_open  ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE., kiolib = jprstlib ) 
     444            CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) 
     445            CALL iom_close ( inum ) 
     446         ENDIF 
     447      ELSE                                       ! runoffs applied at the surface 
     448         nk_rnf(:,:) = 1 
     449         h_rnf (:,:) = fse3t(:,:,1) 
    382450      ENDIF 
    383451      ! 
    … …  
    400468         IF( rn_hrnf > 0._wp ) THEN 
    401469            nkrnf = 2 
    402             DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1   ;   END DO 
     470            DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1 
     471            END DO 
    403472            IF( ln_sco )   CALL ctl_warn( 'sbc_rnf: number of levels over which Kz is increased is computed for zco...' ) 
    404473         ENDIF 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r5500 r5630  
    5858      REAL(wp) ::   zcoef, zf_sbc       ! local scalar 
    5959      REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts 
    60       REAL(wp), DIMENSION(jpi,jpj)      :: zub, zvb,zdep 
    6160      !!--------------------------------------------------------------------- 
    62        
     61 
    6362      !                                        !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) 
    6463      DO jj = 1, jpj 
    … …  
    6867         END DO 
    6968      END DO 
    70       zub(:,:)        = ub (:,:,1       ) 
    71       zvb(:,:)        = vb (:,:,1       ) 
    72       ! 
    73       IF( lk_vvl ) THEN 
    74          zdep(:,:) = fse3t_n(:,:,1) 
    75       ENDIF 
    76       !                                                   ! ---------------------------------------- ! 
     69      ! 
    7770      IF( nn_fsbc == 1 ) THEN                             !   Instantaneous surface fields        ! 
    7871         !                                                ! ---------------------------------------- ! 
    79          ssu_m(:,:) = zub(:,:) 
    80          ssv_m(:,:) = zvb(:,:) 
     72         ssu_m(:,:) = ub(:,:,1) 
     73         ssv_m(:,:) = vb(:,:,1) 
    8174         IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    8275         ELSE                    ;   sst_m(:,:) = zts(:,:,jp_tem) 
    … …  
    8881         ENDIF 
    8982         ! 
    90          IF( lk_vvl )   fse3t_m(:,:) = zdep(:,:) 
     83         IF( lk_vvl )   e3t_m(:,:) = fse3t_n(:,:,1) 
     84         ! 
     85         frq_m(:,:) = fraqsr_1lev(:,:) 
    9186         ! 
    9287      ELSE 
    … …  
    9792            IF(lwp) WRITE(numout,*) '~~~~~~~   mean fields initialised to instantaneous values' 
    9893            zcoef = REAL( nn_fsbc - 1, wp ) 
    99             ssu_m(:,:) = zcoef * zub(:,:) 
    100             ssv_m(:,:) = zcoef * zvb(:,:) 
     94            ssu_m(:,:) = zcoef * ub(:,:,1) 
     95            ssv_m(:,:) = zcoef * vb(:,:,1) 
    10196            IF( ln_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    10297            ELSE                    ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem) 
    … …  
    108103            ENDIF 
    109104            ! 
    110             IF( lk_vvl )   fse3t_m(:,:) = zcoef * zdep(:,:) 
     105            IF( lk_vvl )   e3t_m(:,:) = zcoef * fse3t_n(:,:,1) 
     106            ! 
     107            frq_m(:,:) = zcoef * fraqsr_1lev(:,:) 
    111108            !                                             ! ---------------------------------------- ! 
    112109         ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN      !   Initialisation: New mean computation   ! 
    … …  
    117114            sss_m(:,:) = 0.e0 
    118115            ssh_m(:,:) = 0.e0 
    119             IF( lk_vvl )   fse3t_m(:,:) = 0.e0 
     116            IF( lk_vvl )   e3t_m(:,:) = 0.e0 
     117            frq_m(:,:) = 0.e0 
    120118         ENDIF 
    121119         !                                                ! ---------------------------------------- ! 
    122120         !                                                !        Cumulate at each time step        ! 
    123121         !                                                ! ---------------------------------------- ! 
    124          ssu_m(:,:) = ssu_m(:,:) + zub(:,:) 
    125          ssv_m(:,:) = ssv_m(:,:) + zvb(:,:) 
     122         ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 
     123         ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 
    126124         IF( ln_useCT )  THEN    ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    127125         ELSE                    ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 
    … …  
    133131         ENDIF 
    134132         ! 
    135          IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) + zdep(:,:) 
     133         IF( lk_vvl )   e3t_m(:,:) = fse3t_m(:,:) + fse3t_n(:,:,1) 
     134         ! 
     135         frq_m(:,:) =   frq_m(:,:) + fraqsr_1lev(:,:) 
    136136 
    137137         !                                                ! ---------------------------------------- ! 
    … …  
    144144            ssv_m(:,:) = ssv_m(:,:) * zcoef           ! 
    145145            ssh_m(:,:) = ssh_m(:,:) * zcoef           ! mean SSH             [m] 
    146             IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) * zcoef   ! mean vertical scale factor [m] 
     146            IF( lk_vvl )   e3t_m(:,:) = fse3t_m(:,:) * zcoef   ! mean vertical scale factor [m] 
     147            frq_m(:,:) = frq_m(:,:) * zcoef   ! mean fraction of solar net radiation absorbed in the 1st T level [-] 
    147148            ! 
    148149         ENDIF 
    … …  
    161162            CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m  ) 
    162163            CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m  ) 
    163             IF( lk_vvl ) THEN 
    164                CALL iom_rstput( kt, nitrst, numrow, 'fse3t_m'  , fse3t_m(:,:)  ) 
    165             END IF 
    166             ! 
    167          ENDIF 
    168          ! 
     164            IF( lk_vvl )   CALL iom_rstput( kt, nitrst, numrow, 'e3t_m'  , e3t_m  ) 
     165            CALL iom_rstput( kt, nitrst, numrow, 'frq_m'  , frq_m  ) 
     166            ! 
     167         ENDIF 
     168         ! 
     169      ENDIF 
     170      ! 
     171      IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN          !   Mean value at each nn_fsbc time-step   ! 
     172         CALL iom_put( 'ssu_m', ssu_m ) 
     173         CALL iom_put( 'ssv_m', ssv_m ) 
     174         CALL iom_put( 'sst_m', sst_m ) 
     175         CALL iom_put( 'sss_m', sss_m ) 
     176         CALL iom_put( 'ssh_m', ssh_m ) 
     177         IF( lk_vvl )   CALL iom_put( 'e3t_m', e3t_m ) 
     178         CALL iom_put( 'frq_m', frq_m ) 
    169179      ENDIF 
    170180      ! 
    … …  
    202212            CALL iom_get( numror, jpdom_autoglo, 'sss_m'  , sss_m  )   !   "         "    salinity    (T-point) 
    203213            CALL iom_get( numror, jpdom_autoglo, 'ssh_m'  , ssh_m  )   !   "         "    height      (T-point) 
    204             IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_m', fse3t_m(:,:) ) 
     214            IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'e3t_m', e3t_m ) 
     215            ! fraction of solar net radiation absorbed in 1st T level 
     216            IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 
     217               CALL iom_get( numror, jpdom_autoglo, 'frq_m'  , frq_m  ) 
     218            ELSE 
     219               frq_m(:,:) = 1._wp   ! default definition 
     220            ENDIF 
    205221            ! 
    206222            IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN      ! nn_fsbc has changed between 2 runs 
    … …  
    213229               sss_m(:,:) = zcoef * sss_m(:,:) 
    214230               ssh_m(:,:) = zcoef * ssh_m(:,:) 
    215                IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_m(:,:) 
     231               IF( lk_vvl )   e3t_m(:,:) = zcoef * fse3t_m(:,:) 
     232               frq_m(:,:) = zcoef * frq_m(:,:) 
    216233            ELSE 
    217234               IF(lwp) WRITE(numout,*) '~~~~~~~   mean fields read in the ocean restart file' 
    … …  
    220237      ENDIF 
    221238      ! 
     239      IF( .NOT. l_ssm_mean ) THEN   ! default initialisation. needed by lim_istate 
     240         ! 
     241         IF(lwp) WRITE(numout,*) '          default initialisation of ss?_m arrays' 
     242         ssu_m(:,:) = ub(:,:,1) 
     243         ssv_m(:,:) = vb(:,:,1) 
     244         IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     245         ELSE                    ;   sst_m(:,:) = tsn(:,:,1,jp_tem) 
     246         ENDIF 
     247         sss_m(:,:) = tsn(:,:,1,jp_sal) 
     248         ssh_m(:,:) = sshn(:,:) 
     249         IF( lk_vvl )   e3t_m(:,:) = fse3t_n(:,:,1) 
     250         frq_m(:,:) = 1._wp 
     251         ! 
     252      ENDIF 
     253      ! 
    222254   END SUBROUTINE sbc_ssm_init 
    223255 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r5500 r5630  
    7474   PUBLIC   eos_init       ! called by istate module 
    7575 
    76    !                                          !!* Namelist (nameos) * 
    77    INTEGER , PUBLIC ::   nn_eos   = 0         !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
    78    LOGICAL , PUBLIC ::   ln_useCT  = .FALSE. ! determine if eos_pt_from_ct is used to compute sst_m 
     76   !                                !!* Namelist (nameos) * 
     77   INTEGER , PUBLIC ::   nn_eos     ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
     78   LOGICAL , PUBLIC ::   ln_useCT  ! determine if eos_pt_from_ct is used to compute sst_m 
    7979 
    8080   !                                   !!!  simplified eos coefficients 
    … …  
    12521252            WRITE(numout,*) '             model uses Conservative Temperature' 
    12531253            WRITE(numout,*) '             Important: model must be initialized with CT and SA fields' 
     1254         ELSE 
     1255            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12541256         ENDIF 
    12551257      ENDIF 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90

    r5500 r5630  
    2121   USE trdtra          ! trends manager: tracers  
    2222   USE in_out_manager  ! I/O manager 
     23   USE iom             ! I/O manager 
     24   USE fldread         ! read input fields 
     25   USE lbclnk            ! ocean lateral boundary conditions (or mpp link) 
     26   USE lib_mpp           ! distributed memory computing library 
    2327   USE prtctl          ! Print control 
    2428   USE wrk_nemo        ! Memory Allocation 
    … …  
    3741 
    3842   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   qgh_trd0   ! geothermal heating trend 
     43   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh              ! structure of input qgh (file informations, fields read) 
    3944  
    4045   !! * Substitutions 
    … …  
    9297      END DO 
    9398      ! 
     99      CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 
     100      ! 
    94101      IF( l_trdtra ) THEN        ! Save the geothermal heat flux trend for diagnostics 
    95102         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    … …  
    125132      INTEGER  ::   inum                ! temporary logical unit 
    126133      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    127       ! 
    128       NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst  
     134      INTEGER  ::   ierror              ! local integer 
     135      ! 
     136      TYPE(FLD_N)        ::   sn_qgh    ! informations about the geotherm. field to be read 
     137      CHARACTER(len=256) ::   cn_dir    ! Root directory for location of ssr files 
     138      ! 
     139      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir  
    129140      !!---------------------------------------------------------------------- 
    130141 
    … …  
    161172         CASE ( 2 )                          !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 
    162173            IF(lwp) WRITE(numout,*) '      *** variable geothermal heat flux' 
    163             CALL iom_open ( 'geothermal_heating.nc', inum ) 
    164             CALL iom_get  ( inum, jpdom_data, 'heatflow', qgh_trd0 ) 
    165             CALL iom_close( inum ) 
    166             qgh_trd0(:,:) = r1_rau0_rcp * qgh_trd0(:,:) * 1.e-3     ! conversion in W/m2 
     174            ! 
     175            ALLOCATE( sf_qgh(1), STAT=ierror ) 
     176            IF( ierror > 0 ) THEN 
     177               CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' )   ; 
     178               RETURN 
     179            ENDIF 
     180            ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1)   ) 
     181            IF( sn_qgh%ln_tint )ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) 
     182            ! fill sf_chl with sn_chl and control print 
     183            CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init',   & 
     184               &          'bottom temperature boundary condition', 'nambbc' ) 
     185 
     186            CALL fld_read( nit000, 1, sf_qgh )                         ! Read qgh data 
     187            qgh_trd0(:,:) = r1_rau0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 
    167188            ! 
    168189         CASE DEFAULT 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90

    r5500 r5630  
    99   !!            3.0  ! 2008-06  (G. Madec)  applied on ta, sa and called before tranxt in step.F90 
    1010   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA 
    11    !!            3.7  ! 2014-06  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 
     11   !!            3.6  ! 2015-05  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 
    1212   !!---------------------------------------------------------------------- 
    1313 
    … …  
    6464      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    6565      INTEGER  ::   inpcc        ! number of statically instable water column 
    66       INTEGER  ::   jiter, ikbot, ik, ikup, ikdown, ilayer, ikm   ! local integers 
     66      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers 
    6767      LOGICAL  ::   l_bottom_reached, l_column_treated 
    6868      REAL(wp) ::   zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 
    6969      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 
     70      REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp       ! acceptance criteria for neutrality (N2==0) 
    7071      REAL(wp), POINTER, DIMENSION(:)       ::   zvn2   ! vertical profile of N2 at 1 given point... 
    7172      REAL(wp), POINTER, DIMENSION(:,:)     ::   zvts   ! vertical profile of T and S at 1 given point... 
    … …  
    7576      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   ztrdt, ztrds   ! 3D workspace 
    7677      ! 
    77       !!LB debug: 
    78       LOGICAL, PARAMETER :: l_LB_debug = .FALSE. 
    79       INTEGER :: ilc1, jlc1, klc1, nncpu 
    80       LOGICAL :: lp_monitor_point = .FALSE. 
    81       !!LB debug. 
     78      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
     79      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1" 
     80      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu" 
    8281      !!---------------------------------------------------------------------- 
    8382      ! 
    … …  
    9796         ENDIF 
    9897 
    99          !LB debug: 
    100          IF( lwp .AND. l_LB_debug ) THEN 
    101             WRITE(numout,*) 
    102             WRITE(numout,*) 'LOLO: entering tra_npc, kt, narea =', kt, narea 
    103          ENDIF 
    104          !LBdebug: Monitoring of 1 column subject to convection... 
    10598         IF( l_LB_debug ) THEN 
    106             ! Location of 1 known convection spot to follow what's happening in the water column 
    107             ilc1 = 54 ;  jlc1 = 15 ; ! Labrador ORCA1 4x4 cpus: 
    108             nncpu = 15  ; ! the CPU domain contains the convection spot 
    109             !ilc1 = 14 ;  jlc1 = 13 ; ! Labrador ORCA1 8x8 cpus: 
    110             !nncpu = 54  ; ! the CPU domain contains the convection spot 
     99            ! Location of 1 known convection site to follow what's happening in the water column 
     100            ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column...            
     101            nncpu = 1  ;            ! the CPU domain contains the convection spot 
    111102            klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...           
    112103         ENDIF 
    113          !LBdebug. 
    114  
    115          CALL eos_rab( tsa, zab )         ! after alpha and beta 
    116          CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala 
     104          
     105         CALL eos_rab( tsa, zab )         ! after alpha and beta (given on T-points) 
     106         CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala  (given on W-points) 
    117107         
    118108         inpcc = 0 
    … …  
    134124                     IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
    135125                     ! writing only if on CPU domain where conv region is: 
    136                      lp_monitor_point = (narea == nncpu).AND.lp_monitor_point  
    137                       
    138                      IF(lp_monitor_point) THEN 
    139                         WRITE(numout,*) '' ;WRITE(numout,*) '' ; 
    140                        WRITE(numout,'("Time step = ",i6.6," !!!")')  kt 
    141                         WRITE(numout,'(" *** BEFORE anything, N^2 for point ",i3,",",i3,":" )') ji,jj 
    142                         DO jk = 1, klc1 
    143                            WRITE(numout,*) jk, zvn2(jk) 
    144                         END DO 
    145                         WRITE(numout,*) ' ' 
    146                      ENDIF 
     126                     lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
    147127                  ENDIF                                  !LB debug  end 
    148128 
    149129                  ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
    150                   ik = 1                ! because N2 is irrelevant at the surface level (will start at ik=2) 
     130                  ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
    151131                  ilayer = 0 
    152132                  jiter  = 0 
    … …  
    163143                     DO WHILE ( .NOT. l_bottom_reached ) 
    164144 
    165                         ik = ik + 1 
     145                        ikp = ikp + 1 
    166146                        
    167                         !! Checking level ik for instability 
     147                        !! Testing level ikp for instability 
    168148                        !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    169  
    170                         IF( zvn2(ik) < 0. ) THEN ! Instability found! 
    171  
    172                            ikm  = ik              ! first level whith negative N2 
    173                            ilayer = ilayer + 1    ! yet another layer found.... 
    174                            IF(jiter == 1) inpcc = inpcc + 1 
    175  
    176                            IF(l_LB_debug .AND. lp_monitor_point) & 
    177                               & WRITE(numout,*) 'Negative N2 at ik =', ikm, ' layer nb.', ilayer, & 
    178                               & ' inpcc =', inpcc 
    179  
    180                            !! Case we mix with upper regions where N2==0: 
    181                            !! All the points above ikup where N2 == 0 must also be mixed => we go 
    182                            !! upward to find a new ikup, where the layer doesn't have N2==0 
    183                            ikup = ikm 
    184                            DO jk = ikm, 2, -1 
    185                               ikup = ikup - 1 
    186                               IF( (zvn2(jk-1) > 0.).OR.(ikup == 1) ) EXIT 
    187                            END DO 
    188                            
    189                            ! adjusting ikup if the upper part of the unstable column was neutral (N2=0) 
    190                            IF((zvn2(ikup+1) == 0.).AND.(ikup /= 1)) ikup = ikup+1 ; 
    191  
    192                            
    193                            IF( lp_monitor_point )   WRITE(numout,*) ' => ikup is =', ikup, ' layer nb.', ilayer 
    194                            
     149                        IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
     150 
     151                           ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
     152 
     153                           IF( lp_monitor_point ) THEN  
     154                              WRITE(numout,*) 
     155                              IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
     156                                 WRITE(numout,*) 
     157                                 WRITE(numout,*) 'Time step = ',kt,' !!!' 
     158                              ENDIF 
     159                              WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
     160                                 &                                    ' in column! Starting at ikp =', ikp 
     161                              WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
     162                              DO jk = 1, klc1 
     163                                 WRITE(numout,*) jk, zvn2(jk) 
     164                              END DO 
     165                              WRITE(numout,*) 
     166                           ENDIF 
     167                            
     168 
     169                           IF( jiter == 1 )   inpcc = inpcc + 1  
     170 
     171                           IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
     172 
     173                           !! ikup is the uppermost point where mixing will start: 
     174                           ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
     175                            
     176                           !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
     177                           IF( ikp > 2 ) THEN 
     178                              DO jk = ikp-1, 2, -1 
     179                                 IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
     180                                    ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
     181                                 ELSE 
     182                                    EXIT 
     183                                 ENDIF 
     184                              END DO 
     185                           ENDIF 
     186                            
     187                           IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
     188 
    195189                           zsum_temp = 0._wp 
    196190                           zsum_sali = 0._wp 
    … …  
    199193                           zsum_z    = 0._wp 
    200194                                                     
    201                            DO jk = ikup, ikbot+1      ! Inside the instable (and overlying neutral) portion of the column 
    202                               ! 
    203                               IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '     -> summing for jk =', jk 
     195                           DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    204196                              ! 
    205197                              zdz       = fse3t(ji,jj,jk) 
    … …  
    209201                              zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
    210202                              zsum_z    = zsum_z    + zdz 
    211                               ! 
    212                               !! EXIT if we found the bottom of the unstable portion of the water column     
    213                               IF( (zvn2(jk+1) > 0.).OR.(jk == ikbot ).OR.((jk==ikm).AND.(zvn2(jk+1) == 0.)) )   EXIT 
     203                              !                               
     204                              IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
     205                              !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
     206                              IF( zvn2(jk+1) > zn2_zero ) EXIT 
    214207                           END DO 
    215208                           
    216                            !ik     = jk !LB remove? 
    217                            ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative N2 
    218                            
    219                            IF(l_LB_debug .AND. lp_monitor_point) & 
    220                               &    WRITE(numout,*) '  => ikdown =', ikdown, '  layer nb.', ilayer 
    221                            
    222                            ! Mixing Temperature and salinity between ikup and ikdown: 
     209                           ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
     210                           IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
     211 
     212                           ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
    223213                           zta   = zsum_temp/zsum_z 
    224214                           zsa   = zsum_sali/zsum_z 
    … …  
    226216                           zbeta = zsum_beta/zsum_z 
    227217 
    228                            IF(l_LB_debug .AND. lp_monitor_point) THEN 
     218                           IF( lp_monitor_point ) THEN 
     219                              WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
     220                                 &            ' and ikdown =',ikdown,', in layer #',ilayer 
    229221                              WRITE(numout,*) '  => Mean temp. in that portion =', zta 
    230222                              WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
    231                               WRITE(numout,*) '  => Mean Alpha in that portion =', zalfa 
     223                              WRITE(numout,*) '  => Mean Alfa in that portion =', zalfa 
    232224                              WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
    233225                           ENDIF 
    … …  
    240232                              zvab(jk,jp_sal) = zbeta 
    241233                           END DO 
    242                            ! 
    243                            !! Before updating N2, it is possible that another unstable 
    244                            !! layer exists underneath the one we just homogeneized! 
    245                            ik = ikdown 
    246                            !  
    247                         ENDIF  ! IF( zvn2(ik+1) < 0. ) THEN 
    248                         ! 
    249                         IF( ik == ikbot ) l_bottom_reached = .TRUE. 
     234                            
     235                            
     236                           !! Updating N2 in the relvant portion of the water column 
     237                           !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
     238                           !! => Need to re-compute N2! will use Alpha and Beta! 
     239                            
     240                           ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
     241                           ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
     242                            
     243                           DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
     244 
     245                              !! Interpolating alfa and beta at W point: 
     246                              zrw =  (fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk)) & 
     247                                 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 
     248                              zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
     249                              zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
     250 
     251                              !! N2 at W point, doing exactly as in eosbn2.F90: 
     252                              zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     253                                 &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
     254                                 &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     255 
     256                              !! OR, faster  => just considering the vertical gradient of density 
     257                              !! as only the signa maters... 
     258                              !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     259                              !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
     260 
     261                           END DO 
     262                         
     263                           ikp = MIN(ikdown+1,ikbot) 
     264                            
     265 
     266                        ENDIF  !IF( zvn2(ikp) < 0. ) 
     267 
     268 
     269                        IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
    250270                        ! 
    251271                     END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
    252272 
    253                      IF( ik /= ikbot )   STOP 'ERROR: tranpc.F90 => PROBLEM #1' 
     273                     IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
    254274                     
    255                      ! ******* At this stage ik == ikbot ! ******* 
     275                     ! ******* At this stage ikp == ikbot ! ******* 
    256276                     
    257                      IF( ilayer > 0 ) THEN 
    258                         !! least an unstable layer has been found 
    259                         !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
    260                         !! => Need to re-compute N2! will use Alpha and Beta! 
     277                     IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
    261278                        ! 
    262                         DO jk = ikup+1, ikdown+1   ! we must go 1 point deeper than ikdown!      
    263                            !! Doing exactly as in eosbn2.F90: 
    264                            !! * Except that we only are interested in the sign of N2 !!! 
    265                            !!   => just considering the vertical gradient of density 
    266                            zrw =   (fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk)) & 
    267                                & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 
    268                            zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
    269                            zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
    270                            
    271                            !zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    272                            !     &           - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
    273                            !     &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
    274                            zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    275                                 &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )   
    276                         END DO 
    277  
    278                         IF(l_LB_debug .AND. lp_monitor_point) THEN 
    279                            WRITE(numout, '(" *** After iteration #",i3.3,", N^2 for point ",i3,",",i3,":" )') & 
    280                               & jiter, ji,jj 
     279                        IF( lp_monitor_point ) THEN 
     280                           WRITE(numout,*) 
     281                           WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
     282                           WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
    281283                           DO jk = 1, klc1 
    282284                              WRITE(numout,*) jk, zvn2(jk) 
    283285                           END DO 
    284                            WRITE(numout,*) ' ' 
     286                           WRITE(numout,*) 
    285287                        ENDIF 
    286  
    287                         ik     = 1  ! starting again at the surface for the next iteration 
     288                        ! 
     289                        ikp    = 1     ! starting again at the surface for the next iteration 
    288290                        ilayer = 0 
    289291                     ENDIF 
    290292                     ! 
    291                      IF( ik >= ikbot ) THEN 
    292                         IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '    --- exiting jiter loop ---' 
    293                         l_column_treated = .TRUE. 
    294                      ENDIF 
     293                     IF( ikp >= ikbot )   l_column_treated = .TRUE. 
    295294                     ! 
    296295                  END DO ! DO WHILE ( .NOT. l_column_treated ) 
    … …  
    300299                  tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 
    301300 
    302                   !! lolo:  Should we update something else???? 
    303                   !! => like alpha and beta? 
    304  
    305                   IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '' 
     301                  !! LB:  Potentially some other global variable beside theta and S can be treated here 
     302                  !!      like BGC tracers. 
     303 
     304                  IF( lp_monitor_point )   WRITE(numout,*) 
    306305 
    307306               ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
    … …  
    321320         CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. )   ;   CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    322321         ! 
    323          IF(lwp) THEN 
    324             WRITE(numout,*) 'LOLO: exiting tra_npc, kt =', kt 
    325             WRITE(numout,*)' => number of statically instable water column : ',inpcc 
    326             WRITE(numout,*) '' ; WRITE(numout,*) '' 
     322         IF( lwp .AND. l_LB_debug ) THEN 
     323            WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 
     324            WRITE(numout,*) 
    327325         ENDIF 
    328326         ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r5500 r5630  
    2727   USE dom_oce         ! ocean space and time domain variables  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
     29   USE sbcrnf          ! river runoffs 
    2930   USE zdf_oce         ! ocean vertical mixing 
    3031   USE domvvl          ! variable volume 
    … …  
    143144      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    144145         ! 
    145          IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! variable volume level (vvl)      
    146          ELSE                 ;   CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
     146         IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, rdttra, 'TRA', tsb, tsn, tsa,   & 
     147           &                                                              sbc_tsc, sbc_tsc_b, jpts )  ! variable volume level (vvl)  
     148         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    147149         ENDIF 
    148150      ENDIF  
    … …  
    241243 
    242244 
    243    SUBROUTINE tra_nxt_vvl( kt, kit000, cdtype, ptb, ptn, pta, kjpt ) 
     245   SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) 
    244246      !!---------------------------------------------------------------------- 
    245247      !!                   ***  ROUTINE tra_nxt_vvl  *** 
    … …  
    265267      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    266268      !!---------------------------------------------------------------------- 
    267       INTEGER         , INTENT(in   )                               ::   kt       ! ocean time-step index 
    268       INTEGER         , INTENT(in   )                               ::   kit000   ! first time step index 
    269       CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    270       INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    271       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    272       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    273       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     269      INTEGER         , INTENT(in   )                               ::  kt       ! ocean time-step index 
     270      INTEGER         , INTENT(in   )                               ::  kit000   ! first time step index 
     271      REAL(wp)        , INTENT(in   ), DIMENSION(jpk)               ::  p2dt     ! time-step 
     272      CHARACTER(len=3), INTENT(in   )                               ::  cdtype   ! =TRA or TRC (tracer indicator) 
     273      INTEGER         , INTENT(in   )                               ::  kjpt     ! number of tracers 
     274      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptb      ! before tracer fields 
     275      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptn      ! now tracer fields 
     276      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  pta      ! tracer trend 
     277      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc   ! surface tracer content 
     278      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc_b ! before surface tracer content 
     279 
    274280      !!      
    275       LOGICAL  ::   ll_tra, ll_tra_hpg, ll_traqsr   ! local logical 
     281      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
    276282      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    277283      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    286292      ! 
    287293      IF( cdtype == 'TRA' )  THEN    
    288          ll_tra     = .TRUE.           ! active tracers case   
    289294         ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg 
    290295         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
     296         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    291297      ELSE                           
    292          ll_tra     = .FALSE.          ! passive tracers case 
    293298         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    294299         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
     300         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
    295301      ENDIF 
    296302      ! 
    297303      DO jn = 1, kjpt       
    298304         DO jk = 1, jpkm1 
    299             zfact1 = atfp * rdttra(jk) 
     305            zfact1 = atfp * p2dt(jk) 
    300306            zfact2 = zfact1 / rau0 
    301307            DO jj = 1, jpj 
    … …  
    315321                  ztc_f  = ztc_n  + atfp * ztc_d 
    316322                  ! 
    317                   IF( ll_tra .AND. jk == 1 ) THEN           ! first level only for T & S 
    318                       ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) ) 
    319                       ztc_f  = ztc_f  - zfact1 * ( sbc_tsc(ji,jj,jn) - sbc_tsc_b(ji,jj,jn) ) 
     323                  IF( jk == 1 ) THEN           ! first level  
     324                     ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     325                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    320326                  ENDIF 
     327 
    321328                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
    322329                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    323330 
    324                    ze3t_f = 1.e0 / ze3t_f 
    325                    ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
    326                    ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
    327                    ! 
    328                    IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
    329                       ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
    330                       pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
    331                    ENDIF 
     331                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     332                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
     333                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     334 
     335                  ze3t_f = 1.e0 / ze3t_f 
     336                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
     337                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
     338                  ! 
     339                  IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
     340                     ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
     341                     pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
     342                  ENDIF 
    332343               END DO 
    333344            END DO 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r5500 r5630  
    3232   USE wrk_nemo       ! Memory Allocation 
    3333   USE timing         ! Timing 
    34    USE sbc_ice, ONLY : lk_lim3 
    3534 
    3635   IMPLICIT NONE 
    … …  
    3837 
    3938   PUBLIC   tra_qsr       ! routine called by step.F90 (ln_traqsr=T) 
    40    PUBLIC   tra_qsr_init  ! routine called by opa.F90 
     39   PUBLIC   tra_qsr_init  ! routine called by nemogcm.F90 
    4140 
    4241   !                                 !!* Namelist namtra_qsr: penetrative solar radiation 
    … …  
    5049   REAL(wp), PUBLIC ::   rn_si0       !: very near surface depth of extinction      (RGB & 2 bands) 
    5150   REAL(wp), PUBLIC ::   rn_si1       !: deepest depth of extinction (water type I)       (2 bands) 
    52     
     51  
    5352   ! Module variables 
    5453   REAL(wp) ::   xsi0r                           !: inverse of rn_si0 
    … …  
    165164         CALL iom_put( 'qsr3d', etot3 )   ! Shortwave Radiation 3D distribution 
    166165         ! clem: store attenuation coefficient of the first ocean level 
    167          IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     166         IF ( ln_qsr_ice ) THEN 
    168167            DO jj = 1, jpj 
    169168               DO ji = 1, jpi 
    170169                  IF ( qsr(ji,jj) /= 0._wp ) THEN 
    171170                     fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 
     171                  ELSE 
     172                     fraqsr_1lev(ji,jj) = 1. 
    172173                  ENDIF 
    173174               END DO 
    … …  
    233234               END DO 
    234235               ! clem: store attenuation coefficient of the first ocean level 
    235                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     236               IF ( ln_qsr_ice ) THEN 
    236237                  DO jj = 1, jpj 
    237238                     DO ji = 1, jpi 
    … …  
    256257               END DO 
    257258               ! clem: store attenuation coefficient of the first ocean level 
    258                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     259               IF ( ln_qsr_ice ) THEN 
    259260                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    260261               ENDIF 
    … …  
    279280               END DO 
    280281               ! clem: store attenuation coefficient of the first ocean level 
    281                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     282               IF ( ln_qsr_ice ) THEN 
    282283                  DO jj = 1, jpj 
    283284                     DO ji = 1, jpi 
    … …  
    298299               END DO 
    299300               ! clem: store attenuation coefficient of the first ocean level 
    300                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     301               IF ( ln_qsr_ice ) THEN 
    301302                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    302303               ENDIF 
    … …  
    324325            &                    'at it= ', kt,' date= ', ndastp 
    325326         IF(lwp) WRITE(numout,*) '~~~~' 
    326          CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b', qsr_hc ) 
     327         CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc      ) 
     328         CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )   ! default definition in sbcssm  
    327329         ! 
    328330      ENDIF 
    … …  
    379381      ! 
    380382      IF( nn_timing == 1 )  CALL timing_start('tra_qsr_init') 
    381       ! 
    382       ! Default value for fraqsr_1lev 
    383       IF( .NOT. ln_rstart ) THEN 
    384          fraqsr_1lev(:,:) = 1._wp 
    385       ENDIF 
    386383      ! 
    387384      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    … …  
    412409         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    413410         WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1 = ', rn_si1 
    414          WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice     
    415411      ENDIF 
    416412 
    … …  
    564560      ENDIF 
    565561      ! 
     562      ! initialisation of fraqsr_1lev used in sbcssm 
     563      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 
     564         CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev'  , fraqsr_1lev  ) 
     565      ELSE 
     566         fraqsr_1lev(:,:) = 1._wp   ! default definition 
     567      ENDIF 
     568      ! 
    566569      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    567570      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5500 r5630  
    2121   USE sbcmod          ! ln_rnf   
    2222   USE sbcrnf          ! River runoff   
     23   USE sbcisf          ! Ice shelf    
    2324   USE traqsr          ! solar radiation penetration 
    2425   USE trd_oce         ! trends: ocean variables 
    … …  
    2728   USE in_out_manager  ! I/O manager 
    2829   USE prtctl          ! Print control 
    29    USE sbcrnf          ! River runoff   
    30    USE sbcisf          ! Ice shelf    
    31    USE sbcmod          ! ln_rnf   
    3230   USE iom 
    3331   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r5500 r5630  
    8888         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    8989      END SELECT 
     90      ! DRAKKAR SSS control { 
     91      ! JMM avoid negative salinities near river outlet ! Ugly fix 
     92      ! JMM : restore negative salinities to small salinities: 
     93      WHERE ( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
    9094 
    9195      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r5500 r5630  
    124124      IF(lwp) WRITE(numout,*) '   convection :' 
    125125      ! 
    126       IF( ln_zdfnpc )   CALL ctl_stop( ' zdf_init: non penetrative convective scheme is not working',   & 
    127          &                                       ' set ln_zdfnpc to FALSE' ) 
     126#if defined key_top 
     127      IF( ln_zdfnpc )   CALL ctl_stop( ' zdf_init: npc scheme is not working with key_top' ) 
     128#endif 
    128129      ! 
    129130      ioptio = 0 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r5500 r5630  
    761761      IF( nn_pdl  < 0   .OR.  nn_pdl  > 1 )   CALL ctl_stop( 'bad flag: nn_pdl is  0 or 1    ' ) 
    762762      IF( nn_htau < 0   .OR.  nn_htau > 1 )   CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 
    763       IF( nn_etau == 3 .AND. .NOT. lk_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 
     763      IF( nn_etau == 3 .AND. .NOT. ln_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 
    764764 
    765765      IF( ln_mxl0 ) THEN 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r5500 r5630  
    8282   USE crsini          ! initialise grid coarsening utility 
    8383   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
     84   USE sbc_oce, ONLY: lk_oasis 
    8485   USE stopar 
    8586   USE stopts 
    … …  
    197198#if defined key_iomput 
    198199      CALL xios_finalize                ! end mpp communications with xios 
    199       IF( lk_cpl ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS 
     200      IF( lk_oasis ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS 
    200201#else 
    201       IF( lk_cpl ) THEN  
     202      IF( lk_oasis ) THEN  
    202203         CALL cpl_finalize              ! end coupling and mpp communications with OASIS 
    203204      ELSE 
    … …  
    228229      ! 
    229230      cltxt = '' 
     231      cxios_context = 'nemo' 
    230232      ! 
    231233      !                             ! Open reference namelist and configuration namelist files 
    … …  
    274276#if defined key_iomput 
    275277      IF( Agrif_Root() ) THEN 
    276          IF( lk_cpl ) THEN 
    277             CALL cpl_init( ilocal_comm )                               ! nemo local communicator given by oasis 
    278             CALL xios_initialize( "oceanx",local_comm=ilocal_comm )    ! send nemo communicator to xios 
     278         IF( lk_oasis ) THEN 
     279            CALL cpl_init( "oceanx", ilocal_comm )                     ! nemo local communicator given by oasis 
     280            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios 
    279281         ELSE 
    280             CALL  xios_initialize( "nemo",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
     282            CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
    281283         ENDIF 
    282284      ENDIF 
    283       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
     285      ! Nodes selection (control print return in cltxt) 
     286      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
    284287#else 
    285       IF( lk_cpl ) THEN 
     288      IF( lk_oasis ) THEN 
    286289         IF( Agrif_Root() ) THEN 
    287             CALL cpl_init( ilocal_comm )                       ! nemo local communicator given by oasis 
     290            CALL cpl_init( "oceanx", ilocal_comm )                      ! nemo local communicator given by oasis 
    288291         ENDIF 
    289          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt) 
     292         ! Nodes selection (control print return in cltxt) 
     293         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
    290294      ELSE 
    291295         ilocal_comm = 0 
    292          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
     296         ! Nodes selection (control print return in cltxt) 
     297         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 
    293298      ENDIF 
    294299#endif 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/step.F90

    r5500 r5630  
    8383      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
    8484# if defined key_iomput 
    85       IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( "nemo" ) 
     85      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    8686# endif 
    8787#endif 
    8888                             indic = 0           ! reset to no error condition 
    8989      IF( kstp == nit000 ) THEN 
    90                       CALL iom_init( "nemo" )      ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    91          IF( ln_crs ) CALL iom_init( "nemo_crs" )  ! initialize context for coarse grid 
     90         ! must be done after nemo_init for AGRIF+XIOS+OASIS 
     91                      CALL iom_init(      cxios_context          )  ! iom_put initialization 
     92         IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" )  ! initialize context for coarse grid 
    9293      ENDIF 
    9394 
    9495      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    95                              CALL iom_setkt( kstp - nit000 + 1, "nemo"     )   ! say to iom that we are at time step kstp 
    96       IF( ln_crs     )       CALL iom_setkt( kstp - nit000 + 1, "nemo_crs" )   ! say to iom that we are at time step kstp 
     96                             CALL iom_setkt( kstp - nit000 + 1,      cxios_context          )   ! tell iom we are at time step kstp 
     97      IF( ln_crs     )       CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" )   ! tell iom we are at time step kstp 
    9798 
    9899      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    100101      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    101102      IF( lk_tide    )   CALL sbc_tide( kstp ) 
    102       IF( lk_bdy     )   CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
    103  
     103      IF( lk_bdy     )  THEN 
     104         IF( ln_apr_dyn) CALL sbc_apr( kstp )   ! bdy_dta needs ssh_ib  
     105                         CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
     106      ENDIF 
    104107                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    105108                                                      ! clem: moved here for bdy ice purpose 
    106  
    107109      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    108110      ! Update stochastic parameters and random T/S fluctuations 
    … …  
    168170      IF( lk_traldf_eiv )   CALL ldf_eiv( kstp )      ! eddy induced velocity coefficient 
    169171#endif 
    170 #if defined key_traldf_c3d && key_traldf_smag 
     172#if defined key_traldf_c3d && defined key_traldf_smag 
    171173                          CALL ldf_tra_smag( kstp )      ! eddy induced velocity coefficient 
    172174#  endif 
    173 #if defined key_dynldf_c3d && key_dynldf_smag 
     175#if defined key_dynldf_c3d && defined key_dynldf_smag 
    174176                          CALL ldf_dyn_smag( kstp )      ! eddy induced velocity coefficient 
    175177#  endif 
    … …  
    225227      IF( lk_floats  )      CALL flo_stp( kstp )         ! drifting Floats 
    226228      IF( lk_diahth  )      CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
    227       IF( .NOT. lk_cpl )    CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
     229      IF( .NOT. ln_cpl )    CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
    228230      IF( lk_diadct  )      CALL dia_dct( kstp )         ! Transports 
    229231      IF( lk_diaar5  )      CALL dia_ar5( kstp )         ! ar5 diag 
    … …  
    355357      ! Coupled mode 
    356358      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    357       IF( lk_cpl           )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
     359      IF( lk_oasis         )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
    358360      ! 
    359361#if defined key_iomput 
    360362      IF( kstp == nitend .OR. indic < 0 ) THEN  
    361                       CALL iom_context_finalize( "nemo"     ) ! needed for XIOS+AGRIF 
    362          IF( ln_crs ) CALL iom_context_finalize( "nemo_crs" ) !  
     363                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
     364         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    363365      ENDIF 
    364366#endif 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r5500 r5630  
    2727   USE sbc_oce          ! surface boundary condition: ocean 
    2828   USE sbctide          ! Tide initialisation 
     29   USE sbcapr           ! surface boundary condition: ssh_ib required by bdydta  
    2930 
    3031   USE traqsr           ! solar radiation penetration      (tra_qsr routine) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90

    r5500 r5630  
    3232   !!   'key_top'                                                 bio-model           
    3333   !!---------------------------------------------------------------------- 
     34   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .TRUE.   !: TOP model 
    3435   LOGICAL, PUBLIC, PARAMETER ::   lk_qsr_bio = .TRUE.   !: bio-model light absorption flag 
    3536#else 
    … …  
    3738   !! Default option                          No bio-model light absorption       
    3839   !!---------------------------------------------------------------------- 
     40   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .FALSE.   !: TOP model 
    3941   LOGICAL, PUBLIC, PARAMETER ::   lk_qsr_bio = .FALSE.   !: bio-model light absorption flag 
    4042#endif 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90

    r5500 r5630  
    121121 
    122122   LOGICAL ::   linit = .FALSE. 
     123   LOGICAL ::   ldebug = .FALSE. 
    123124   !!---------------------------------------------------------------------- 
    124125   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    … …  
    486487       
    487488      IF( SUM( tree(ii)%ishape ) == 0 ) THEN                    ! create a new branch  
     489         IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype 
    488490         tree(ii)%itype = itype                                        ! define the type of this branch  
    489491         tree(ii)%ishape(:) = ishape(:)                                ! define the shape of this branch  
    … …  
    515517         tree(ii)%current%next%in_use = .FALSE.                        ! this leaf is not yet used 
    516518         tree(ii)%current%next%indic = tree(ii)%current%indic + 1      ! number of this leaf 
     519         IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic 
    517520         tree(ii)%current%next%prev => tree(ii)%current                ! previous leaf of the new leaf is the current leaf 
    518521         tree(ii)%current%next%next => NULL()                          ! next leaf is not yet defined 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/SAS_SRC/daymod.F90

    r5500 r5630  
    8080      ndt05   = NINT(0.5 * rdttra(1)) 
    8181 
    82       ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) 
    83       ndastp = ndate0 - 1        ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
    84       adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
    85       IF( ABS(adatrj  - REAL(NINT(adatrj),wp)) < 0.1 / rday )   adatrj = REAL(NINT(adatrj),wp)   ! avoid truncation error 
    86       ! 
    87       IF(lwp) THEN 
    88          WRITE(numout,*) ' *** Info used values : ' 
    89          WRITE(numout,*) '   date ndastp                                      : ', ndastp 
    90          WRITE(numout,*) '   number of elapsed days since the begining of run : ', adatrj 
    91          WRITE(numout,*) 
    92       ENDIF 
     82      ! ==> clem: here we read the ocean restart for the date (only if it exists) 
     83      !           It is not clean and another solution should be found 
     84      CALL day_rst( nit000, 'READ' ) 
     85      ! ==> 
    9386 
    9487      ! set the calendar from ndastp (read in restart file and namelist) 
    … …  
    131124 
    132125      ! control print 
    133       IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i6)')' ==============>> 1/2 time step before the start of the run DATE Y/M/D = ',   & 
     126      IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8)')' =======>> 1/2 time step before the start of the run DATE Y/M/D = ',   & 
    134127           &                   nyear, '/', nmonth, '/', nday, '  nsec_day:', nsec_day, '  nsec_week:', nsec_week 
    135128 
    … …  
    285278      ! 
    286279   END SUBROUTINE day 
     280 
     281 
     282   SUBROUTINE day_rst( kt, cdrw ) 
     283      !!--------------------------------------------------------------------- 
     284      !!                   ***  ROUTINE ts_rst  *** 
     285      !! 
     286      !!  ** Purpose : Read or write calendar in restart file: 
     287      !! 
     288      !!  WRITE(READ) mode: 
     289      !!       kt        : number of time step since the begining of the experiment at the 
     290      !!                   end of the current(previous) run 
     291      !!       adatrj(0) : number of elapsed days since the begining of the experiment at the 
     292      !!                   end of the current(previous) run (REAL -> keep fractions of day) 
     293      !!       ndastp    : date at the end of the current(previous) run (coded as yyyymmdd integer) 
     294      !! 
     295      !!   According to namelist parameter nrstdt, 
     296      !!       nrstdt = 0  no control on the date (nit000 is  arbitrary). 
     297      !!       nrstdt = 1  we verify that nit000 is equal to the last 
     298      !!                   time step of previous run + 1. 
     299      !!       In both those options, the  exact duration of the experiment 
     300      !!       since the beginning (cumulated duration of all previous restart runs) 
     301      !!       is not stored in the restart and is assumed to be (nit000-1)*rdt. 
     302      !!       This is valid is the time step has remained constant. 
     303      !! 
     304      !!       nrstdt = 2  the duration of the experiment in days (adatrj) 
     305      !!                    has been stored in the restart file. 
     306      !!---------------------------------------------------------------------- 
     307      INTEGER         , INTENT(in) ::   kt         ! ocean time-step 
     308      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag 
     309      ! 
     310      REAL(wp) ::   zkt, zndastp 
     311      !!---------------------------------------------------------------------- 
     312 
     313      IF( TRIM(cdrw) == 'READ' ) THEN 
     314 
     315         IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN 
     316            ! Get Calendar informations 
     317            CALL iom_get( numror, 'kt', zkt )   ! last time-step of previous run 
     318            IF(lwp) THEN 
     319               WRITE(numout,*) ' *** Info read in restart : ' 
     320               WRITE(numout,*) '   previous time-step                               : ', NINT( zkt ) 
     321               WRITE(numout,*) ' *** restart option' 
     322               SELECT CASE ( nrstdt ) 
     323               CASE ( 0 )   ;   WRITE(numout,*) ' nrstdt = 0 : no control of nit000' 
     324               CASE ( 1 )   ;   WRITE(numout,*) ' nrstdt = 1 : no control the date at nit000 (use ndate0 read in the namelist)' 
     325               CASE ( 2 )   ;   WRITE(numout,*) ' nrstdt = 2 : calendar parameters read in restart' 
     326               END SELECT 
     327               WRITE(numout,*) 
     328            ENDIF 
     329            ! Control of date 
     330            IF( nit000 - NINT( zkt ) /= 1 .AND. nrstdt /= 0 )                                         & 
     331                 &   CALL ctl_stop( ' ===>>>> : problem with nit000 for the restart',                 & 
     332                 &                  ' verify the restart file or rerun with nrstdt = 0 (namelist)' ) 
     333            ! define ndastp and adatrj 
     334            IF ( nrstdt == 2 ) THEN 
     335               ! read the parameters correspondting to nit000 - 1 (last time step of previous run) 
     336               CALL iom_get( numror, 'ndastp', zndastp ) 
     337               ndastp = NINT( zndastp ) 
     338               CALL iom_get( numror, 'adatrj', adatrj  ) 
     339            ELSE 
     340               ! parameters correspondting to nit000 - 1 (as we start the step loop with a call to day) 
     341               ndastp = ndate0 - 1     ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
     342               adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
     343               ! note this is wrong if time step has changed during run 
     344            ENDIF 
     345         ELSE 
     346            ! parameters correspondting to nit000 - 1 (as we start the step loop with a call to day) 
     347            ndastp = ndate0 - 1        ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
     348            adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
     349         ENDIF 
     350         IF( ABS(adatrj  - REAL(NINT(adatrj),wp)) < 0.1 / rday )   adatrj = REAL(NINT(adatrj),wp)   ! avoid truncation error 
     351         ! 
     352         IF(lwp) THEN 
     353            WRITE(numout,*) ' *** Info used values : ' 
     354            WRITE(numout,*) '   date ndastp                                      : ', ndastp 
     355            WRITE(numout,*) '   number of elapsed days since the begining of run : ', adatrj 
     356            WRITE(numout,*) 
     357         ENDIF 
     358         ! 
     359      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN 
     360         ! 
     361         IF( kt == nitrst ) THEN 
     362            IF(lwp) WRITE(numout,*) 
     363            IF(lwp) WRITE(numout,*) 'rst_write : write oce restart file  kt =', kt 
     364            IF(lwp) WRITE(numout,*) '~~~~~~~' 
     365         ENDIF 
     366         ! calendar control 
     367         CALL iom_rstput( kt, nitrst, numrow, 'kt'     , REAL( kt    , wp) )   ! time-step 
     368         CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) )   ! date 
     369         CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj            )   ! number of elapsed days since 
     370         !                                                                     ! the begining of the run [s] 
     371      ENDIF 
     372      ! 
     373   END SUBROUTINE day_rst 
    287374   !!====================================================================== 
    288375END MODULE daymod 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r5500 r5630  
    4242   USE step_oce        ! module used in the ocean time stepping module 
    4343   USE sbc_oce         ! surface boundary condition: ocean 
    44    USE cla             ! cross land advection               (tra_cla routine) 
    4544   USE domcfg          ! domain configuration               (dom_cfg routine) 
    4645   USE daymod          ! calendar 
    … …  
    5049   USE step            ! NEMO time-stepping                 (stp     routine) 
    5150   USE lib_mpp         ! distributed memory computing 
     51#if defined key_nosignedzero 
     52   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
     53#endif 
    5254#if defined key_iomput 
    5355   USE xios 
    5456#endif 
     57   USE cpl_oasis3 
    5558   USE sbcssm 
    56    USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges  
     59   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 
     60   USE icbstp          ! handle bergs, calving, themodynamics and transport 
     61#if defined key_bdy 
     62   USE bdyini          ! open boundary cond. setting       (bdy_init routine). clem: mandatory for LIM3 
     63   USE bdydta          ! open boundary cond. setting   (bdy_dta_init routine). clem: mandatory for LIM3 
     64#endif 
     65   USE bdy_par 
    5766 
    5867   IMPLICIT NONE 
    … …  
    96105      !                            !-----------------------! 
    97106#if defined key_agrif 
    98       CALL Agrif_Declare_Var       ! AGRIF: set the meshes 
     107      CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM 
     108      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA  
     109# if defined key_top 
     110      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
     111# endif 
     112# if defined key_lim2 
     113      CALL Agrif_Declare_Var_lim2  !  "      "   "   "      "  LIM 
     114# endif 
    99115#endif 
    100116      ! check that all process are still there... If some process have an error, 
    … …  
    118134         IF( lk_mpp )   CALL mpp_max( nstop ) 
    119135      END DO 
     136      ! 
     137      IF( ln_icebergs )   CALL icb_end( nitend ) 
     138 
    120139      !                            !------------------------! 
    121140      !                            !==  finalize the run  ==! 
    … …  
    136155      ! 
    137156      CALL nemo_closefile 
     157      ! 
    138158#if defined key_iomput 
    139159      CALL xios_finalize                ! end mpp communications with xios 
     160      IF( lk_oasis ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS 
    140161#else 
    141       IF( lk_mpp )   CALL mppstop       ! end mpp communications 
     162      IF( lk_oasis ) THEN  
     163         CALL cpl_finalize              ! end coupling and mpp communications with OASIS 
     164      ELSE 
     165         IF( lk_mpp )   CALL mppstop    ! end mpp communications 
     166      ENDIF 
    142167#endif 
    143168      ! 
    … …  
    154179      INTEGER ::   ilocal_comm   ! local integer       
    155180      INTEGER ::   ios 
    156  
    157181      CHARACTER(len=80), DIMENSION(16) ::   cltxt 
    158       !! 
     182      CHARACTER(len=80) ::   clname 
     183      ! 
    159184      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
    160185         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   & 
    … …  
    163188         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    164189      !!---------------------------------------------------------------------- 
     190      ! 
    165191      cltxt = '' 
    166192      ! 
    167193      !                             ! Open reference namelist and configuration namelist files 
    168       CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    169       CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     194      IF( lk_oasis ) THEN  
     195         CALL ctl_opn( numnam_ref, 'namelist_sas_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     196         CALL ctl_opn( numnam_cfg, 'namelist_sas_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     197         cxios_context = 'sas' 
     198         clname = 'output.namelist_sas.dyn' 
     199      ELSE 
     200         CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     201         CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     202         cxios_context = 'nemo' 
     203         clname = 'output.namelist.dyn' 
     204   ENDIF 
    170205      ! 
    171206      REWIND( numnam_ref )              ! Namelist namctl in reference namelist : Control prints & Benchmark 
    … …  
    186221904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )    
    187222 
     223! Force values for AGRIF zoom (cf. agrif_user.F90) 
     224#if defined key_agrif 
     225   IF( .NOT. Agrif_Root() ) THEN 
     226      jpiglo  = nbcellsx + 2 + 2*nbghostcells 
     227      jpjglo  = nbcellsy + 2 + 2*nbghostcells 
     228      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
     229      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
     230      jpidta  = jpiglo 
     231      jpjdta  = jpjglo 
     232      jpizoom = 1 
     233      jpjzoom = 1 
     234      nperio  = 0 
     235      jperio  = 0 
     236      ln_use_jattr = .false. 
     237   ENDIF 
     238#endif 
     239      ! 
    188240      !                             !--------------------------------------------! 
    189241      !                             !  set communicator & select the local node  ! 
    … …  
    193245#if defined key_iomput 
    194246      IF( Agrif_Root() ) THEN 
    195          CALL  xios_initialize( "nemo",return_comm=ilocal_comm ) 
    196       ENDIF 
    197       narea = mynode ( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )  ! Nodes selection 
     247         IF( lk_oasis ) THEN 
     248            CALL cpl_init( "sas", ilocal_comm )                          ! nemo local communicator given by oasis  
     249            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios 
     250         ELSE 
     251            CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )        ! nemo local communicator given by xios 
     252         ENDIF 
     253      ENDIF 
     254      narea = mynode ( cltxt, clname, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )  ! Nodes selection 
    198255#else 
    199       ilocal_comm = 0 
    200       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )        ! Nodes selection (control print return in cltxt) 
     256      IF( lk_oasis ) THEN 
     257         IF( Agrif_Root() ) THEN 
     258            CALL cpl_init( "sas", ilocal_comm )                          ! nemo local communicator given by oasis 
     259         ENDIF 
     260         narea = mynode( cltxt, clname, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt) 
     261      ELSE 
     262         ilocal_comm = 0 
     263         narea = mynode( cltxt, clname, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
     264      ENDIF 
    201265#endif 
    202266      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 ) 
    … …  
    229293      ! than variables 
    230294      IF( Agrif_Root() ) THEN 
     295#if defined key_nemocice_decomp 
     296         jpi = ( nx_global+2-2*jpreci + (jpni-1) ) / jpni + 2*jpreci ! first  dim. 
     297         jpj = ( ny_global+2-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim.  
     298#else 
    231299         jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim. 
    232 #if defined key_nemocice_decomp 
    233          jpj = ( jpjglo+1-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim.  
    234 #else 
    235300         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    236301#endif 
     302      ENDIF 
    237303         jpk = jpkdta                                             ! third dim 
    238304         jpim1 = jpi-1                                            ! inner domain indices 
    … …  
    240306         jpkm1 = jpk-1                                            !   "           " 
    241307         jpij  = jpi*jpj                                          !  jpi x j 
    242       ENDIF 
    243308 
    244309      IF(lwp) THEN                            ! open listing units 
    245310         ! 
    246          CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     311         IF( lk_oasis ) THEN 
     312            CALL ctl_opn( numout,   'sas.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     313         ELSE 
     314            CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     315         ENDIF 
    247316         ! 
    248317         WRITE(numout,*) 
    … …  
    287356 
    288357      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
    289                             CALL flush(numout) 
    290  
    291358                            CALL day_init   ! model calendar (using both namelist and restart infos) 
    292359 
    293360                            CALL sbc_init   ! Forcings : surface module  
     361                             
     362      ! ==> clem: open boundaries init. is mandatory for LIM3 because ice BDY is not decoupled from   
     363      !           the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules.  
     364      !           This is not clean and should be changed in the future.  
     365      IF( lk_bdy        )   CALL     bdy_init 
     366      IF( lk_bdy        )   CALL bdy_dta_init 
     367      ! ==> 
    294368       
    295369      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 
    … …  
    397471      ENDIF 
    398472      ! 
     473      IF( 1_wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ',  & 
     474         &                                               'f2003 standard. '                              ,  & 
     475         &                                               'Compile with key_nosignedzero enabled' ) 
     476      ! 
    399477   END SUBROUTINE nemo_ctl 
    400478 
    … …  
    436514      USE diawri    , ONLY: dia_wri_alloc 
    437515      USE dom_oce   , ONLY: dom_oce_alloc 
    438       USE oce       , ONLY : sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass  
    439       ! 
    440       INTEGER :: ierr,ierr4 
     516#if defined key_bdy    
     517      USE bdy_oce   , ONLY: bdy_oce_alloc 
     518      USE oce         ! clem: mandatory for LIM3 because needed for bdy arrays 
     519#else 
     520      USE oce       , ONLY : sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 
     521#endif 
     522      ! 
     523      INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6 
     524      INTEGER :: jpm 
    441525      !!---------------------------------------------------------------------- 
    442526      ! 
    443527      ierr =        dia_wri_alloc   () 
    444528      ierr = ierr + dom_oce_alloc   ()          ! ocean domain 
    445       ALLOCATE( snwice_mass(jpi,jpj)  , snwice_mass_b(jpi,jpj),             & 
    446          &      snwice_fmass(jpi,jpj), STAT= ierr4 ) 
    447       ierr = ierr + ierr4 
     529#if defined key_bdy 
     530      ierr = ierr + bdy_oce_alloc   ()          ! bdy masks (incl. initialization) 
     531      ierr = ierr + oce_alloc       ()          ! (tsn...) 
     532#endif 
     533 
     534#if ! defined key_bdy 
     535       ALLOCATE( snwice_mass(jpi,jpj)  , snwice_mass_b(jpi,jpj),             & 
     536         &      snwice_fmass(jpi,jpj)  , STAT= ierr1 ) 
     537      ! 
     538      ! lim code currently uses surface temperature and salinity in tsn array for initialisation 
     539      ! and ub, vb arrays in ice dynamics, so allocate enough of arrays to use 
     540      ! clem: should not be needed. To be checked out 
     541      jpm = MAX(jp_tem, jp_sal) 
     542      ALLOCATE( tsn(jpi,jpj,1,jpm)  , STAT=ierr2 ) 
     543      ALLOCATE( ub(jpi,jpj,1)       , STAT=ierr3 ) 
     544      ALLOCATE( vb(jpi,jpj,1)       , STAT=ierr4 ) 
     545      ALLOCATE( tsb(jpi,jpj,1,jpm)  , STAT=ierr5 ) 
     546      ALLOCATE( sshn(jpi,jpj)       , STAT=ierr6 ) 
     547      ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6  
     548#endif 
    448549      ! 
    449550      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    … …  
    470571      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 
    471572      !!---------------------------------------------------------------------- 
    472  
     573      ! 
    473574      ierr = 0 
    474  
     575      ! 
    475576      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 
    476  
     577      ! 
    477578      IF( nfact <= 1 ) THEN 
    478579         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' 
    … …  
    516617      INTEGER, PARAMETER :: ntest = 14 
    517618      INTEGER :: ilfax(ntest) 
    518  
     619      ! 
    519620      ! lfax contains the set of allowed factors. 
    520621      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    … …  
    601702          !loop over the other north-fold processes to find the processes 
    602703          !managing the points belonging to the sxT-dxT range 
    603           DO jn = jpnij - jpni +1, jpnij 
    604              IF ( njmppt(jn) == njmppmax ) THEN 
     704   
     705          DO jn = 1, jpni 
    605706                !sxT is the first point (in the global domain) of the jn 
    606707                !process 
    607                 sxT = nimppt(jn) 
     708                sxT = nfiimpp(jn, jpnj) 
    608709                !dxT is the last point (in the global domain) of the jn 
    609710                !process 
    610                 dxT = nimppt(jn) + nlcit(jn) - 1 
     711                dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 
    611712                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 
    612713                   nsndto = nsndto + 1 
    613                    isendto(nsndto) = jn 
    614                 ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN 
     714                     isendto(nsndto) = jn 
     715                ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN 
    615716                   nsndto = nsndto + 1 
    616717                   isendto(nsndto) = jn 
    … …  
    619720                   isendto(nsndto) = jn 
    620721                END IF 
    621              END IF 
    622722          END DO 
     723          nfsloop = 1 
     724          nfeloop = nlci 
     725          DO jn = 2,jpni-1 
     726           IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN 
     727              IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN 
     728                 nfsloop = nldi 
     729              ENDIF 
     730              IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN 
     731                 nfeloop = nlei 
     732              ENDIF 
     733           ENDIF 
     734        END DO 
     735 
    623736      ENDIF 
    624737      l_north_nogather = .TRUE. 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/SAS_SRC/sbcssm.F90

    r5500 r5630  
    3636   PUBLIC   sbc_ssm        ! called by sbc 
    3737 
    38    CHARACTER(len=100)   ::   cn_dir     = './'    !: Root directory for location of ssm files 
    39    LOGICAL              ::   ln_3d_uv   = .true.  !: specify whether input velocity data is 3D 
    40    INTEGER  , SAVE      ::   nfld_3d 
    41    INTEGER  , SAVE      ::   nfld_2d 
    42  
    43    INTEGER  , PARAMETER ::   jpfld_3d = 4   ! maximum number of files to read 
    44    INTEGER  , PARAMETER ::   jpfld_2d = 1   ! maximum number of files to read 
    45    INTEGER  , SAVE      ::   jf_tem         ! index of temperature 
    46    INTEGER  , SAVE      ::   jf_sal         ! index of salinity 
    47    INTEGER  , SAVE      ::   jf_usp         ! index of u velocity component 
    48    INTEGER  , SAVE      ::   jf_vsp         ! index of v velocity component 
    49    INTEGER  , SAVE      ::   jf_ssh         ! index of sea surface height 
     38   CHARACTER(len=100)   ::   cn_dir        !: Root directory for location of ssm files 
     39   LOGICAL              ::   ln_3d_uve     !: specify whether input velocity data is 3D 
     40   LOGICAL              ::   ln_read_frq   !: specify whether we must read frq or not 
     41   LOGICAL              ::   l_initdone = .false. 
     42   INTEGER     ::   nfld_3d 
     43   INTEGER     ::   nfld_2d 
     44 
     45   INTEGER     ::   jf_tem         ! index of temperature 
     46   INTEGER     ::   jf_sal         ! index of salinity 
     47   INTEGER     ::   jf_usp         ! index of u velocity component 
     48   INTEGER     ::   jf_vsp         ! index of v velocity component 
     49   INTEGER     ::   jf_ssh         ! index of sea surface height 
     50   INTEGER     ::   jf_e3t         ! index of first T level thickness 
     51   INTEGER     ::   jf_frq         ! index of fraction of qsr absorbed in the 1st T level 
    5052 
    5153   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_3d  ! structure of input fields (file information, fields read) 
    5254   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_2d  ! structure of input fields (file information, fields read) 
    5355 
    54    !! * Substitutions 
    55 #  include "domzgr_substitute.h90" 
    56 #  include "vectopt_loop_substitute.h90" 
    5756   !!---------------------------------------------------------------------- 
    5857   !! NEMO/OFF 3.3 , NEMO Consortium (2010) 
    … …  
    8685      IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d )      !==   read data at kt time step   ==! 
    8786      !  
    88       IF( ln_3d_uv ) THEN 
     87      IF( ln_3d_uve ) THEN 
    8988         ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1)    ! u-velocity 
    9089         ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity  
     90         IF( lk_vvl )   e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1)    ! v-velocity  
    9191      ELSE 
    9292         ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1)    ! u-velocity 
    9393         ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity  
     94         IF( lk_vvl )   e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1)    ! v-velocity  
    9495      ENDIF 
    9596      ! 
    … …  
    9798      sss_m(:,:) = sf_ssm_2d(jf_sal)%fnow(:,:,1) * tmask(:,:,1)    ! salinity 
    9899      ssh_m(:,:) = sf_ssm_2d(jf_ssh)%fnow(:,:,1) * tmask(:,:,1)    ! sea surface height 
    99       ! 
    100       tsn(:,:,1,jp_tem) = sst_m(:,:) 
    101       tsn(:,:,1,jp_sal) = sss_m(:,:) 
     100      IF( ln_read_frq )   frq_m(:,:) = sf_ssm_2d(jf_frq)%fnow(:,:,1) * tmask(:,:,1)    ! sea surface height 
     101      ! 
    102102      IF ( nn_ice == 1 ) THEN 
     103         tsn(:,:,1,jp_tem) = sst_m(:,:) 
     104         tsn(:,:,1,jp_sal) = sss_m(:,:) 
    103105         tsb(:,:,1,jp_tem) = sst_m(:,:) 
    104106         tsb(:,:,1,jp_sal) = sss_m(:,:) 
    105107      ENDIF 
    106       ub (:,:,1       ) = ssu_m(:,:) 
    107       vb (:,:,1       ) = ssv_m(:,:) 
     108      ub (:,:,1) = ssu_m(:,:) 
     109      vb (:,:,1) = ssv_m(:,:) 
    108110 
    109111      IF(ln_ctl) THEN                  ! print control 
    … …  
    113115         CALL prt_ctl(tab2d_1=ssv_m, clinfo1=' ssv_m   - : ', mask1=vmask, ovlap=1   ) 
    114116         CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' ssh_m   - : ', mask1=tmask, ovlap=1   ) 
     117         IF( lk_vvl      )   CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' e3t_m   - : ', mask1=tmask, ovlap=1   ) 
     118         IF( ln_read_frq )   CALL prt_ctl(tab2d_1=frq_m, clinfo1=' frq_m   - : ', mask1=tmask, ovlap=1   ) 
     119      ENDIF 
     120      ! 
     121      IF( l_initdone ) THEN          !   Mean value at each nn_fsbc time-step   ! 
     122         CALL iom_put( 'ssu_m', ssu_m ) 
     123         CALL iom_put( 'ssv_m', ssv_m ) 
     124         CALL iom_put( 'sst_m', sst_m ) 
     125         CALL iom_put( 'sss_m', sss_m ) 
     126         CALL iom_put( 'ssh_m', ssh_m ) 
     127         IF( lk_vvl      )   CALL iom_put( 'e3t_m', e3t_m ) 
     128         IF( ln_read_frq )   CALL iom_put( 'frq_m', frq_m ) 
    115129      ENDIF 
    116130      ! 
    … …  
    138152      TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::  slf_2d       ! array of namelist information on the fields to read 
    139153      TYPE(FLD_N) :: sn_tem, sn_sal                     ! information about the fields to be read 
    140       TYPE(FLD_N) :: sn_usp, sn_vsp, sn_ssh 
    141       ! 
    142       NAMELIST/namsbc_sas/cn_dir, ln_3d_uv, sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh 
    143       !!---------------------------------------------------------------------- 
     154      TYPE(FLD_N) :: sn_usp, sn_vsp 
     155      TYPE(FLD_N) :: sn_ssh, sn_e3t, sn_frq 
     156      ! 
     157      NAMELIST/namsbc_sas/cn_dir, ln_3d_uve, ln_read_frq, sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq 
     158      !!---------------------------------------------------------------------- 
     159       
     160      IF( ln_rstart .AND. nn_components == jp_iam_sas ) RETURN 
    144161       
    145162      REWIND( numnam_ref )              ! Namelist namsbc_sas in reference namelist : Input fields 
    … …  
    159176         WRITE(numout,*) '~~~~~~~~~~~ ' 
    160177         WRITE(numout,*) '   Namelist namsbc_sas' 
     178         WRITE(numout,*) '      Are we supplying a 3D u,v and e3 field                             ln_3d_uve   = ', ln_3d_uve 
     179         WRITE(numout,*) '      Are we reading frq (fraction of qsr absorbed in the 1st T level)   ln_read_frq = ', ln_read_frq 
    161180         WRITE(numout,*) 
    162181      ENDIF 
    163        
    164182      ! 
    165183      !! switch off stuff that isn't sensible with a standalone module 
    … …  
    170188         ln_apr_dyn = .FALSE. 
    171189      ENDIF 
    172       IF( ln_dm2dc ) THEN 
    173          IF( lwp ) WRITE(numout,*) 'No diurnal cycle needed with StandAlone Surface scheme' 
    174          ln_dm2dc = .FALSE. 
    175       ENDIF 
    176190      IF( ln_rnf ) THEN 
    177191         IF( lwp ) WRITE(numout,*) 'No runoff needed with StandAlone Surface scheme' 
    … …  
    190204         nn_closea = 0 
    191205      ENDIF 
    192  
    193206      !  
    194207      !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and 
    195208      !! when we have other 3d arrays that we need to read in 
    196209      !! so if a new field is added i.e. jf_new, just give it the next integer in sequence 
    197       !! for the corresponding dimension (currently if ln_3d_uv is true, 4 for 2d and 3 for 3d, 
    198       !! alternatively if ln_3d_uv is false, 6 for 2d and 1 for 3d), reset nfld_3d, nfld_2d, 
     210      !! for the corresponding dimension (currently if ln_3d_uve is true, 4 for 2d and 3 for 3d, 
     211      !! alternatively if ln_3d_uve is false, 6 for 2d and 1 for 3d), reset nfld_3d, nfld_2d, 
    199212      !! and the rest of the logic should still work 
    200213      ! 
    201       jf_tem = 1 ; jf_sal = 2 ; jf_ssh = 3 
    202       ! 
    203       IF( ln_3d_uv ) THEN 
    204          jf_usp = 1 ; jf_vsp = 2 
    205          nfld_3d  = 2 
    206          nfld_2d  = 3 
     214      jf_tem = 1 ; jf_sal = 2 ; jf_ssh = 3 ; jf_frq = 4   ! default 2D fields index 
     215      ! 
     216      IF( ln_3d_uve ) THEN 
     217         jf_usp = 1 ; jf_vsp = 2 ; jf_e3t = 3      ! define 3D fields index 
     218         nfld_3d  = 2 + COUNT( (/lk_vvl/) )        ! number of 3D fields to read 
     219         nfld_2d  = 3 + COUNT( (/ln_read_frq/) )   ! number of 2D fields to read 
    207220      ELSE 
    208          jf_usp = 4 ; jf_vsp = 5 
    209          nfld_3d  = 0 
    210          nfld_2d  = 5 
     221         jf_usp = 4 ; jf_vsp = 5 ; jf_e3t = 6 ; jf_frq = 6 + COUNT( (/lk_vvl/) )   ! update 2D fields index 
     222         nfld_3d  = 0                                                              ! no 3D fields to read 
     223         nfld_2d  = 5 + COUNT( (/lk_vvl/) ) + COUNT( (/ln_read_frq/) )             ! number of 2D fields to read 
    211224      ENDIF 
    212225 
    … …  
    216229            CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 3d structure' )   ;   RETURN 
    217230         ENDIF 
    218          IF( ln_3d_uv ) THEN 
    219             slf_3d(jf_usp) = sn_usp 
    220             slf_3d(jf_vsp) = sn_vsp 
    221          ENDIF 
     231         slf_3d(jf_usp) = sn_usp 
     232         slf_3d(jf_vsp) = sn_vsp 
     233         IF( lk_vvl )   slf_3d(jf_e3t) = sn_e3t 
    222234      ENDIF 
    223235 
    … …  
    228240         ENDIF 
    229241         slf_2d(jf_tem) = sn_tem ; slf_2d(jf_sal) = sn_sal ; slf_2d(jf_ssh) = sn_ssh 
    230          IF( .NOT. ln_3d_uv ) THEN 
     242         IF( ln_read_frq )   slf_2d(jf_frq) = sn_frq 
     243         IF( .NOT. ln_3d_uve ) THEN 
    231244            slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp 
    232          ENDIF 
    233       ENDIF 
    234       ! 
     245            IF( lk_vvl )   slf_2d(jf_e3t) = sn_e3t 
     246         ENDIF 
     247      ENDIF 
     248      ! 
     249      ierr1 = 0    ! default definition if slf_?d(ifpr)%ln_tint = .false.  
    235250      IF( nfld_3d > 0 ) THEN 
    236251         ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr )         ! set sf structure 
    … …  
    265280      ENDIF 
    266281      ! 
    267       ! lim code currently uses surface temperature and salinity in tsn array for initialisation 
    268       ! and ub, vb arrays in ice dynamics 
    269       ! so allocate enough of arrays to use 
    270       ! 
    271       ierr3 = 0 
    272       jpm = MAX(jp_tem, jp_sal) 
    273       ALLOCATE( tsn(jpi,jpj,1,jpm), STAT=ierr0 ) 
    274       ALLOCATE( ub(jpi,jpj,1)     , STAT=ierr1 ) 
    275       ALLOCATE( vb(jpi,jpj,1)     , STAT=ierr2 ) 
    276       IF ( nn_ice == 1 ) ALLOCATE( tsb(jpi,jpj,1,jpm), STAT=ierr3 ) 
    277       ierr = ierr0 + ierr1 + ierr2 + ierr3 
    278       IF( ierr > 0 ) THEN 
    279          CALL ctl_stop('sbc_ssm_init: unable to allocate surface arrays') 
    280       ENDIF 
    281       ! 
    282282      ! finally tidy up 
    283283 
    284284      IF( nfld_3d > 0 ) DEALLOCATE( slf_3d, STAT=ierr ) 
    285285      IF( nfld_2d > 0 ) DEALLOCATE( slf_2d, STAT=ierr ) 
     286 
     287      CALL sbc_ssm( nit000 )   ! need to define ss?_m arrays used in limistate 
     288      IF( .NOT. ln_read_frq )   frq_m(:,:) = 1. 
     289      l_initdone = .TRUE. 
    286290      ! 
    287291   END SUBROUTINE sbc_ssm_init 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/SAS_SRC/step.F90

    r5500 r5630  
    1717   USE dom_oce          ! ocean space and time domain variables  
    1818   USE in_out_manager   ! I/O manager 
     19   USE sbc_oce 
     20   USE sbccpl 
    1921   USE iom              ! 
    2022   USE lbclnk 
    … …  
    3537 
    3638   USE timing           ! Timing             
     39 
     40   USE bdy_par          ! clem: mandatory for LIM3 
     41#if defined key_bdy 
     42   USE bdydta           ! clem: mandatory for LIM3 
     43#endif 
    3744 
    3845   IMPLICIT NONE 
    … …  
    7279      kstp = nit000 + Agrif_Nb_Step() 
    7380# if defined key_iomput 
    74       IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( "nemo" ) 
     81      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    7582# endif    
    7683#endif    
    77       IF( kstp == nit000 )   CALL iom_init( "nemo" )      ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
     84      IF( kstp == nit000 )   CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    7885      IF( kstp /= nit000 )   CALL day( kstp )             ! Calendar (day was already called at nit000 in day_init) 
    79                              CALL iom_setkt( kstp, "nemo" )       ! say to iom that we are at time step kstp 
     86                             CALL iom_setkt( kstp - nit000 + 1, cxios_context )   ! tell iom we are at time step kstp 
    8087 
     88      ! ==> clem: open boundaries is mandatory for LIM3 because ice BDY is not decoupled from   
     89      !           the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules. 
     90      !           From SAS: ocean bdy data are wrong  (but we do not care) and ice bdy data are OK.   
     91      !           This is not clean and should be changed in the future.  
     92#if defined key_bdy 
     93      IF( lk_bdy     )       CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
     94#endif 
     95      ! ==> 
    8196                             CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    8297 
    … …  
    86101                                                          ! need to keep the same interface  
    87102                             CALL stp_ctl( kstp, indic ) 
     103      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     104      ! Coupled mode 
     105      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     106      IF( lk_oasis    )  CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges if OASIS-coupled ice 
     107 
    88108#if defined key_iomput 
    89       IF( kstp == nitend )   CALL iom_context_finalize( "nemo" ) ! needed for XIOS+AGRIF 
     109      IF( kstp == nitend .OR. indic < 0 ) THEN  
     110                             CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 
     111      ENDIF 
    90112#endif 
    91113      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/C14b/trcwri_c14b.F90

    r5500 r5630  
    66   !! History :   1.0  !  2009-05 (C. Ethe)  Original code 
    77   !!---------------------------------------------------------------------- 
    8 #if defined key_top && key_c14b && defined key_iomput 
     8#if defined key_top && defined key_c14b && defined key_iomput 
    99   !!---------------------------------------------------------------------- 
    1010   !!   'key_c14b'                                           c14b model 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/CFC/trcwri_cfc.F90

    r5500 r5630  
    66   !! History :   1.0  !  2009-05 (C. Ethe)  Original code 
    77   !!---------------------------------------------------------------------- 
    8 #if defined key_top && key_cfc && defined key_iomput 
     8#if defined key_top && defined key_cfc && defined key_iomput 
    99   !!---------------------------------------------------------------------- 
    1010   !!   'key_cfc'                                           cfc model 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcini_my_trc.F90

    r5500 r5630  
    4242 
    4343      IF(lwp) WRITE(numout,*) 
    44       IF(lwp) WRITE(numout,*) ' trc_ini_my_trc: initialisation of MY_TRC model' 
     44      IF(lwp) WRITE(numout,*) ' trc_ini_my_trc: passive tracer unit vector' 
     45      IF(lwp) WRITE(numout,*) ' To check conservation : ' 
     46      IF(lwp) WRITE(numout,*) '   1 - No sea-ice model ' 
     47      IF(lwp) WRITE(numout,*) '   2 - No runoff '  
     48      IF(lwp) WRITE(numout,*) '   3 - precipitation and evaporation equal to 1 : E=P=1 '  
    4549      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
    4650       
    47       IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 0. 
     51      IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 1. 
    4852      ! 
    4953   END SUBROUTINE trc_ini_my_trc 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcsms_my_trc.F90

    r5500 r5630  
    4646      INTEGER ::   jn   ! dummy loop index 
    4747      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrmyt 
    48 !!---------------------------------------------------------------------- 
     48      !!---------------------------------------------------------------------- 
    4949      ! 
    5050      IF( nn_timing == 1 )  CALL timing_start('trc_sms_my_trc') 
    … …  
    5555 
    5656      IF( l_trdtrc )  CALL wrk_alloc( jpi, jpj, jpk, ztrmyt ) 
    57  
    58       WHERE( (glamt <= 170) .AND. (glamt >= 160) .AND. (gphit <= -74) .AND. (gphit >=-75.6) ) 
    59         trn(:,:,1,jpmyt1) = 1._wp 
    60         trb(:,:,1,jpmyt1) = 1._wp 
    61         tra(:,:,1,jpmyt1) = 0._wp 
    62       END WHERE 
    6357 
    6458      IF( l_trdtrc ) THEN      ! Save the trends in the ixed layer 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcwri_my_trc.F90

    r5500 r5630  
    66   !! History :   1.0  !  2009-05 (C. Ethe)  Original code 
    77   !!---------------------------------------------------------------------- 
    8 #if defined key_top && key_my_trc && defined key_iomput 
     8#if defined key_top && defined key_my_trc && defined key_iomput 
    99   !!---------------------------------------------------------------------- 
    1010   !!   'key_my_trc'                                           my_trc model 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zopt.F90

    r5500 r5630  
    8989 
    9090      !                                          ! surface irradiance 
    91       zpar0m (:,:)   = qsr   (:,:) * 0.43        ! ------------------ 
     91      !                                          ! ------------------ 
     92      IF( ln_dm2dc ) THEN   ;   zpar0m(:,:) = qsr_mean(:,:) * 0.43 
     93      ELSE                  ;   zpar0m(:,:) = qsr     (:,:) * 0.43 
     94      ENDIF 
    9295      zpar100(:,:)   = zpar0m(:,:) * 0.01 
    9396      zparr  (:,:,1) = zpar0m(:,:) * 0.5 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90

    r5500 r5630  
    4444CONTAINS 
    4545 
    46    SUBROUTINE p4z_bio ( kt, jnt ) 
     46   SUBROUTINE p4z_bio ( kt, knt ) 
    4747      !!--------------------------------------------------------------------- 
    4848      !!                     ***  ROUTINE p4z_bio  *** 
    … …  
    5454      !! ** Method  : - ??? 
    5555      !!--------------------------------------------------------------------- 
    56       INTEGER, INTENT(in) :: kt, jnt 
    57       INTEGER  ::  ji, jj, jk, jn 
    58       REAL(wp) ::  ztra 
    59 #if defined key_kriest 
    60       REAL(wp) ::  zcoef1, zcoef2 
    61 #endif 
     56      INTEGER, INTENT(in) :: kt, knt 
     57      INTEGER             :: ji, jj, jk, jn 
    6258      CHARACTER (len=25) :: charout 
    6359 
    … …  
    8076 
    8177           
    82       CALL p4z_opt  ( kt, jnt )     ! Optic: PAR in the water column 
    83       CALL p4z_sink ( kt, jnt )     ! vertical flux of particulate organic matter 
    84       CALL p4z_fechem(kt, jnt )     ! Iron chemistry/scavenging 
    85       CALL p4z_lim  ( kt, jnt )     ! co-limitations by the various nutrients 
    86       CALL p4z_prod ( kt, jnt )     ! phytoplankton growth rate over the global ocean.  
     78      CALL p4z_opt  ( kt, knt )     ! Optic: PAR in the water column 
     79      CALL p4z_sink ( kt, knt )     ! vertical flux of particulate organic matter 
     80      CALL p4z_fechem(kt, knt )     ! Iron chemistry/scavenging 
     81      CALL p4z_lim  ( kt, knt )     ! co-limitations by the various nutrients 
     82      CALL p4z_prod ( kt, knt )     ! phytoplankton growth rate over the global ocean.  
    8783      !                             ! (for each element : C, Si, Fe, Chl ) 
    8884      CALL p4z_mort ( kt      )     ! phytoplankton mortality 
    89       !                             ! zooplankton sources/sinks routines  
    90       CALL p4z_micro( kt, jnt )           ! microzooplankton 
    91       CALL p4z_meso ( kt, jnt )           ! mesozooplankton 
    92       CALL p4z_rem  ( kt, jnt )     ! remineralization terms of organic matter+scavenging of Fe 
     85     !                             ! zooplankton sources/sinks routines  
     86      CALL p4z_micro( kt, knt )           ! microzooplankton 
     87      CALL p4z_meso ( kt, knt )           ! mesozooplankton 
     88      CALL p4z_rem  ( kt, knt )     ! remineralization terms of organic matter+scavenging of Fe 
    9389      !                             ! test if tracers concentrations fall below 0. 
    94       xnegtr(:,:,:) = 1.e0 
    95       DO jn = jp_pcs0, jp_pcs1 
    96          DO jk = 1, jpk 
    97             DO jj = 1, jpj 
    98                DO ji = 1, jpi 
    99                   IF( ( trn(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 
    100                      ztra             = ABS( trn(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 
    101  
    102                      xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk),  ztra ) 
    103                   ENDIF 
    104               END DO 
    105             END DO 
    106          END DO 
    107       END DO 
    108       !                                ! where at least 1 tracer concentration becomes negative 
    109       !                                !  
    110       DO jn = jp_pcs0, jp_pcs1 
    111          trn(:,:,:,jn) = trn(:,:,:,jn) + xnegtr(:,:,:) * tra(:,:,:,jn) 
    112       END DO 
    113  
    114  
    115       tra(:,:,:,:) = 0.e0 
    116  
    117 #if defined key_kriest 
    118       !  
    119       zcoef1 = 1.e0 / xkr_massp  
    120       zcoef2 = 1.e0 / xkr_massp / 1.1 
    121       DO jk = 1,jpkm1 
    122          trn(:,:,jk,jpnum) = MAX(  trn(:,:,jk,jpnum), trn(:,:,jk,jppoc) * zcoef1 / xnumm(jk)  ) 
    123          trn(:,:,jk,jpnum) = MIN(  trn(:,:,jk,jpnum), trn(:,:,jk,jppoc) * zcoef2              ) 
    124       END DO 
    125 #endif 
    126  
    127       ! 
     90      !                                                             ! 
    12891      IF(ln_ctl)   THEN  ! print mean trends (used for debugging) 
    12992         WRITE(charout, FMT="('bio ')") 
    13093         CALL prt_ctl_trc_info(charout) 
    131          CALL prt_ctl_trc(tab4d=trn, mask=tmask, clinfo=ctrcnm) 
     94         CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) 
    13295      ENDIF 
    13396      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zfechem.F90

    r5500 r5630  
    4848CONTAINS 
    4949 
    50    SUBROUTINE p4z_fechem( kt, jnt ) 
     50   SUBROUTINE p4z_fechem( kt, knt ) 
    5151      !!--------------------------------------------------------------------- 
    5252      !!                     ***  ROUTINE p4z_fechem  *** 
    … …  
    6262      !!--------------------------------------------------------------------- 
    6363      ! 
    64       INTEGER, INTENT(in) ::   kt, jnt ! ocean time step 
     64      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    6565      ! 
    6666      INTEGER  ::   ji, jj, jk, jic 
    … …  
    101101      ! ------------------------------------------------- 
    102102      IF( ln_ligvar ) THEN 
    103          ztotlig(:,:,:) =  0.09 * trn(:,:,:,jpdoc) * 1E6 + ligand * 1E9 
     103         ztotlig(:,:,:) =  0.09 * trb(:,:,:,jpdoc) * 1E6 + ligand * 1E9 
    104104         ztotlig(:,:,:) =  MIN( ztotlig(:,:,:), 10. ) 
    105105      ELSE 
    … …  
    127127                  zionic = 19.9201 * tsn(ji,jj,jk,jp_sal) / ( 1000. - 1.00488 * tsn(ji,jj,jk,jp_sal) + rtrn ) 
    128128                  zph    = -LOG10( MAX( hi(ji,jj,jk), rtrn) ) 
    129                   zoxy   = trn(ji,jj,jk,jpoxy) * ( rhop(ji,jj,jk) / 1.e3 ) 
     129                  zoxy   = trb(ji,jj,jk,jpoxy) * ( rhop(ji,jj,jk) / 1.e3 ) 
    130130                  ! Fe2+ oxydation rate from Santana-Casiano et al. (2005) 
    131131                  zkox   = 35.407 - 6.7109 * zph + 0.5342 * zph * zph - 5362.6 / ( tsn(ji,jj,jk,jp_tem) + 273.15 )  & 
    … …  
    137137                  zkph1 = zkph2 / 5. 
    138138                  ! pass the dfe concentration from PISCES 
    139                   ztfe = trn(ji,jj,jk,jpfer) * 1e9 
     139                  ztfe = trb(ji,jj,jk,jpfer) * 1e9 
    140140                  ! ---------------------------------------------------------- 
    141141                  ! ANALYTICAL SOLUTION OF ROOTS OF THE FE3+ EQUATION 
    … …  
    204204                  zkeq           = fekeq(ji,jj,jk) 
    205205                  zfesatur       = zTL1(ji,jj,jk) * 1E-9 
    206                   ztfe           = trn(ji,jj,jk,jpfer)  
     206                  ztfe           = trb(ji,jj,jk,jpfer)  
    207207                  ! Fe' is the root of a 2nd order polynom 
    208208                  zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe )               & 
    … …  
    210210                     &               + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) 
    211211                  zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 
    212                   zFeL1(ji,jj,jk) = MAX( 0., trn(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 
     212                  zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 
    213213              END DO 
    214214            END DO 
    … …  
    240240               ENDIF 
    241241#if defined key_kriest 
    242                ztrc   = ( trn(ji,jj,jk,jppoc) + trn(ji,jj,jk,jpcal) + trn(ji,jj,jk,jpgsi) ) * 1.e6  
     242               ztrc   = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6  
    243243#else 
    244                ztrc   = ( trn(ji,jj,jk,jppoc) + trn(ji,jj,jk,jpgoc) + trn(ji,jj,jk,jpcal) + trn(ji,jj,jk,jpgsi) ) * 1.e6  
     244               ztrc   = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6  
    245245#endif 
    246246               IF( ln_dust )  zdust  = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) ! dust in kg/m2/s 
    … …  
    251251               ! to later allocate scavenged iron to the different organic pools 
    252252               ! --------------------------------------------------------- 
    253                zdenom1 = xlam1 * trn(ji,jj,jk,jppoc) / zlam1b 
     253               zdenom1 = xlam1 * trb(ji,jj,jk,jppoc) / zlam1b 
    254254#if ! defined key_kriest 
    255                zdenom2 = xlam1 * trn(ji,jj,jk,jpgoc) / zlam1b 
     255               zdenom2 = xlam1 * trb(ji,jj,jk,jpgoc) / zlam1b 
    256256#endif 
    257257 
    … …  
    262262               zlamfac = MIN( 1.  , zlamfac ) 
    263263               zdep    = MIN( 1., 1000. / fsdept(ji,jj,jk) ) 
    264                zlam1b  = xlam1 * MAX( 0.e0, ( trn(ji,jj,jk,jpfer) * 1.e9 - ztotlig(ji,jj,jk) ) ) 
    265                zcoag   = zfeequi * zlam1b * zstep + 1E-4 * ( 1. - zlamfac ) * zdep * zstep * trn(ji,jj,jk,jpfer) 
     264               zlam1b  = xlam1 * MAX( 0.e0, ( trb(ji,jj,jk,jpfer) * 1.e9 - ztotlig(ji,jj,jk) ) ) 
     265               zcoag   = zfeequi * zlam1b * zstep + 1E-4 * ( 1. - zlamfac ) * zdep * zstep * trb(ji,jj,jk,jpfer) 
    266266 
    267267               !  Compute the coagulation of colloidal iron. This parameterization  
    … …  
    269269               !  It requires certainly some more work as it is very poorly constrained. 
    270270               !  ---------------------------------------------------------------- 
    271                zlam1a  = ( 0.369  * 0.3 * trn(ji,jj,jk,jpdoc) + 102.4  * trn(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
    272                    &   + ( 114.   * 0.3 * trn(ji,jj,jk,jpdoc) + 5.09E3 * trn(ji,jj,jk,jppoc) ) 
     271               zlam1a  = ( 0.369  * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4  * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
     272                   &   + ( 114.   * 0.3 * trb(ji,jj,jk,jpdoc) + 5.09E3 * trb(ji,jj,jk,jppoc) ) 
    273273               zaggdfea = zlam1a * zstep * zfecoll 
    274274#if defined key_kriest 
    … …  
    278278               tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea + zaggdfeb 
    279279#else 
    280                zlam1b = 3.53E3 *   trn(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
     280               zlam1b = 3.53E3 *   trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
    281281               zaggdfeb = zlam1b * zstep * zfecoll 
    282282               ! 
    … …  
    292292      !  ---------------------------------------- 
    293293      IF( ln_fechem ) THEN 
    294           biron(:,:,:) = MAX( 0., trn(:,:,:,jpfer) - zFeP(:,:,:) * 1E-9 ) 
     294          biron(:,:,:) = MAX( 0., trb(:,:,:,jpfer) - zFeP(:,:,:) * 1E-9 ) 
    295295      ELSE 
    296           biron(:,:,:) = trn(:,:,:,jpfer)  
     296          biron(:,:,:) = trb(:,:,:,jpfer)  
    297297      ENDIF 
    298298 
    299299      !  Output of some diagnostics variables 
    300300      !     --------------------------------- 
    301       IF( lk_iomput .AND. jnt == nrdttrc ) THEN 
     301      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    302302         IF( iom_use("Fe3")    )  CALL iom_put("Fe3"    , zFe3   (:,:,:)       * tmask(:,:,:) )   ! Fe3+ 
    303303         IF( iom_use("FeL1")   )  CALL iom_put("FeL1"   , zFeL1  (:,:,:)       * tmask(:,:,:) )   ! FeL1 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r5500 r5630  
    6868CONTAINS 
    6969 
    70    SUBROUTINE p4z_flx ( kt ) 
     70   SUBROUTINE p4z_flx ( kt, knt ) 
    7171      !!--------------------------------------------------------------------- 
    7272      !!                     ***  ROUTINE p4z_flx  *** 
    … …  
    8181      !!--------------------------------------------------------------------- 
    8282      ! 
    83       INTEGER, INTENT(in) ::   kt   ! 
     83      INTEGER, INTENT(in) ::   kt, knt   ! 
    8484      ! 
    8585      INTEGER  ::   ji, jj, jm, iind, iindm1 
    … …  
    101101      !     IS USED TO COMPUTE AIR-SEA FLUX OF CO2 
    102102 
    103       IF( kt /= nit000 ) CALL p4z_patm( kt )    ! Get sea-level pressure (E&K [1981] climatology) for use in flux calcs 
     103      IF( kt /= nit000 .AND. knt == 1 ) CALL p4z_patm( kt )    ! Get sea-level pressure (E&K [1981] climatology) for use in flux calcs 
    104104 
    105105      IF( ln_co2int ) THEN  
    … …  
    130130               zbot  = borat(ji,jj,1) 
    131131               zfact = rhop(ji,jj,1) / 1000. + rtrn 
    132                zdic  = trn(ji,jj,1,jpdic) / zfact 
     132               zdic  = trb(ji,jj,1,jpdic) / zfact 
    133133               zph   = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 
    134                zalka = trn(ji,jj,1,jptal) / zfact 
     134               zalka = trb(ji,jj,1,jptal) / zfact 
    135135 
    136136               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    … …  
    184184            zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
    185185            zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
    186             oce_co2(ji,jj) = ( zfld - zflu ) * rfact * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
     186            oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
    187187            ! compute the trend 
    188             tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) / fse3t(ji,jj,1) 
     188            tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) * rfact2 / fse3t(ji,jj,1) 
    189189 
    190190            ! Compute O2 flux  
    191191            zfld16 = atcox * patm(ji,jj) * chemc(ji,jj,2) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
    192             zflu16 = trn(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
     192            zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
    193193            zoflx(ji,jj) = zfld16 - zflu16 
    194             tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zoflx(ji,jj) / fse3t(ji,jj,1) 
     194            tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zoflx(ji,jj) * rfact2 / fse3t(ji,jj,1) 
    195195         END DO 
    196196      END DO 
    … …  
    207207      ENDIF 
    208208 
    209       IF( lk_iomput ) THEN 
     209      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    210210         CALL wrk_alloc( jpi, jpj, zw2d )   
    211211         IF( iom_use( "Cflx"  ) )  THEN 
    212             zw2d(:,:) = oce_co2(:,:) / e1e2t(:,:) / rfact 
     212            zw2d(:,:) = oce_co2(:,:) / e1e2t(:,:) * rfact2r 
    213213            CALL iom_put( "Cflx"     , zw2d )  
    214214         ENDIF 
    … …  
    226226         ENDIF 
    227227         IF( iom_use( "Dpo2" ) )  THEN 
    228            zw2d(:,:) = ( atcox * patm(:,:) - trn(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1) 
     228           zw2d(:,:) = ( atcox * patm(:,:) - trb(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1) 
    229229           CALL iom_put( "Dpo2"  , zw2d ) 
    230230         ENDIF 
    … …  
    235235      ELSE 
    236236         IF( ln_diatrc ) THEN 
    237             trc2d(:,:,jp_pcs0_2d    ) = oce_co2(:,:) / e1e2t(:,:) / rfact  
     237            trc2d(:,:,jp_pcs0_2d    ) = oce_co2(:,:) / e1e2t(:,:) * rfact2r  
    238238            trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)  
    239239            trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)  

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zint.F90

    r5500 r5630  
    5656      DO ji = 1, jpi 
    5757         DO jj = 1, jpj 
    58             zvar = trn(ji,jj,1,jpsil) * trn(ji,jj,1,jpsil) 
     58            zvar = trb(ji,jj,1,jpsil) * trb(ji,jj,1,jpsil) 
    5959            xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zvar / ( xksilim * xksilim + zvar ) ) * 1e-6 ) 
    6060         END DO 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90

    r5500 r5630  
    6262CONTAINS 
    6363 
    64    SUBROUTINE p4z_lim( kt, jnt ) 
     64   SUBROUTINE p4z_lim( kt, knt ) 
    6565      !!--------------------------------------------------------------------- 
    6666      !!                     ***  ROUTINE p4z_lim  *** 
    … …  
    7272      !!--------------------------------------------------------------------- 
    7373      ! 
    74       INTEGER, INTENT(in)  :: kt, jnt 
     74      INTEGER, INTENT(in)  :: kt, knt 
    7575      ! 
    7676      INTEGER  ::   ji, jj, jk 
    7777      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim 
    7878      REAL(wp) ::   zconcd, zconcd2, zconcn, zconcn2 
    79       REAL(wp) ::   z1_trndia, z1_trnphy, ztem1, ztem2, zetot1, zetot2 
     79      REAL(wp) ::   z1_trbdia, z1_trbphy, ztem1, ztem2, zetot1, zetot2 
    8080      REAL(wp) ::   zdenom, zratio, zironmin 
    8181      REAL(wp) ::   zconc1d, zconc1dnh4, zconc0n, zconc0nnh4    
    … …  
    9090               ! Tuning of the iron concentration to a minimum level that is set to the detection limit 
    9191               !------------------------------------- 
    92                zno3    = trn(ji,jj,jk,jpno3) / 40.e-6 
     92               zno3    = trb(ji,jj,jk,jpno3) / 40.e-6 
    9393               zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 ) 
    9494               zferlim = MIN( zferlim, 7e-11 ) 
    95                trn(ji,jj,jk,jpfer) = MAX( trn(ji,jj,jk,jpfer), zferlim ) 
     95               trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim ) 
    9696 
    9797               ! Computation of a variable Ks for iron on diatoms taking into account 
    9898               ! that increasing biomass is made of generally bigger cells 
    9999               !------------------------------------------------ 
    100                zconcd   = MAX( 0.e0 , trn(ji,jj,jk,jpdia) - xsizedia ) 
    101                zconcd2  = trn(ji,jj,jk,jpdia) - zconcd 
    102                zconcn   = MAX( 0.e0 , trn(ji,jj,jk,jpphy) - xsizephy ) 
    103                zconcn2  = trn(ji,jj,jk,jpphy) - zconcn 
    104                z1_trnphy   = 1. / ( trn(ji,jj,jk,jpphy) + rtrn ) 
    105                z1_trndia   = 1. / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    106  
    107                concdfe(ji,jj,jk) = MAX( concdfer, ( zconcd2 * concdfer + concdfer * xsizerd * zconcd ) * z1_trndia ) 
    108                zconc1d           = MAX( concdno3, ( zconcd2 * concdno3 + concdno3 * xsizerd * zconcd ) * z1_trndia ) 
    109                zconc1dnh4        = MAX( concdnh4, ( zconcd2 * concdnh4 + concdnh4 * xsizerd * zconcd ) * z1_trndia ) 
    110  
    111                concnfe(ji,jj,jk) = MAX( concnfer, ( zconcn2 * concnfer + concnfer * xsizern * zconcn ) * z1_trnphy ) 
    112                zconc0n           = MAX( concnno3, ( zconcn2 * concnno3 + concnno3 * xsizern * zconcn ) * z1_trnphy ) 
    113                zconc0nnh4        = MAX( concnnh4, ( zconcn2 * concnnh4 + concnnh4 * xsizern * zconcn ) * z1_trnphy ) 
     100               zconcd   = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia ) 
     101               zconcd2  = trb(ji,jj,jk,jpdia) - zconcd 
     102               zconcn   = MAX( 0.e0 , trb(ji,jj,jk,jpphy) - xsizephy ) 
     103               zconcn2  = trb(ji,jj,jk,jpphy) - zconcn 
     104               z1_trbphy   = 1. / ( trb(ji,jj,jk,jpphy) + rtrn ) 
     105               z1_trbdia   = 1. / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     106 
     107               concdfe(ji,jj,jk) = MAX( concdfer, ( zconcd2 * concdfer + concdfer * xsizerd * zconcd ) * z1_trbdia ) 
     108               zconc1d           = MAX( concdno3, ( zconcd2 * concdno3 + concdno3 * xsizerd * zconcd ) * z1_trbdia ) 
     109               zconc1dnh4        = MAX( concdnh4, ( zconcd2 * concdnh4 + concdnh4 * xsizerd * zconcd ) * z1_trbdia ) 
     110 
     111               concnfe(ji,jj,jk) = MAX( concnfer, ( zconcn2 * concnfer + concnfer * xsizern * zconcn ) * z1_trbphy ) 
     112               zconc0n           = MAX( concnno3, ( zconcn2 * concnno3 + concnno3 * xsizern * zconcn ) * z1_trbphy ) 
     113               zconc0nnh4        = MAX( concnnh4, ( zconcn2 * concnnh4 + concnnh4 * xsizern * zconcn ) * z1_trbphy ) 
    114114 
    115115               ! Michaelis-Menten Limitation term for nutrients Small bacteria 
    116116               ! ------------------------------------------------------------- 
    117                zdenom = 1. /  ( concbno3 * concbnh4 + concbnh4 * trn(ji,jj,jk,jpno3) + concbno3 * trn(ji,jj,jk,jpnh4) ) 
    118                xnanono3(ji,jj,jk) = trn(ji,jj,jk,jpno3) * concbnh4 * zdenom 
    119                xnanonh4(ji,jj,jk) = trn(ji,jj,jk,jpnh4) * concbno3 * zdenom 
     117               zdenom = 1. /  ( concbno3 * concbnh4 + concbnh4 * trb(ji,jj,jk,jpno3) + concbno3 * trb(ji,jj,jk,jpnh4) ) 
     118               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * concbnh4 * zdenom 
     119               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * concbno3 * zdenom 
    120120               ! 
    121121               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) 
    122                zlim2    = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + concbnh4 ) 
    123                zlim3    = trn(ji,jj,jk,jpfer) / ( concbfe + trn(ji,jj,jk,jpfer) ) 
    124                zlim4    = trn(ji,jj,jk,jpdoc) / ( xkdoc   + trn(ji,jj,jk,jpdoc) ) 
     122               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbnh4 ) 
     123               zlim3    = trb(ji,jj,jk,jpfer) / ( concbfe + trb(ji,jj,jk,jpfer) ) 
     124               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) ) 
    125125               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) 
    126126               xlimbac (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) * zlim4 
    … …  
    128128               ! Michaelis-Menten Limitation term for nutrients Small flagellates 
    129129               ! ----------------------------------------------- 
    130                zdenom = 1. /  ( zconc0n * zconc0nnh4 + zconc0nnh4 * trn(ji,jj,jk,jpno3) + zconc0n * trn(ji,jj,jk,jpnh4) ) 
    131                xnanono3(ji,jj,jk) = trn(ji,jj,jk,jpno3) * zconc0nnh4 * zdenom 
    132                xnanonh4(ji,jj,jk) = trn(ji,jj,jk,jpnh4) * zconc0n    * zdenom 
     130               zdenom = 1. /  ( zconc0n * zconc0nnh4 + zconc0nnh4 * trb(ji,jj,jk,jpno3) + zconc0n * trb(ji,jj,jk,jpnh4) ) 
     131               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc0nnh4 * zdenom 
     132               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc0n    * zdenom 
    133133               ! 
    134134               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) 
    135                zlim2    = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + zconc0nnh4 ) 
    136                zratio   = trn(ji,jj,jk,jpnfe) * z1_trnphy  
    137                zironmin = xcoef1 * trn(ji,jj,jk,jpnch) * z1_trnphy + xcoef2 * zlim1 + xcoef3 * xnanono3(ji,jj,jk) 
     135               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc0nnh4 ) 
     136               zratio   = trb(ji,jj,jk,jpnfe) * z1_trbphy  
     137               zironmin = xcoef1 * trb(ji,jj,jk,jpnch) * z1_trbphy + xcoef2 * zlim1 + xcoef3 * xnanono3(ji,jj,jk) 
    138138               zlim3    = MAX( 0.,( zratio - zironmin ) / qnfelim ) 
    139139               xnanopo4(ji,jj,jk) = zlim2 
    … …  
    143143               !   Michaelis-Menten Limitation term for nutrients Diatoms 
    144144               !   ---------------------------------------------- 
    145                zdenom   = 1. / ( zconc1d * zconc1dnh4 + zconc1dnh4 * trn(ji,jj,jk,jpno3) + zconc1d * trn(ji,jj,jk,jpnh4) ) 
    146                xdiatno3(ji,jj,jk) = trn(ji,jj,jk,jpno3) * zconc1dnh4 * zdenom 
    147                xdiatnh4(ji,jj,jk) = trn(ji,jj,jk,jpnh4) * zconc1d    * zdenom 
     145               zdenom   = 1. / ( zconc1d * zconc1dnh4 + zconc1dnh4 * trb(ji,jj,jk,jpno3) + zconc1d * trb(ji,jj,jk,jpnh4) ) 
     146               xdiatno3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc1dnh4 * zdenom 
     147               xdiatnh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc1d    * zdenom 
    148148               ! 
    149149               zlim1    = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) 
    150                zlim2    = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + zconc1dnh4  ) 
    151                zlim3    = trn(ji,jj,jk,jpsil) / ( trn(ji,jj,jk,jpsil) + xksi(ji,jj) ) 
    152                zratio   = trn(ji,jj,jk,jpdfe) * z1_trndia 
    153                zironmin = xcoef1 * trn(ji,jj,jk,jpdch) * z1_trndia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk) 
     150               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc1dnh4  ) 
     151               zlim3    = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) ) 
     152               zratio   = trb(ji,jj,jk,jpdfe) * z1_trbdia 
     153               zironmin = xcoef1 * trb(ji,jj,jk,jpdch) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk) 
    154154               zlim4    = MAX( 0., ( zratio - zironmin ) / qdfelim ) 
    155155               xdiatpo4(ji,jj,jk) = zlim2 
    … …  
    166166         DO jj = 1, jpj 
    167167            DO ji = 1, jpi 
    168                zlim1 =  ( trn(ji,jj,jk,jpno3) * concnnh4 + trn(ji,jj,jk,jpnh4) * concnno3 )    & 
    169                   &   / ( concnno3 * concnnh4 + concnnh4 * trn(ji,jj,jk,jpno3) + concnno3 * trn(ji,jj,jk,jpnh4) )  
    170                zlim2  = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + concnnh4 ) 
    171                zlim3  = trn(ji,jj,jk,jpfer) / ( trn(ji,jj,jk,jpfer) +  5.E-11   ) 
     168               zlim1 =  ( trb(ji,jj,jk,jpno3) * concnnh4 + trb(ji,jj,jk,jpnh4) * concnno3 )    & 
     169                  &   / ( concnno3 * concnnh4 + concnnh4 * trb(ji,jj,jk,jpno3) + concnno3 * trb(ji,jj,jk,jpnh4) )  
     170               zlim2  = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnnh4 ) 
     171               zlim3  = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) +  5.E-11   ) 
    172172               ztem1  = MAX( 0., tsn(ji,jj,jk,jp_tem) ) 
    173173               ztem2  = tsn(ji,jj,jk,jp_tem) - 10. 
    174                zetot1 = MAX( 0., etot(ji,jj,jk) - 1.) / ( 4. + etot(ji,jj,jk) )  
    175                zetot2 = 30. / ( 30. + etot(ji,jj,jk) )  
     174               zetot1 = MAX( 0., etot_ndcy(ji,jj,jk) - 1.) / ( 4. + etot_ndcy(ji,jj,jk) )  
     175               zetot2 = 30. / ( 30. + etot_ndcy(ji,jj,jk) )  
    176176 
    177177               xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 )                  & 
    178178                  &                       * ztem1 / ( 0.1 + ztem1 )                     & 
    179                   &                       * MAX( 1., trn(ji,jj,jk,jpphy) * 1.e6 / 2. )  & 
     179                  &                       * MAX( 1., trb(ji,jj,jk,jpphy) * 1.e6 / 2. )  & 
    180180                  &                       * zetot1 * zetot2               & 
    181181                  &                       * ( 1. + EXP(-ztem2 * ztem2 / 25. ) )         & 
    … …  
    188188      ! 
    189189      ! 
    190       IF( lk_iomput .AND. jnt == nrdttrc ) THEN        ! save output diagnostics 
     190      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics 
    191191        IF( iom_use( "xfracal" ) ) CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) )  ! euphotic layer deptht 
    192192        IF( iom_use( "LNnut"   ) ) CALL iom_put( "LNnut"  , xlimphy(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90

    r5500 r5630  
    4848CONTAINS 
    4949 
    50    SUBROUTINE p4z_lys( kt ) 
     50   SUBROUTINE p4z_lys( kt, knt ) 
    5151      !!--------------------------------------------------------------------- 
    5252      !!                     ***  ROUTINE p4z_lys  *** 
    … …  
    5959      !!--------------------------------------------------------------------- 
    6060      ! 
    61       INTEGER, INTENT(in) ::   kt ! ocean time step 
     61      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    6262      INTEGER  ::   ji, jj, jk, jn 
    6363      REAL(wp) ::   zalk, zdic, zph, zah2 
    6464      REAL(wp) ::   zdispot, zfact, zcalcon, zalka, zaldi 
    6565      REAL(wp) ::   zomegaca, zexcess, zexcess0 
    66       REAL(wp) ::   zrfact2 
    6766      CHARACTER (len=25) :: charout 
    6867      REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zcaldiss    
    … …  
    8988                  zfact = rhop(ji,jj,jk) / 1000. + rtrn 
    9089                  zph  = hi(ji,jj,jk) * tmask(ji,jj,jk) / zfact + ( 1.-tmask(ji,jj,jk) ) * 1.e-9 ! [H+] 
    91                   zdic  = trn(ji,jj,jk,jpdic) / zfact 
    92                   zalka = trn(ji,jj,jk,jptal) / zfact 
     90                  zdic  = trb(ji,jj,jk,jpdic) / zfact 
     91                  zalka = trb(ji,jj,jk,jptal) / zfact 
    9392                  ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    9493                  zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
    … …  
    130129               !       (ACCORDING TO THIS FORMULATION ALSO SOME PARTICULATE 
    131130               !       CACO3 GETS DISSOLVED EVEN IN THE CASE OF OVERSATURATION) 
    132                zdispot = kdca * zexcess * trn(ji,jj,jk,jpcal) 
     131               zdispot = kdca * zexcess * trb(ji,jj,jk,jpcal) 
    133132# if defined key_degrad 
    134133               zdispot = zdispot * facvol(ji,jj,jk) 
    … …  
    136135              !  CHANGE OF [CO3--] , [ALK], PARTICULATE [CACO3], 
    137136              !       AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION 
    138               zcaldiss(ji,jj,jk)  = zdispot / rmtss ! calcite dissolution 
    139               zco3(ji,jj,jk)      = zco3(ji,jj,jk) + zcaldiss(ji,jj,jk) * rfact 
     137              zcaldiss(ji,jj,jk)  = zdispot * rfact2 / rmtss ! calcite dissolution 
     138              zco3(ji,jj,jk)      = zco3(ji,jj,jk) + zcaldiss(ji,jj,jk) 
    140139              ! 
    141140              tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2. * zcaldiss(ji,jj,jk) 
    … …  
    147146      ! 
    148147 
    149       IF( lk_iomput ) THEN 
     148      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    150149         IF( iom_use( "PH"     ) ) CALL iom_put( "PH"    , -1. * LOG10( hi(:,:,:) )          * tmask(:,:,:) ) 
    151150         IF( iom_use( "CO3"    ) ) CALL iom_put( "CO3"   , zco3(:,:,:) * 1.e+3               * tmask(:,:,:) ) 
    152151         IF( iom_use( "CO3sat" ) ) CALL iom_put( "CO3sat", aksp(:,:,:) * 1.e+3 / calcon      * tmask(:,:,:) ) 
    153          IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) 
     152         IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r   * tmask(:,:,:) ) 
    154153      ELSE 
    155154         trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmeso.F90

    r5500 r5630  
    6060CONTAINS 
    6161 
    62    SUBROUTINE p4z_meso( kt, jnt ) 
     62   SUBROUTINE p4z_meso( kt, knt ) 
    6363      !!--------------------------------------------------------------------- 
    6464      !!                     ***  ROUTINE p4z_meso  *** 
    … …  
    6868      !! ** Method  : - ??? 
    6969      !!--------------------------------------------------------------------- 
    70       INTEGER, INTENT(in) ::   kt, jnt ! ocean time step 
     70      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    7171      INTEGER  :: ji, jj, jk 
    7272      REAL(wp) :: zcompadi, zcompaph, zcompapoc, zcompaz, zcompam 
    … …  
    9797         DO jj = 1, jpj 
    9898            DO ji = 1, jpi 
    99                zcompam   = MAX( ( trn(ji,jj,jk,jpmes) - 1.e-9 ), 0.e0 ) 
     99               zcompam   = MAX( ( trb(ji,jj,jk,jpmes) - 1.e-9 ), 0.e0 ) 
    100100# if defined key_degrad 
    101101               zstep     = xstep * facvol(ji,jj,jk) 
    … …  
    107107               !  Respiration rates of both zooplankton 
    108108               !  ------------------------------------- 
    109                zrespz2   = resrat2 * zfact * trn(ji,jj,jk,jpmes) / ( xkmort + trn(ji,jj,jk,jpmes) )  & 
     109               zrespz2   = resrat2 * zfact * trb(ji,jj,jk,jpmes) / ( xkmort + trb(ji,jj,jk,jpmes) )  & 
    110110                  &      + resrat2 * zfact * 3. * nitrfac(ji,jj,jk) 
    111111 
    … …  
    113113               !  no real reason except that it seems to be more stable and may mimic predation 
    114114               !  --------------------------------------------------------------- 
    115                ztortz2   = mzrat2 * 1.e6 * zfact * trn(ji,jj,jk,jpmes) 
     115               ztortz2   = mzrat2 * 1.e6 * zfact * trb(ji,jj,jk,jpmes) 
    116116               ! 
    117                zcompadi  = MAX( ( trn(ji,jj,jk,jpdia) - xthresh2dia ), 0.e0 ) 
    118                zcompaz   = MAX( ( trn(ji,jj,jk,jpzoo) - xthresh2zoo ), 0.e0 ) 
     117               zcompadi  = MAX( ( trb(ji,jj,jk,jpdia) - xthresh2dia ), 0.e0 ) 
     118               zcompaz   = MAX( ( trb(ji,jj,jk,jpzoo) - xthresh2zoo ), 0.e0 ) 
    119119               ! Size effect of nanophytoplankton on grazing : the smaller it is, the less prone 
    120120               ! it is to predation by mesozooplankton 
    121121               ! ------------------------------------------------------------------------------- 
    122                zcompaph  = MAX( ( trn(ji,jj,jk,jpphy) - xthresh2phy ), 0.e0 ) & 
     122               zcompaph  = MAX( ( trb(ji,jj,jk,jpphy) - xthresh2phy ), 0.e0 ) & 
    123123                  &      * MIN(1., MAX( 0., ( quotan(ji,jj,jk) - 0.2) / 0.3 ) ) 
    124                zcompapoc = MAX( ( trn(ji,jj,jk,jppoc) - xthresh2poc ), 0.e0 ) 
     124               zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthresh2poc ), 0.e0 ) 
    125125 
    126126               zfood     = xprefc * zcompadi + xprefz * zcompaz + xprefp * zcompaph + xprefpoc * zcompapoc  
    … …  
    128128               zdenom    = zfoodlim / ( xkgraz2 + zfoodlim ) 
    129129               zdenom2   = zdenom / ( zfood + rtrn ) 
    130                zgraze2   = grazrat2 * zstep * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jpmes)  
     130               zgraze2   = grazrat2 * zstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpmes)  
    131131 
    132132               zgrazd    = zgraze2  * xprefc   * zcompadi  * zdenom2  
    … …  
    135135               zgrazpoc  = zgraze2  * xprefpoc * zcompapoc * zdenom2  
    136136 
    137                zgraznf   = zgrazn   * trn(ji,jj,jk,jpnfe) / ( trn(ji,jj,jk,jpphy) + rtrn) 
    138                zgrazf    = zgrazd   * trn(ji,jj,jk,jpdfe) / ( trn(ji,jj,jk,jpdia) + rtrn) 
    139                zgrazpof  = zgrazpoc * trn(ji,jj,jk,jpsfe) / ( trn(ji,jj,jk,jppoc) + rtrn) 
     137               zgraznf   = zgrazn   * trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) + rtrn) 
     138               zgrazf    = zgrazd   * trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn) 
     139               zgrazpof  = zgrazpoc * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn) 
    140140 
    141141               !  Mesozooplankton flux feeding on GOC 
    … …  
    144144# if ! defined key_kriest 
    145145               zgrazffeg = grazflux  * zstep * wsbio4(ji,jj,jk)      & 
    146                &           * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jpgoc) * trn(ji,jj,jk,jpmes) 
    147                zgrazfffg = zgrazffeg * trn(ji,jj,jk,jpbfe) / (trn(ji,jj,jk,jpgoc) + rtrn) 
     146               &           * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes) 
     147               zgrazfffg = zgrazffeg * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) 
    148148# endif 
    149149               zgrazffep = grazflux  * zstep *  wsbio3(ji,jj,jk)     & 
    150                &           * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpmes) 
    151                zgrazfffp = zgrazffep * trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn) 
     150               &           * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpmes) 
     151               zgrazfffp = zgrazffep * trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) 
    152152              ! 
    153153# if ! defined key_kriest 
    … …  
    158158              ! diatoms based aggregates are more prone to fractionation 
    159159              ! since they are more porous (marine snow instead of fecal pellets) 
    160               zratio    = trn(ji,jj,jk,jpgsi) / ( trn(ji,jj,jk,jpgoc) + rtrn ) 
     160              zratio    = trb(ji,jj,jk,jpgsi) / ( trb(ji,jj,jk,jpgoc) + rtrn ) 
    161161              zratio2   = zratio * zratio 
    162162              zfrac     = zproport * grazflux  * zstep * wsbio4(ji,jj,jk)      & 
    163                &          * trn(ji,jj,jk,jpgoc) * trn(ji,jj,jk,jpmes)          & 
     163               &          * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes)          & 
    164164               &          * ( 0.2 + 3.8 * zratio2 / ( 1.**2 + zratio2 ) ) 
    165               zfracfe   = zfrac * trn(ji,jj,jk,jpbfe) / (trn(ji,jj,jk,jpgoc) + rtrn) 
     165              zfracfe   = zfrac * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) 
    166166 
    167167              zgrazffep = zproport * zgrazffep 
    … …  
    215215               tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) - zgrazz 
    216216               tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgrazn 
    217                tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazn * trn(ji,jj,jk,jpnch) / ( trn(ji,jj,jk,jpphy) + rtrn ) 
    218                tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazd * trn(ji,jj,jk,jpdch) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    219                tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazd * trn(ji,jj,jk,jpdsi) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    220                tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazd * trn(ji,jj,jk,jpdsi) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
     217               tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazn * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpphy) + rtrn ) 
     218               tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazd * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     219               tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazd * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     220               tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazd * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
    221221               tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgraznf 
    222222               tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazf 
    … …  
    231231               tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) + zprcaca 
    232232#if defined key_kriest 
    233               znumpoc = trn(ji,jj,jk,jpnum) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     233              znumpoc = trb(ji,jj,jk,jpnum) / ( trb(ji,jj,jk,jppoc) + rtrn ) 
    234234              tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zmortzgoc - zgrazpoc - zgrazffep + zgrapoc2 
    235235              tra(ji,jj,jk,jpnum) = tra(ji,jj,jk,jpnum) - zgrazpoc * znumpoc + zgrapoc2 * xkr_dmeso      & 
    … …  
    248248      END DO 
    249249      ! 
    250       IF( lk_iomput .AND. jnt == nrdttrc ) THEN 
     250      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    251251         CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 
    252252         IF( iom_use( "GRAZ2" ) ) THEN 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90

    r5500 r5630  
    5959CONTAINS 
    6060 
    61    SUBROUTINE p4z_micro( kt, jnt ) 
     61   SUBROUTINE p4z_micro( kt, knt ) 
    6262      !!--------------------------------------------------------------------- 
    6363      !!                     ***  ROUTINE p4z_micro  *** 
    … …  
    6868      !!--------------------------------------------------------------------- 
    6969      INTEGER, INTENT(in) ::  kt  ! ocean time step 
    70       INTEGER, INTENT(in) ::  jnt  
     70      INTEGER, INTENT(in) ::  knt  
    7171      ! 
    7272      INTEGER  :: ji, jj, jk 
    … …  
    9090         DO jj = 1, jpj 
    9191            DO ji = 1, jpi 
    92                zcompaz = MAX( ( trn(ji,jj,jk,jpzoo) - 1.e-9 ), 0.e0 ) 
     92               zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - 1.e-9 ), 0.e0 ) 
    9393               zstep   = xstep 
    9494# if defined key_degrad 
    … …  
    9999               !  Respiration rates of both zooplankton 
    100100               !  ------------------------------------- 
    101                zrespz = resrat * zfact * trn(ji,jj,jk,jpzoo) / ( xkmort + trn(ji,jj,jk,jpzoo) )  & 
     101               zrespz = resrat * zfact * trb(ji,jj,jk,jpzoo) / ( xkmort + trb(ji,jj,jk,jpzoo) )  & 
    102102                  &   + resrat * zfact * 3. * nitrfac(ji,jj,jk) 
    103103 
    … …  
    105105               !  no real reason except that it seems to be more stable and may mimic predation. 
    106106               !  --------------------------------------------------------------- 
    107                ztortz = mzrat * 1.e6 * zfact * trn(ji,jj,jk,jpzoo) 
    108  
    109                zcompadi  = MIN( MAX( ( trn(ji,jj,jk,jpdia) - xthreshdia ), 0.e0 ), xsizedia ) 
    110                zcompaph  = MAX( ( trn(ji,jj,jk,jpphy) - xthreshphy ), 0.e0 ) 
    111                zcompapoc = MAX( ( trn(ji,jj,jk,jppoc) - xthreshpoc ), 0.e0 ) 
     107               ztortz = mzrat * 1.e6 * zfact * trb(ji,jj,jk,jpzoo) 
     108 
     109               zcompadi  = MIN( MAX( ( trb(ji,jj,jk,jpdia) - xthreshdia ), 0.e0 ), xsizedia ) 
     110               zcompaph  = MAX( ( trb(ji,jj,jk,jpphy) - xthreshphy ), 0.e0 ) 
     111               zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthreshpoc ), 0.e0 ) 
    112112                
    113113               !     Microzooplankton grazing 
    … …  
    117117               zdenom    = zfoodlim / ( xkgraz + zfoodlim ) 
    118118               zdenom2   = zdenom / ( zfood + rtrn ) 
    119                zgraze    = grazrat * zstep * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jpzoo)  
     119               zgraze    = grazrat * zstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpzoo)  
    120120 
    121121               zgrazp    = zgraze  * xpref2p * zcompaph  * zdenom2  
    … …  
    123123               zgrazsd   = zgraze  * xpref2d * zcompadi  * zdenom2  
    124124 
    125                zgrazpf   = zgrazp  * trn(ji,jj,jk,jpnfe) / (trn(ji,jj,jk,jpphy) + rtrn) 
    126                zgrazmf   = zgrazm  * trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn) 
    127                zgrazsf   = zgrazsd * trn(ji,jj,jk,jpdfe) / (trn(ji,jj,jk,jpdia) + rtrn) 
     125               zgrazpf   = zgrazp  * trb(ji,jj,jk,jpnfe) / (trb(ji,jj,jk,jpphy) + rtrn) 
     126               zgrazmf   = zgrazm  * trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) 
     127               zgrazsf   = zgrazsd * trb(ji,jj,jk,jpdfe) / (trb(ji,jj,jk,jpdia) + rtrn) 
    128128               ! 
    129129               zgraztot  = zgrazp  + zgrazm  + zgrazsd  
    … …  
    165165               tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgrazp 
    166166               tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zgrazsd 
    167                tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazp  * trn(ji,jj,jk,jpnch)/(trn(ji,jj,jk,jpphy)+rtrn) 
    168                tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazsd * trn(ji,jj,jk,jpdch)/(trn(ji,jj,jk,jpdia)+rtrn) 
    169                tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazsd * trn(ji,jj,jk,jpdsi)/(trn(ji,jj,jk,jpdia)+rtrn) 
    170                tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazsd * trn(ji,jj,jk,jpdsi)/(trn(ji,jj,jk,jpdia)+rtrn) 
     167               tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazp  * trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) 
     168               tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazsd * trb(ji,jj,jk,jpdch)/(trb(ji,jj,jk,jpdia)+rtrn) 
     169               tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazsd * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) 
     170               tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazsd * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) 
    171171               tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgrazpf 
    172172               tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazsf 
    … …  
    184184#if defined key_kriest 
    185185               tra(ji,jj,jk,jpnum) = tra(ji,jj,jk,jpnum) + zmortz * xkr_dmicro & 
    186                                                          - zgrazm * trn(ji,jj,jk,jpnum) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     186                                                         - zgrazm * trb(ji,jj,jk,jpnum) / ( trb(ji,jj,jk,jppoc) + rtrn ) 
    187187#endif 
    188188            END DO 
    … …  
    190190      END DO 
    191191      ! 
    192       IF( lk_iomput .AND. jnt == nrdttrc ) THEN 
     192      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    193193         CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 
    194194         IF( iom_use( "GRAZ1" ) ) THEN 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90

    r5500 r5630  
    8585         DO jj = 1, jpj 
    8686            DO ji = 1, jpi 
    87                zcompaph = MAX( ( trn(ji,jj,jk,jpphy) - 1e-8 ), 0.e0 ) 
     87               zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - 1e-8 ), 0.e0 ) 
    8888               zstep    = xstep 
    8989# if defined key_degrad 
    … …  
    9494               !     due to turbulence is negligible. Mortality is also set 
    9595               !     to 0 
    96                zsizerat = MIN(1., MAX( 0., (quotan(ji,jj,jk) - 0.2) / 0.3) ) * trn(ji,jj,jk,jpphy) 
     96               zsizerat = MIN(1., MAX( 0., (quotan(ji,jj,jk) - 0.2) / 0.3) ) * trb(ji,jj,jk,jpphy) 
    9797               !     Squared mortality of Phyto similar to a sedimentation term during 
    9898               !     blooms (Doney et al. 1996) 
    … …  
    102102               !     increased when nutrients are limiting phytoplankton growth 
    103103               !     as observed for instance in case of iron limitation. 
    104                ztortp = mprat * xstep * zcompaph / ( xkmort + trn(ji,jj,jk,jpphy) ) * zsizerat 
     104               ztortp = mprat * xstep * zcompaph / ( xkmort + trb(ji,jj,jk,jpphy) ) * zsizerat 
    105105 
    106106               zmortp = zrespp + ztortp 
    … …  
    108108               !   Update the arrays TRA which contains the biological sources and sinks 
    109109 
    110                zfactfe = trn(ji,jj,jk,jpnfe)/(trn(ji,jj,jk,jpphy)+rtrn) 
    111                zfactch = trn(ji,jj,jk,jpnch)/(trn(ji,jj,jk,jpphy)+rtrn) 
     110               zfactfe = trb(ji,jj,jk,jpnfe)/(trb(ji,jj,jk,jpphy)+rtrn) 
     111               zfactch = trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) 
    112112               tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zmortp 
    113113               tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zmortp * zfactch 
    … …  
    172172            DO ji = 1, jpi 
    173173 
    174                zcompadi = MAX( ( trn(ji,jj,jk,jpdia) - 1e-9), 0. ) 
     174               zcompadi = MAX( ( trb(ji,jj,jk,jpdia) - 1e-9), 0. ) 
    175175 
    176176               !    Aggregation term for diatoms is increased in case of nutrient 
    … …  
    186186               zlim2   = xlimdia(ji,jj,jk) * xlimdia(ji,jj,jk) 
    187187               zlim1   = 0.25 * ( 1. - zlim2 ) / ( 0.25 + zlim2 )  
    188                zrespp2 = 1.e6 * zstep * (  wchld + wchldm * zlim1 ) * xdiss(ji,jj,jk) * zcompadi * trn(ji,jj,jk,jpdia) 
     188               zrespp2 = 1.e6 * zstep * (  wchld + wchldm * zlim1 ) * xdiss(ji,jj,jk) * zcompadi * trb(ji,jj,jk,jpdia) 
    189189 
    190190               !     Phytoplankton mortality.  
    191191               !     ------------------------ 
    192                ztortp2 = mprat2 * zstep * trn(ji,jj,jk,jpdia)  / ( xkmort + trn(ji,jj,jk,jpdia) ) * zcompadi  
     192               ztortp2 = mprat2 * zstep * trb(ji,jj,jk,jpdia)  / ( xkmort + trb(ji,jj,jk,jpdia) ) * zcompadi  
    193193 
    194194               zmortp2 = zrespp2 + ztortp2 
    … …  
    196196               !   Update the arrays tra which contains the biological sources and sinks 
    197197               !   --------------------------------------------------------------------- 
    198                zfactch = trn(ji,jj,jk,jpdch) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    199                zfactfe = trn(ji,jj,jk,jpdfe) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    200                zfactsi = trn(ji,jj,jk,jpdsi) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
     198               zfactch = trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     199               zfactfe = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     200               zfactsi = trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
    201201               tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zmortp2  
    202202               tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zmortp2 * zfactch 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

    r5500 r5630  
    3535   REAL(wp) :: parlux      !: Fraction of shortwave as PAR 
    3636   REAL(wp) :: xparsw                 !: parlux/3 
     37   REAL(wp) :: xsi0r                 !:  1. /rn_si0 
    3738 
    3839   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_par      ! structure of input par 
    … …  
    4243 
    4344   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: enano, ediat   !: PAR for phyto, nano and diat  
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etot_ndcy      !: PAR over 24h in case of diurnal cycle 
    4446   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: emoy           !: averaged PAR in the mixed layer 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ekb, ekg, ekr  !: wavelength (Red-Green-Blue) 
    4548 
    4649   INTEGER  ::   nksrp   ! levels below which the light cannot penetrate ( depth larger than 391 m) 
    … …  
    5760CONTAINS 
    5861 
    59    SUBROUTINE p4z_opt( kt, jnt ) 
     62   SUBROUTINE p4z_opt( kt, knt ) 
    6063      !!--------------------------------------------------------------------- 
    6164      !!                     ***  ROUTINE p4z_opt  *** 
    … …  
    6770      !!--------------------------------------------------------------------- 
    6871      ! 
    69       INTEGER, INTENT(in) ::   kt, jnt   ! ocean time step 
     72      INTEGER, INTENT(in) ::   kt, knt   ! ocean time step 
    7073      ! 
    7174      INTEGER  ::   ji, jj, jk 
    7275      INTEGER  ::   irgb 
    73       REAL(wp) ::   zchl, zxsi0r 
     76      REAL(wp) ::   zchl 
    7477      REAL(wp) ::   zc0 , zc1 , zc2, zc3, z1_dep 
    75       REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp, zetmp1, zetmp2 
    76       REAL(wp), POINTER, DIMENSION(:,:,:) :: zekg, zekr, zekb, ze0, ze1, ze2, ze3 
     78      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 
     79      REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 
    7780      !!--------------------------------------------------------------------- 
    7881      ! 
    … …  
    8083      ! 
    8184      ! Allocate temporary workspace 
    82       CALL wrk_alloc( jpi, jpj,      zdepmoy, zetmp, zetmp1, zetmp2 )  
    83       CALL wrk_alloc( jpi, jpj, jpk, zekg, zekr, zekb, ze0, ze1, ze2, ze3 ) 
    84  
    85       IF( jnt == 1 .AND. ln_varpar ) CALL p4z_optsbc( kt ) 
     85      CALL wrk_alloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     86      CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 
     87 
     88      IF( knt == 1 .AND. ln_varpar ) CALL p4z_opt_sbc( kt ) 
    8689 
    8790      !     Initialisation of variables used to compute PAR 
    8891      !     ----------------------------------------------- 
    89       ze1(:,:,jpk) = 0._wp 
    90       ze2(:,:,jpk) = 0._wp 
    91       ze3(:,:,jpk) = 0._wp 
    92  
     92      ze1(:,:,:) = 0._wp 
     93      ze2(:,:,:) = 0._wp 
     94      ze3(:,:,:) = 0._wp 
    9395      !                                        !* attenuation coef. function of Chlorophyll and wavelength (Red-Green-Blue) 
    9496      DO jk = 1, jpkm1                         !  -------------------------------------------------------- 
    … …  
    9799!CDIR NOVERRCHK 
    98100            DO ji = 1, jpi 
    99                zchl = ( trn(ji,jj,jk,jpnch) + trn(ji,jj,jk,jpdch) + rtrn ) * 1.e6 
     101               zchl = ( trb(ji,jj,jk,jpnch) + trb(ji,jj,jk,jpdch) + rtrn ) * 1.e6 
    100102               zchl = MIN(  10. , MAX( 0.05, zchl )  ) 
    101103               irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn ) 
    102104               !                                                          
    103                zekb(ji,jj,jk) = xkrgb(1,irgb) * fse3t(ji,jj,jk) 
    104                zekg(ji,jj,jk) = xkrgb(2,irgb) * fse3t(ji,jj,jk) 
    105                zekr(ji,jj,jk) = xkrgb(3,irgb) * fse3t(ji,jj,jk) 
     105               ekb(ji,jj,jk) = xkrgb(1,irgb) * fse3t(ji,jj,jk) 
     106               ekg(ji,jj,jk) = xkrgb(2,irgb) * fse3t(ji,jj,jk) 
     107               ekr(ji,jj,jk) = xkrgb(3,irgb) * fse3t(ji,jj,jk) 
    106108            END DO 
    107109         END DO 
    108110      END DO 
    109  
    110  
    111111      !                                        !* Photosynthetically Available Radiation (PAR) 
    112112      !                                        !  -------------------------------------- 
    113  
    114       IF( ln_varpar ) THEN 
    115          ze1(:,:,1) = par_varsw(:,:) * qsr(:,:) * EXP( -0.5 * zekb(:,:,1) ) 
    116          ze2(:,:,1) = par_varsw(:,:) * qsr(:,:) * EXP( -0.5 * zekg(:,:,1) ) 
    117          ze3(:,:,1) = par_varsw(:,:) * qsr(:,:) * EXP( -0.5 * zekr(:,:,1) ) 
     113      IF( l_trcdm2dc ) THEN                     !  diurnal cycle 
     114         ! 1% of qsr to compute euphotic layer 
     115         zqsr100(:,:) = 0.01 * qsr_mean(:,:)     !  daily mean qsr 
     116         ! 
     117         CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 )  
     118         ! 
     119         DO jk = 1, nksrp       
     120            etot_ndcy(:,:,jk) =        ze1(:,:,jk) +        ze2(:,:,jk) +       ze3(:,:,jk) 
     121            enano    (:,:,jk) =  2.1 * ze1(:,:,jk) + 0.42 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 
     122            ediat    (:,:,jk) =  1.6 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.7 * ze3(:,:,jk) 
     123         END DO 
     124         ! 
     125         CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     126         ! 
     127         DO jk = 1, nksrp       
     128            etot(:,:,jk) =  ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) 
     129         END DO 
     130         ! 
    118131      ELSE 
    119          ze1(:,:,1) = xparsw         * qsr(:,:) * EXP( -0.5 * zekb(:,:,1) ) 
    120          ze2(:,:,1) = xparsw         * qsr(:,:) * EXP( -0.5 * zekg(:,:,1) ) 
    121          ze3(:,:,1) = xparsw         * qsr(:,:) * EXP( -0.5 * zekr(:,:,1) ) 
    122       ENDIF 
    123  
    124 !CDIR NOVERRCHK 
    125       DO jj = 1, jpj 
    126 !CDIR NOVERRCHK 
    127          DO ji = 1, jpi 
    128             zc1 = ze1(ji,jj,1) 
    129             zc2 = ze2(ji,jj,1)  
    130             zc3 = ze3(ji,jj,1) 
    131             etot (ji,jj,1) = (       zc1 +        zc2 +       zc3 ) 
    132             enano(ji,jj,1) = ( 2.1 * zc1 + 0.42 * zc2 + 0.4 * zc3 ) 
    133             ediat(ji,jj,1) = ( 1.6 * zc1 + 0.69 * zc2 + 0.7 * zc3 ) 
    134          END DO 
    135       END DO 
    136  
    137      
    138       DO jk = 2, nksrp       
    139 !CDIR NOVERRCHK 
    140          DO jj = 1, jpj 
    141 !CDIR NOVERRCHK 
    142             DO ji = 1, jpi 
    143                zc1 = ze1(ji,jj,jk-1) * EXP( -0.5 * ( zekb(ji,jj,jk-1) + zekb(ji,jj,jk) ) ) 
    144                zc2 = ze2(ji,jj,jk-1) * EXP( -0.5 * ( zekg(ji,jj,jk-1) + zekg(ji,jj,jk) ) ) 
    145                zc3 = ze3(ji,jj,jk-1) * EXP( -0.5 * ( zekr(ji,jj,jk-1) + zekr(ji,jj,jk) ) ) 
    146                ze1  (ji,jj,jk) = zc1 
    147                ze2  (ji,jj,jk) = zc2 
    148                ze3  (ji,jj,jk) = zc3 
    149                etot (ji,jj,jk) = (       zc1 +        zc2 +       zc3 ) 
    150                enano(ji,jj,jk) = ( 2.1 * zc1 + 0.42 * zc2 + 0.4 * zc3 ) 
    151                ediat(ji,jj,jk) = ( 1.6 * zc1 + 0.69 * zc2 + 0.7 * zc3 ) 
    152             END DO 
    153          END DO 
    154       END DO 
     132         ! 1% of qsr to compute euphotic layer 
     133         zqsr100(:,:) = 0.01 * qsr(:,:) 
     134         ! 
     135         CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     136         ! 
     137         DO jk = 1, nksrp       
     138            etot (:,:,jk) =        ze1(:,:,jk) +        ze2(:,:,jk) +       ze3(:,:,jk) 
     139            enano(:,:,jk) =  2.1 * ze1(:,:,jk) + 0.42 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 
     140            ediat(:,:,jk) =  1.6 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.7 * ze3(:,:,jk) 
     141         END DO 
     142         etot_ndcy(:,:,:) =  etot(:,:,:)  
     143      ENDIF 
     144 
    155145 
    156146      IF( ln_qsr_bio ) THEN                    !* heat flux accros w-level (used in the dynamics) 
    157147         !                                     !  ------------------------ 
    158          zxsi0r = 1.e0 / rn_si0 
    159          ! 
    160          ze0(:,:,1) = rn_abs * qsr(:,:) 
    161          !                                                    ! surface value : separation in R-G-B + near surface 
    162          IF( ln_varpar ) THEN 
    163             ze0(:,:,1) = ( 1. - 3. * par_varsw(:,:) ) * qsr(:,:) 
    164             ze1(:,:,1) = par_varsw(:,:)               * qsr(:,:)          
    165             ze2(:,:,1) = par_varsw(:,:)               * qsr(:,:) 
    166             ze3(:,:,1) = par_varsw(:,:)               * qsr(:,:) 
    167          ELSE 
    168             ze0(:,:,1) = ( 1. - 3. * xparsw )  * qsr(:,:) 
    169             ze1(:,:,1) = xparsw                * qsr(:,:)          
    170             ze2(:,:,1) = xparsw                * qsr(:,:) 
    171             ze3(:,:,1) = xparsw                * qsr(:,:) 
    172          ENDIF 
     148         CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3, pe0=ze0 ) 
     149         ! 
    173150         etot3(:,:,1) =  qsr(:,:) * tmask(:,:,1) 
    174          ! 
    175          ! 
    176151         DO jk = 2, nksrp + 1 
    177 !CDIR NOVERRCHK 
    178             DO jj = 1, jpj 
    179 !CDIR NOVERRCHK 
    180                DO ji = 1, jpi 
    181                   zc0 = ze0(ji,jj,jk-1) * EXP( -fse3t(ji,jj,jk-1) * zxsi0r ) 
    182                   zc1 = ze1(ji,jj,jk-1) * EXP( -zekb(ji,jj,jk-1 ) ) 
    183                   zc2 = ze2(ji,jj,jk-1) * EXP( -zekg(ji,jj,jk-1 ) ) 
    184                   zc3 = ze3(ji,jj,jk-1) * EXP( -zekr(ji,jj,jk-1 ) ) 
    185                   ze0(ji,jj,jk) = zc0 
    186                   ze1(ji,jj,jk) = zc1 
    187                   ze2(ji,jj,jk) = zc2 
    188                   ze3(ji,jj,jk) = zc3 
    189                   etot3(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,jk) 
    190               END DO 
    191               ! 
    192             END DO 
    193             ! 
    194         END DO 
    195         ! 
    196       ENDIF 
    197  
     152            etot3(:,:,jk) =  ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk) 
     153         END DO 
     154         !                                     !  ------------------------ 
     155      ENDIF 
    198156      !                                        !* Euphotic depth and level 
    199157      neln(:,:) = 1                            !  ------------------------ 
    … …  
    203161         DO jj = 1, jpj 
    204162           DO ji = 1, jpi 
    205               IF( etot(ji,jj,jk) * tmask(ji,jj,jk) >= 0.0043 * qsr(ji,jj) )  THEN 
     163              IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.43 * zqsr100(ji,jj) )  THEN 
    206164                 neln(ji,jj) = jk+1                    ! Euphotic level : 1rst T-level strictly below Euphotic layer 
    207                  !                                     ! nb: ensure the compatibility with nmld_trc definition in trd_mxl_trc_zint 
     165                 !                                     ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint 
    208166                 heup(ji,jj) = fsdepw(ji,jj,jk+1)      ! Euphotic layer depth 
    209167              ENDIF 
    … …  
    211169        END DO 
    212170      END DO 
    213   
     171      ! 
    214172      heup(:,:) = MIN( 300., heup(:,:) ) 
    215  
    216173      !                                        !* mean light over the mixed layer 
    217174      zdepmoy(:,:)   = 0.e0                    !  ------------------------------- 
    218       zetmp  (:,:)   = 0.e0 
    219175      zetmp1 (:,:)   = 0.e0 
    220176      zetmp2 (:,:)   = 0.e0 
     177      zetmp3 (:,:)   = 0.e0 
     178      zetmp4 (:,:)   = 0.e0 
    221179 
    222180      DO jk = 1, nksrp 
    … …  
    226184            DO ji = 1, jpi 
    227185               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
    228                   zetmp  (ji,jj) = zetmp  (ji,jj) + etot (ji,jj,jk) * fse3t(ji,jj,jk) 
    229                   zetmp1 (ji,jj) = zetmp1 (ji,jj) + enano(ji,jj,jk) * fse3t(ji,jj,jk) 
    230                   zetmp2 (ji,jj) = zetmp2 (ji,jj) + ediat(ji,jj,jk) * fse3t(ji,jj,jk) 
     186                  zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot     (ji,jj,jk) * fse3t(ji,jj,jk) ! remineralisation 
     187                  zetmp2 (ji,jj) = zetmp2 (ji,jj) + etot_ndcy(ji,jj,jk) * fse3t(ji,jj,jk) ! production 
     188                  zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano    (ji,jj,jk) * fse3t(ji,jj,jk) ! production 
     189                  zetmp4 (ji,jj) = zetmp4 (ji,jj) + ediat    (ji,jj,jk) * fse3t(ji,jj,jk) ! production 
    231190                  zdepmoy(ji,jj) = zdepmoy(ji,jj) + fse3t(ji,jj,jk) 
    232191               ENDIF 
    … …  
    235194      END DO 
    236195      ! 
    237       emoy(:,:,:) = etot(:,:,:) 
     196      emoy(:,:,:) = etot(:,:,:)       ! remineralisation 
     197      zpar(:,:,:) = etot_ndcy(:,:,:)  ! diagnostic : PAR with no diurnal cycle  
    238198      ! 
    239199      DO jk = 1, nksrp 
    … …  
    244204               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
    245205                  z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) 
    246                   emoy (ji,jj,jk) = zetmp (ji,jj) * z1_dep 
    247                   enano(ji,jj,jk) = zetmp1(ji,jj) * z1_dep 
    248                   ediat(ji,jj,jk) = zetmp2(ji,jj) * z1_dep 
     206                  emoy (ji,jj,jk) = zetmp1(ji,jj) * z1_dep 
     207                  zpar (ji,jj,jk) = zetmp2(ji,jj) * z1_dep 
     208                  enano(ji,jj,jk) = zetmp3(ji,jj) * z1_dep 
     209                  ediat(ji,jj,jk) = zetmp4(ji,jj) * z1_dep 
    249210               ENDIF 
    250211            END DO 
    251212         END DO 
    252213      END DO 
    253  
     214      ! 
    254215      IF( lk_iomput ) THEN 
    255         IF( jnt == nrdttrc  ) THEN 
    256            IF( iom_use( "Heup" ) ) CALL iom_put( "Heup", heup(:,:  ) * tmask(:,:,1) )  ! euphotic layer deptht 
    257            IF( iom_use( "PAR"  ) ) CALL iom_put( "PAR" , emoy(:,:,:) * tmask(:,:,:) )  ! Photosynthetically Available Radiation 
     216        IF( knt == nrdttrc ) THEN 
     217           IF( iom_use( "Heup"  ) ) CALL iom_put( "Heup" , heup(:,:  ) * tmask(:,:,1) )  ! euphotic layer deptht 
     218           IF( iom_use( "PARDM" ) ) CALL iom_put( "PARDM", zpar(:,:,:) * tmask(:,:,:) )  ! Photosynthetically Available Radiation 
     219           IF( iom_use( "PAR"   ) ) CALL iom_put( "PAR"  , emoy(:,:,:) * tmask(:,:,:) )  ! Photosynthetically Available Radiation 
    258220        ENDIF 
    259221      ELSE 
    260222         IF( ln_diatrc ) THEN        ! save output diagnostics 
    261             trc2d(:,:,  jp_pcs0_2d + 10) = heup(:,:  ) * tmask(:,:,1)   
     223            trc2d(:,:,  jp_pcs0_2d + 10) = heup(:,:  ) * tmask(:,:,1) 
    262224            trc3d(:,:,:,jp_pcs0_3d + 3)  = etot(:,:,:) * tmask(:,:,:) 
    263225         ENDIF 
    264226      ENDIF 
    265227      ! 
    266       CALL wrk_dealloc( jpi, jpj,      zdepmoy, zetmp, zetmp1, zetmp2 ) 
    267       CALL wrk_dealloc( jpi, jpj, jpk, zekg, zekr, zekb, ze0, ze1, ze2, ze3 ) 
     228      CALL wrk_dealloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     229      CALL wrk_dealloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 
    268230      ! 
    269231      IF( nn_timing == 1 )  CALL timing_stop('p4z_opt') 
    … …  
    271233   END SUBROUTINE p4z_opt 
    272234 
    273    SUBROUTINE p4z_optsbc( kt ) 
    274       !!---------------------------------------------------------------------- 
    275       !!                  ***  routine p4z_optsbc  *** 
     235   SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0 )  
     236      !!---------------------------------------------------------------------- 
     237      !!                  ***  routine p4z_opt_par  *** 
     238      !! 
     239      !! ** purpose :   compute PAR of each wavelength (Red-Green-Blue) 
     240      !!                for a given shortwave radiation 
     241      !! 
     242      !!---------------------------------------------------------------------- 
     243      !! * arguments 
     244      INTEGER, INTENT(in)                                       ::  kt            !   ocean time-step 
     245      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in)              ::  pqsr          !   shortwave 
     246      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::  pe1 , pe2 , pe3   !  PAR ( R-G-B) 
     247      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL ::  pe0   
     248      !! * local variables 
     249      INTEGER    ::   ji, jj, jk     ! dummy loop indices 
     250      REAL(wp), DIMENSION(jpi,jpj)     ::  zqsr          !   shortwave 
     251      !!---------------------------------------------------------------------- 
     252 
     253      !  Real shortwave 
     254      IF( ln_varpar ) THEN  ;  zqsr(:,:) = par_varsw(:,:) * pqsr(:,:) 
     255      ELSE                  ;  zqsr(:,:) = xparsw         * pqsr(:,:) 
     256      ENDIF 
     257      ! 
     258      IF( PRESENT( pe0 ) ) THEN     !  W-level 
     259         ! 
     260         pe0(:,:,1) = pqsr(:,:) - 3. * zqsr(:,:)    !   ( 1 - 3 * alpha ) * q 
     261         pe1(:,:,1) = zqsr(:,:)          
     262         pe2(:,:,1) = zqsr(:,:) 
     263         pe3(:,:,1) = zqsr(:,:) 
     264         ! 
     265         DO jk = 2, nksrp + 1 
     266!CDIR NOVERRCHK 
     267            DO jj = 1, jpj 
     268!CDIR NOVERRCHK 
     269               DO ji = 1, jpi 
     270                  pe0(ji,jj,jk) = pe0(ji,jj,jk-1) * EXP( -fse3t(ji,jj,jk-1) * xsi0r ) 
     271                  pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -ekb(ji,jj,jk-1 ) ) 
     272                  pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -ekg(ji,jj,jk-1 ) ) 
     273                  pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -ekr(ji,jj,jk-1 ) ) 
     274               END DO 
     275              ! 
     276            END DO 
     277            ! 
     278         END DO 
     279        ! 
     280      ELSE   ! T- level 
     281        ! 
     282        pe1(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekb(:,:,1) ) 
     283        pe2(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekg(:,:,1) ) 
     284        pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) ) 
     285        ! 
     286        DO jk = 2, nksrp       
     287!CDIR NOVERRCHK 
     288           DO jj = 1, jpj 
     289!CDIR NOVERRCHK 
     290              DO ji = 1, jpi 
     291                 pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) ) 
     292                 pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) ) 
     293                 pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -0.5 * ( ekr(ji,jj,jk-1) + ekr(ji,jj,jk) ) ) 
     294              END DO 
     295           END DO 
     296        END DO     
     297        ! 
     298      ENDIF 
     299      !  
     300   END SUBROUTINE p4z_opt_par 
     301 
     302 
     303   SUBROUTINE p4z_opt_sbc( kt ) 
     304      !!---------------------------------------------------------------------- 
     305      !!                  ***  routine p4z_opt_sbc  *** 
    276306      !! 
    277307      !! ** purpose :   read and interpolate the variable PAR fraction 
    … …  
    284314      !!---------------------------------------------------------------------- 
    285315      !! * arguments 
    286       INTEGER, INTENT( in  ) ::   kt   ! ocean time step 
     316      INTEGER ,                INTENT(in) ::   kt     ! ocean time step 
    287317 
    288318      !! * local declarations 
    … …  
    297327         IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_par > 1 ) ) THEN 
    298328            CALL fld_read( kt, 1, sf_par ) 
    299             par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) )/3.0 
     329            par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) ) / 3.0 
    300330         ENDIF 
    301331      ENDIF 
    … …  
    303333      IF( nn_timing == 1 )  CALL timing_stop('p4z_optsbc') 
    304334      ! 
    305    END SUBROUTINE p4z_optsbc 
     335   END SUBROUTINE p4z_opt_sbc 
    306336 
    307337   SUBROUTINE p4z_opt_init 
    … …  
    347377      ! 
    348378      xparsw = parlux / 3.0 
     379      xsi0r  = 1.e0 / rn_si0 
    349380      ! 
    350381      ! Variable PAR at the surface of the ocean 
    … …  
    372403      IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' 
    373404      ! 
    374                          etot (:,:,:) = 0._wp 
    375                          enano(:,:,:) = 0._wp 
    376                          ediat(:,:,:) = 0._wp 
    377       IF( ln_qsr_bio )   etot3(:,:,:) = 0._wp 
     405                         ekr      (:,:,:) = 0._wp 
     406                         ekb      (:,:,:) = 0._wp 
     407                         ekg      (:,:,:) = 0._wp 
     408                         etot     (:,:,:) = 0._wp 
     409                         etot_ndcy(:,:,:) = 0._wp 
     410                         enano    (:,:,:) = 0._wp 
     411                         ediat    (:,:,:) = 0._wp 
     412      IF( ln_qsr_bio )   etot3    (:,:,:) = 0._wp 
    378413      !  
    379414      IF( nn_timing == 1 )  CALL timing_stop('p4z_opt_init') 
    … …  
    386421      !!                     ***  ROUTINE p4z_opt_alloc  *** 
    387422      !!---------------------------------------------------------------------- 
    388       ALLOCATE( enano(jpi,jpj,jpk), ediat(jpi,jpj,jpk), emoy (jpi,jpj,jpk), STAT=p4z_opt_alloc )  
     423      ALLOCATE( ekb(jpi,jpj,jpk)      , ekr(jpi,jpj,jpk), ekg(jpi,jpj,jpk),   & 
     424        &       enano(jpi,jpj,jpk)    , ediat(jpi,jpj,jpk), & 
     425        &       etot_ndcy(jpi,jpj,jpk), emoy (jpi,jpj,jpk), STAT=p4z_opt_alloc )  
    389426         ! 
    390427      IF( p4z_opt_alloc /= 0 ) CALL ctl_warn('p4z_opt_alloc : failed to allocate arrays.') 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90

    r5500 r5630  
    6464CONTAINS 
    6565 
    66    SUBROUTINE p4z_prod( kt , jnt ) 
     66   SUBROUTINE p4z_prod( kt , knt ) 
    6767      !!--------------------------------------------------------------------- 
    6868      !!                     ***  ROUTINE p4z_prod  *** 
    … …  
    7474      !!--------------------------------------------------------------------- 
    7575      ! 
    76       INTEGER, INTENT(in) :: kt, jnt 
     76      INTEGER, INTENT(in) :: kt, knt 
    7777      ! 
    7878      INTEGER  ::   ji, jj, jk 
    … …  
    129129      END DO 
    130130 
    131       IF( ln_newprod ) THEN 
    132          ! Impact of the day duration on phytoplankton growth 
    133          DO jk = 1, jpkm1 
    134             DO jj = 1 ,jpj 
    135                DO ji = 1, jpi 
    136                   IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
    137                      zval = MAX( 1., zstrn(ji,jj) ) 
    138                      zval = 1.5 * zval / ( 12. + zval ) 
    139                      zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 
    140                      zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 
    141                   ENDIF 
    142                END DO 
    143             END DO 
    144          END DO 
    145       ENDIF 
     131      ! Impact of the day duration on phytoplankton growth 
     132      DO jk = 1, jpkm1 
     133         DO jj = 1 ,jpj 
     134            DO ji = 1, jpi 
     135               IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
     136                  zval = MAX( 1., zstrn(ji,jj) ) 
     137                  zval = 1.5 * zval / ( 12. + zval ) 
     138                  zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 
     139                  zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 
     140               ENDIF 
     141            END DO 
     142         END DO 
     143      END DO 
    146144 
    147145      ! Maximum light intensity 
    … …  
    157155               DO ji = 1, jpi 
    158156                  ! Computation of the P-I slope for nanos and diatoms 
    159                   IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     157                  IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    160158                      ztn         = MAX( 0., tsn(ji,jj,jk,jp_tem) - 15. ) 
    161159                      zadap       = xadap * ztn / ( 2.+ ztn ) 
    162                       zconctemp   = MAX( 0.e0 , trn(ji,jj,jk,jpdia) - xsizedia ) 
    163                       zconctemp2  = trn(ji,jj,jk,jpdia) - zconctemp 
     160                      zconctemp   = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia ) 
     161                      zconctemp2  = trb(ji,jj,jk,jpdia) - zconctemp 
    164162                      znanotot    = enano(ji,jj,jk) * zstrn(ji,jj) 
    165163                      zdiattot    = ediat(ji,jj,jk) * zstrn(ji,jj) 
    166164                      ! 
    167165                      zpislopead (ji,jj,jk) = pislope * ( 1.+ zadap  * EXP( -znanotot ) )  & 
    168                          &                   * trn(ji,jj,jk,jpnch) /( trn(ji,jj,jk,jpphy) * 12. + rtrn) 
     166                         &                   * trb(ji,jj,jk,jpnch) /( trb(ji,jj,jk,jpphy) * 12. + rtrn) 
    169167                      ! 
    170                       zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp) / ( trn(ji,jj,jk,jpdia) + rtrn )   & 
    171                          &                   * trn(ji,jj,jk,jpdch) /( trn(ji,jj,jk,jpdia) * 12. + rtrn) 
     168                      zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp) / ( trb(ji,jj,jk,jpdia) + rtrn )   & 
     169                         &                   * trb(ji,jj,jk,jpdch) /( trb(ji,jj,jk,jpdia) * 12. + rtrn) 
    172170 
    173171                      ! Computation of production function for Carbon 
    … …  
    196194 
    197195                  ! Computation of the P-I slope for nanos and diatoms 
    198                   IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     196                  IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    199197                      ztn         = MAX( 0., tsn(ji,jj,jk,jp_tem) - 15. ) 
    200198                      zadap       = ztn / ( 2.+ ztn ) 
    201                       zconctemp   = MAX( 0.e0 , trn(ji,jj,jk,jpdia) - xsizedia ) 
    202                       zconctemp2  = trn(ji,jj,jk,jpdia) - zconctemp 
     199                      zconctemp   = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia ) 
     200                      zconctemp2  = trb(ji,jj,jk,jpdia) - zconctemp 
     201                      znanotot    = enano(ji,jj,jk) * zstrn(ji,jj) 
     202                      zdiattot    = ediat(ji,jj,jk) * zstrn(ji,jj) 
    203203                      ! 
    204                       zpislopead (ji,jj,jk) = pislope  * ( 1.+ zadap  * EXP( -0.21 * enano(ji,jj,jk) ) ) 
    205                       zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp)  / ( trn(ji,jj,jk,jpdia) + rtrn ) 
    206  
    207                       zpislopen =  zpislopead(ji,jj,jk) * trn(ji,jj,jk,jpnch)                & 
    208                         &          / ( trn(ji,jj,jk,jpphy) * 12.                  + rtrn )   & 
     204                      zpislopead (ji,jj,jk) = pislope  * ( 1.+ zadap  * EXP( -znanotot ) ) 
     205                      zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp)  / ( trb(ji,jj,jk,jpdia) + rtrn ) 
     206 
     207                      zpislopen =  zpislopead(ji,jj,jk) * trb(ji,jj,jk,jpnch)                & 
     208                        &          / ( trb(ji,jj,jk,jpphy) * 12.                  + rtrn )   & 
    209209                        &          / ( prmax(ji,jj,jk) * rday * xlimphy(ji,jj,jk) + rtrn ) 
    210210 
    211                       zpislope2n = zpislopead2(ji,jj,jk) * trn(ji,jj,jk,jpdch)                & 
    212                         &          / ( trn(ji,jj,jk,jpdia) * 12.                  + rtrn )   & 
     211                      zpislope2n = zpislopead2(ji,jj,jk) * trb(ji,jj,jk,jpdch)                & 
     212                        &          / ( trb(ji,jj,jk,jpdia) * 12.                  + rtrn )   & 
    213213                        &          / ( prmax(ji,jj,jk) * rday * xlimdia(ji,jj,jk) + rtrn ) 
    214214 
    215215                      ! Computation of production function for Carbon 
    216216                      !  --------------------------------------------- 
    217                       zprbio(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislopen  * enano(ji,jj,jk) ) ) 
    218                       zprdia(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislope2n * ediat(ji,jj,jk) ) ) 
     217                      zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen  * znanotot ) ) 
     218                      zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpislope2n * zdiattot ) ) 
    219219 
    220220                      !  Computation of production function for Chlorophyll 
    221221                      !-------------------------------------------------- 
    222                       zprnch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislopen  * enano(ji,jj,jk) * zstrn(ji,jj) ) ) 
    223                       zprdch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislope2n * ediat(ji,jj,jk) * zstrn(ji,jj) ) ) 
     222                      zprnch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislopen  * enano(ji,jj,jk) ) ) 
     223                      zprdch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislope2n * ediat(ji,jj,jk) ) ) 
    224224                  ENDIF 
    225225               END DO 
    … …  
    252252            DO ji = 1, jpi 
    253253 
    254                 IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     254                IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    255255                   !    Si/C of diatoms 
    256256                   !    ------------------------ 
    … …  
    258258                   !    Si/C is arbitrariliy increased for very high Si concentrations 
    259259                   !    to mimic the very high ratios observed in the Southern Ocean (silpot2) 
    260                   zlim  = trn(ji,jj,jk,jpsil) / ( trn(ji,jj,jk,jpsil) + xksi1 ) 
     260                  zlim  = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi1 ) 
    261261                  zsilim = MIN( zprdia(ji,jj,jk) / ( prmax(ji,jj,jk) + rtrn ), xlimsi(ji,jj,jk) ) 
    262262                  zsilfac = 4.4 * EXP( -4.23 * zsilim ) * MAX( 0.e0, MIN( 1., 2.2 * ( zlim - 0.5 ) )  ) + 1.e0 
    263                   zsiborn = trn(ji,jj,jk,jpsil) * trn(ji,jj,jk,jpsil) * trn(ji,jj,jk,jpsil) 
     263                  zsiborn = trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) 
    264264                  IF (gphit(ji,jj) < -30 ) THEN 
    265265                    zsilfac2 = 1. + 2. * zsiborn / ( zsiborn + xksi2**3 ) 
    … …  
    302302!CDIR NOVERRCHK 
    303303            DO ji = 1, jpi 
    304                IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     304               IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    305305                  !  production terms for nanophyto. 
    306                   zprorca(ji,jj,jk) = zprbio(ji,jj,jk)  * xlimphy(ji,jj,jk) * trn(ji,jj,jk,jpphy) * rfact2 
     306                  zprorca(ji,jj,jk) = zprbio(ji,jj,jk)  * xlimphy(ji,jj,jk) * trb(ji,jj,jk,jpphy) * rfact2 
    307307                  zpronew(ji,jj,jk) = zprorca(ji,jj,jk) * xnanono3(ji,jj,jk) / ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + rtrn ) 
    308308                  ! 
    309                   zratio = trn(ji,jj,jk,jpnfe) / ( trn(ji,jj,jk,jpphy) + rtrn ) 
     309                  zratio = trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) + rtrn ) 
    310310                  zratio = zratio / fecnm  
    311311                  zmax   = MAX( 0., ( 1. - zratio ) / ABS( 1.05 - zratio ) )  
    … …  
    313313                  &             * ( 4. - 4.5 * xlimnfe(ji,jj,jk) / ( xlimnfe(ji,jj,jk) + 0.5 ) )    & 
    314314                  &             * biron(ji,jj,jk) / ( biron(ji,jj,jk) + concnfe(ji,jj,jk) )  & 
    315                   &             * zmax * trn(ji,jj,jk,jpphy) * rfact2 
     315                  &             * zmax * trb(ji,jj,jk,jpphy) * rfact2 
    316316                  !  production terms for diatomees 
    317                   zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * trn(ji,jj,jk,jpdia) * rfact2 
     317                  zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * trb(ji,jj,jk,jpdia) * rfact2 
    318318                  zpronewd(ji,jj,jk) = zprorcad(ji,jj,jk) * xdiatno3(ji,jj,jk) / ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + rtrn ) 
    319319                  ! 
    320                   zratio = trn(ji,jj,jk,jpdfe) / ( trn(ji,jj,jk,jpdia) + rtrn ) 
     320                  zratio = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn ) 
    321321                  zratio = zratio / fecdm  
    322322                  zmax   = MAX( 0., ( 1. - zratio ) / ABS( 1.05 - zratio ) )  
    … …  
    324324                  &             * ( 4. - 4.5 * xlimdfe(ji,jj,jk) / ( xlimdfe(ji,jj,jk) + 0.5 ) )    & 
    325325                  &             * biron(ji,jj,jk) / ( biron(ji,jj,jk) + concdfe(ji,jj,jk) )  & 
    326                   &             * zmax * trn(ji,jj,jk,jpdia) * rfact2 
     326                  &             * zmax * trb(ji,jj,jk,jpdia) * rfact2 
    327327               ENDIF 
    328328            END DO 
    … …  
    341341                     zprdch(ji,jj,jk) = zprdch(ji,jj,jk) * zmixdiat(ji,jj) 
    342342                  ENDIF 
    343                   IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     343                  IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    344344                     !  production terms for nanophyto. ( chlorophyll ) 
    345345                     znanotot = enano(ji,jj,jk) * zstrn(ji,jj) 
    … …  
    365365!CDIR NOVERRCHK 
    366366               DO ji = 1, jpi 
    367                   IF( etot(ji,jj,jk) > 1.E-3 ) THEN 
     367                  IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    368368                     !  production terms for nanophyto. ( chlorophyll ) 
    369                      znanotot = enano(ji,jj,jk) * zstrn(ji,jj) 
    370                      zprod = rday * zprorca(ji,jj,jk) * zprnch(ji,jj,jk) * trn(ji,jj,jk,jpphy) * xlimphy(ji,jj,jk) 
     369                     znanotot = enano(ji,jj,jk) 
     370                     zprod = rday * zprorca(ji,jj,jk) * zprnch(ji,jj,jk) * trb(ji,jj,jk,jpphy) * xlimphy(ji,jj,jk) 
    371371                     zprochln(ji,jj,jk) = chlcmin * 12. * zprorca (ji,jj,jk) 
    372372                     zprochln(ji,jj,jk) = zprochln(ji,jj,jk) + (chlcnm-chlcmin) * 144. * zprod            & 
    373                      &                    / ( zpislopead(ji,jj,jk) * trn(ji,jj,jk,jpnch) * znanotot +rtrn ) 
     373                     &                    / ( zpislopead(ji,jj,jk) * trb(ji,jj,jk,jpnch) * znanotot +rtrn ) 
    374374                     !  production terms for diatomees ( chlorophyll ) 
    375                      zdiattot = ediat(ji,jj,jk) * zstrn(ji,jj) 
    376                      zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * trn(ji,jj,jk,jpdia) * xlimdia(ji,jj,jk) 
     375                     zdiattot = ediat(ji,jj,jk) 
     376                     zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * trb(ji,jj,jk,jpdia) * xlimdia(ji,jj,jk) 
    377377                     zprochld(ji,jj,jk) = chlcmin * 12. * zprorcad(ji,jj,jk) 
    378378                     zprochld(ji,jj,jk) = zprochld(ji,jj,jk) + (chlcdm-chlcmin) * 144. * zprod             & 
    379                      &                    / ( zpislopead2(ji,jj,jk) * trn(ji,jj,jk,jpdch) * zdiattot +rtrn ) 
     379                     &                    / ( zpislopead2(ji,jj,jk) * trb(ji,jj,jk,jpdch) * zdiattot +rtrn ) 
    380380                  ENDIF 
    381381               END DO 
    … …  
    414414 
    415415    ! Total primary production per year 
    416     IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. jnt == nrdttrc )  )  & 
     416    IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc )  )  & 
    417417         & tpp = glob_sum( ( zprorca(:,:,:) + zprorcad(:,:,:) ) * cvol(:,:,:) ) 
    418418 
    419419    IF( lk_iomput ) THEN 
    420        IF( jnt == nrdttrc ) THEN 
     420       IF( knt == nrdttrc ) THEN 
    421421          CALL wrk_alloc( jpi, jpj,      zw2d ) 
    422422          CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zrem.F90

    r5500 r5630  
    5959CONTAINS 
    6060 
    61    SUBROUTINE p4z_rem( kt, jnt ) 
     61   SUBROUTINE p4z_rem( kt, knt ) 
    6262      !!--------------------------------------------------------------------- 
    6363      !!                     ***  ROUTINE p4z_rem  *** 
    … …  
    6868      !!--------------------------------------------------------------------- 
    6969      ! 
    70       INTEGER, INTENT(in) ::   kt, jnt ! ocean time step 
     70      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    7171      ! 
    7272      INTEGER  ::   ji, jj, jk 
    … …  
    104104               zdep = MAX( hmld(ji,jj), heup(ji,jj) ) 
    105105               IF( fsdept(ji,jj,jk) < zdep ) THEN 
    106                   zdepbac(ji,jj,jk) = MIN( 0.7 * ( trn(ji,jj,jk,jpzoo) + 2.* trn(ji,jj,jk,jpmes) ), 4.e-6 ) 
     106                  zdepbac(ji,jj,jk) = MIN( 0.7 * ( trb(ji,jj,jk,jpzoo) + 2.* trb(ji,jj,jk,jpmes) ), 4.e-6 ) 
    107107                  ztempbac(ji,jj)   = zdepbac(ji,jj,jk) 
    108108               ELSE 
    … …  
    119119            DO ji = 1, jpi 
    120120               ! denitrification factor computed from O2 levels 
    121                nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trn(ji,jj,jk,jpoxy) )    & 
    122                   &                                / ( oxymin + trn(ji,jj,jk,jpoxy) )  ) 
     121               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    & 
     122                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  ) 
    123123               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) ) 
    124124            END DO 
    … …  
    140140               ! Ammonification in oxic waters with oxygen consumption 
    141141               ! ----------------------------------------------------- 
    142                zolimit = zremik * ( 1.- nitrfac(ji,jj,jk) ) * trn(ji,jj,jk,jpdoc)  
    143                zolimi(ji,jj,jk) = MIN( ( trn(ji,jj,jk,jpoxy) - rtrn ) / o2ut, zolimit )  
     142               zolimit = zremik * ( 1.- nitrfac(ji,jj,jk) ) * trb(ji,jj,jk,jpdoc)  
     143               zolimi(ji,jj,jk) = MIN( ( trb(ji,jj,jk,jpoxy) - rtrn ) / o2ut, zolimit )  
    144144               ! Ammonification in suboxic waters with denitrification 
    145145               ! ------------------------------------------------------- 
    146                denitr(ji,jj,jk)  = MIN(  ( trn(ji,jj,jk,jpno3) - rtrn ) / rdenit,   & 
    147                   &                     zremik * nitrfac(ji,jj,jk) * trn(ji,jj,jk,jpdoc)  ) 
     146               denitr(ji,jj,jk)  = MIN(  ( trb(ji,jj,jk,jpno3) - rtrn ) / rdenit,   & 
     147                  &                     zremik * nitrfac(ji,jj,jk) * trb(ji,jj,jk,jpdoc)  ) 
    148148               ! 
    149149               zolimi (ji,jj,jk) = MAX( 0.e0, zolimi (ji,jj,jk) ) 
    … …  
    165165               ! below 2 umol/L. Inhibited at strong light  
    166166               ! ---------------------------------------------------------- 
    167                zonitr  =nitrif * zstep * trn(ji,jj,jk,jpnh4) / ( 1.+ emoy(ji,jj,jk) ) * ( 1.- nitrfac(ji,jj,jk) )  
    168                denitnh4(ji,jj,jk) = nitrif * zstep * trn(ji,jj,jk,jpnh4) * nitrfac(ji,jj,jk)  
     167               zonitr  =nitrif * zstep * trb(ji,jj,jk,jpnh4) / ( 1.+ emoy(ji,jj,jk) ) * ( 1.- nitrfac(ji,jj,jk) )  
     168               denitnh4(ji,jj,jk) = nitrif * zstep * trb(ji,jj,jk,jpnh4) * nitrfac(ji,jj,jk)  
    169169               ! Update of the tracers trends 
    170170               ! ---------------------------- 
    … …  
    192192               ! ---------------------------------------------------------- 
    193193               zbactfer = 10.e-6 *  rfact2 * prmax(ji,jj,jk) * xlimbacl(ji,jj,jk)             & 
    194                   &              * trn(ji,jj,jk,jpfer) / ( 2.5E-10 + trn(ji,jj,jk,jpfer) )    & 
     194                  &              * trb(ji,jj,jk,jpfer) / ( 2.5E-10 + trb(ji,jj,jk,jpfer) )    & 
    195195                  &              * zdepprod(ji,jj,jk) * zdepbac(ji,jj,jk) 
    196196#if defined key_kriest 
    … …  
    228228               ! means a disaggregation constant about 0.5 the value in oxic zones 
    229229               ! ----------------------------------------------------------------- 
    230                zorem  = zremip * trn(ji,jj,jk,jppoc) 
    231                zofer  = zremip * trn(ji,jj,jk,jpsfe) 
     230               zorem  = zremip * trb(ji,jj,jk,jppoc) 
     231               zofer  = zremip * trb(ji,jj,jk,jpsfe) 
    232232#if ! defined key_kriest 
    233                zorem2 = zremip * trn(ji,jj,jk,jpgoc) 
    234                zofer2 = zremip * trn(ji,jj,jk,jpbfe) 
     233               zorem2 = zremip * trb(ji,jj,jk,jpgoc) 
     234               zofer2 = zremip * trb(ji,jj,jk,jpbfe) 
    235235#else 
    236                zorem2 = zremip * trn(ji,jj,jk,jpnum) 
     236               zorem2 = zremip * trb(ji,jj,jk,jpnum) 
    237237#endif 
    238238 
    … …  
    272272               ! Remineralization rate of BSi depedant on T and saturation 
    273273               ! --------------------------------------------------------- 
    274                zsatur   = ( sio3eq(ji,jj,jk) - trn(ji,jj,jk,jpsil) ) / ( sio3eq(ji,jj,jk) + rtrn ) 
     274               zsatur   = ( sio3eq(ji,jj,jk) - trb(ji,jj,jk,jpsil) ) / ( sio3eq(ji,jj,jk) + rtrn ) 
    275275               zsatur   = MAX( rtrn, zsatur ) 
    276276               zsatur2  = ( 1. + tsn(ji,jj,jk,jp_tem) / 400.)**37 
    … …  
    287287               zfactdep = xsilab * EXP(-( xsiremlab - xsirem ) * znusil2 * zdep / wsbio2 ) * ztem / ( ztem + 10. ) 
    288288               zsiremin = ( xsiremlab * zfactdep + xsirem * ( 1. - zfactdep ) ) * zstep * znusil 
    289                zosil    = zsiremin * trn(ji,jj,jk,jpgsi) 
     289               zosil    = zsiremin * trb(ji,jj,jk,jpgsi) 
    290290               ! 
    291291               tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) - zosil 
    … …  
    315315      END DO 
    316316 
    317       IF( jnt == nrdttrc ) THEN 
     317      IF( knt == nrdttrc ) THEN 
    318318          CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 
    319319          zfact = 1.e+3 * rfact2r  !  conversion from mol/l/kt to  mol/m3/s 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r5500 r5630  
    117117         IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_dust > 1 ) ) THEN 
    118118            CALL fld_read( kt, 1, sf_dust ) 
    119             dust(:,:) = sf_dust(1)%fnow(:,:,1) 
     119            IF( nn_ice_tr == -1 .AND. .NOT. ln_ironice ) THEN 
     120               dust(:,:) = sf_dust(1)%fnow(:,:,1) 
     121            ELSE 
     122               dust(:,:) = sf_dust(1)%fnow(:,:,1) * ( 1.0 - fr_i(:,:) ) 
     123            ENDIF 
    120124         ENDIF 
    121125      ENDIF 
    … …  
    136140            DO jj = 1, jpj 
    137141               DO ji = 1, jpi 
    138                   zcoef = ryyss * cvol(ji,jj,1)  
     142                  zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj)  
    139143                  rivalk(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)                                    & 
    140144                     &              * 1.E3        / ( 12. * zcoef + rtrn ) 
    … …  
    187191      INTEGER  :: ierr, ierr1, ierr2, ierr3 
    188192      INTEGER  :: ios                 ! Local integer output status for namelist read 
     193      INTEGER  :: ik50                !  last level where depth less than 50 m 
     194      INTEGER  :: isrow             ! index for ORCA1 starting row 
    189195      REAL(wp) :: zexpide, zdenitide, zmaskt 
    190196      REAL(wp) :: ztimes_dust, ztimes_riv, ztimes_ndep  
    … …  
    216222902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampissbc in configuration namelist', lwp ) 
    217223      IF(lwm) WRITE ( numonp, nampissbc ) 
     224 
     225      IF ( ( nn_ice_tr >= 0 ) .AND. ln_ironice ) THEN 
     226         IF(lwp) THEN 
     227            WRITE(numout,*) ' ln_ironice incompatible with nn_ice_tr = ', nn_ice_tr 
     228            WRITE(numout,*) ' Specify your sea ice iron concentration in nampisice instead ' 
     229            WRITE(numout,*) ' ln_ironice is forced to .FALSE. ' 
     230            ln_ironice = .FALSE. 
     231         ENDIF 
     232      ENDIF 
    218233 
    219234      IF(lwp) THEN 
    … …  
    247262      ENDIF 
    248263 
     264      ! set the number of level over which river runoffs are applied  
     265      ! online configuration : computed in sbcrnf 
     266      IF( lk_offline ) THEN 
     267        nk_rnf(:,:) = 1 
     268        h_rnf (:,:) = fsdept(:,:,1) 
     269      ENDIF 
     270 
    249271      ! dust input from the atmosphere 
    250272      ! ------------------------------ 
    … …  
    358380         rivalkinput = 0._wp 
    359381      END IF  
    360  
    361382      ! nutrient input from dust 
    362383      ! ------------------------ 
    … …  
    410431         CALL iom_close( numiron ) 
    411432         ! 
    412          DO jk = 1, 5 
     433         ik50 = 5        !  last level where depth less than 50 m 
     434         DO jk = jpkm1, 1, -1 
     435            IF( gdept_1d(jk) > 50. )  ik50 = jk - 1 
     436         END DO 
     437         IF (lwp) WRITE(numout,*) 
     438         IF (lwp) WRITE(numout,*) ' Level corresponding to 50m depth ',  ik50,' ', gdept_1d(ik50+1) 
     439         IF (lwp) WRITE(numout,*) 
     440         DO jk = 1, ik50 
    413441            DO jj = 2, jpjm1 
    414442               DO ji = fs_2, fs_jpim1 
    … …  
    421449            END DO 
    422450         END DO 
    423          IF( cp_cfg == 'orca' .AND. jp_cfg == 2 ) THEN 
    424             ii0 = 176   ;   ii1 =  176        ! Southern Island : Kerguelen 
    425             ij0 =  37   ;   ij1 =   37  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    426             ! 
    427             ii0 = 119   ;   ii1 =  119        ! South Georgia 
    428             ij0 =  29   ;   ij1 =   29  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    429             ! 
    430             ii0 = 111   ;   ii1 =  111        ! Falklands 
    431             ij0 =  35   ;   ij1 =   35  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    432             ! 
    433             ii0 = 168   ;   ii1 =  168        ! Crozet 
    434             ij0 =  40   ;   ij1 =   40  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    435             ! 
    436             ii0 = 119   ;   ii1 =  119        ! South Orkney 
    437             ij0 =  28   ;   ij1 =   28  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    438             ! 
    439             ii0 = 140   ;   ii1 =  140        ! Bouvet Island 
    440             ij0 =  33   ;   ij1 =   33  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    441             ! 
    442             ii0 = 178   ;   ii1 =  178        ! Prince edwards 
    443             ij0 =  34   ;   ij1 =   34  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    444             ! 
    445             ii0 =  43   ;   ii1 =   43        ! Balleny islands 
    446             ij0 =  21   ;   ij1 =   21  ;   zcmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =  0.3_wp   
    447          ENDIF 
     451         ! 
    448452         CALL lbc_lnk( zcmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
     453         ! 
    449454         DO jk = 1, jpk 
    450455            DO jj = 1, jpj 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r5500 r5630  
    2121   USE p4zopt          !  optical model 
    2222   USE p4zlim          !  Co-limitations of differents nutrients 
    23    USE p4zrem          !  Remineralisation of organic matter 
    2423   USE p4zsbc          !  External source of nutrients  
    2524   USE p4zint          !  interpolation and computation of various fields 
    … …  
    3029   PRIVATE 
    3130 
    32    PUBLIC   p4z_sed    
     31   PUBLIC   p4z_sed   
     32   PUBLIC   p4z_sed_alloc 
     33  
    3334 
    3435   !! * Module variables 
     36   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nitrpot    !: Nitrogen fixation  
     37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:  ) :: sdenit     !: Nitrate reduction in the sediments 
    3538   REAL(wp) :: r1_rday                  !: inverse of rday 
    36  
    37    INTEGER ::  numnit   
    38  
    3939 
    4040   !!* Substitution 
    … …  
    4747CONTAINS 
    4848 
    49    SUBROUTINE p4z_sed( kt, jnt ) 
     49   SUBROUTINE p4z_sed( kt, knt ) 
    5050      !!--------------------------------------------------------------------- 
    5151      !!                     ***  ROUTINE p4z_sed  *** 
    … …  
    5858      !!--------------------------------------------------------------------- 
    5959      ! 
    60       INTEGER, INTENT(in) ::   kt, jnt ! ocean time step 
     60      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    6161      INTEGER  ::   ji, jj, jk, ikt 
    6262#if ! defined key_sed 
    … …  
    6969      REAL(wp) ::  zsiloss, zcaloss, zws3, zws4, zwsc, zdep, zwstpoc 
    7070      REAL(wp) ::  ztrfer, ztrpo4, zwdust, zlight 
    71       REAL(wp) ::  zrdenittot, zsdenittot, znitrpottot 
    7271      ! 
    7372      CHARACTER (len=25) :: charout 
    74       REAL(wp), POINTER, DIMENSION(:,:  ) :: zpdep, zsidep, zwork1, zwork2, zwork3, zwork4 
     73      REAL(wp), POINTER, DIMENSION(:,:  ) :: zpdep, zsidep, zwork1, zwork2, zwork3 
    7574      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdenit2d, zironice, zbureff 
    7675      REAL(wp), POINTER, DIMENSION(:,:  ) :: zwsbio3, zwsbio4, zwscal 
    77       REAL(wp), POINTER, DIMENSION(:,:,:) :: znitrpot, zirondep, zsoufer 
     76      REAL(wp), POINTER, DIMENSION(:,:,:) :: zirondep, zsoufer 
    7877      !!--------------------------------------------------------------------- 
    7978      ! 
    8079      IF( nn_timing == 1 )  CALL timing_start('p4z_sed') 
    8180      ! 
    82       IF( kt == nittrc000 .AND. jnt == 1 )  THEN 
    83          r1_rday  = 1. / rday 
    84          IF( ln_check_mass .AND. lwp)  & 
    85            &  CALL ctl_opn( numnit, 'nitrogen.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
    86       ENDIF 
     81      IF( kt == nittrc000 .AND. knt == 1 )   r1_rday  = 1. / rday 
    8782      ! 
    8883      ! Allocate temporary workspace 
    89       CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zwork4, zbureff ) 
     84      CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
    9085      CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    91       CALL wrk_alloc( jpi, jpj, jpk, znitrpot, zsoufer ) 
     86      CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) 
    9287 
    9388      zdenit2d(:,:) = 0.e0 
    … …  
    9691      zwork2  (:,:) = 0.e0 
    9792      zwork3  (:,:) = 0.e0 
    98       zwork4  (:,:) = 0.e0 
    9993 
    10094      ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. 
    … …  
    108102               zdep    = rfact2 / fse3t(ji,jj,1) 
    109103               zwflux  = fmmflx(ji,jj) / 1000._wp 
    110                zfminus = MIN( 0._wp, -zwflux ) * trn(ji,jj,1,jpfer) * zdep 
     104               zfminus = MIN( 0._wp, -zwflux ) * trb(ji,jj,1,jpfer) * zdep 
    111105               zfplus  = MAX( 0._wp, -zwflux ) * icefeinput * zdep 
    112106               zironice(ji,jj) =  zfplus + zfminus 
    … …  
    114108         END DO 
    115109         ! 
    116          trn(:,:,1,jpfer) = trn(:,:,1,jpfer) + zironice(:,:)  
     110         tra(:,:,1,jpfer) = tra(:,:,1,jpfer) + zironice(:,:)  
    117111         !  
    118          IF( lk_iomput .AND. jnt == nrdttrc .AND. iom_use( "Ironice" ) )   & 
     112         IF( lk_iomput .AND. knt == nrdttrc .AND. iom_use( "Ironice" ) )   & 
    119113            &   CALL iom_put( "Ironice", zironice(:,:) * 1.e+3 * rfact2r * fse3t(:,:,1) * tmask(:,:,1) ) ! iron flux from ice 
    120114         ! 
    … …  
    144138         END DO 
    145139         !                                              ! Iron solubilization of particles in the water column 
    146          trn(:,:,1,jppo4) = trn(:,:,1,jppo4) + zpdep   (:,:) 
    147          trn(:,:,1,jpsil) = trn(:,:,1,jpsil) + zsidep  (:,:) 
    148          trn(:,:,:,jpfer) = trn(:,:,:,jpfer) + zirondep(:,:,:)  
     140         tra(:,:,1,jppo4) = tra(:,:,1,jppo4) + zpdep   (:,:) 
     141         tra(:,:,1,jpsil) = tra(:,:,1,jpsil) + zsidep  (:,:) 
     142         tra(:,:,:,jpfer) = tra(:,:,:,jpfer) + zirondep(:,:,:)  
    149143         !  
    150144         IF( lk_iomput ) THEN 
    151             IF( jnt == nrdttrc ) THEN 
     145            IF( knt == nrdttrc ) THEN 
    152146                IF( iom_use( "Irondep" ) )   & 
    153147                &  CALL iom_put( "Irondep", zirondep(:,:,1) * 1.e+3 * rfact2r * fse3t(:,:,1) * tmask(:,:,1) ) ! surface downward dust depo of iron 
    … …  
    167161      ! ---------------------------------------------------------- 
    168162      IF( ln_river ) THEN 
    169          trn(:,:,1,jppo4) = trn(:,:,1,jppo4) + rivdip(:,:) * rfact2 
    170          trn(:,:,1,jpno3) = trn(:,:,1,jpno3) + rivdin(:,:) * rfact2 
    171          trn(:,:,1,jpfer) = trn(:,:,1,jpfer) + rivdic(:,:) * 5.e-5 * rfact2 
    172          trn(:,:,1,jpsil) = trn(:,:,1,jpsil) + rivdsi(:,:) * rfact2 
    173          trn(:,:,1,jpdic) = trn(:,:,1,jpdic) + rivdic(:,:) * rfact2 
    174          trn(:,:,1,jptal) = trn(:,:,1,jptal) + ( rivalk(:,:) - rno3 * rivdin(:,:) ) * rfact2 
     163         DO jj = 1, jpj 
     164            DO ji = 1, jpi 
     165               DO jk = 1, nk_rnf(ji,jj) 
     166                  tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) +  rivdip(ji,jj) * rfact2 
     167                  tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) +  rivdin(ji,jj) * rfact2 
     168                  tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) +  rivdic(ji,jj) * 5.e-5 * rfact2 
     169                  tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) +  rivdsi(ji,jj) * rfact2 
     170                  tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) +  rivdic(ji,jj) * rfact2 
     171                  tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) +  ( rivalk(ji,jj) - rno3 * rivdin(ji,jj) ) * rfact2 
     172               ENDDO 
     173            ENDDO 
     174         ENDDO 
    175175      ENDIF 
    176176       
    … …  
    178178      ! ---------------------------------------------------------- 
    179179      IF( ln_ndepo ) THEN 
    180          trn(:,:,1,jpno3) = trn(:,:,1,jpno3) + nitdep(:,:) * rfact2 
    181          trn(:,:,1,jptal) = trn(:,:,1,jptal) - rno3 * nitdep(:,:) * rfact2 
     180         tra(:,:,1,jpno3) = tra(:,:,1,jpno3) + nitdep(:,:) * rfact2 
     181         tra(:,:,1,jptal) = tra(:,:,1,jptal) - rno3 * nitdep(:,:) * rfact2 
    182182      ENDIF 
    183183 
    … …  
    185185      ! ------------------------------------------------------ 
    186186      IF( ln_ironsed ) THEN 
    187          trn(:,:,:,jpfer) = trn(:,:,:,jpfer) + ironsed(:,:,:) * rfact2 
     187         tra(:,:,:,jpfer) = tra(:,:,:,jpfer) + ironsed(:,:,:) * rfact2 
    188188         ! 
    189          IF( lk_iomput .AND. jnt == nrdttrc .AND. iom_use( "Ironsed" ) )   & 
     189         IF( lk_iomput .AND. knt == nrdttrc .AND. iom_use( "Ironsed" ) )   & 
    190190            &   CALL iom_put( "Ironsed", ironsed(:,:,:) * 1.e+3 * tmask(:,:,:) ) ! iron inputs from sediments 
    191191      ENDIF 
    … …  
    194194      ! ------------------------------------------------------ 
    195195      IF( ln_hydrofe ) THEN 
    196          trn(:,:,:,jpfer) = trn(:,:,:,jpfer) + hydrofe(:,:,:) * rfact2 
     196         tra(:,:,:,jpfer) = tra(:,:,:,jpfer) + hydrofe(:,:,:) * rfact2 
    197197         ! 
    198          IF( lk_iomput .AND. jnt == nrdttrc .AND. iom_use( "HYDR" ) )   & 
     198         IF( lk_iomput .AND. knt == nrdttrc .AND. iom_use( "HYDR" ) )   & 
    199199            &   CALL iom_put( "HYDR", hydrofe(:,:,:) * 1.e+3 * tmask(:,:,:) ) ! hydrothermal iron input 
    200200      ENDIF 
    … …  
    222222              ikt = mbkt(ji,jj) 
    223223# if defined key_kriest 
    224               zflx =    trn(ji,jj,ikt,jppoc) * zwsbio3(ji,jj)    * 1E3 * 1E6 / 1E4 
     224              zflx =    trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj)    * 1E3 * 1E6 / 1E4 
    225225# else 
    226               zflx = (  trn(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj)   & 
    227                 &     + trn(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) )  * 1E3 * 1E6 / 1E4 
     226              zflx = (  trb(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj)   & 
     227                &     + trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) )  * 1E3 * 1E6 / 1E4 
    228228#endif 
    229229              zflx  = LOG10( MAX( 1E-3, zflx ) ) 
    230               zo2   = LOG10( MAX( 10. , trn(ji,jj,ikt,jpoxy) * 1E6 ) ) 
    231               zno3  = LOG10( MAX( 1.  , trn(ji,jj,ikt,jpno3) * 1E6 * rno3 ) ) 
     230              zo2   = LOG10( MAX( 10. , trb(ji,jj,ikt,jpoxy) * 1E6 ) ) 
     231              zno3  = LOG10( MAX( 1.  , trb(ji,jj,ikt,jpno3) * 1E6 * rno3 ) ) 
    232232              zdep  = LOG10( fsdepw(ji,jj,ikt+1) ) 
    233233              zdenit2d(ji,jj) = -2.2567 - 1.185 * zflx - 0.221 * zflx**2 - 0.3995 * zno3 * zo2 + 1.25 * zno3    & 
    … …  
    235235              zdenit2d(ji,jj) = 10.0**( zdenit2d(ji,jj) ) 
    236236              ! 
    237               zflx = (  trn(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj)   & 
    238                 &     + trn(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) ) * 1E6 
     237              zflx = (  trb(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj)   & 
     238                &     + trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) ) * 1E6 
    239239              zbureff(ji,jj) = 0.013 + 0.53 * zflx**2 / ( 7.0 + zflx )**2 
    240240           ENDIF 
    … …  
    251251               ikt = mbkt(ji,jj)  
    252252# if defined key_kriest 
    253                zwork1(ji,jj) = trn(ji,jj,ikt,jpgsi) * zwscal (ji,jj) 
    254                zwork2(ji,jj) = trn(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) 
     253               zwork1(ji,jj) = trb(ji,jj,ikt,jpgsi) * zwscal (ji,jj) 
     254               zwork2(ji,jj) = trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) 
    255255# else 
    256                zwork1(ji,jj) = trn(ji,jj,ikt,jpgsi) * zwsbio4(ji,jj) 
    257                zwork2(ji,jj) = trn(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj) + trn(ji,jj,ikt,jppoc) * zwsbio3(ji,jj)  
     256               zwork1(ji,jj) = trb(ji,jj,ikt,jpgsi) * zwsbio4(ji,jj) 
     257               zwork2(ji,jj) = trb(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj) + trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj)  
    258258# endif 
    259259               ! For calcite, burial efficiency is made a function of saturation 
    260260               zfactcal      = MIN( excess(ji,jj,ikt), 0.2 ) 
    261261               zfactcal      = MIN( 1., 1.3 * ( 0.2 - zfactcal ) / ( 0.4 - zfactcal ) ) 
    262                zwork3(ji,jj) = trn(ji,jj,ikt,jpcal) * zwscal(ji,jj) * 2.e0 * zfactcal 
     262               zwork3(ji,jj) = trb(ji,jj,ikt,jpcal) * zwscal(ji,jj) * 2.e0 * zfactcal 
    263263            ENDIF 
    264264         END DO 
    … …  
    279279         DO ji = 1, jpi 
    280280            ikt  = mbkt(ji,jj) 
    281             zdep = xstep / fse3t(ji,jj,ikt) 
     281            zdep = xstep / fse3t(ji,jj,ikt)  
    282282            zws4 = zwsbio4(ji,jj) * zdep 
    283283            zwsc = zwscal (ji,jj) * zdep 
    284284# if defined key_kriest 
    285             zsiloss = trn(ji,jj,ikt,jpgsi) * zws4 
     285            zsiloss = trb(ji,jj,ikt,jpgsi) * zws4 
    286286# else 
    287             zsiloss = trn(ji,jj,ikt,jpgsi) * zwsc 
     287            zsiloss = trb(ji,jj,ikt,jpgsi) * zwsc 
    288288# endif 
    289             zcaloss = trn(ji,jj,ikt,jpcal) * zwsc 
     289            zcaloss = trb(ji,jj,ikt,jpcal) * zwsc 
    290290            ! 
    291             trn(ji,jj,ikt,jpgsi) = trn(ji,jj,ikt,jpgsi) - zsiloss 
    292             trn(ji,jj,ikt,jpcal) = trn(ji,jj,ikt,jpcal) - zcaloss 
     291            tra(ji,jj,ikt,jpgsi) = tra(ji,jj,ikt,jpgsi) - zsiloss 
     292            tra(ji,jj,ikt,jpcal) = tra(ji,jj,ikt,jpcal) - zcaloss 
    293293#if ! defined key_sed 
    294             trn(ji,jj,ikt,jpsil) = trn(ji,jj,ikt,jpsil) + zsiloss * zrivsil  
     294            tra(ji,jj,ikt,jpsil) = tra(ji,jj,ikt,jpsil) + zsiloss * zrivsil  
    295295            zfactcal = MIN( excess(ji,jj,ikt), 0.2 ) 
    296296            zfactcal = MIN( 1., 1.3 * ( 0.2 - zfactcal ) / ( 0.4 - zfactcal ) ) 
    297297            zrivalk  =  1._wp - ( rivalkinput * r1_ryyss ) * zfactcal / ( zsumsedcal + rtrn ) 
    298             trn(ji,jj,ikt,jptal) =  trn(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 
    299             trn(ji,jj,ikt,jpdic) =  trn(ji,jj,ikt,jpdic) + zcaloss * zrivalk 
     298            tra(ji,jj,ikt,jptal) =  tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 
     299            tra(ji,jj,ikt,jpdic) =  tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 
    300300#endif 
    301301         END DO 
    … …  
    304304      DO jj = 1, jpj 
    305305         DO ji = 1, jpi 
    306             ikt     = mbkt(ji,jj) 
    307             zdep    = xstep / fse3t(ji,jj,ikt) 
     306            ikt  = mbkt(ji,jj) 
     307            zdep = xstep / fse3t(ji,jj,ikt)  
    308308            zws4 = zwsbio4(ji,jj) * zdep 
    309309            zws3 = zwsbio3(ji,jj) * zdep 
    310310            zrivno3 = 1. - zbureff(ji,jj) 
    311311# if ! defined key_kriest 
    312             trn(ji,jj,ikt,jpgoc) = trn(ji,jj,ikt,jpgoc) - trn(ji,jj,ikt,jpgoc) * zws4 
    313             trn(ji,jj,ikt,jppoc) = trn(ji,jj,ikt,jppoc) - trn(ji,jj,ikt,jppoc) * zws3 
    314             trn(ji,jj,ikt,jpbfe) = trn(ji,jj,ikt,jpbfe) - trn(ji,jj,ikt,jpbfe) * zws4 
    315             trn(ji,jj,ikt,jpsfe) = trn(ji,jj,ikt,jpsfe) - trn(ji,jj,ikt,jpsfe) * zws3 
    316             zwstpoc              =  trn(ji,jj,ikt,jpgoc) * zws4 + trn(ji,jj,ikt,jppoc) * zws3  
     312            tra(ji,jj,ikt,jpgoc) = tra(ji,jj,ikt,jpgoc) - trb(ji,jj,ikt,jpgoc) * zws4  
     313            tra(ji,jj,ikt,jppoc) = tra(ji,jj,ikt,jppoc) - trb(ji,jj,ikt,jppoc) * zws3 
     314            tra(ji,jj,ikt,jpbfe) = tra(ji,jj,ikt,jpbfe) - trb(ji,jj,ikt,jpbfe) * zws4 
     315            tra(ji,jj,ikt,jpsfe) = tra(ji,jj,ikt,jpsfe) - trb(ji,jj,ikt,jpsfe) * zws3 
     316            zwstpoc              = trb(ji,jj,ikt,jpgoc) * zws4 + trb(ji,jj,ikt,jppoc) * zws3 
    317317# else 
    318             trn(ji,jj,ikt,jpnum) = trn(ji,jj,ikt,jpnum) - trn(ji,jj,ikt,jpnum) * zws4 
    319             trn(ji,jj,ikt,jppoc) = trn(ji,jj,ikt,jppoc) - trn(ji,jj,ikt,jppoc) * zws3 
    320             trn(ji,jj,ikt,jpsfe) = trn(ji,jj,ikt,jpsfe) - trn(ji,jj,ikt,jpsfe) * zws3 
    321             zwstpoc = trn(ji,jj,ikt,jppoc) * zws3  
     318            tra(ji,jj,ikt,jpnum) = tra(ji,jj,ikt,jpnum) - trb(ji,jj,ikt,jpnum) * zws4  
     319            tra(ji,jj,ikt,jppoc) = tra(ji,jj,ikt,jppoc) - trb(ji,jj,ikt,jppoc) * zws3 
     320            tra(ji,jj,ikt,jpsfe) = tra(ji,jj,ikt,jpsfe) - trb(ji,jj,ikt,jpsfe) * zws3 
     321            zwstpoc = trb(ji,jj,ikt,jppoc) * zws3  
    322322# endif 
    323323 
    … …  
    325325            ! The 0.5 factor in zpdenit and zdenitt is to avoid negative NO3 concentration after both denitrification 
    326326            ! in the sediments and just above the sediments. Not very clever, but simpliest option. 
    327             zpdenit  = MIN( 0.5 * ( trn(ji,jj,ikt,jpno3) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3 ) 
     327            zpdenit  = MIN( 0.5 * ( trb(ji,jj,ikt,jpno3) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3 ) 
    328328            z1pdenit = zwstpoc * zrivno3 - zpdenit 
    329             zolimit = MIN( ( trn(ji,jj,ikt,jpoxy) - rtrn ) / o2ut, z1pdenit * ( 1.- nitrfac(ji,jj,ikt) ) ) 
    330             zdenitt = MIN(  0.5 * ( trn(ji,jj,ikt,jpno3) - rtrn ) / rdenit, z1pdenit * nitrfac(ji,jj,ikt) ) 
    331             trn(ji,jj,ikt,jpdoc) = trn(ji,jj,ikt,jpdoc) + z1pdenit - zolimit - zdenitt 
    332             trn(ji,jj,ikt,jppo4) = trn(ji,jj,ikt,jppo4) + zpdenit + zolimit + zdenitt 
    333             trn(ji,jj,ikt,jpnh4) = trn(ji,jj,ikt,jpnh4) + zpdenit + zolimit + zdenitt 
    334             trn(ji,jj,ikt,jpno3) = trn(ji,jj,ikt,jpno3) - rdenit * (zpdenit + zdenitt) 
    335             trn(ji,jj,ikt,jpoxy) = trn(ji,jj,ikt,jpoxy) - zolimit * o2ut 
    336             trn(ji,jj,ikt,jptal) = trn(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 
    337             trn(ji,jj,ikt,jpdic) = trn(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 
    338             zwork4(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 
     329            zolimit = MIN( ( trb(ji,jj,ikt,jpoxy) - rtrn ) / o2ut, z1pdenit * ( 1.- nitrfac(ji,jj,ikt) ) ) 
     330            zdenitt = MIN(  0.5 * ( trb(ji,jj,ikt,jpno3) - rtrn ) / rdenit, z1pdenit * nitrfac(ji,jj,ikt) ) 
     331            tra(ji,jj,ikt,jpdoc) = tra(ji,jj,ikt,jpdoc) + z1pdenit - zolimit - zdenitt 
     332            tra(ji,jj,ikt,jppo4) = tra(ji,jj,ikt,jppo4) + zpdenit + zolimit + zdenitt 
     333            tra(ji,jj,ikt,jpnh4) = tra(ji,jj,ikt,jpnh4) + zpdenit + zolimit + zdenitt 
     334            tra(ji,jj,ikt,jpno3) = tra(ji,jj,ikt,jpno3) - rdenit * (zpdenit + zdenitt) 
     335            tra(ji,jj,ikt,jpoxy) = tra(ji,jj,ikt,jpoxy) - zolimit * o2ut 
     336            tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 
     337            tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 
     338            sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 
    339339#endif 
    340340         END DO 
    … …  
    356356#endif 
    357357               ztrfer = biron(ji,jj,jk)       / ( concfediaz + biron(ji,jj,jk)       ) 
    358                ztrpo4 = trn  (ji,jj,jk,jppo4) / ( concnnh4   + trn  (ji,jj,jk,jppo4) )  
    359                zlight =  ( 1.- EXP( -etot(ji,jj,jk) / diazolight ) )  
    360                znitrpot(ji,jj,jk) =  MAX( 0.e0, ( 0.6 * tgfunc(ji,jj,jk) - 2.15 ) * r1_rday )   & 
     358               ztrpo4 = trb  (ji,jj,jk,jppo4) / ( concnnh4   + trb  (ji,jj,jk,jppo4) )  
     359               zlight =  ( 1.- EXP( -etot_ndcy(ji,jj,jk) / diazolight ) )  
     360               nitrpot(ji,jj,jk) =  MAX( 0.e0, ( 0.6 * tgfunc(ji,jj,jk) - 2.15 ) * r1_rday )   & 
    361361                 &         *  zfact * MIN( ztrfer, ztrpo4 ) * zlight 
    362362               zsoufer(ji,jj,jk) = zlight * 2E-11 / (2E-11 + biron(ji,jj,jk)) 
    … …  
    370370         DO jj = 1, jpj 
    371371            DO ji = 1, jpi 
    372                zfact = znitrpot(ji,jj,jk) * nitrfix 
    373                trn(ji,jj,jk,jpnh4) = trn(ji,jj,jk,jpnh4) +             zfact 
    374                trn(ji,jj,jk,jptal) = trn(ji,jj,jk,jptal) + rno3      * zfact 
    375                trn(ji,jj,jk,jpoxy) = trn(ji,jj,jk,jpoxy) + o2nit     * zfact  
    376                trn(ji,jj,jk,jppo4) = trn(ji,jj,jk,jppo4) + concdnh4 / ( concdnh4 + trn(ji,jj,jk,jppo4) ) & 
    377                &                     * 0.002 * trn(ji,jj,jk,jpdoc) * rfact2 / rday 
    378                trn(ji,jj,jk,jpfer) = trn(ji,jj,jk,jpfer) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * rfact2 / rday 
     372               zfact = nitrpot(ji,jj,jk) * nitrfix 
     373               tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) +             zfact 
     374               tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3      * zfact 
     375               tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + o2nit     * zfact  
     376               tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + concdnh4 / ( concdnh4 + trb(ji,jj,jk,jppo4) ) & 
     377               &                     * 0.002 * trb(ji,jj,jk,jpdoc) * xstep 
     378               tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * xstep 
    379379           END DO 
    380380         END DO  
    381381      END DO 
    382382 
    383       ! Global budget of N SMS : denitrification in the water column and in the sediment 
    384       !                          nitrogen fixation by the diazotrophs 
    385       ! -------------------------------------------------------------------------------- 
    386       zrdenittot   = glob_sum ( denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) ) 
    387       zsdenittot   = glob_sum ( zwork4(:,:)   * e1e2t(:,:) ) 
    388       znitrpottot  = glob_sum ( znitrpot(:,:,:) * nitrfix              * cvol(:,:,:) ) 
    389       zfact = 1.e+3 * rfact2r * rno3 * 14. / 1.e12 * ryyss   ! conversion molC/l/kt ----> TgN/m3/year 
    390       ! 
    391       IF( ln_check_mass .AND. ( kt == nitend .AND. jnt == nrdttrc ) .AND. ( lwp )  )  & 
    392          &  WRITE(numnit,9100) ndastp, znitrpottot * zfact  , & 
    393          &                             zrdenittot  * zfact  , & 
    394          &                             zsdenittot  * zfact 
    395       ! 
    396383      IF( lk_iomput ) THEN 
    397          IF( jnt == nrdttrc ) THEN 
     384         IF( knt == nrdttrc ) THEN 
    398385            zfact = 1.e+3 * rfact2r * rno3  !  conversion from molC/l/kt  to molN/m3/s 
    399             IF( iom_use("Nfix"   ) ) CALL iom_put( "Nfix"  , znitrpot(:,:,:) * nitrfix * zfact * tmask(:,:,:) )  ! nitrogen fixation  
    400             IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", zwork4(:,:) * zfact * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
    401             IF( iom_use("tnfix"  ) ) CALL iom_put( "tnfix"  , znitrpottot * zfact  )               ! Global  nitrogen fixation 
    402             IF( iom_use("tdenit" ) ) CALL iom_put( "tdenit" , zrdenittot  * zfact  )               ! Total denitrification 
     386            IF( iom_use("Nfix"   ) ) CALL iom_put( "Nfix", nitrpot(:,:,:) * nitrfix * zfact * tmask(:,:,:) )  ! nitrogen fixation  
    403387            IF( iom_use("INTNFIX") ) THEN   ! nitrogen fixation rate in ocean ( vertically integrated ) 
    404388               zwork1(:,:) = 0. 
    405389               DO jk = 1, jpkm1 
    406                  zwork1(:,:) = zwork1(:,:) + znitrpot(:,:,jk) * nitrfix * zfact * fse3t(:,:,jk) * tmask(:,:,jk) 
     390                 zwork1(:,:) = zwork1(:,:) + nitrpot(:,:,jk) * nitrfix * zfact * fse3t(:,:,jk) * tmask(:,:,jk) 
    407391               ENDDO 
    408392               CALL iom_put( "INTNFIX" , zwork1 )  
    … …  
    411395      ELSE 
    412396         IF( ln_diatrc )  & 
    413             &  trc2d(:,:,jp_pcs0_2d + 12) = znitrpot(:,:,1) * nitrfix * rno3 * 1.e+3 * rfact2r * fse3t(:,:,1) * tmask(:,:,1) 
     397            &  trc2d(:,:,jp_pcs0_2d + 12) = nitrpot(:,:,1) * nitrfix * rno3 * 1.e+3 * rfact2r * fse3t(:,:,1) * tmask(:,:,1) 
    414398      ENDIF 
    415399      ! 
    … …  
    417401         WRITE(charout, fmt="('sed ')") 
    418402         CALL prt_ctl_trc_info(charout) 
    419          CALL prt_ctl_trc(tab4d=trn, mask=tmask, clinfo=ctrcnm) 
    420       ENDIF 
    421       ! 
    422       CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zwork4, zbureff ) 
     403         CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) 
     404      ENDIF 
     405      ! 
     406      CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
    423407      CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    424       CALL wrk_dealloc( jpi, jpj, jpk, znitrpot, zsoufer ) 
     408      CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) 
    425409      ! 
    426410      IF( nn_timing == 1 )  CALL timing_stop('p4z_sed') 
    … …  
    429413      ! 
    430414   END SUBROUTINE p4z_sed 
     415 
     416 
     417   INTEGER FUNCTION p4z_sed_alloc() 
     418      !!---------------------------------------------------------------------- 
     419      !!                     ***  ROUTINE p4z_sed_alloc  *** 
     420      !!---------------------------------------------------------------------- 
     421      ALLOCATE( nitrpot(jpi,jpj,jpk), sdenit(jpi,jpj), STAT=p4z_sed_alloc ) 
     422      ! 
     423      IF( p4z_sed_alloc /= 0 )   CALL ctl_warn('p4z_sed_alloc: failed to allocate arrays') 
     424      ! 
     425   END FUNCTION p4z_sed_alloc 
     426 
    431427 
    432428#else 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsink.F90

    r5500 r5630  
    7979   !!---------------------------------------------------------------------- 
    8080 
    81    SUBROUTINE p4z_sink ( kt, jnt ) 
     81   SUBROUTINE p4z_sink ( kt, knt ) 
    8282      !!--------------------------------------------------------------------- 
    8383      !!                     ***  ROUTINE p4z_sink  *** 
    … …  
    8888      !! ** Method  : - ??? 
    8989      !!--------------------------------------------------------------------- 
    90       INTEGER, INTENT(in) :: kt, jnt 
     90      INTEGER, INTENT(in) :: kt, knt 
    9191      INTEGER  ::   ji, jj, jk, jit 
    9292      INTEGER  ::   iiter1, iiter2 
    … …  
    199199               zfact = zstep * xdiss(ji,jj,jk) 
    200200               !  Part I : Coagulation dependent on turbulence 
    201                zagg1 = 25.9  * zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) 
    202                zagg2 = 4452. * zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) 
     201               zagg1 = 25.9  * zfact * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jppoc) 
     202               zagg2 = 4452. * zfact * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpgoc) 
    203203 
    204204               ! Part II : Differential settling 
    205205 
    206206               !  Aggregation of small into large particles 
    207                zagg3 =  47.1 * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) 
    208                zagg4 =  3.3  * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) 
     207               zagg3 =  47.1 * zstep * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpgoc) 
     208               zagg4 =  3.3  * zstep * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jppoc) 
    209209 
    210210               zagg   = zagg1 + zagg2 + zagg3 + zagg4 
    211                zaggfe = zagg * trn(ji,jj,jk,jpsfe) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     211               zaggfe = zagg * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn ) 
    212212 
    213213               ! Aggregation of DOC to POC :  
    … …  
    215215               ! 2nd term is shear aggregation of DOC-POC 
    216216               ! 3rd term is differential settling of DOC-POC 
    217                zaggdoc  = ( ( 0.369 * 0.3 * trn(ji,jj,jk,jpdoc) + 102.4 * trn(ji,jj,jk,jppoc) ) * zfact       & 
    218                &            + 2.4 * zstep * trn(ji,jj,jk,jppoc) ) * 0.3 * trn(ji,jj,jk,jpdoc) 
     217               zaggdoc  = ( ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * zfact       & 
     218               &            + 2.4 * zstep * trb(ji,jj,jk,jppoc) ) * 0.3 * trb(ji,jj,jk,jpdoc) 
    219219               ! transfer of DOC to GOC :  
    220220               ! 1st term is shear aggregation 
    221221               ! 2nd term is differential settling  
    222                zaggdoc2 = ( 3.53E3 * zfact + 0.1 * zstep ) * trn(ji,jj,jk,jpgoc) * 0.3 * trn(ji,jj,jk,jpdoc) 
     222               zaggdoc2 = ( 3.53E3 * zfact + 0.1 * zstep ) * trb(ji,jj,jk,jpgoc) * 0.3 * trb(ji,jj,jk,jpdoc) 
    223223               ! tranfer of DOC to POC due to brownian motion 
    224                zaggdoc3 =  ( 5095. * trn(ji,jj,jk,jppoc) + 114. * 0.3 * trn(ji,jj,jk,jpdoc) ) *zstep * 0.3 * trn(ji,jj,jk,jpdoc) 
     224               zaggdoc3 =  ( 5095. * trb(ji,jj,jk,jppoc) + 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) *zstep * 0.3 * trb(ji,jj,jk,jpdoc) 
    225225 
    226226               !  Update the trends 
    … …  
    237237 
    238238     ! Total carbon export per year 
    239      IF( iom_use( "tcexp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. jnt == nrdttrc )  )  & 
     239     IF( iom_use( "tcexp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc )  )  & 
    240240        &   t_oce_co2_exp = glob_sum( ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * e1e2t(:,:) * tmask(:,:,1) ) 
    241241     ! 
    242242     IF( lk_iomput ) THEN 
    243        IF( jnt == nrdttrc ) THEN 
     243       IF( knt == nrdttrc ) THEN 
    244244          CALL wrk_alloc( jpi, jpj,      zw2d ) 
    245245          CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 
    … …  
    328328   !!---------------------------------------------------------------------- 
    329329 
    330    SUBROUTINE p4z_sink ( kt, jnt ) 
     330   SUBROUTINE p4z_sink ( kt, knt ) 
    331331      !!--------------------------------------------------------------------- 
    332332      !!                ***  ROUTINE p4z_sink  *** 
    … …  
    338338      !!--------------------------------------------------------------------- 
    339339      ! 
    340       INTEGER, INTENT(in) :: kt, jnt 
     340      INTEGER, INTENT(in) :: kt, knt 
    341341      ! 
    342342      INTEGER  :: ji, jj, jk, jit, niter1, niter2 
    … …  
    373373            DO ji = 1, jpi 
    374374               IF( tmask(ji,jj,jk) /= 0.e0 ) THEN 
    375                   znum = trn(ji,jj,jk,jppoc) / ( trn(ji,jj,jk,jpnum) + rtrn ) / xkr_massp 
     375                  znum = trb(ji,jj,jk,jppoc) / ( trb(ji,jj,jk,jpnum) + rtrn ) / xkr_massp 
    376376                  ! -------------- To avoid sinking speed over 50 m/day ------- 
    377377                  znum  = MIN( xnumm(jk), znum ) 
    … …  
    435435               IF( tmask(ji,jj,jk) /= 0.e0 ) THEN 
    436436 
    437                   znum = trn(ji,jj,jk,jppoc)/(trn(ji,jj,jk,jpnum)+rtrn) / xkr_massp 
     437                  znum = trb(ji,jj,jk,jppoc)/(trb(ji,jj,jk,jpnum)+rtrn) / xkr_massp 
    438438                  !-------------- To avoid sinking speed over 50 m/day ------- 
    439439                  znum  = min(xnumm(jk),znum) 
    … …  
    453453                  !    ---------------------------------------------- 
    454454 
    455                   zagg1 =  0.163 * trn(ji,jj,jk,jpnum)**2               & 
     455                  zagg1 =  0.163 * trb(ji,jj,jk,jpnum)**2               & 
    456456                     &            * 2.*( (zfm-1.)*(zfm*xkr_mass_max**3-xkr_mass_min**3)    & 
    457457                     &            * (zeps-1)/zdiv1 + 3.*(zfm*xkr_mass_max-xkr_mass_min)    & 
    458458                     &            * (zfm*xkr_mass_max**2-xkr_mass_min**2)                  & 
    459459                     &            * (zeps-1.)**2/(zdiv2*zdiv3))  
    460                   zagg2 =  2*0.163*trn(ji,jj,jk,jpnum)**2*zfm*                       & 
     460                  zagg2 =  2*0.163*trb(ji,jj,jk,jpnum)**2*zfm*                       & 
    461461                     &                   ((xkr_mass_max**3+3.*(xkr_mass_max**2          & 
    462462                     &                    *xkr_mass_min*(zeps-1.)/zdiv2                 & 
    … …  
    466466                     &                    (zeps-2.)+(zeps-1.)/zdiv3)+(zeps-1.)/zdiv1))     
    467467 
    468                   zagg3 =  0.163*trn(ji,jj,jk,jpnum)**2*zfm**2*8. * xkr_mass_max**3   
     468                  zagg3 =  0.163*trb(ji,jj,jk,jpnum)**2*zfm**2*8. * xkr_mass_max**3   
    469469                   
    470470                 !    Aggregation of small into large particles 
    … …  
    472472                 !    ---------------------------------------------- 
    473473 
    474                   zagg4 =  2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2*                       & 
     474                  zagg4 =  2.*3.141*0.125*trb(ji,jj,jk,jpnum)**2*                       & 
    475475                     &                 xkr_wsbio_min*(zeps-1.)**2                         & 
    476476                     &                 *(xkr_mass_min**2*((1.-zsm*zfm)/(zdiv3*zdiv4)      & 
    … …  
    479479                     &                 *xkr_eta)/(zdiv*zdiv3*zdiv5) )    
    480480 
    481                   zagg5 =   2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2                         & 
     481                  zagg5 =   2.*3.141*0.125*trb(ji,jj,jk,jpnum)**2                         & 
    482482                     &                 *(zeps-1.)*zfm*xkr_wsbio_min                        & 
    483483                     &                 *(zsm*(xkr_mass_min**2-zfm*xkr_mass_max**2)         & 
    … …  
    489489                  !     ------------------------------------ 
    490490 
    491                   zfract = 2.*3.141*0.125*trn(ji,jj,jk,jpmes)*12./0.12/0.06**3*trn(ji,jj,jk,jpnum)  & 
     491                  zfract = 2.*3.141*0.125*trb(ji,jj,jk,jpmes)*12./0.12/0.06**3*trb(ji,jj,jk,jpnum)  & 
    492492                    &      * (0.01/xkr_mass_min)**(1.-zeps)*0.1**2  & 
    493493                    &      * 10000.*xstep 
    … …  
    496496                  !     -------------------------------------- 
    497497 
    498                   zaggdoc = 0.83 * trn(ji,jj,jk,jpdoc) * xstep * xdiss(ji,jj,jk) * trn(ji,jj,jk,jpdoc)   & 
    499                      &        + 0.005 * 231. * trn(ji,jj,jk,jpdoc) * xstep * trn(ji,jj,jk,jpdoc) 
    500                   zaggdoc1 = 271. * trn(ji,jj,jk,jppoc) * xstep * xdiss(ji,jj,jk) * trn(ji,jj,jk,jpdoc)  & 
    501                      &  + 0.02 * 16706. * trn(ji,jj,jk,jppoc) * xstep * trn(ji,jj,jk,jpdoc) 
     498                  zaggdoc = 0.83 * trb(ji,jj,jk,jpdoc) * xstep * xdiss(ji,jj,jk) * trb(ji,jj,jk,jpdoc)   & 
     499                     &        + 0.005 * 231. * trb(ji,jj,jk,jpdoc) * xstep * trb(ji,jj,jk,jpdoc) 
     500                  zaggdoc1 = 271. * trb(ji,jj,jk,jppoc) * xstep * xdiss(ji,jj,jk) * trb(ji,jj,jk,jpdoc)  & 
     501                     &  + 0.02 * 16706. * trb(ji,jj,jk,jppoc) * xstep * trb(ji,jj,jk,jpdoc) 
    502502 
    503503# if defined key_degrad 
    … …  
    514514                  zagg = 0.5 * xkr_stick * ( zaggsh + zaggsi ) 
    515515                  ! 
    516                   znumdoc = trn(ji,jj,jk,jpnum) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     516                  znumdoc = trb(ji,jj,jk,jpnum) / ( trb(ji,jj,jk,jppoc) + rtrn ) 
    517517                  tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zaggdoc + zaggdoc1 
    518518                  tra(ji,jj,jk,jpnum) = tra(ji,jj,jk,jpnum) + zfract + zaggdoc / xkr_massp - zagg 
    … …  
    528528     ! 
    529529     IF( lk_iomput ) THEN 
    530         IF( jnt == nrdttrc ) THEN 
     530        IF( knt == nrdttrc ) THEN 
    531531          CALL wrk_alloc( jpi, jpj,      zw2d ) 
    532532          CALL wrk_alloc( jpi, jpj, jpk, zw3d ) 
    … …  
    800800      ztraz(:,:,:) = 0.e0 
    801801      zakz (:,:,:) = 0.e0 
    802       ztrb (:,:,:) = trn(:,:,:,jp_tra) 
     802      ztrb (:,:,:) = trb(:,:,:,jp_tra) 
    803803 
    804804      DO jk = 1, jpkm1 
    … …  
    815815         !  first guess of the slopes interior values 
    816816         DO jk = 2, jpkm1 
    817             ztraz(:,:,jk) = ( trn(:,:,jk-1,jp_tra) - trn(:,:,jk,jp_tra) ) * tmask(:,:,jk) 
     817            ztraz(:,:,jk) = ( trb(:,:,jk-1,jp_tra) - trb(:,:,jk,jp_tra) ) * tmask(:,:,jk) 
    818818         END DO 
    819819         ztraz(:,:,1  ) = 0.0 
    … …  
    846846                  zigma = zwsink2(ji,jj,jk+1) * zstep / fse3w(ji,jj,jk+1) 
    847847                  zew   = zwsink2(ji,jj,jk+1) 
    848                   psinkflx(ji,jj,jk+1) = -zew * ( trn(ji,jj,jk,jp_tra) - 0.5 * ( 1 + zigma ) * zakz(ji,jj,jk) ) * zstep 
     848                  psinkflx(ji,jj,jk+1) = -zew * ( trb(ji,jj,jk,jp_tra) - 0.5 * ( 1 + zigma ) * zakz(ji,jj,jk) ) * zstep 
    849849               END DO 
    850850            END DO 
    … …  
    859859               DO ji = 1, jpi 
    860860                  zflx = ( psinkflx(ji,jj,jk) - psinkflx(ji,jj,jk+1) ) / fse3t(ji,jj,jk) 
    861                   trn(ji,jj,jk,jp_tra) = trn(ji,jj,jk,jp_tra) + zflx 
     861                  trb(ji,jj,jk,jp_tra) = trb(ji,jj,jk,jp_tra) + zflx 
    862862               END DO 
    863863            END DO 
    … …  
    875875      END DO 
    876876 
    877       trn(:,:,:,jp_tra) = ztrb(:,:,:) 
     877      trb(:,:,:,jp_tra) = ztrb(:,:,:) 
    878878      psinkflx(:,:,:)   = 2. * psinkflx(:,:,:) 
    879879      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

    r5500 r5630  
    2424   USE p4zsed          !  Sedimentation 
    2525   USE p4zint          !  time interpolation 
     26   USE p4zrem          !  remineralisation 
    2627   USE iom             !  I/O manager 
    2728   USE trd_oce         !  Ocean trends variables 
    … …  
    3637   PUBLIC   p4z_sms        ! called in p4zsms.F90 
    3738 
    38    REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget 
    39    INTEGER ::  numco2, numnut  !: logical unit for co2 budget 
    40  
     39   REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget, po4budget 
     40   REAL(wp) :: xfact1, xfact2 
     41   INTEGER ::  numco2, numnut, numnit  !: logical unit for co2 budget 
     42 
     43   !!* Array used to indicate negative tracer values 
     44   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xnegtr     !: ??? 
     45 
     46 
     47   !! * Substitutions 
     48#  include "top_substitute.h90" 
    4149   !!---------------------------------------------------------------------- 
    4250   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    … …  
    6169      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
    6270      !! 
    63       INTEGER ::   jnt, jn, jl 
     71      INTEGER ::   ji, jj, jk, jnt, jn, jl 
     72      REAL(wp) ::  ztra 
     73#if defined key_kriest 
     74      REAL(wp) ::  zcoef1, zcoef2 
     75#endif 
    6476      CHARACTER (len=25) :: charout 
    65       REAL(wp), POINTER, DIMENSION(:,:,:,:)  :: ztrdpis 
    6677      !!--------------------------------------------------------------------- 
    6778      ! 
    6879      IF( nn_timing == 1 )  CALL timing_start('p4z_sms') 
    6980      ! 
    70       IF( l_trdtrc )  THEN 
    71          CALL wrk_alloc( jpi, jpj, jpk, jp_pisces, ztrdpis )  
    72          DO jn = 1, jp_pisces 
    73             jl = jn + jp_pcs0 - 1 
    74             ztrdpis(:,:,:,jn) = trn(:,:,:,jl) 
    75          ENDDO 
    76       ENDIF 
    77       ! 
    7881      IF( kt == nittrc000 ) THEN 
     82        ! 
     83        ALLOCATE( xnegtr(jpi,jpj,jpk) ) 
    7984        ! 
    8085        CALL p4z_che                              ! initialize the chemical constants 
    … …  
    8893      IF( ln_pisdmp .AND. MOD( kt - nn_dttrc, nn_pisdmp ) == 0 )   CALL p4z_dmp( kt )      ! Relaxation of some tracers 
    8994      ! 
     95      !                                                                    !   set time step size (Euler/Leapfrog) 
     96      IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN   ;    rfact = rdttrc(1)     !  at nittrc000 
     97      ELSEIF( kt <= nittrc000 + nn_dttrc )                          THEN   ;    rfact = 2. * rdttrc(1)   ! at nittrc000 or nittrc000+nn_dttrc (Leapfrog) 
     98      ENDIF 
     99      ! 
     100      IF( ( ln_top_euler .AND. kt == nittrc000 )  .OR. ( .NOT.ln_top_euler .AND. kt <= nittrc000 + nn_dttrc ) ) THEN 
     101         rfactr  = 1. / rfact 
     102         rfact2  = rfact / FLOAT( nrdttrc ) 
     103         rfact2r = 1. / rfact2 
     104         xstep = rfact2 / rday         ! Time step duration for biology 
     105         IF(lwp) WRITE(numout,*)  
     106         IF(lwp) WRITE(numout,*) '    Passive Tracer  time step    rfact  = ', rfact, ' rdt = ', rdttra(1) 
     107         IF(lwp) write(numout,*) '    PISCES  Biology time step    rfact2 = ', rfact2 
     108         IF(lwp) WRITE(numout,*) 
     109      ENDIF 
     110 
     111      IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN 
     112         DO jn = jp_pcs0, jp_pcs1              !   SMS on tracer without Asselin time-filter 
     113            trb(:,:,:,jn) = trn(:,:,:,jn) 
     114         END DO 
     115      ENDIF 
     116      ! 
    90117      IF( ndayflxtr /= nday_year ) THEN      ! New days 
    91118         ! 
    … …  
    105132      DO jnt = 1, nrdttrc          ! Potential time splitting if requested 
    106133         ! 
    107          CALL p4z_bio (kt, jnt)    ! Biology 
    108          CALL p4z_sed (kt, jnt)    ! Sedimentation 
    109          ! 
     134         CALL p4z_bio( kt, jnt )   ! Biology 
     135         CALL p4z_sed( kt, jnt )   ! Sedimentation 
     136         CALL p4z_lys( kt, jnt )   ! Compute CaCO3 saturation 
     137         CALL p4z_flx( kt, jnt )   ! Compute surface fluxes 
     138         ! 
     139         xnegtr(:,:,:) = 1.e0 
    110140         DO jn = jp_pcs0, jp_pcs1 
    111             trb(:,:,:,jn) = trn(:,:,:,jn) 
    112          ENDDO 
    113          ! 
     141            DO jk = 1, jpk 
     142               DO jj = 1, jpj 
     143                  DO ji = 1, jpi 
     144                     IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 
     145                        ztra             = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 
     146                        xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk),  ztra ) 
     147                     ENDIF 
     148                 END DO 
     149               END DO 
     150            END DO 
     151         END DO 
     152         !                                ! where at least 1 tracer concentration becomes negative 
     153         !                                !  
     154         DO jn = jp_pcs0, jp_pcs1 
     155           trb(:,:,:,jn) = trb(:,:,:,jn) + xnegtr(:,:,:) * tra(:,:,:,jn) 
     156         END DO 
     157        ! 
     158         DO jn = jp_pcs0, jp_pcs1 
     159            tra(:,:,:,jn) = 0._wp 
     160         END DO 
     161         ! 
     162         IF( ln_top_euler ) THEN 
     163            DO jn = jp_pcs0, jp_pcs1 
     164               trn(:,:,:,jn) = trb(:,:,:,jn) 
     165            END DO 
     166         ENDIF 
    114167      END DO 
    115168 
    116       IF( l_trdtrc )  THEN 
    117          DO jn = 1, jp_pisces 
    118             jl = jn + jp_pcs0 - 1 
    119             ztrdpis(:,:,:,jn) = ( ztrdpis(:,:,:,jn) - trn(:,:,:,jl) ) * rfact2r 
    120          ENDDO 
    121       ENDIF 
    122       CALL p4z_lys( kt )             ! Compute CaCO3 saturation 
    123       CALL p4z_flx( kt )             ! Compute surface fluxes 
    124  
    125       DO jn = jp_pcs0, jp_pcs1 
    126         CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. ) 
    127         CALL lbc_lnk( trb(:,:,:,jn), 'T', 1. ) 
    128         CALL lbc_lnk( tra(:,:,:,jn), 'T', 1. ) 
     169#if defined key_kriest 
     170      !  
     171      zcoef1 = 1.e0 / xkr_massp  
     172      zcoef2 = 1.e0 / xkr_massp / 1.1 
     173      DO jk = 1,jpkm1 
     174         trb(:,:,jk,jpnum) = MAX(  trb(:,:,jk,jpnum), trb(:,:,jk,jppoc) * zcoef1 / xnumm(jk)  ) 
     175         trb(:,:,jk,jpnum) = MIN(  trb(:,:,jk,jpnum), trb(:,:,jk,jppoc) * zcoef2              ) 
    129176      END DO 
    130177      ! 
     178#endif 
     179      ! 
     180      ! 
     181      IF( l_trdtrc ) THEN 
     182         DO jn = jp_pcs0, jp_pcs1 
     183           CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt )   ! save trends 
     184         END DO 
     185      END IF 
     186      ! 
    131187      IF( lk_sed ) THEN  
    132188         ! 
    … …  
    134190         ! 
    135191         DO jn = jp_pcs0, jp_pcs1 
    136            CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. ) 
     192           CALL lbc_lnk( trb(:,:,:,jn), 'T', 1. ) 
    137193         END DO 
    138194         ! 
    … …  
    141197      IF( lrst_trc )  CALL p4z_rst( kt, 'WRITE' )  !* Write PISCES informations in restart file  
    142198      ! 
    143       IF( l_trdtrc ) THEN 
    144          DO jn = 1, jp_pisces 
    145             jl = jn + jp_pcs0 - 1 
    146              ztrdpis(:,:,:,jn) = ztrdpis(:,:,:,jn) + tra(:,:,:,jl) 
    147              CALL trd_trc( ztrdpis(:,:,:,jn), jn, jptra_sms, kt )   ! save trends 
    148           END DO 
    149           CALL wrk_dealloc( jpi, jpj, jpk, jp_pisces, ztrdpis )  
    150       END IF 
    151       ! 
     199 
    152200      IF( lk_iomput .OR. ln_check_mass )  CALL p4z_chk_mass( kt ) ! Mass conservation checking 
    153201 
    … …  
    280328               ztmas   = tmask(ji,jj,jk) 
    281329               ztmas1  = 1. - tmask(ji,jj,jk) 
    282                zcaralk = trn(ji,jj,jk,jptal) - borat(ji,jj,jk) / (  1. + 1.E-8 / ( rtrn + akb3(ji,jj,jk) )  ) 
    283                zco3    = ( zcaralk - trn(ji,jj,jk,jpdic) ) * ztmas + 0.5e-3 * ztmas1 
    284                zbicarb = ( 2. * trn(ji,jj,jk,jpdic) - zcaralk ) 
     330               zcaralk = trb(ji,jj,jk,jptal) - borat(ji,jj,jk) / (  1. + 1.E-8 / ( rtrn + akb3(ji,jj,jk) )  ) 
     331               zco3    = ( zcaralk - trb(ji,jj,jk,jpdic) ) * ztmas + 0.5e-3 * ztmas1 
     332               zbicarb = ( 2. * trb(ji,jj,jk,jpdic) - zcaralk ) 
    285333               hi(ji,jj,jk) = ( ak23(ji,jj,jk) * zbicarb / zco3 ) * ztmas + 1.e-9 * ztmas1 
    286334            END DO 
    … …  
    361409      REAL(wp) ::  silmean = 91.51     ! mean value of silicate 
    362410      ! 
    363       REAL(wp) :: zarea, zalksum, zpo4sum, zno3sum, zsilsum 
     411      REAL(wp) :: zarea, zalksumn, zpo4sumn, zno3sumn, zsilsumn 
     412      REAL(wp) :: zalksumb, zpo4sumb, zno3sumb, zsilsumb 
    364413      !!--------------------------------------------------------------------- 
    365414 
    … …  
    374423         zarea          = 1._wp / glob_sum( cvol(:,:,:) ) * 1e6               
    375424 
    376          zalksum = glob_sum( trn(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
    377          zpo4sum = glob_sum( trn(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
    378          zno3sum = glob_sum( trn(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
    379          zsilsum = glob_sum( trn(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
     425         zalksumn = glob_sum( trn(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
     426         zpo4sumn = glob_sum( trn(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
     427         zno3sumn = glob_sum( trn(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
     428         zsilsumn = glob_sum( trn(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
    380429  
    381          IF(lwp) WRITE(numout,*) '       TALK mean : ', zalksum 
    382          trn(:,:,:,jptal) = trn(:,:,:,jptal) * alkmean / zalksum 
    383  
    384          IF(lwp) WRITE(numout,*) '       PO4  mean : ', zpo4sum 
    385          trn(:,:,:,jppo4) = trn(:,:,:,jppo4) * po4mean / zpo4sum 
    386  
    387          IF(lwp) WRITE(numout,*) '       NO3  mean : ', zno3sum 
    388          trn(:,:,:,jpno3) = trn(:,:,:,jpno3) * no3mean / zno3sum 
    389  
    390          IF(lwp) WRITE(numout,*) '       SiO3 mean : ', zsilsum 
    391          trn(:,:,:,jpsil) = MIN( 400.e-6,trn(:,:,:,jpsil) * silmean / zsilsum ) 
    392          ! 
    393       ENDIF 
    394  
     430         IF(lwp) WRITE(numout,*) '       TALKN mean : ', zalksumn 
     431         trn(:,:,:,jptal) = trn(:,:,:,jptal) * alkmean / zalksumn 
     432 
     433         IF(lwp) WRITE(numout,*) '       PO4N  mean : ', zpo4sumn 
     434         trn(:,:,:,jppo4) = trn(:,:,:,jppo4) * po4mean / zpo4sumn 
     435 
     436         IF(lwp) WRITE(numout,*) '       NO3N  mean : ', zno3sumn 
     437         trn(:,:,:,jpno3) = trn(:,:,:,jpno3) * no3mean / zno3sumn 
     438 
     439         IF(lwp) WRITE(numout,*) '       SiO3N mean : ', zsilsumn 
     440         trn(:,:,:,jpsil) = MIN( 400.e-6,trn(:,:,:,jpsil) * silmean / zsilsumn ) 
     441         ! 
     442         ! 
     443         IF( .NOT. ln_top_euler ) THEN 
     444            zalksumb = glob_sum( trb(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
     445            zpo4sumb = glob_sum( trb(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
     446            zno3sumb = glob_sum( trb(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
     447            zsilsumb = glob_sum( trb(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
     448  
     449            IF(lwp) WRITE(numout,*) ' ' 
     450            IF(lwp) WRITE(numout,*) '       TALKB mean : ', zalksumb 
     451            trb(:,:,:,jptal) = trb(:,:,:,jptal) * alkmean / zalksumb 
     452 
     453            IF(lwp) WRITE(numout,*) '       PO4B  mean : ', zpo4sumb 
     454            trb(:,:,:,jppo4) = trb(:,:,:,jppo4) * po4mean / zpo4sumb 
     455 
     456            IF(lwp) WRITE(numout,*) '       NO3B  mean : ', zno3sumb 
     457            trb(:,:,:,jpno3) = trb(:,:,:,jpno3) * no3mean / zno3sumb 
     458 
     459            IF(lwp) WRITE(numout,*) '       SiO3B mean : ', zsilsumb 
     460            trb(:,:,:,jpsil) = MIN( 400.e-6,trb(:,:,:,jpsil) * silmean / zsilsumb ) 
     461        ENDIF 
     462        ! 
     463      ENDIF 
     464        ! 
    395465   END SUBROUTINE p4z_dmp 
    396466 
    … …  
    406476      INTEGER , INTENT( in ) ::   kt      ! ocean time-step index       
    407477      REAL(wp)               ::  zfact        
    408       !! 
     478      REAL(wp) ::  zrdenittot, zsdenittot, znitrpottot 
     479      CHARACTER(LEN=100)   ::   cltxt 
     480      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol 
     481      INTEGER :: jk 
     482      !!---------------------------------------------------------------------- 
     483 
     484      ! 
    409485      !!--------------------------------------------------------------------- 
    410486 
    … …  
    413489            CALL ctl_opn( numco2, 'carbon.budget'  , 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
    414490            CALL ctl_opn( numnut, 'nutrient.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     491            CALL ctl_opn( numnit, 'nitrogen.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     492            xfact1 = rfact2r * 12. / 1.e15 * ryyss    ! conversion molC/kt --> PgC/yr 
     493            xfact2 = 1.e+3 * rno3 * 14. / 1.e12 * ryyss   ! conversion molC/l/s ----> TgN/m3/yr 
     494            cltxt='time-step   Alkalinity        Nitrate        Phosphorus         Silicate           Iron' 
     495            IF( lwp ) WRITE(numnut,*)  TRIM(cltxt) 
     496            IF( lwp ) WRITE(numnut,*)  
    415497         ENDIF 
    416498      ENDIF 
    417499 
     500      ! 
    418501      IF( iom_use( "pno3tot" ) .OR. ( ln_check_mass .AND. kt == nitend )  ) THEN 
    419502         !   Compute the budget of NO3, ALK, Si, Fer 
    … …  
    431514      ENDIF 
    432515      ! 
    433       IF( iom_use( "psiltot" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     516      IF( iom_use( "ppo4tot" ) .OR. ( ln_check_mass .AND. kt == nitend )  ) THEN 
     517         po4budget = glob_sum( (   trn(:,:,:,jppo4)                     & 
     518            &                    + trn(:,:,:,jpphy) + trn(:,:,:,jpdia)  & 
     519            &                    + trn(:,:,:,jpzoo) + trn(:,:,:,jpmes)  & 
     520            &                    + trn(:,:,:,jppoc)                     & 
     521#if ! defined key_kriest 
     522            &                    + trn(:,:,:,jpgoc)                     & 
     523#endif 
     524            &                    + trn(:,:,:,jpdoc)                     ) * cvol(:,:,:)  ) 
     525         po4budget = po4budget / areatot 
     526         CALL iom_put( "ppo4tot", po4budget ) 
     527      ENDIF 
     528      ! 
     529      IF( iom_use( "psiltot" ) .OR. ( ln_check_mass .AND. kt == nitend )  ) THEN 
    434530         silbudget = glob_sum( (   trn(:,:,:,jpsil) + trn(:,:,:,jpgsi)  & 
    435531            &                    + trn(:,:,:,jpdsi)                     ) * cvol(:,:,:)  ) 
    … …  
    439535      ENDIF 
    440536      ! 
    441       IF( iom_use( "palktot" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     537      IF( iom_use( "palktot" ) .OR. ( ln_check_mass .AND. kt == nitend )  ) THEN 
    442538         alkbudget = glob_sum( (   trn(:,:,:,jpno3) * rno3              & 
    443539            &                    + trn(:,:,:,jptal)                     & 
    … …  
    448544      ENDIF 
    449545      ! 
    450       IF( iom_use( "pfertot" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     546      IF( iom_use( "pfertot" ) .OR. ( ln_check_mass .AND. kt == nitend )  ) THEN 
    451547         ferbudget = glob_sum( (   trn(:,:,:,jpfer) + trn(:,:,:,jpnfe)  & 
    452548            &                    + trn(:,:,:,jpdfe)                     & 
    … …  
    462558      ENDIF 
    463559      ! 
     560 
     561      ! Global budget of N SMS : denitrification in the water column and in the sediment 
     562      !                          nitrogen fixation by the diazotrophs 
     563      ! -------------------------------------------------------------------------------- 
     564      IF( iom_use( "tnfix" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     565         znitrpottot  = glob_sum ( nitrpot(:,:,:) * nitrfix * cvol(:,:,:) ) 
     566         CALL iom_put( "tnfix"  , znitrpottot * 1.e+3 * rno3 )  ! Global  nitrogen fixation molC/l  to molN/m3  
     567      ENDIF 
     568      ! 
     569      IF( iom_use( "tdenit" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     570         zrdenittot   = glob_sum ( denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) ) 
     571         CALL iom_put( "tdenit"  , zrdenittot * 1.e+3 * rno3 )  ! Total denitrification molC/l to molN/m3  
     572      ENDIF 
     573      ! 
     574      IF( iom_use( "Sdenit" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
     575         zsdenittot   = glob_sum ( sdenit(:,:) * e1e2t(:,:) ) 
     576         CALL iom_put( "Sdenit", sdenit(:,:) * zfact * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
     577      ENDIF 
     578 
    464579      IF( ln_check_mass .AND. kt == nitend ) THEN   ! Compute the budget of NO3, ALK, Si, Fer 
    465          zfact = rfact2r * 12. / 1.e15 * ryyss    ! conversion molC/kt --> PgC/year 
    466580         t_atm_co2_flx  = t_atm_co2_flx / glob_sum( e1e2t(:,:) ) 
    467          t_oce_co2_flx  = t_oce_co2_flx         * zfact * (-1 ) 
    468          tpp            = tpp           * 1000. * zfact 
    469          t_oce_co2_exp  = t_oce_co2_exp * 1000. * zfact 
     581         t_oce_co2_flx  = t_oce_co2_flx         * xfact1 * (-1 ) 
     582         tpp            = tpp           * 1000. * xfact1 
     583         t_oce_co2_exp  = t_oce_co2_exp * 1000. * xfact1 
    470584         IF( lwp ) WRITE(numco2,9000) ndastp, t_atm_co2_flx, t_oce_co2_flx, tpp, t_oce_co2_exp 
    471          IF( lwp ) WRITE(numnut,9500) ndastp, alkbudget        * 1.e+06, & 
     585         IF( lwp ) WRITE(numnut,9100) ndastp, alkbudget        * 1.e+06, & 
    472586             &                                no3budget * rno3 * 1.e+06, & 
     587             &                                po4budget * po4r * 1.e+06, & 
    473588             &                                silbudget        * 1.e+06, & 
    474589             &                                ferbudget        * 1.e+09 
     590         ! 
     591         IF( lwp ) WRITE(numnit,9200) ndastp, znitrpottot * xfact2  , & 
     592         &                             zrdenittot  * xfact2  , & 
     593         &                             zsdenittot  * xfact2 
     594 
    475595      ENDIF 
    476596      ! 
    477597 9000  FORMAT(i8,f10.5,e18.10,f10.5,f10.5) 
    478  9500  FORMAT(i8,4e18.10) 
     598 9100  FORMAT(i8,5e18.10) 
     599 9200  FORMAT(i8,3f10.5) 
     600 
    479601       ! 
    480602   END SUBROUTINE p4z_chk_mass 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/par_pisces.F90

    r5500 r5630  
    6363   INTEGER, PUBLIC, PARAMETER ::   jpdia = 11    !: Diatoms Concentration 
    6464   INTEGER, PUBLIC, PARAMETER ::   jpmes = 12    !: Mesozooplankton Concentration 
    65    INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: (big) Silicate Concentration 
     65   INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: Diatoms Silicate Concentration 
    6666   INTEGER, PUBLIC, PARAMETER ::   jpfer = 14    !: Iron Concentration 
    6767   INTEGER, PUBLIC, PARAMETER ::   jpnum = 15    !: Big iron particles Concentration 
    6868   INTEGER, PUBLIC, PARAMETER ::   jpsfe = 16    !: number of particulate organic phosphate concentration 
    6969   INTEGER, PUBLIC, PARAMETER ::   jpdfe = 17    !: Diatoms iron Concentration 
    70    INTEGER, PUBLIC, PARAMETER ::   jpgsi = 18    !: Diatoms Silicate Concentration 
     70   INTEGER, PUBLIC, PARAMETER ::   jpgsi = 18    !: (big) Silicate Concentration 
    7171   INTEGER, PUBLIC, PARAMETER ::   jpnfe = 19    !: Nano iron Concentration 
    7272   INTEGER, PUBLIC, PARAMETER ::   jpnch = 20    !: Nano Chlorophyll Concentration 
    … …  
    102102   INTEGER, PUBLIC, PARAMETER ::   jpdia = 11    !: Diatoms Concentration 
    103103   INTEGER, PUBLIC, PARAMETER ::   jpmes = 12    !: Mesozooplankton Concentration 
    104    INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: (big) Silicate Concentration 
     104   INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: Diatoms Silicate Concentration 
    105105   INTEGER, PUBLIC, PARAMETER ::   jpfer = 14    !: Iron Concentration 
    106106   INTEGER, PUBLIC, PARAMETER ::   jpbfe = 15    !: Big iron particles Concentration 
    … …  
    108108   INTEGER, PUBLIC, PARAMETER ::   jpsfe = 17    !: Small iron particles Concentration 
    109109   INTEGER, PUBLIC, PARAMETER ::   jpdfe = 18    !: Diatoms iron Concentration 
    110    INTEGER, PUBLIC, PARAMETER ::   jpgsi = 19    !: Diatoms Silicate Concentration 
     110   INTEGER, PUBLIC, PARAMETER ::   jpgsi = 19    !: (big) Silicate Concentration 
    111111   INTEGER, PUBLIC, PARAMETER ::   jpnfe = 20    !: Nano iron Concentration 
    112112   INTEGER, PUBLIC, PARAMETER ::   jpnch = 21    !: Nano Chlorophyll Concentration 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r5500 r5630  
    106106   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tgfunc2   !: Temp. dependancy of mesozooplankton rates 
    107107 
    108    !!* Array used to indicate negative tracer values 
    109    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xnegtr     !: ??? 
    110  
    111108#if defined key_kriest 
    112109   !!*  Kriest parameter for aggregation 
    … …  
    131128      !!---------------------------------------------------------------------- 
    132129      USE lib_mpp , ONLY: ctl_warn 
    133       INTEGER ::   ierr(6)        ! Local variables 
     130      INTEGER ::   ierr(5)        ! Local variables 
    134131      !!---------------------------------------------------------------------- 
    135132      ierr(:) = 0 
    … …  
    162159      ALLOCATE( tgfunc(jpi,jpj,jpk)  , tgfunc2(jpi,jpj,jpk) ,    STAT=ierr(5) ) 
    163160         ! 
    164       !* Array used to indicate negative tracer values   
    165       ALLOCATE( xnegtr(jpi,jpj,jpk)  ,                           STAT=ierr(6) ) 
    166161#endif 
    167162      ! 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90

    r5500 r5630  
    7171      USE p4zmort         !  Mortality terms for phytoplankton 
    7272      USE p4zlys          !  Calcite saturation 
     73      USE p4zsed          !  Sedimentation & burial 
    7374      ! 
    7475      REAL(wp), SAVE :: sco2   =  2.312e-3_wp 
    75       REAL(wp), SAVE :: alka0  =  2.423e-3_wp 
     76      REAL(wp), SAVE :: alka0  =  2.426e-3_wp 
    7677      REAL(wp), SAVE :: oxyg0  =  177.6e-6_wp  
    77       REAL(wp), SAVE :: po4    =  2.174e-6_wp  
     78      REAL(wp), SAVE :: po4    =  2.165e-6_wp  
    7879      REAL(wp), SAVE :: bioma0 =  1.000e-8_wp   
    79       REAL(wp), SAVE :: silic1 =  91.65e-6_wp   
    80       REAL(wp), SAVE :: no3    =  31.04e-6_wp * 7.625_wp 
     80      REAL(wp), SAVE :: silic1 =  91.51e-6_wp   
     81      REAL(wp), SAVE :: no3    =  30.9e-6_wp * 7.625_wp 
    8182      ! 
    8283      INTEGER  ::  ji, jj, jk, ierr 
    … …  
    9798      ierr = ierr +  p4z_rem_alloc() 
    9899      ierr = ierr +  p4z_flx_alloc() 
     100      ierr = ierr +  p4z_sed_alloc() 
    99101      ! 
    100102      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    … …  
    107109      CALL p4z_sms_init       !  Maint routine 
    108110      !                                            ! Time-step 
    109       rfact   = rdttrc(1)                          ! --------- 
    110       rfactr  = 1. / rfact 
    111       rfact2  = rfact / FLOAT( nrdttrc ) 
    112       rfact2r = 1. / rfact2 
    113  
    114       IF(lwp) WRITE(numout,*) '    Passive Tracer  time step    rfact  = ', rfact, ' rdt = ', rdttra(1) 
    115       IF(lwp) write(numout,*) '    PISCES  Biology time step    rfact2 = ', rfact2 
    116  
    117  
    118111 
    119112      ! Set biological ratios 
    … …  
    165158      END IF 
    166159 
    167       ! Time step duration for biology 
    168       xstep = rfact2 / rday 
    169160 
    170161      CALL p4z_sink_init      !  vertical flux of particulate organic matter 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90

    r5500 r5630  
    8383      IF( kt == nittrc000 )   CALL trc_adv_ctl          ! initialisation & control of options 
    8484 
    85       IF( ln_top_euler) THEN 
    86          r2dt(:) =  rdttrc(:)              ! = rdttrc (use Euler time stepping) 
    87       ELSE 
    88          IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
    89             r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
    90          ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
    91             r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
    92          ENDIF 
     85      IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN     ! at nittrc000 
     86         r2dt(:) =  rdttrc(:)           ! = rdttrc (use or restarting with Euler time stepping) 
     87      ELSEIF( kt <= nittrc000 + nn_dttrc ) THEN          ! at nittrc000 or nittrc000+1 
     88         r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
    9389      ENDIF 
    94  
    9590      !                                                   ! effective transport 
    9691      DO jk = 1, jpkm1 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90

    r5500 r5630  
    126126                     DO jj = 2, jpjm1 
    127127                        DO ji = fs_2, fs_jpim1   ! vector opt. 
    128                            IF( avt(ji,jj,jk) <= 5.e-4 )  THEN  
     128                           IF( avt(ji,jj,jk) <= 5.e-4_wp )  THEN  
    129129                              ztra = restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - trb(ji,jj,jk,jn) ) 
    130130                              tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
    … …  
    185185      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    186186      ! 
    187       INTEGER :: ji, jj, jk, jn, jl, jc                     ! dummy loop indicesa 
     187      INTEGER :: ji , jj, jk, jn, jl, jc                     ! dummy loop indicesa 
     188      INTEGER :: isrow                                      ! local index 
    188189      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta       ! 3D  workspace 
    189190 
    … …  
    201202            ! 
    202203            SELECT CASE ( jp_cfg ) 
     204            !                                           ! ======================= 
     205            CASE ( 1 )                                  ! eORCA_R1 configuration 
     206            !                                           ! ======================= 
     207            isrow = 332 - jpjglo 
     208            ! 
     209                                                        ! Caspian Sea 
     210            nctsi1(1)   = 332  ; nctsj1(1)   = 243 - isrow 
     211            nctsi2(1)   = 344  ; nctsj2(1)   = 275 - isrow 
     212            !                                         
    203213            !                                           ! ======================= 
    204214            CASE ( 2 )                                  !  ORCA_R2 configuration 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90

    r5500 r5630  
    217217      ENDIF 
    218218 
    219       IF( .NOT. ln_trcldf_diff ) THEN 
    220          IF(lwp) WRITE(numout,*) '          No lateral diffusion on passive tracers' 
    221          nldf = -2 
    222       ENDIF 
    223  
    224219      IF(lwp) THEN 
    225220         WRITE(numout,*) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r5500 r5630  
    3333 
    3434   !                                        !!: ** lateral mixing namelist (nam_trcldf) ** 
    35    LOGICAL , PUBLIC ::   ln_trcldf_diff      !: flag of perform or not the lateral diff. 
    3635   LOGICAL , PUBLIC ::   ln_trcldf_lap       !: laplacian operator 
    3736   LOGICAL , PUBLIC ::   ln_trcldf_bilap     !: bilaplacian operator 
    … …  
    7372         &                 ln_trcadv_ubs  , ln_trcadv_qck, ln_trcadv_msc_ups 
    7473 
    75       NAMELIST/namtrc_ldf/ ln_trcldf_diff , ln_trcldf_lap  ,     & 
     74      NAMELIST/namtrc_ldf/ ln_trcldf_lap  ,     & 
    7675         &                 ln_trcldf_bilap, ln_trcldf_level,     & 
    7776         &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0 
    … …  
    121120         WRITE(numout,*) '~~~~~~~~~~~' 
    122121         WRITE(numout,*) '   Namelist namtrc_ldf : set lateral mixing parameters (type, direction, coefficients)' 
    123          WRITE(numout,*) '      perform lateral diffusion or not                   ln_trcldf_diff  = ', ln_trcldf_diff 
    124122         WRITE(numout,*) '      laplacian operator                                 ln_trcldf_lap   = ', ln_trcldf_lap 
    125123         WRITE(numout,*) '      bilaplacian operator                               ln_trcldf_bilap = ', ln_trcldf_bilap 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r5500 r5630  
    118118      ! set time step size (Euler/Leapfrog) 
    119119      IF( neuler == 0 .AND. kt ==  nittrc000 ) THEN  ;  r2dt(:) =     rdttrc(:)   ! at nittrc000             (Euler) 
    120       ELSEIF( kt <= nittrc000 + 1 )            THEN  ;  r2dt(:) = 2.* rdttrc(:)   ! at nit000 or nit000+1 (Leapfrog) 
     120      ELSEIF( kt <= nittrc000 + nn_dttrc )     THEN  ;  r2dt(:) = 2.* rdttrc(:)   ! at nit000 or nit000+1 (Leapfrog) 
    121121      ENDIF 
    122122 
    … …  
    137137      ELSE 
    138138         ! Leap-Frog + Asselin filter time stepping 
    139          IF( lk_vvl ) THEN   ;   CALL tra_nxt_vvl( kt, nittrc000, 'TRC', trb, trn, tra, jptra )      ! variable volume level (vvl)  
    140          ELSE                ;   CALL tra_nxt_fix( kt, nittrc000, 'TRC', trb, trn, tra, jptra )      ! fixed    volume level  
     139         IF( lk_vvl ) THEN   ;   CALL tra_nxt_vvl( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra,      & 
     140           &                                                                sbc_trc, sbc_trc_b, jptra )      ! variable volume level (vvl)  
     141         ELSE                ;   CALL tra_nxt_fix( kt, nittrc000,         'TRC', trb, trn, tra, jptra )      ! fixed    volume level  
    141142         ENDIF 
    142143      ENDIF 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r5500 r5630  
    1919   USE trc             ! ocean  passive tracers variables 
    2020   USE prtctl_trc      ! Print control for debbuging 
     21   USE iom 
    2122   USE trd_oce 
    2223   USE trdtra 
    … …  
    2627 
    2728   PUBLIC   trc_sbc   ! routine called by step.F90 
     29 
     30   REAL(wp) ::   r2dt  !  time-step at surface 
    2831 
    2932   !! * Substitutions 
    … …  
    6063      INTEGER, INTENT( in ) ::   kt          ! ocean time-step index 
    6164      ! 
    62       INTEGER  ::   ji, jj, jn           ! dummy loop indices 
    63       REAL(wp) ::   zsrau, zse3t   ! temporary scalars 
     65      INTEGER  ::   ji, jj, jn                                     ! dummy loop indices 
     66      REAL(wp) ::   zse3t, zrtrn, zratio, zfact                    ! temporary scalars 
     67      REAL(wp) ::   zswitch, zftra, zcd, zdtra, ztfx, ztra         ! temporary scalars 
    6468      CHARACTER (len=22) :: charout 
    6569      REAL(wp), POINTER, DIMENSION(:,:  ) :: zsfx 
    6670      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrtrd 
     71 
    6772      !!--------------------------------------------------------------------- 
    6873      ! 
    … …  
    7277                      CALL wrk_alloc( jpi, jpj,      zsfx   ) 
    7378      IF( l_trdtrc )  CALL wrk_alloc( jpi, jpj, jpk, ztrtrd ) 
     79      ! 
     80      zrtrn = 1.e-15_wp 
     81 
     82      SELECT CASE( nn_ice_embd )         ! levitating or embedded sea-ice option 
     83         CASE( 0    )   ;   zswitch = 1  ! (0) standard levitating sea-ice : salt exchange only 
     84         CASE( 1, 2 )   ;   zswitch = 0  ! (1) levitating sea-ice: salt and volume exchange but no pressure effect                                 
     85                                         ! (2) embedded sea-ice : salt and volume fluxes and pressure 
     86      END SELECT 
     87 
     88      IF( ln_top_euler) THEN 
     89         r2dt =  rdttrc(1)              ! = rdttrc (use Euler time stepping) 
     90      ELSE 
     91         IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
     92            r2dt = rdttrc(1)           ! = rdttrc (restarting with Euler time stepping) 
     93         ELSEIF( kt <= nittrc000 + nn_dttrc ) THEN          ! at nittrc000 or nittrc000+1 
     94            r2dt = 2. * rdttrc(1)       ! = 2 rdttrc (leapfrog) 
     95         ENDIF 
     96      ENDIF 
     97 
    7498 
    7599      IF( kt == nittrc000 ) THEN 
    … …  
    77101         IF(lwp) WRITE(numout,*) 'trc_sbc : Passive tracers surface boundary condition' 
    78102         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     103 
     104         IF( ln_rsttr .AND.    &                     ! Restart: read in restart  file 
     105            iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN 
     106            IF(lwp) WRITE(numout,*) '          nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file' 
     107            zfact = 0.5_wp 
     108            DO jn = 1, jptra 
     109               CALL iom_get( numrtr, jpdom_autoglo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) )   ! before tracer content sbc 
     110            END DO 
     111         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
     112           zfact = 1._wp 
     113           sbc_trc_b(:,:,:) = 0._wp 
     114         ENDIF 
     115      ELSE                                         ! Swap of forcing fields 
     116         IF( ln_top_euler ) THEN 
     117            zfact = 1._wp 
     118            sbc_trc_b(:,:,:) = 0._wp 
     119         ELSE 
     120            zfact = 0.5_wp 
     121            sbc_trc_b(:,:,:) = sbc_trc(:,:,:) 
     122         ENDIF 
     123         ! 
    79124      ENDIF 
    80125 
    … …  
    90135 
    91136      ! 0. initialization 
    92       zsrau = 1. / rau0 
    93137      DO jn = 1, jptra 
    94138         ! 
    95139         IF( l_trdtrc ) ztrtrd(:,:,:) = tra(:,:,:,jn)  ! save trends 
    96140         !                                             ! add the trend to the general tracer trend 
     141 
     142         IF ( nn_ice_tr == -1 ) THEN  ! No tracers in sea ice (null concentration in sea ice) 
     143 
     144            DO jj = 2, jpj 
     145               DO ji = fs_2, fs_jpim1   ! vector opt. 
     146                  sbc_trc(ji,jj,jn) = zsfx(ji,jj) * r1_rau0 * trn(ji,jj,1,jn) 
     147               END DO 
     148            END DO 
     149 
     150         ELSE 
     151 
     152            DO jj = 2, jpj 
     153               DO ji = fs_2, fs_jpim1   ! vector opt. 
     154                  zse3t = 1. / fse3t(ji,jj,1) 
     155                  ! tracer flux at the ice/ocean interface (tracer/m2/s) 
     156                  zftra = - trc_i(ji,jj,jn) * fmmflx(ji,jj) ! uptake of tracer in the sea ice 
     157                  zcd   =   trc_o(ji,jj,jn) * fmmflx(ji,jj) ! concentration dilution due to freezing-melting, 
     158                                                               ! only used in the levitating sea ice case 
     159                  ! tracer flux only       : add concentration dilution term in net tracer flux, no F-M in volume flux 
     160                  ! tracer and mass fluxes : no concentration dilution term in net tracer flux, F-M term in volume flux 
     161                  ztfx  = zftra + zswitch * zcd                ! net tracer flux (+C/D if no ice/ocean mass exchange) 
     162    
     163                  zdtra = r1_rau0 * ( ztfx + zsfx(ji,jj) * trn(ji,jj,1,jn) )  
     164                  IF ( zdtra < 0. ) THEN 
     165                     zratio = -zdtra * zse3t * r2dt / ( trn(ji,jj,1,jn) + zrtrn ) 
     166                     zdtra = MIN(1.0, zratio) * zdtra ! avoid negative concentrations to arise 
     167                  ENDIF 
     168                  sbc_trc(ji,jj,jn) =  zdtra  
     169               END DO 
     170            END DO 
     171         ENDIF 
     172         !                                       Concentration dilution effect on tracers due to evaporation & precipitation  
    97173         DO jj = 2, jpj 
    98174            DO ji = fs_2, fs_jpim1   ! vector opt. 
    99                zse3t = 1. / fse3t(ji,jj,1) 
    100                tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + zsfx(ji,jj) *  zsrau * trn(ji,jj,1,jn) * zse3t 
     175               zse3t = zfact / fse3t(ji,jj,1) 
     176               tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + ( sbc_trc_b(ji,jj,jn) + sbc_trc(ji,jj,jn) ) * zse3t 
    101177            END DO 
    102178         END DO 
    103           
     179         ! 
    104180         IF( l_trdtrc ) THEN 
    105181            ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) 
    … …  
    109185      END DO                                                     ! tracer loop 
    110186      !                                                          ! =========== 
     187 
     188      !                                           Write in the tracer restar  file 
     189      !                                          ******************************* 
     190      IF( lrst_trc ) THEN 
     191         IF(lwp) WRITE(numout,*) 
     192         IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in tracer restart file ',   & 
     193            &                    'at it= ', kt,' date= ', ndastp 
     194         IF(lwp) WRITE(numout,*) '~~~~' 
     195         DO jn = 1, jptra 
     196            CALL iom_rstput( kt, nitrst, numrtw, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc(:,:,jn) ) 
     197         END DO 
     198      ENDIF 
     199      ! 
    111200      IF( ln_ctl )   THEN 
    112201         WRITE(charout, FMT="('sbc ')") ;  CALL prt_ctl_trc_info(charout) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/TRP/trczdf.F90

    r5500 r5630  
    7373      IF( kt == nittrc000 )   CALL zdf_ctl          ! initialisation & control of options 
    7474 
    75       IF( ln_top_euler) THEN 
    76          r2dt(:) =  rdttrc(:)              ! = rdttrc (use Euler time stepping) 
    77       ELSE 
    78          IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
    79             r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
    80          ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
    81             r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
    82          ENDIF 
     75      IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN     ! at nittrc000 
     76         r2dt(:) =  rdttrc(:)           ! = rdttrc (use or restarting with Euler time stepping) 
     77      ELSEIF( kt <= nittrc000 + nn_dttrc ) THEN          ! at nittrc000 or nittrc000+1 
     78         r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
    8379      ENDIF 
    8480 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r5500 r5630  
    8787   USE sbc_oce , ONLY :   fmmflx     =>    fmmflx     !: freshwater budget: volume flux               [Kg/m2/s] 
    8888   USE sbc_oce , ONLY :   rnf        =>    rnf        !: river runoff   [Kg/m2/s] 
    89    USE sbc_oce , ONLY :   ln_dm2dc   =>    ln_dm2dc   !: Daily mean to Diurnal Cycle short wave (qsr)  
     89   USE sbc_oce , ONLY :   ln_dm2dc   =>    ln_dm2dc   !: Diurnal Cycle  
     90   USE sbc_oce , ONLY :   ncpl_qsr_freq   =>   ncpl_qsr_freq   !: qsr coupling frequency per days from atmospher 
    9091   USE sbc_oce , ONLY :   ln_rnf     =>    ln_rnf     !: runoffs / runoff mouths 
    9192   USE sbc_oce , ONLY :   fr_i       =>    fr_i       !: ice fraction (between 0 to 1) 
     93   USE sbc_oce , ONLY :   nn_ice_embd => nn_ice_embd  !: flag for  levitating/embedding sea-ice in the ocean 
    9294   USE traqsr  , ONLY :   rn_abs     =>    rn_abs     !: fraction absorbed in the very near surface 
    9395   USE traqsr  , ONLY :   rn_si0     =>    rn_si0     !: very near surface depth of extinction 
    … …  
    9698   USE sbcrnf  , ONLY :   rnfmsk_z   =>    rnfmsk_z   !: mixed adv scheme in runoffs vicinity (vert.) 
    9799   USE sbcrnf  , ONLY :   h_rnf      =>    h_rnf      !: river runoff   [Kg/m2/s] 
     100   USE sbcrnf  , ONLY :   nk_rnf     =>    nk_rnf     !: depth of runoff in model level 
    98101 
    99102   USE trc_oce 
    … …  
    135138# endif 
    136139 
     140   USE diaar5 , ONLY :   lk_diaar5  =>   lk_diaar5 
    137141#else 
    138142   !!---------------------------------------------------------------------- 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trc.F90

    r5500 r5630  
    3434   REAL(wp), PUBLIC                                                ::  areatot        !: total volume  
    3535   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  )         ::  cvol           !: volume correction -degrad option-  
    36    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  trn            !: traceur concentration for now time step 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  tra            !: traceur concentration for next time step 
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  trb            !: traceur concentration for before time step 
     36   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  trn            !: tracer concentration for now time step 
     37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  tra            !: tracer concentration for next time step 
     38   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:)         ::  trb            !: tracer concentration for before time step 
     39   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  )         ::  sbc_trc_b      !: Before sbc fluxes for tracers 
     40   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  )         ::  sbc_trc        !: Now sbc fluxes for tracers 
     41 
     42   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  )         ::  trc_i          !: prescribed tracer concentration in sea ice for SBC 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  )         ::  trc_o          !: prescribed tracer concentration in ocean for SBC 
     44   INTEGER             , PUBLIC                                    ::  nn_ice_tr      !: handling of sea ice tracers 
    3945 
    4046   !! interpolated gradient 
    … …  
    4450   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)           ::  gtrui          !: hor. gradient at u-points at top    ocean level 
    4551   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)           ::  gtrvi          !: hor. gradient at v-points at top    ocean level 
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)             ::  qsr_mean        !: daily mean qsr 
    4653    
    4754   !! passive tracers  (input and output) 
    … …  
    6370   LOGICAL             , PUBLIC                                    ::  ln_trcdmp_clo  !: internal damping flag on closed seas 
    6471   INTEGER             , PUBLIC                                    ::  nittrc000       !: first time step of passive tracers model 
     72   LOGICAL             , PUBLIC                                    ::  l_trcdm2dc     !: Diurnal cycle for TOP 
     73 
     74   !! Information for the ice module for tracers 
     75   !! ------------------------------------------ 
     76   TYPE TRC_I_NML                    !--- Ice tracer namelist structure 
     77         REAL(wp)         :: trc_ratio  ! ice-ocean trc ratio 
     78         REAL(wp)         :: trc_prescr ! prescribed ice trc cc 
     79         CHARACTER(len=2) :: ctrc_o     ! choice of ocean trc cc 
     80   END TYPE 
     81 
     82   REAL(wp), DIMENSION(jptra), PUBLIC         :: trc_ice_ratio, & ! ice-ocean tracer ratio 
     83                                                 trc_ice_prescr   ! prescribed ice trc cc 
     84   CHARACTER(len=2), DIMENSION(jptra), PUBLIC :: cn_trc_o ! choice of ocean tracer cc 
    6585 
    6686   !! information for outputs 
    … …  
    187207      ! 
    188208      ALLOCATE( trn(jpi,jpj,jpk,jptra), trb(jpi,jpj,jpk,jptra), tra(jpi,jpj,jpk,jptra),       &   
     209         &      trc_i(jpi,jpj,jptra)  , trc_o(jpi,jpj,jptra)                          ,       & 
    189210         &      gtru (jpi,jpj,jptra)  , gtrv (jpi,jpj,jptra)                          ,       & 
    190211         &      gtrui(jpi,jpj,jptra)  , gtrvi(jpi,jpj,jptra)                          ,       & 
     212         &      sbc_trc_b(jpi,jpj,jptra), sbc_trc(jpi,jpj,jptra)                      ,       &   
    191213         &      cvol(jpi,jpj,jpk)     , rdttrc(jpk)           , trai(jptra)           ,       & 
    192214         &      ctrcnm(jptra)         , ctrcln(jptra)         , ctrcun(jptra)         ,       &  
    193          &      ln_trc_ini(jptra)     , ln_trc_wri(jptra)                             ,  STAT = trc_alloc  )   
     215         &      ln_trc_ini(jptra)     , ln_trc_wri(jptra)     , qsr_mean(jpi,jpj)     ,  STAT = trc_alloc  )   
    194216 
    195217      IF( trc_alloc /= 0 )   CALL ctl_warn('trc_alloc: failed to allocate arrays') 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r5500 r5630  
    223223                           sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 
    224224                        ENDIF 
     225                        ik = mikt(ji,jj) 
     226                        IF( ik > 1 ) THEN 
     227                           zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
     228                           sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik+1) 
     229                        ENDIF 
    225230                     END DO 
    226231                  END DO 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r5500 r5630  
    3131   USE lib_mpp         ! distribued memory computing library 
    3232   USE sbc_oce 
     33   USE trcice          ! tracers in sea ice 
    3334  
    3435   IMPLICIT NONE 
    … …  
    7172      CALL top_alloc()              ! allocate TOP arrays 
    7273 
    73 #if defined key_offline 
    74       ltrcdm2dc = .FALSE. 
    75 #endif 
    76  
    77       IF( ltrcdm2dc )CALL ctl_warn( ' Diurnal cycle on physics but not in PISCES or LOBSTER ' ) 
     74      l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 ) 
     75      l_trcdm2dc = l_trcdm2dc  .AND. .NOT. lk_offline 
     76      IF( l_trcdm2dc .AND. lwp ) & 
     77         &   CALL ctl_warn(' Coupling with passive tracers and used of diurnal cycle. & 
     78         & Computation of a daily mean shortwave for some biogeochemical models) ') 
    7879 
    7980      IF( nn_cla == 1 )   & 
    … …  
    100101      IF( lk_c14b    )       CALL trc_ini_c14b         ! C14 bomb  tracer 
    101102      IF( lk_my_trc  )       CALL trc_ini_my_trc       ! MY_TRC  tracers 
     103 
     104      CALL trc_ice_ini                                 ! Tracers in sea ice 
    102105 
    103106      IF( lwp ) THEN 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

    r5500 r5630  
    147147 
    148148 
     149      ! Call the ice module for tracers 
     150      ! ------------------------------- 
     151      CALL trc_nam_ice 
     152 
    149153      ! namelist of SMS 
    150154      ! ---------------       
    … …  
    216220    END SUBROUTINE trc_nam_run 
    217221 
     222   SUBROUTINE trc_nam_ice 
     223      !!--------------------------------------------------------------------- 
     224      !!                     ***  ROUTINE trc_nam_ice *** 
     225      !! 
     226      !! ** Purpose :   Read the namelist for the ice effect on tracers 
     227      !! 
     228      !! ** Method  : - 
     229      !! 
     230      !!--------------------------------------------------------------------- 
     231      ! --- Variable declarations --- ! 
     232      INTEGER :: jn      ! dummy loop indices 
     233      INTEGER :: ios     ! Local integer output status for namelist read 
     234 
     235      ! --- Namelist declarations --- ! 
     236      TYPE(TRC_I_NML), DIMENSION(jptra) :: sn_tri_tracer 
     237      NAMELIST/namtrc_ice/ nn_ice_tr, sn_tri_tracer 
     238 
     239      IF(lwp) THEN 
     240         WRITE(numout,*) 
     241         WRITE(numout,*) 'trc_nam_ice : Read the namelist for trc_ice' 
     242         WRITE(numout,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' 
     243      ENDIF 
     244 
     245      IF( nn_timing == 1 )  CALL timing_start('trc_nam_ice') 
     246 
     247      ! 
     248      REWIND( numnat_ref )              ! Namelist namtrc_ice in reference namelist : Passive tracer input data 
     249      READ  ( numnat_ref, namtrc_ice, IOSTAT = ios, ERR = 901) 
     250 901  IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtrc_ice in reference namelist ', lwp ) 
     251 
     252      REWIND( numnat_cfg )              ! Namelist namtrc_ice in configuration namelist : Pisces external sources of nutrients 
     253      READ  ( numnat_cfg, namtrc_ice, IOSTAT = ios, ERR = 902 ) 
     254 902  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ice in configuration namelist', lwp ) 
     255 
     256      IF( lwp ) THEN 
     257         WRITE(numout,*) ' ' 
     258         WRITE(numout,*) ' Sea ice tracers option (nn_ice_tr) : ', nn_ice_tr 
     259         WRITE(numout,*) ' ' 
     260      ENDIF 
     261 
     262      ! Assign namelist stuff 
     263      DO jn = 1, jptra 
     264         trc_ice_ratio(jn)  = sn_tri_tracer(jn)%trc_ratio 
     265         trc_ice_prescr(jn) = sn_tri_tracer(jn)%trc_prescr 
     266         cn_trc_o      (jn) = sn_tri_tracer(jn)%ctrc_o 
     267      END DO 
     268 
     269      IF( nn_timing == 1 )   CALL timing_stop('trc_nam_ice') 
     270      ! 
     271   END SUBROUTINE trc_nam_ice 
    218272 
    219273   SUBROUTINE trc_nam_trc 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trcrst.F90

    r5500 r5630  
    207207         ENDIF 
    208208 
    209          CALL iom_open( TRIM(cn_trcrst_indir)//'/'//cn_trcrst_in, numrtr, kiolib = jlibalt ) 
    210  
    211          CALL iom_get ( numrtr, 'kt', zkt )   ! last time-step of previous run 
    212  
    213          IF(lwp) THEN 
    214             WRITE(numout,*) ' *** Info read in restart : ' 
    215             WRITE(numout,*) '   previous time-step                               : ', NINT( zkt ) 
    216             WRITE(numout,*) ' *** restart option' 
    217             SELECT CASE ( nn_rsttr ) 
    218             CASE ( 0 )   ;   WRITE(numout,*) ' nn_rsttr = 0 : no control of nittrc000' 
    219             CASE ( 1 )   ;   WRITE(numout,*) ' nn_rsttr = 1 : no control the date at nittrc000 (use ndate0 read in the namelist)' 
    220             CASE ( 2 )   ;   WRITE(numout,*) ' nn_rsttr = 2 : calendar parameters read in restart' 
    221             END SELECT 
    222             WRITE(numout,*) 
    223          ENDIF 
    224          ! Control of date  
    225          IF( nittrc000  - NINT( zkt ) /= nn_dttrc .AND.  nn_rsttr /= 0 )                                  & 
    226             &   CALL ctl_stop( ' ===>>>> : problem with nittrc000 for the restart',                 & 
    227             &                  ' verify the restart file or rerun with nn_rsttr = 0 (namelist)' ) 
    228          IF( lk_offline ) THEN      ! set the date in offline mode 
    229             ! Check dynamics and tracer time-step consistency and force Euler restart if changed 
    230             IF( iom_varid( numrtr, 'rdttrc1', ldstop = .FALSE. ) > 0 )   THEN 
    231                CALL iom_get( numrtr, 'rdttrc1', zrdttrc1 ) 
    232                IF( zrdttrc1 /= rdt * nn_dttrc )   neuler = 0 
    233             ENDIF 
    234             !                          ! define ndastp and adatrj 
    235             IF( nn_rsttr == 2 ) THEN 
     209         IF( ln_rsttr ) THEN 
     210            CALL iom_open( TRIM(cn_trcrst_indir)//'/'//cn_trcrst_in, numrtr, kiolib = jlibalt ) 
     211            CALL iom_get ( numrtr, 'kt', zkt )   ! last time-step of previous run 
     212 
     213            IF(lwp) THEN 
     214               WRITE(numout,*) ' *** Info read in restart : ' 
     215               WRITE(numout,*) '   previous time-step                               : ', NINT( zkt ) 
     216               WRITE(numout,*) ' *** restart option' 
     217               SELECT CASE ( nn_rsttr ) 
     218               CASE ( 0 )   ;   WRITE(numout,*) ' nn_rsttr = 0 : no control of nittrc000' 
     219               CASE ( 1 )   ;   WRITE(numout,*) ' nn_rsttr = 1 : no control the date at nittrc000 (use ndate0 read in the namelist)' 
     220               CASE ( 2 )   ;   WRITE(numout,*) ' nn_rsttr = 2 : calendar parameters read in restart' 
     221               END SELECT 
     222               WRITE(numout,*) 
     223            ENDIF 
     224            ! Control of date  
     225            IF( nittrc000  - NINT( zkt ) /= nn_dttrc .AND.  nn_rsttr /= 0 )                                  & 
     226               &   CALL ctl_stop( ' ===>>>> : problem with nittrc000 for the restart',                 & 
     227               &                  ' verify the restart file or rerun with nn_rsttr = 0 (namelist)' ) 
     228         ENDIF 
     229         ! 
     230         IF( lk_offline ) THEN     
     231            !                                          ! set the date in offline mode 
     232            IF( ln_rsttr .AND. nn_rsttr == 2 ) THEN 
    236233               CALL iom_get( numrtr, 'ndastp', zndastp )  
    237234               ndastp = NINT( zndastp ) 
    238235               CALL iom_get( numrtr, 'adatrj', adatrj  ) 
    239             ELSE 
     236             ELSE 
    240237               ndastp = ndate0 - 1     ! ndate0 read in the namelist in dom_nam 
    241238               adatrj = ( REAL( nittrc000-1, wp ) * rdttra(1) ) / rday 
    … …  
    248245              WRITE(numout,*) '   number of elapsed days since the begining of run : ', adatrj 
    249246              WRITE(numout,*) 
     247            ENDIF 
     248            ! 
     249            IF( ln_rsttr )  THEN   ;    neuler = 1 
     250            ELSE                   ;    neuler = 0 
    250251            ENDIF 
    251252            ! 
    … …  
    278279      INTEGER  :: jk, jn 
    279280      REAL(wp) :: ztraf, zmin, zmax, zmean, zdrift 
     281      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol 
    280282      !!---------------------------------------------------------------------- 
    281283 
    … …  
    286288      ENDIF 
    287289      ! 
    288       DO jn = 1, jptra 
    289          ztraf = glob_sum( trn(:,:,:,jn) * cvol(:,:,:) ) 
     290      DO jk = 1, jpk 
     291         zvol(:,:,jk) = e1e2t(:,:) * fse3t_a(:,:,jk) * tmask(:,:,jk) 
     292      END DO 
     293      ! 
     294      DO jn = 1, jptra 
     295         ztraf = glob_sum( trn(:,:,:,jn) * zvol(:,:,:) ) 
    290296         zmin  = MINVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) 
    291297         zmax  = MAXVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) 

  • branches/UKMO/dev_r5107_restart_func_and_date/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r5500 r5630  
    3030   PUBLIC   trc_stp    ! called by step 
    3131 
     32   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr ! save qsr during TOP time-step 
     33   REAL(wp) :: rdt_sampl 
     34   INTEGER  :: nb_rec_per_days 
     35   INTEGER  :: isecfst, iseclast 
     36   LOGICAL  :: llnew 
     37 
    3238   !! * Substitutions 
    3339#  include "domzgr_substitute.h90" 
    … …  
    5460      CHARACTER (len=25)    ::  charout  
    5561 
    56       REAL(wp), DIMENSION(:,:), POINTER ::   zqsr_tmp ! save qsr during TOP time-step 
    5762      !!------------------------------------------------------------------- 
    5863      ! 
    … …  
    6873         areatot         = glob_sum( cvol(:,:,:) ) 
    6974      ENDIF 
    70       !     
    71       IF( ltrcdm2dc ) THEN 
    72          ! When Diurnal cycle, core bulk and LIM2  are activated, put daily mean qsr in qsr for TOP/biogeochemistery time-step 
    73          ! and save qsr with diurnal cycle in qsr_tmp 
    74          CALL wrk_alloc( jpi,jpj, zqsr_tmp ) 
    75          zqsr_tmp(:,:) = qsr     (:,:) 
    76          qsr     (:,:) = qsr_mean(:,:)     
    77       ENDIF 
     75      ! 
     76      IF( l_trcdm2dc )   CALL trc_mean_qsr( kt ) 
    7877      !     
    7978      IF( nn_dttrc /= 1 )   CALL trc_sub_stp( kt )  ! averaging physical variables for sub-stepping 
    … …  
    106105      ENDIF 
    107106      ! 
    108       IF( ltrcdm2dc ) THEN 
    109          ! put back qsr with diurnal cycle in qsr 
    110          qsr(:,:) = zqsr_tmp(:,:) 
    111          CALL wrk_dealloc( jpi,jpj, zqsr_tmp ) 
    112       ENDIF 
    113       ! 
    114107      ztrai = 0._wp                                                   !  content of all tracers 
    115108      DO jn = 1, jptra 
    … …  
    122115      ! 
    123116   END SUBROUTINE trc_stp 
     117 
     118   SUBROUTINE trc_mean_qsr( kt ) 
     119      !!---------------------------------------------------------------------- 
     120      !!             ***  ROUTINE trc_mean_qsr  *** 
     121      !! 
     122      !! ** Purpose :  Compute daily mean qsr for biogeochemical model in case 
     123      !!               of diurnal cycle 
     124      !! 
     125      !! ** Method  : store in TOP the qsr every hour ( or every time-step the latter  
     126      !!              is greater than 1 hour ) and then, compute the  mean with  
     127      !!              a moving average over 24 hours.  
     128      !!              In coupled mode, the sampling is done at every coupling frequency  
     129      !!---------------------------------------------------------------------- 
     130      INTEGER, INTENT(in) ::   kt 
     131      INTEGER  :: jn 
     132 
     133      IF( kt == nittrc000 ) THEN 
     134         IF( ln_cpl )  THEN   
     135            rdt_sampl = 86400. / ncpl_qsr_freq 
     136            nb_rec_per_days = ncpl_qsr_freq 
     137         ELSE   
     138            rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 
     139            nb_rec_per_days = INT( 86400 / rdt_sampl ) 
     140         ENDIF 
     141         ! 
     142         IF( lwp ) THEN 
     143            WRITE(numout,*)  
     144            WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_days 
     145            WRITE(numout,*)  
     146         ENDIF 
     147         ! 
     148         ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_days ) ) 
     149         DO jn = 1, nb_rec_per_days 
     150            qsr_arr(:,:,jn) = qsr(:,:) 
     151         ENDDO 
     152         qsr_mean(:,:) = qsr(:,:) 
     153         ! 
     154         isecfst  = nsec_year + nsec1jan000   !   number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
     155         iseclast = isecfst 
     156         ! 
     157      ENDIF 
     158      ! 
     159      iseclast = nsec_year + nsec1jan000 
     160      llnew   = ( iseclast - isecfst )  > INT( rdt_sampl )   !   new shortwave to store 
     161      IF( kt /= nittrc000 .AND. llnew ) THEN 
     162          IF( lwp ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', kt, & 
     163             &                      ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 
     164          isecfst = iseclast 
     165          DO jn = 1, nb_rec_per_days - 1 
     166             qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 
     167          ENDDO 
     168          qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 
     169          qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days 
     170      ENDIF 
     171      ! 
     172   END SUBROUTINE trc_mean_qsr 
    124173 
    125174#else 
Note: See TracChangeset for help on using the changeset viewer.