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 4924 for branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC – NEMO

Ignore:
Timestamp:
2014-11-28T18:24:01+01:00 (9 years ago)
Author:
mathiot
Message:

UKM02_ice_shelves merged and SETTE tested with revision 4879 of trunk

Location:
branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC
Files:
41 edited

Legend:

Unmodified
Added
Removed

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r4608 r4924  
    104104   REAL(wp),    DIMENSION(jp_bdy) ::   rn_time_dmp_out          !: Damping time scale in days at radiation outflow points 
    105105 
    106 #if ( defined key_lim2 || defined key_lim3 ) 
    107106   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_ice_lim       ! Choice of boundary condition for sea ice variables  
    108107   INTEGER, DIMENSION(jp_bdy)           ::   nn_ice_lim_dta   !: = 0 use the initial state as bdy dta ;  
    109108                                                              !: = 1 read it in a NetCDF file 
    110 #endif 
     109   REAL(wp),    DIMENSION(jp_bdy) ::   rn_ice_tem             !: choice of the temperature of incoming sea ice 
     110   REAL(wp),    DIMENSION(jp_bdy) ::   rn_ice_sal             !: choice of the salinity    of incoming sea ice 
     111   REAL(wp),    DIMENSION(jp_bdy) ::   rn_ice_age             !: choice of the age         of incoming sea ice 
    111112   ! 
    112113    

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r4624 r4924  
    676676               CALL iom_close ( inum ) 
    677677               !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 
    678                !CALL iom_open ( bn_a_i %clname, inum ) 
     678               !CALL iom_open ( bn_a_i%clname, inum ) 
    679679               !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
    680680                IF ( zndims == 4 ) THEN 
    … …  
    740740      jstart = 1 
    741741      DO ib_bdy = 1, nb_bdy 
    742          jend = nb_bdy_fld(ib_bdy)  
     742         jend = jstart - 1 + nb_bdy_fld(ib_bdy)  
    743743         CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(ib_bdy), 'bdy_dta',   & 
    744744         &              'open boundary conditions', 'nambdy_dta' ) 
    … …  
    907907   !!============================================================================== 
    908908END MODULE bdydta 
    909  
    910  

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn.F90

    r4370 r4924  
    3030   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    3131   USE in_out_manager  ! 
    32    USE domvvl 
     32   USE domvvl          ! variable volume 
    3333 
    3434   IMPLICIT NONE 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r4333 r4924  
    2424   USE par_ice_2 
    2525   USE ice_2           ! LIM_2 ice variables 
     26   USE dom_ice_2       ! sea-ice domain 
    2627#elif defined key_lim3 
    2728   USE par_ice 
    2829   USE ice             ! LIM_3 ice variables 
     30   USE dom_ice         ! sea-ice domain 
    2931#endif  
    3032   USE par_oce         ! ocean parameters 
    3133   USE dom_oce         ! ocean space and time domain variables  
    32    USE dom_ice          ! sea-ice domain 
    3334   USE sbc_oce         ! Surface boundary condition: ocean fields 
    3435   USE bdy_oce         ! ocean open boundary conditions 
    … …  
    99100      REAL(wp) ::   zinda, ztmelts, zdh 
    100101 
    101       REAL(wp), PARAMETER  ::   zsal = 6.3    ! arbitrary salinity    for incoming ice 
    102       REAL(wp), PARAMETER  ::   ztem = 270.0  ! arbitrary temperature for incoming ice 
    103       REAL(wp), PARAMETER  ::   zage = 30.0   ! arbitrary age         for incoming ice 
    104102      !!------------------------------------------------------------------------------ 
    105103      ! 
    … …  
    233231 
    234232               ! Ice salinity, age, temperature 
    235                sm_i(ji,jj,jl)   = zinda * zsal  + ( 1.0 - zinda ) * s_i_min 
    236                o_i(ji,jj,jl)    = zinda * zage  + ( 1.0 - zinda ) 
    237                t_su(ji,jj,jl)   = zinda * ztem  + ( 1.0 - zinda ) * ztem 
     233               sm_i(ji,jj,jl)   = zinda * rn_ice_sal(ib_bdy)  + ( 1.0 - zinda ) * s_i_min 
     234               o_i(ji,jj,jl)    = zinda * rn_ice_age(ib_bdy)  + ( 1.0 - zinda ) 
     235               t_su(ji,jj,jl)   = zinda * rn_ice_tem(ib_bdy)  + ( 1.0 - zinda ) * rn_ice_tem(ib_bdy) 
    238236               DO jk = 1, nlay_s 
    239                   t_s(ji,jj,jk,jl) = zinda * ztem + ( 1.0 - zinda ) * rtt 
     237                  t_s(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt 
    240238               END DO 
    241239               DO jk = 1, nlay_i 
    242                   t_i(ji,jj,jk,jl) = zinda * ztem + ( 1.0 - zinda ) * rtt  
    243                   s_i(ji,jj,jk,jl) = zinda * zsal + ( 1.0 - zinda ) * s_i_min 
     240                  t_i(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt  
     241                  s_i(ji,jj,jk,jl) = zinda * rn_ice_sal(ib_bdy) + ( 1.0 - zinda ) * s_i_min 
    244242               END DO 
    245243                
    … …  
    259257 
    260258            END SELECT 
     259 
     260            ! if salinity is constant, then overwrite rn_ice_sal 
     261            IF( num_sal == 1 ) THEN 
     262               sm_i(ji,jj,jl)   = bulk_sal 
     263               s_i (ji,jj,:,jl) = bulk_sal 
     264            ENDIF 
    261265 
    262266            ! contents 
    … …  
    338342      DO ib_bdy=1, nb_bdy 
    339343         ! 
    340          SELECT CASE( nn_ice_lim(ib_bdy) ) 
     344         SELECT CASE( cn_ice_lim(ib_bdy) ) 
    341345 
    342346         CASE('none') 
    … …  
    355359                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    356360                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    357                   zflag = idx_bdy(ib_bdy)%flagu(jb) 
     361                  zflag = idx_bdy(ib_bdy)%flagu(jb,jgrd) 
    358362                   
    359363                  IF ( ABS( zflag ) == 1. ) THEN  ! eastern and western boundaries 
    … …  
    384388                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    385389                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    386                   zflag = idx_bdy(ib_bdy)%flagv(jb) 
     390                  zflag = idx_bdy(ib_bdy)%flagv(jb,jgrd) 
    387391                   
    388392                  IF ( ABS( zflag ) == 1. ) THEN  ! northern and southern boundaries 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r4726 r4924  
    100100         &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &   
    101101         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
    102 #if ( defined key_lim2 || defined key_lim3 ) 
    103102         &             cn_ice_lim, nn_ice_lim_dta,                           & 
    104 #endif 
     103         &             rn_ice_tem, rn_ice_sal, rn_ice_age,                 & 
    105104         &             ln_vol, nn_volctl, nn_rimwidth 
    106105      !! 
    … …  
    359358        ENDIF 
    360359        IF(lwp) WRITE(numout,*) 
     360        IF(lwp) WRITE(numout,*) '      tem of bdy sea-ice = ', rn_ice_tem(ib_bdy)          
     361        IF(lwp) WRITE(numout,*) '      sal of bdy sea-ice = ', rn_ice_sal(ib_bdy)          
     362        IF(lwp) WRITE(numout,*) '      age of bdy sea-ice = ', rn_ice_age(ib_bdy)          
    361363#endif 
    362364 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r4624 r4924  
    418418      DO ib_bdy = 1,nb_bdy 
    419419 
    420          ! line below should be simplified (runoff case) 
    421 !! CHANUT: TO BE SORTED OUT 
    422 !!         IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(nn_tra(ib_bdy).NE.4)) THEN 
    423420         IF ( nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN 
    424421 
    … …  
    453450            IF ( PRESENT(kit) ) THEN 
    454451               IF ( lk_first_btstp ) THEN ! Save slow varying open boundary data: 
    455                   dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy(ib_bdy)%ssh(1:ilen0(1)) 
    456                   dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy(ib_bdy)%u2d(1:ilen0(2)) 
    457                   dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy(ib_bdy)%v2d(1:ilen0(3)) 
     452                  IF ( dta_bdy(ib_bdy)%ll_ssh ) dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy(ib_bdy)%ssh(1:ilen0(1)) 
     453                  IF ( dta_bdy(ib_bdy)%ll_u2d ) dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy(ib_bdy)%u2d(1:ilen0(2)) 
     454                  IF ( dta_bdy(ib_bdy)%ll_v2d ) dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy(ib_bdy)%v2d(1:ilen0(3)) 
    458455 
    459456               ELSE ! Initialize arrays from slow varying open boundary data:             
    460                   dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 
    461                   dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 
    462                   dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 
     457                  IF ( dta_bdy(ib_bdy)%ll_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 
     458                  IF ( dta_bdy(ib_bdy)%ll_u2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 
     459                  IF ( dta_bdy(ib_bdy)%ll_v2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 
    463460               ENDIF 
    464461            ENDIF 
    … …  
    471468               z_sist = zramp * SIN( z_sarg ) 
    472469               ! 
    473                igrd=1                              ! SSH on tracer grid 
    474                DO ib = 1, ilen0(igrd) 
    475                   dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & 
    476                      &                      ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & 
    477                      &                        tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) 
    478                END DO 
    479                ! 
    480                igrd=2                              ! U grid 
    481                DO ib = 1, ilen0(igrd) 
    482                   dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & 
    483                      &                      ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & 
    484                      &                        tides(ib_bdy)%u(ib,itide,2)*z_sist ) 
    485                END DO 
    486                ! 
    487                igrd=3                              ! V grid 
    488                DO ib = 1, ilen0(igrd)  
    489                   dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & 
    490                      &                      ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & 
    491                      &                        tides(ib_bdy)%v(ib,itide,2)*z_sist ) 
    492                END DO 
    493             END DO 
     470               IF ( dta_bdy(ib_bdy)%ll_ssh ) THEN 
     471                  igrd=1                              ! SSH on tracer grid 
     472                  DO ib = 1, ilen0(igrd) 
     473                     dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & 
     474                        &                      ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & 
     475                        &                        tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) 
     476                  END DO 
     477               ENDIF 
     478               ! 
     479               IF ( dta_bdy(ib_bdy)%ll_u2d ) THEN 
     480                  igrd=2                              ! U grid 
     481                  DO ib = 1, ilen0(igrd) 
     482                     dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & 
     483                        &                      ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & 
     484                        &                        tides(ib_bdy)%u(ib,itide,2)*z_sist ) 
     485                  END DO 
     486               ENDIF 
     487               ! 
     488               IF ( dta_bdy(ib_bdy)%ll_v2d ) THEN 
     489                  igrd=3                              ! V grid 
     490                  DO ib = 1, ilen0(igrd)  
     491                     dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & 
     492                        &                      ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & 
     493                        &                        tides(ib_bdy)%v(ib,itide,2)*z_sist ) 
     494                  END DO 
     495               ENDIF 
     496            END DO              
    494497         END IF 
    495498      END DO 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/C1D/c1d.F90

    r4624 r4924  
    2727   REAL(wp), PUBLIC            ::  rn_lat1d     ! Column latitude 
    2828   REAL(wp), PUBLIC            ::  rn_lon1d     ! Column longitude 
     29   LOGICAL , PUBLIC            ::  ln_c1d_locpt ! Localization (or not) of 1D column in a grid 
    2930 
    3031   !!---------------------------------------------------------------------- 
    … …  
    4445      !!---------------------------------------------------------------------- 
    4546      INTEGER ::   ios                 ! Local integer output status for namelist read 
    46       NAMELIST/namc1d/ rn_lat1d, rn_lon1d 
     47      NAMELIST/namc1d/ rn_lat1d, rn_lon1d , ln_c1d_locpt 
    4748      !!---------------------------------------------------------------------- 
    4849      ! 
    … …  
    6364         WRITE(numout,*) '~~~~~~~~' 
    6465         WRITE(numout,*) '   Namelist namc1d : set options for the C1D model' 
    65          WRITE(numout,*) '      column latitude                 rn_lat1d = ', rn_lat1d 
    66          WRITE(numout,*) '      column longitude                rn_lon1d = ', rn_lon1d 
     66         WRITE(numout,*) '      column latitude                 rn_lat1d     = ', rn_lat1d 
     67         WRITE(numout,*) '      column longitude                rn_lon1d     = ', rn_lon1d 
     68         WRITE(numout,*) '      column localization in a grid   ln_c1d_locpt = ', ln_c1d_locpt 
    6769      ENDIF 
    6870      ! 
    … …  
    7880   LOGICAL, PUBLIC, PARAMETER ::   lk_c1d = .FALSE.   !: 1D config. flag de-activated 
    7981   REAL(wp)                   ::   rn_lat1d, rn_lon1d 
     82   LOGICAL , PUBLIC           ::   ln_c1d_locpt = .FALSE.  
     83 
    8084CONTAINS 
    8185 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/C1D/domc1d.F90

    r4245 r4924  
    4343      !! ** Action  : Recalculate jpizoom, jpjzoom (indices of C1D zoom) 
    4444      !!---------------------------------------------------------------------- 
     45      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin,   & 
     46         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,                  & 
     47         &             rn_rdtmax, rn_rdth     , nn_closea , ln_crs,    & 
     48         &             jphgr_msh, & 
     49         &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & 
     50         &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & 
     51         &             ppa2, ppkth2, ppacr2 
     52 
    4553      INTEGER  ::  ji, jj                          ! Dummy loop indices 
    4654      INTEGER  ::  inum                            ! Coordinate file handle (case 0) 
    4755      INTEGER  ::  ijeq                            ! Index of equator T point (case 4) 
     56      INTEGER  ::  ios                             ! Local integer output status for namelist read 
    4857 
    4958      INTEGER , DIMENSION(2) ::   iloc             ! Minloc returned indices 
    … …  
    6372      IF( nn_timing == 1 )   CALL timing_start('dom_c1d') 
    6473 
     74      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 
     75      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 901 ) 
     76901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist', lwp ) 
     77   
     78      ! 
     79      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 
     80      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 902 ) 
     81902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 
     82 
    6583      CALL wrk_alloc( jpidta, jpjdta, gphidta, glamdta, zdist ) 
    6684 
    … …  
    8098         CALL iom_get( inum, jpdom_unknown, 'gphit', gphidta ) ! so use jpdom_unknown not jpdom_data 
    8199         CALL iom_close ( inum ) 
    82  
    83          PRINT *,'Check dom_c1d coordinates file data read in:' !!! 
    84          PRINT *,'Bottom-left most glamdta is ', glamdta(1,1)    !!! Need to check 
    85          PRINT *,'Bottom-left most gphidta is ', gphidta(1,1)    !!! field read 
    86          PRINT *,'We are using nimpp,njmpp = ' , nimpp,njmpp     !!! 
    87100 
    88101      CASE ( 1 )                 ! geographical mesh on the sphere with regular grid-spacing 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r4724 r4924  
    1818   USE daymod 
    1919   USE tide_mod 
     20   ! 
    2021   USE in_out_manager  ! I/O units 
    2122   USE iom             ! I/0 library 
    … …  
    3435   INTEGER, PARAMETER :: jpdimsparse  = jpincomax*300*24 
    3536 
    36    !                            !!!namelist variables 
     37   !                         !!** namelist variables ** 
    3738   INTEGER ::   nit000_han    ! First time step used for harmonic analysis 
    3839   INTEGER ::   nitend_han    ! Last time step used for harmonic analysis 
    3940   INTEGER ::   nstep_han     ! Time step frequency for harmonic analysis 
    40    INTEGER ::   nb_ana           ! Number of harmonics to analyse 
     41   INTEGER ::   nb_ana        ! Number of harmonics to analyse 
    4142 
    4243   INTEGER , ALLOCATABLE, DIMENSION(:)       ::   name 
    … …  
    119120            ENDIF 
    120121         END DO 
    121       ENDDO 
     122      END DO 
    122123      ! 
    123124      IF(lwp) THEN 
    … …  
    158159      ! ---------------------------- 
    159160      ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 
    160       ana_temp(:,:,:,:) = 0.e0 
     161      ana_temp(:,:,:,:) = 0._wp 
    161162 
    162163   END SUBROUTINE dia_harm_init 
    … …  
    179180      IF( nn_timing == 1 )   CALL timing_start('dia_harm') 
    180181 
    181       IF ( kt == nit000 ) CALL dia_harm_init 
    182  
    183       IF ( ((kt.GE.nit000_han).AND.(kt.LE.nitend_han)).AND. & 
    184            (MOD(kt,nstep_han).EQ.0) ) THEN 
    185  
    186         ztime = (kt-nit000+1)*rdt  
     182      IF( kt == nit000 ) CALL dia_harm_init 
     183 
     184      IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN 
     185 
     186         ztime = (kt-nit000+1) * rdt  
    187187        
    188         nhc = 0 
    189         DO jh = 1,nb_ana 
    190           DO jc = 1,2 
    191             nhc = nhc+1 
    192             ztemp =(     MOD(jc,2) * ft(jh) *COS(ana_freq(jh)*ztime + vt(jh) + ut(jh))  & 
    193                     +(1.-MOD(jc,2))* ft(jh) *SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) 
    194  
    195             DO jj = 1,jpj 
    196               DO ji = 1,jpi 
    197                 ! Elevation 
    198                 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
     188         nhc = 0 
     189         DO jh = 1, nb_ana 
     190            DO jc = 1, 2 
     191               nhc = nhc+1 
     192               ztemp =(     MOD(jc,2) * ft(jh) *COS(ana_freq(jh)*ztime + vt(jh) + ut(jh))  & 
     193                  &    +(1.-MOD(jc,2))* ft(jh) *SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) 
     194 
     195               DO jj = 1,jpj 
     196                  DO ji = 1,jpi 
     197                     ! Elevation 
     198                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
    199199#if defined key_dynspg_ts 
    200                 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 
    201                 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 
    202 #endif 
    203               END DO 
    204             END DO 
    205  
    206           END DO 
    207         END DO 
    208         
     200                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 
     201                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 
     202#endif 
     203                  END DO 
     204               END DO 
     205               ! 
     206            END DO 
     207         END DO 
     208         !        
    209209      END IF 
    210210 
    … …  
    249249         keq = keq + 1 
    250250         kun = 0 
    251          DO jh = 1,nb_ana 
    252             DO jc = 1,2 
     251         DO jh = 1, nb_ana 
     252            DO jc = 1, 2 
    253253               kun = kun + 1 
    254254               ksp = ksp + 1 
    … …  
    296296               out_eta(ji,jj,jh       ) = X1 * tmask_i(ji,jj) 
    297297               out_eta(ji,jj,jh+nb_ana) = X2 * tmask_i(ji,jj) 
    298             ENDDO 
    299          ENDDO 
    300       ENDDO 
     298            END DO 
     299         END DO 
     300      END DO 
    301301 
    302302      ! ubar: 
    … …  
    309309                  kun = kun + 1 
    310310                  ztmp4(kun)=ana_temp(ji,jj,kun,2) 
    311                ENDDO 
    312             ENDDO 
     311               END DO 
     312            END DO 
    313313 
    314314            CALL SUR_DETERMINE(jj+1) 
    … …  
    316316            ! Fill output array 
    317317            DO jh = 1, nb_ana 
    318                ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1) 
    319                ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2) 
     318               ana_amp(ji,jj,jh,1) = ztmp7((jh-1)*2+1) 
     319               ana_amp(ji,jj,jh,2) = ztmp7((jh-1)*2+2) 
    320320            END DO 
    321321 
    … …  
    326326         DO ji = 1, jpi 
    327327            DO jh = 1, nb_ana  
    328                X1=ana_amp(ji,jj,jh,1) 
     328               X1= ana_amp(ji,jj,jh,1) 
    329329               X2=-ana_amp(ji,jj,jh,2) 
    330330               out_u(ji,jj,jh) = X1 * umask_i(ji,jj) 
    … …  
    343343                  kun = kun + 1 
    344344                  ztmp4(kun)=ana_temp(ji,jj,kun,3) 
    345                ENDDO 
    346             ENDDO 
     345               END DO 
     346            END DO 
    347347 
    348348            CALL SUR_DETERMINE(jj+1) 
    … …  
    364364               out_v(ji,jj,jh)=X1 * vmask_i(ji,jj) 
    365365               out_v(ji,jj,nb_ana+jh)=X2 * vmask_i(ji,jj) 
    366             ENDDO 
    367          ENDDO 
    368       ENDDO 
     366            END DO 
     367         END DO 
     368      END DO 
    369369 
    370370      CALL dia_wri_harm ! Write results in files 
    … …  
    437437#else 
    438438      DO jh = 1, nb_ana 
    439          CALL iom_put( TRIM(tname(jh))//'x_v', out_u(:,:,jh       ) ) 
    440          CALL iom_put( TRIM(tname(jh))//'y_v', out_u(:,:,jh+nb_ana) ) 
    441       END DO 
    442 #endif 
    443  
     439         CALL iom_put( TRIM(tname(jh))//'x_v', out_v(:,:,jh       ) ) 
     440         CALL iom_put( TRIM(tname(jh))//'y_v', out_v(:,:,jh+nb_ana) ) 
     441      END DO 
     442#endif 
     443      ! 
    444444   END SUBROUTINE dia_wri_harm 
    445445 
    446446 
    447447   SUBROUTINE SUR_DETERMINE(init) 
    448    !!--------------------------------------------------------------------------------- 
    449    !!                      *** ROUTINE SUR_DETERMINE *** 
    450    !!     
    451    !!     
    452    !!        
    453    !!--------------------------------------------------------------------------------- 
    454    INTEGER, INTENT(in) ::   init  
    455    ! 
    456    INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 
    457    REAL(wp)                        :: zval1, zval2, zx1 
    458    REAL(wp), POINTER, DIMENSION(:) :: ztmpx, zcol1, zcol2 
    459    INTEGER , POINTER, DIMENSION(:) :: ipos2, ipivot 
    460    !--------------------------------------------------------------------------------- 
    461    CALL wrk_alloc( jpincomax , ztmpx , zcol1 , zcol2 ) 
    462    CALL wrk_alloc( jpincomax , ipos2 , ipivot        ) 
     448      !!--------------------------------------------------------------------------------- 
     449      !!                      *** ROUTINE SUR_DETERMINE *** 
     450      !!     
     451      !!     
     452      !!        
     453      !!--------------------------------------------------------------------------------- 
     454      INTEGER, INTENT(in) ::   init  
     455      ! 
     456      INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 
     457      REAL(wp)                        :: zval1, zval2, zx1 
     458      REAL(wp), POINTER, DIMENSION(:) :: ztmpx, zcol1, zcol2 
     459      INTEGER , POINTER, DIMENSION(:) :: ipos2, ipivot 
     460      !--------------------------------------------------------------------------------- 
     461      CALL wrk_alloc( jpincomax , ztmpx , zcol1 , zcol2 ) 
     462      CALL wrk_alloc( jpincomax , ipos2 , ipivot        ) 
    463463             
    464    IF( init == 1 ) THEN 
    465       IF( nsparse > jpdimsparse )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 
    466       IF( ninco   > jpincomax   )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 
    467       ! 
    468       ztmp3(:,:) = 0._wp 
    469       ! 
    470       DO jk1_sd = 1, nsparse 
    471          DO jk2_sd = 1, nsparse 
    472             nisparse(jk2_sd) = nisparse(jk2_sd) 
    473             njsparse(jk2_sd) = njsparse(jk2_sd) 
    474             IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 
    475                ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  & 
    476                                                         + valuesparse(jk1_sd)*valuesparse(jk2_sd) 
    477             ENDIF 
    478          END DO 
    479       END DO 
    480  
    481       DO jj_sd = 1 ,ninco 
    482           ipos1(jj_sd) = jj_sd 
    483           ipos2(jj_sd) = jj_sd 
    484       ENDDO 
    485  
    486       DO ji_sd = 1 , ninco 
    487  
    488          !find greatest non-zero pivot: 
    489          zval1 = ABS(ztmp3(ji_sd,ji_sd)) 
    490  
    491          ipivot(ji_sd) = ji_sd 
    492          DO jj_sd = ji_sd, ninco 
    493             zval2 = ABS(ztmp3(ji_sd,jj_sd)) 
    494             IF( zval2.GE.zval1 )THEN 
    495                ipivot(ji_sd) = jj_sd 
    496                zval1         = zval2 
    497             ENDIF 
    498          ENDDO 
    499  
    500          DO ji1_sd = 1, ninco 
    501             zcol1(ji1_sd)               = ztmp3(ji1_sd,ji_sd) 
    502             zcol2(ji1_sd)               = ztmp3(ji1_sd,ipivot(ji_sd)) 
    503             ztmp3(ji1_sd,ji_sd)         = zcol2(ji1_sd) 
    504             ztmp3(ji1_sd,ipivot(ji_sd)) = zcol1(ji1_sd) 
    505          ENDDO 
    506  
    507          ipos2(ji_sd)         = ipos1(ipivot(ji_sd)) 
    508          ipos2(ipivot(ji_sd)) = ipos1(ji_sd) 
    509          ipos1(ji_sd)         = ipos2(ji_sd) 
    510          ipos1(ipivot(ji_sd)) = ipos2(ipivot(ji_sd)) 
    511          zpivot(ji_sd)        = ztmp3(ji_sd,ji_sd) 
    512          DO jj_sd = 1, ninco 
    513             ztmp3(ji_sd,jj_sd) = ztmp3(ji_sd,jj_sd) / zpivot(ji_sd) 
    514          ENDDO 
    515  
     464      IF( init == 1 ) THEN 
     465         IF( nsparse > jpdimsparse )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 
     466         IF( ninco   > jpincomax   )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 
     467         ! 
     468         ztmp3(:,:) = 0._wp 
     469         ! 
     470         DO jk1_sd = 1, nsparse 
     471            DO jk2_sd = 1, nsparse 
     472               nisparse(jk2_sd) = nisparse(jk2_sd) 
     473               njsparse(jk2_sd) = njsparse(jk2_sd) 
     474               IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 
     475                  ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  & 
     476                     &                                     + valuesparse(jk1_sd)*valuesparse(jk2_sd) 
     477               ENDIF 
     478            END DO 
     479         END DO 
     480         ! 
     481         DO jj_sd = 1 ,ninco 
     482            ipos1(jj_sd) = jj_sd 
     483            ipos2(jj_sd) = jj_sd 
     484         END DO 
     485         ! 
     486         DO ji_sd = 1 , ninco 
     487            ! 
     488            !find greatest non-zero pivot: 
     489            zval1 = ABS(ztmp3(ji_sd,ji_sd)) 
     490            ! 
     491            ipivot(ji_sd) = ji_sd 
     492            DO jj_sd = ji_sd, ninco 
     493               zval2 = ABS(ztmp3(ji_sd,jj_sd)) 
     494               IF( zval2.GE.zval1 )THEN 
     495                  ipivot(ji_sd) = jj_sd 
     496                  zval1         = zval2 
     497               ENDIF 
     498            END DO 
     499            ! 
     500            DO ji1_sd = 1, ninco 
     501               zcol1(ji1_sd)               = ztmp3(ji1_sd,ji_sd) 
     502               zcol2(ji1_sd)               = ztmp3(ji1_sd,ipivot(ji_sd)) 
     503               ztmp3(ji1_sd,ji_sd)         = zcol2(ji1_sd) 
     504               ztmp3(ji1_sd,ipivot(ji_sd)) = zcol1(ji1_sd) 
     505            END DO 
     506            ! 
     507            ipos2(ji_sd)         = ipos1(ipivot(ji_sd)) 
     508            ipos2(ipivot(ji_sd)) = ipos1(ji_sd) 
     509            ipos1(ji_sd)         = ipos2(ji_sd) 
     510            ipos1(ipivot(ji_sd)) = ipos2(ipivot(ji_sd)) 
     511            zpivot(ji_sd)        = ztmp3(ji_sd,ji_sd) 
     512            DO jj_sd = 1, ninco 
     513               ztmp3(ji_sd,jj_sd) = ztmp3(ji_sd,jj_sd) / zpivot(ji_sd) 
     514            END DO 
     515            ! 
     516            DO ji2_sd = ji_sd+1, ninco 
     517               zpilier(ji2_sd,ji_sd)=ztmp3(ji2_sd,ji_sd) 
     518               DO jj_sd=1,ninco 
     519                  ztmp3(ji2_sd,jj_sd)=  ztmp3(ji2_sd,jj_sd) - ztmp3(ji_sd,jj_sd) * zpilier(ji2_sd,ji_sd) 
     520               END DO 
     521            END DO 
     522            ! 
     523         END DO 
     524         ! 
     525      ENDIF ! End init==1 
     526 
     527      DO ji_sd = 1, ninco 
     528         ztmp4(ji_sd) = ztmp4(ji_sd) / zpivot(ji_sd) 
    516529         DO ji2_sd = ji_sd+1, ninco 
    517             zpilier(ji2_sd,ji_sd)=ztmp3(ji2_sd,ji_sd) 
    518             DO jj_sd=1,ninco 
    519                ztmp3(ji2_sd,jj_sd)=  ztmp3(ji2_sd,jj_sd) - ztmp3(ji_sd,jj_sd) * zpilier(ji2_sd,ji_sd) 
    520             ENDDO 
    521          ENDDO 
    522  
    523       ENDDO 
    524  
    525    ENDIF ! End init==1 
    526  
    527    DO ji_sd = 1, ninco 
    528       ztmp4(ji_sd) = ztmp4(ji_sd) / zpivot(ji_sd) 
    529       DO ji2_sd = ji_sd+1, ninco 
    530          ztmp4(ji2_sd) = ztmp4(ji2_sd) - ztmp4(ji_sd) * zpilier(ji2_sd,ji_sd) 
    531       ENDDO 
    532    ENDDO 
    533  
    534    !system solving:  
    535    ztmpx(ninco) = ztmp4(ninco) / ztmp3(ninco,ninco) 
    536    ji_sd = ninco 
    537    DO ji_sd = ninco-1, 1, -1 
    538       zx1=0. 
    539       DO jj_sd = ji_sd+1, ninco 
    540          zx1 = zx1 + ztmpx(jj_sd) * ztmp3(ji_sd,jj_sd) 
    541       ENDDO 
    542       ztmpx(ji_sd) = ztmp4(ji_sd)-zx1 
    543    ENDDO 
    544  
    545    DO jj_sd =1, ninco 
    546       ztmp7(ipos1(jj_sd))=ztmpx(jj_sd) 
    547    ENDDO 
    548  
    549    CALL wrk_dealloc( jpincomax , ztmpx , zcol1 , zcol2 ) 
    550    CALL wrk_dealloc( jpincomax , ipos2 , ipivot        ) 
    551  
    552   END SUBROUTINE SUR_DETERMINE 
     530            ztmp4(ji2_sd) = ztmp4(ji2_sd) - ztmp4(ji_sd) * zpilier(ji2_sd,ji_sd) 
     531         END DO 
     532      END DO 
     533 
     534      !system solving:  
     535      ztmpx(ninco) = ztmp4(ninco) / ztmp3(ninco,ninco) 
     536      ji_sd = ninco 
     537      DO ji_sd = ninco-1, 1, -1 
     538         zx1 = 0._wp 
     539         DO jj_sd = ji_sd+1, ninco 
     540            zx1 = zx1 + ztmpx(jj_sd) * ztmp3(ji_sd,jj_sd) 
     541         END DO 
     542         ztmpx(ji_sd) = ztmp4(ji_sd)-zx1 
     543      END DO 
     544 
     545      DO jj_sd =1, ninco 
     546         ztmp7(ipos1(jj_sd))=ztmpx(jj_sd) 
     547      END DO 
     548 
     549      CALL wrk_dealloc( jpincomax , ztmpx , zcol1 , zcol2 ) 
     550      CALL wrk_dealloc( jpincomax , ipos2 , ipivot        ) 
     551      ! 
     552   END SUBROUTINE SUR_DETERMINE 
    553553 
    554554#else 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r4747 r4924  
    4545   USE diadimg         ! dimg direct access file format output 
    4646   USE diaar5, ONLY :   lk_diaar5 
    47    USE dynadv, ONLY :   ln_dynadv_vec 
    4847   USE iom 
    4948   USE ioipsl 
    … …  
    131130      REAL(wp)                     ::   zztmp, zztmpx, zztmpy   !  
    132131      !! 
    133       REAL(wp), POINTER, DIMENSION(:,:)   :: z2d       ! 2D workspace 
     132      REAL(wp), POINTER, DIMENSION(:,:)   :: z2d      ! 2D workspace 
     133      REAL(wp), POINTER, DIMENSION(:,:)   :: z2ds     ! 2D workspace 
    134134      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d      ! 3D workspace 
    135135      !!---------------------------------------------------------------------- 
    … …  
    137137      IF( nn_timing == 1 )   CALL timing_start('dia_wri') 
    138138      !  
    139       CALL wrk_alloc( jpi , jpj      , z2d ) 
     139      CALL wrk_alloc( jpi , jpj      , z2d , z2ds ) 
    140140      CALL wrk_alloc( jpi , jpj, jpk , z3d ) 
    141141      ! 
    … …  
    234234      CALL iom_put( "sstgrad" ,  z2d               )    ! module of sst gradient 
    235235 
     236      ! clem: heat and salt content 
     237      z2d(:,:)  = 0._wp  
     238      z2ds(:,:) = 0._wp  
     239      DO jk = 1, jpkm1 
     240         DO jj = 2, jpjm1 
     241            DO ji = fs_2, fs_jpim1   ! vector opt. 
     242               z2d(ji,jj) = z2d(ji,jj) + rau0 * rcp * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
     243               z2ds(ji,jj) = z2ds(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
     244            END DO 
     245         END DO 
     246      END DO 
     247      CALL lbc_lnk( z2d, 'T', 1. ) 
     248      CALL lbc_lnk( z2ds, 'T', 1. ) 
     249      CALL iom_put( "heatc", z2d )    ! vertically integrated heat content (J/m2) 
     250      CALL iom_put( "saltc", z2ds )   ! vertically integrated salt content (PSU*kg/m2) 
     251   
     252      ! 
     253      rke(:,:,jk) = 0._wp                               !      kinetic energy  
     254      DO jk = 1, jpkm1 
     255         DO jj = 2, jpjm1 
     256            DO ji = fs_2, fs_jpim1   ! vector opt. 
     257               zztmp   = 1._wp / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     258               zztmpx  = 0.5 * (  un(ji-1,jj,jk) * un(ji-1,jj,jk) * e2u(ji-1,jj) * fse3u(ji-1,jj,jk)    & 
     259                  &             + un(ji  ,jj,jk) * un(ji  ,jj,jk) * e2u(ji  ,jj) * fse3u(ji  ,jj,jk) )  & 
     260                  &          *  zztmp  
     261               ! 
     262               zztmpy  = 0.5 * (  vn(ji,jj-1,jk) * vn(ji,jj-1,jk) * e1v(ji,jj-1) * fse3v(ji,jj-1,jk)    & 
     263                  &             + vn(ji,jj  ,jk) * vn(ji,jj  ,jk) * e1v(ji,jj  ) * fse3v(ji,jj  ,jk) )  & 
     264                  &          *  zztmp  
     265               ! 
     266               rke(ji,jj,jk) = 0.5_wp * ( zztmpx + zztmpy ) 
     267               ! 
     268            ENDDO 
     269         ENDDO 
     270      ENDDO 
     271      CALL lbc_lnk( rke, 'T', 1. ) 
     272      CALL iom_put( "eken", rke )            
     273 
    236274      IF( lk_diaar5 ) THEN 
    237275         z3d(:,:,jpk) = 0.e0 
    238276         DO jk = 1, jpkm1 
    239             z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) 
     277            z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 
    240278         END DO 
    241279         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
     280 
    242281         zztmp = 0.5 * rcp 
    243282         z2d(:,:) = 0.e0  
     283         z2ds(:,:) = 0.e0  
    244284         DO jk = 1, jpkm1 
    245285            DO jj = 2, jpjm1 
    246286               DO ji = fs_2, fs_jpim1   ! vector opt. 
    247287                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * zztmp * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
     288                  z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
    248289               END DO 
    249290            END DO 
    250291         END DO 
    251292         CALL lbc_lnk( z2d, 'U', -1. ) 
     293         CALL lbc_lnk( z2ds, 'U', -1. ) 
    252294         CALL iom_put( "u_heattr", z2d )                  ! heat transport in i-direction 
     295         CALL iom_put( "u_salttr", z2ds )                 ! salt transport in i-direction 
     296 
     297         z3d(:,:,jpk) = 0.e0 
    253298         DO jk = 1, jpkm1 
    254             z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) 
     299            z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) 
    255300         END DO 
    256301         CALL iom_put( "v_masstr", z3d )                  ! mass transport in j-direction 
     302 
    257303         z2d(:,:) = 0.e0  
     304         z2ds(:,:) = 0.e0  
    258305         DO jk = 1, jpkm1 
    259306            DO jj = 2, jpjm1 
    260307               DO ji = fs_2, fs_jpim1   ! vector opt. 
    261308                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * zztmp * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
     309                  z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
    262310               END DO 
    263311            END DO 
    264312         END DO 
    265313         CALL lbc_lnk( z2d, 'V', -1. ) 
    266          CALL iom_put( "v_heattr", z2d )                  !  heat transport in i-direction 
    267       ENDIF 
    268       ! 
    269       CALL wrk_dealloc( jpi , jpj      , z2d ) 
     314         CALL lbc_lnk( z2ds, 'V', -1. ) 
     315         CALL iom_put( "v_heattr", z2d )                  !  heat transport in j-direction 
     316         CALL iom_put( "v_salttr", z2ds )                 !  salt transport in j-direction 
     317      ENDIF 
     318      ! 
     319      CALL wrk_dealloc( jpi , jpj      , z2d , z2ds ) 
    270320      CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 
    271321      ! 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r4747 r4924  
    153153   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nldit , nldjt    !: first, last indoor index for each i-domain 
    154154   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nleit , nlejt    !: first, last indoor index for each j-domain 
     155   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit 
    155156 
    156157   !!---------------------------------------------------------------------- 
    … …  
    335336      ierr(:) = 0 
    336337      ! 
    337       ALLOCATE( rdttra(jpk), r2dtra(jpk), mig(jpi), mjg(jpj), STAT=ierr(1) ) 
     338      ALLOCATE( rdttra(jpk), r2dtra(jpk), mig(jpi), mjg(jpj), nfiimpp(jpni,jpnj),  & 
     339         &      nfipproc(jpni,jpnj), nfilcit(jpni,jpnj), STAT=ierr(1) ) 
    338340         ! 
    339341      ALLOCATE( nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) ,     & 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DOM/domcfg.F90

    r4245 r4924  
    8282      !!---------------------------------------------------------------------- 
    8383      !                              ! recalculate jpizoom/jpjzoom given lat/lon 
    84       IF( lk_c1d )  CALL dom_c1d( rn_lat1d, rn_lon1d ) 
     84      IF( lk_c1d .AND. ln_c1d_locpt )  CALL dom_c1d( rn_lat1d, rn_lon1d ) 
    8585      ! 
    8686      !                        ! ============== ! 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r4747 r4924  
    842842            id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 
    843843            id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 
    844             id5 = iom_varid( numror, 'hdif_lf', ldstop = .FALSE. ) 
     844            id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. ) 
    845845            !                             ! --------- ! 
    846846            !                             ! all cases ! 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r4747 r4924  
    20622062            DO jk = 1, jpkm1 
    20632063               IF( scobot(ji,jj) >= fsdept(ji,jj,jk) )   mbathy(ji,jj) = MAX( 2, jk ) 
    2064                IF( scobot(ji,jj) == 0._wp            )   mbathy(ji,jj) = 0 
    2065             END DO 
     2064            END DO 
     2065            IF( scobot(ji,jj) == 0._wp               )   mbathy(ji,jj) = 0 
    20662066         END DO 
    20672067      END DO 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90

    r4666 r4924  
    5050   REAL(wp), PUBLIC ::   rau0     = 1026._wp         !: volumic mass of reference     [kg/m3] 
    5151#else 
    52    REAL(wp), PUBLIC ::   rau0     = 1028.4_wp       !: volumic mass of reference     [kg/m3] 
     52   REAL(wp), PUBLIC ::   rau0     = 1035._wp         !: volumic mass of reference     [kg/m3] 
    5353#endif 
    5454   REAL(wp), PUBLIC ::   r1_rau0                     !: = 1. / rau0                   [m3/kg] 
    5555   REAL(wp), PUBLIC ::   rauw     = 1000._wp         !: volumic mass of pure water    [m3/kg] 
    56    REAL(wp), PUBLIC ::   rcp      =    4.e3_wp       !: ocean specific heat           [J/Kelvin] 
    57    REAL(wp), PUBLIC ::   r1_rcp                      !: = 1. / rcp                    [Kelvin/J] 
     56   REAL(wp), PUBLIC ::   rcp      =    4.e3_wp       !: ocean specific heat           [J/kg/K] 
     57   REAL(wp), PUBLIC ::   r1_rcp                      !: = 1. / rcp                    [kg.K/J] 
    5858   REAL(wp), PUBLIC ::   r1_rau0_rcp                 !: = 1. / ( rau0 * rcp ) 
    5959 
    … …  
    6969#if defined key_lim3 || defined key_cice 
    7070   REAL(wp), PUBLIC ::   rhoic    =  917._wp         !: volumic mass of sea ice                               [kg/m3] 
    71    REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: thermal conductivity of fresh ice 
    72    REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow 
    73    REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat for ice  
     71   REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: thermal conductivity of fresh ice                     [W/m/K] 
     72   REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow                          [W/m/K]  
     73   REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat for ice                                 [J/kg/K] 
    7474   REAL(wp), PUBLIC ::   lsub     =    2.834e+6_wp   !: pure ice latent heat of sublimation                   [J/kg] 
    7575   REAL(wp), PUBLIC ::   lfus     =    0.334e+6_wp   !: latent heat of fusion of fresh ice                    [J/kg] 
    76    REAL(wp), PUBLIC ::   tmut     =    0.054_wp      !: decrease of seawater meltpoint with salinity 
     76   REAL(wp), PUBLIC ::   tmut     =    0.054_wp      !: decrease of seawater meltpoint with salinity          [degC/ppt] 
    7777   REAL(wp), PUBLIC ::   xlsn                        !: = lfus*rhosn (volumetric latent heat fusion of snow)  [J/m3] 
    7878#else 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r4624 r4924  
    4444   USE agrif_opa_interp ! agrif 
    4545#endif 
    46  
     46#if defined key_asminc    
     47   USE asminc          ! Assimilation increment 
     48#endif 
    4749 
    4850   IMPLICIT NONE 
    … …  
    290292      ! 
    291293      DO jk = 1, jpkm1 
    292 #if defined key_vectopt_loop 
    293          DO jj = 1, 1         !Vector opt. => forced unrolling 
    294             DO ji = 1, jpij 
    295 #else  
    296          DO jj = 1, jpj 
    297             DO ji = 1, jpi 
    298 #endif                                                                    
    299                zu_frc(ji,jj) = zu_frc(ji,jj) + fse3u_n(ji,jj,jk) * ua(ji,jj,jk) * umask(ji,jj,jk) 
    300                zv_frc(ji,jj) = zv_frc(ji,jj) + fse3v_n(ji,jj,jk) * va(ji,jj,jk) * vmask(ji,jj,jk)          
    301             END DO 
    302          END DO 
     294         zu_frc(:,:) = zu_frc(:,:) + fse3u_n(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 
     295         zv_frc(:,:) = zv_frc(:,:) + fse3v_n(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)          
    303296      END DO 
    304297      ! 
    … …  
    464457      !                                             ! ==================== !   
    465458      ! Initialize barotropic variables:       
     459      IF( ll_init )THEN 
     460         sshbb_e(:,:) = 0._wp 
     461         ubb_e  (:,:) = 0._wp 
     462         vbb_e  (:,:) = 0._wp 
     463         sshb_e (:,:) = 0._wp 
     464         ub_e   (:,:) = 0._wp 
     465         vb_e   (:,:) = 0._wp 
     466      ENDIF 
     467      ! 
    466468      IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                     
    467469         sshn_e(:,:) = sshn (:,:)             

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r4650 r4924  
    3232   USE trc_oce, ONLY :   nn_dttrc        !  !: frequency of step on passive tracers 
    3333   USE icb_oce, ONLY :   nclasses, class_num       !  !: iceberg classes 
     34#if defined key_lim3 
     35   USE par_ice 
     36#elif defined key_lim2 
     37   USE par_ice_2 
     38#endif 
    3439   USE domngb          ! ocean space and time domain 
    3540   USE phycst          ! physical constants 
    … …  
    4954#endif 
    5055   PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_gettime, iom_rstput, iom_put 
    51    PUBLIC iom_getatt, iom_context_finalize 
     56   PUBLIC iom_getatt, iom_use, iom_context_finalize 
    5257 
    5358   PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 
    … …  
    143148      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 
    144149# endif 
     150#if defined key_lim3 || defined key_lim2 
     151      CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
     152#endif 
    145153      CALL iom_set_axis_attr( "icbcla", class_num ) 
    146154       
    … …  
    10151023      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    10161024      REAL(wp)        , INTENT(in) ::   pfield0d 
     1025      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    10171026#if defined key_iomput 
    1018       CALL xios_send_field(cdname, (/pfield0d/)) 
     1027      zz(:,:)=pfield0d 
     1028      CALL xios_send_field(cdname, zz) 
     1029      !CALL xios_send_field(cdname, (/pfield0d/))  
    10191030#else 
    10201031      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    … …  
    12071218      !! 
    12081219      !!---------------------------------------------------------------------- 
    1209       REAL(wp), DIMENSION(1,1) ::   zz = 1. 
     1220      REAL(wp), DIMENSION(1) ::   zz = 1. 
    12101221      !!---------------------------------------------------------------------- 
    12111222      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
    1212       CALL iom_set_domain_attr('scalarpoint', data_dim=1) 
    1213       CALL iom_set_domain_attr('scalarpoint', lonvalue=(/ zz /), latvalue=(/ zz /)) 
     1223      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
     1224      zz=REAL(narea,wp) 
     1225      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    12141226 
    12151227   END SUBROUTINE set_scalar 
    … …  
    14991511 
    15001512#endif 
     1513 
     1514   LOGICAL FUNCTION iom_use( cdname ) 
     1515      CHARACTER(LEN=*), INTENT(in) ::   cdname 
     1516#if defined key_iomput 
     1517      iom_use = xios_field_is_active( cdname ) 
     1518#else 
     1519      iom_use = .FALSE. 
     1520#endif 
     1521   END FUNCTION iom_use 
    15011522    
    15021523   !!====================================================================== 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r4292 r4924  
    217217         CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, dimids = idimid(1:i_nvd)), clinfo)   ! dimensions ids 
    218218         iom_file(kiomid)%luld(kiv) = .FALSE.   ! default value 
    219          iom_file(kiomid)%dimsz(:,kiv) = 0   ! reset dimsz in case previously used 
     219         iom_file(kiomid)%dimsz(:,kiv) = 0      ! reset dimsz in case previously used 
    220220         DO ji = 1, i_nvd                       ! dimensions size 
    221221            CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, idimid(ji), len = iom_file(kiomid)%dimsz(ji,kiv)), clinfo)    

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r4747 r4924  
    126126                     CALL iom_rstput( kt, nitrst, numrow, 'fsdepw ', fsdepw (:,:,:) ) 
    127127      END IF 
     128      IF( lk_lim3 .AND. .NOT. lk_vvl )  CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    128129                     ! 
    129130                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un        )     ! now fields 
    … …  
    216217         CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    217218         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
     219         IF( lk_lim3 )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    218220      ELSE 
    219221         neuler = 0 
    … …  
    251253         hdivb(:,:,:)   = hdivn(:,:,:) 
    252254         sshb (:,:)     = sshn (:,:) 
     255 
    253256         IF( lk_vvl ) THEN 
    254257            DO jk = 1, jpk 
    … …  
    256259            END DO 
    257260         ENDIF 
    258       ENDIF 
    259       ! 
    260       IF( lk_lim3 ) THEN  
     261 
     262         IF( lk_lim3 .AND. .NOT. lk_vvl ) THEN 
     263            DO jk = 1, jpk 
     264               fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
     265            END DO 
     266         ENDIF 
     267 
     268      ENDIF 
     269      ! 
     270      IF( lk_lim3 ) THEN 
    261271         CALL iom_get( numror, jpdom_autoglo, 'iatte' , iatte ) ! clem modif 
    262272         CALL iom_get( numror, jpdom_autoglo, 'oatte' , oatte ) ! clem modif 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r4230 r4924  
    3333 
    3434   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 3 
    35    INTEGER, PUBLIC                                  ::   nsndto 
     35   INTEGER, PUBLIC                                  ::   nsndto, nfsloop, nfeloop 
    3636   INTEGER, PUBLIC,  DIMENSION (jpmaxngh)           ::   isendto ! processes to which communicate 
    3737 
    … …  
    412412            SELECT CASE ( cd_type ) 
    413413            CASE ( 'T' , 'W' )                         ! T-, W-point 
    414                IF (narea .ne. (jpnij - jpni + 1)) THEN 
     414               IF (nimpp .ne. 1) THEN 
    415415                 startloop = 1 
    416416               ELSE 
    … …  
    420420               DO jk = 1, jpk 
    421421                  DO ji = startloop, nlci 
    422                      ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     422                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    423423                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    424424                  END DO 
     425                  IF(nimpp .eq. 1) THEN 
     426                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 
     427                  ENDIF 
    425428               END DO 
    426429 
    … …  
    435438                 DO jk = 1, jpk 
    436439                    DO ji = startloop, nlci 
    437                        ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     440                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    438441                       jia = ji + nimpp - 1 
    439442                       ijta = jpiglo - jia + 2 
    … …  
    448451 
    449452 
    450  
    451453            CASE ( 'U' )                               ! U-point 
    452                IF (narea .ne. (jpnij)) THEN 
     454               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    453455                  endloop = nlci 
    454456               ELSE 
    … …  
    457459               DO jk = 1, jpk 
    458460                  DO ji = 1, endloop 
    459                      iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     461                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    460462                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    461463                  END DO 
    462                END DO 
    463  
    464                IF (narea .ne. (jpnij)) THEN 
     464                  IF(nimpp .eq. 1) THEN 
     465                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk) 
     466                  ENDIF 
     467                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     468                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 
     469                  ENDIF 
     470               END DO 
     471 
     472               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    465473                  endloop = nlci 
    466474               ELSE 
    … …  
    477485                 DO jk = 1, jpk 
    478486                    DO ji = startloop, endloop 
    479                       iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     487                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    480488                      jia = ji + nimpp - 1 
    481489                      ijua = jpiglo - jia + 1 
    … …  
    490498 
    491499            CASE ( 'V' )                               ! V-point 
    492                IF (narea .ne. (jpnij - jpni + 1)) THEN 
     500               IF (nimpp .ne. 1) THEN 
    493501                  startloop = 1 
    494502               ELSE 
    … …  
    497505               DO jk = 1, jpk 
    498506                  DO ji = startloop, nlci 
    499                      ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     507                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    500508                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    501509                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
    502510                  END DO 
     511                  IF(nimpp .eq. 1) THEN 
     512                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 
     513                  ENDIF 
    503514               END DO 
    504515            CASE ( 'F' )                               ! F-point 
    505                IF (narea .ne. (jpnij)) THEN 
     516               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    506517                  endloop = nlci 
    507518               ELSE 
    … …  
    510521               DO jk = 1, jpk 
    511522                  DO ji = 1, endloop 
    512                      iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     523                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    513524                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    514525                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
    515526                  END DO 
     527                  IF(nimpp .eq. 1) THEN 
     528                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk) 
     529                  ENDIF 
     530                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     531                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 
     532                  ENDIF 
    516533               END DO 
    517534            END SELECT 
    … …  
    524541               DO jk = 1, jpk 
    525542                  DO ji = 1, nlci 
    526                      ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     543                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    527544                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
    528545                  END DO 
    … …  
    530547 
    531548            CASE ( 'U' )                               ! U-point 
    532                IF (narea .ne. (jpnij)) THEN 
     549               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    533550                  endloop = nlci 
    534551               ELSE 
    … …  
    537554               DO jk = 1, jpk 
    538555                  DO ji = 1, endloop 
    539                      iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     556                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    540557                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
    541558                  END DO 
     559                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     560                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 
     561                  ENDIF 
    542562               END DO 
    543563 
    … …  
    545565               DO jk = 1, jpk 
    546566                  DO ji = 1, nlci 
    547                      ijt = jpiglo - ji- nimpp - nimppt(isendto(1)) + 3 
     567                     ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
    548568                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    549569                  END DO 
    … …  
    560580                 DO jk = 1, jpk 
    561581                    DO ji = startloop, nlci 
    562                        ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     582                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    563583                       pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    564584                    END DO 
    … …  
    567587 
    568588            CASE ( 'F' )                               ! F-point 
    569                IF (narea .ne. (jpnij)) THEN 
     589               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    570590                  endloop = nlci 
    571591               ELSE 
    … …  
    574594               DO jk = 1, jpk 
    575595                  DO ji = 1, endloop 
    576                      iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     596                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    577597                     pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    578598                  END DO 
    579                END DO 
    580  
    581                IF (narea .ne. (jpnij)) THEN 
     599                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     600                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 
     601                  ENDIF 
     602               END DO 
     603 
     604               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    582605                  endloop = nlci 
    583606               ELSE 
    … …  
    594617                  DO jk = 1, jpk 
    595618                     DO ji = startloop, endloop 
    596                         iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     619                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    597620                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    598621                     END DO 
    … …  
    656679         ! 
    657680         CASE ( 'T' , 'W' )                               ! T- , W-points 
    658             IF (narea .ne. (jpnij - jpni + 1)) THEN 
     681            IF (nimpp .ne. 1) THEN 
    659682              startloop = 1 
    660683            ELSE 
    … …  
    662685            ENDIF 
    663686            DO ji = startloop, nlci 
    664               ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     687              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    665688              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    666689            END DO 
     690            IF (nimpp .eq. 1) THEN 
     691              pt2dl(1,ijpj)   = psgn * pt2dl(3,ijpj-2) 
     692            ENDIF 
    667693 
    668694            IF(nimpp .ge. (jpiglo/2+1)) THEN 
    … …  
    674700            ENDIF 
    675701            DO ji = startloop, nlci 
    676                ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     702               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    677703               jia = ji + nimpp - 1 
    678704               ijta = jpiglo - jia + 2 
    … …  
    685711 
    686712         CASE ( 'U' )                                     ! U-point 
    687             IF (narea .ne. (jpnij)) THEN 
     713            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    688714               endloop = nlci 
    689715            ELSE 
    … …  
    691717            ENDIF 
    692718            DO ji = 1, endloop 
    693                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     719               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    694720               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    695721            END DO 
    696722 
    697             IF (narea .ne. (jpnij)) THEN 
     723            IF (nimpp .eq. 1) THEN 
     724              pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
     725              pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 
     726            ENDIF 
     727            IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     728              pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
     729            ENDIF 
     730 
     731            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    698732               endloop = nlci 
    699733            ELSE 
    … …  
    708742            ENDIF 
    709743            DO ji = startloop, endloop 
    710                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     744               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    711745               jia = ji + nimpp - 1 
    712746               ijua = jpiglo - jia + 1 
    … …  
    719753 
    720754         CASE ( 'V' )                                     ! V-point 
    721             IF (narea .ne. (jpnij - jpni + 1)) THEN 
     755            IF (nimpp .ne. 1) THEN 
    722756              startloop = 1 
    723757            ELSE 
    … …  
    725759            ENDIF 
    726760            DO ji = startloop, nlci 
    727               ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     761              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    728762              pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
    729763              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
    730764            END DO 
     765            IF (nimpp .eq. 1) THEN 
     766              pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
     767            ENDIF 
    731768 
    732769         CASE ( 'F' )                                     ! F-point 
    733             IF (narea .ne. (jpnij)) THEN 
     770            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    734771               endloop = nlci 
    735772            ELSE 
    … …  
    737774            ENDIF 
    738775            DO ji = 1, endloop 
    739                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     776               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    740777               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
    741778               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
    742779            END DO 
     780            IF (nimpp .eq. 1) THEN 
     781              pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3) 
     782              pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2) 
     783            ENDIF 
     784            IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     785              pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3) 
     786              pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
     787            ENDIF 
    743788 
    744789         CASE ( 'I' )                                     ! ice U-V point (I-point) 
    745             IF (narea .ne. (jpnij - jpni + 1)) THEN 
     790            IF (nimpp .ne. 1) THEN 
    746791               startloop = 1 
    747792            ELSE 
    … …  
    750795            ENDIF 
    751796            DO ji = startloop, nlci 
    752                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     797               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    753798               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    754799            END DO 
    755800 
    756801         CASE ( 'J' )                                     ! first ice U-V point 
    757             IF (narea .ne. (jpnij - jpni + 1)) THEN 
     802            IF (nimpp .ne. 1) THEN 
    758803               startloop = 1 
    759804            ELSE 
    … …  
    762807            ENDIF 
    763808            DO ji = startloop, nlci 
    764                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     809               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    765810               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    766811            END DO 
    767812 
    768813         CASE ( 'K' )                                     ! second ice U-V point 
    769             IF (narea .ne. (jpnij - jpni + 1)) THEN 
     814            IF (nimpp .ne. 1) THEN 
    770815               startloop = 1 
    771816            ELSE 
    … …  
    774819            ENDIF 
    775820            DO ji = startloop, nlci 
    776                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     821               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    777822               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    778823            END DO 
    … …  
    785830         CASE ( 'T' , 'W' )                               ! T-, W-point 
    786831            DO ji = 1, nlci 
    787                ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     832               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    788833               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    789834            END DO 
    790835 
    791836         CASE ( 'U' )                                     ! U-point 
    792             IF (narea .ne. (jpnij)) THEN 
     837            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    793838               endloop = nlci 
    794839            ELSE 
    … …  
    796841            ENDIF 
    797842            DO ji = 1, endloop 
    798                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     843               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    799844               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    800845            END DO 
     846            IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     847               pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
     848            ENDIF 
    801849 
    802850         CASE ( 'V' )                                     ! V-point 
    803851            DO ji = 1, nlci 
    804                ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     852               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    805853               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    806854            END DO 
    … …  
    813861            ENDIF 
    814862            DO ji = startloop, nlci 
    815                ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     863               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    816864               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    817865            END DO 
    818866 
    819867         CASE ( 'F' )                               ! F-point 
    820             IF (narea .ne. (jpnij)) THEN 
     868            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    821869               endloop = nlci 
    822870            ELSE 
    … …  
    824872            ENDIF 
    825873            DO ji = 1, endloop 
    826                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     874               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    827875               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    828876            END DO 
    829  
    830             IF (narea .ne. (jpnij)) THEN 
     877            IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
     878                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
     879            ENDIF 
     880 
     881            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    831882               endloop = nlci 
    832883            ELSE 
    … …  
    842893 
    843894            DO ji = startloop, endloop 
    844                iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     895               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    845896               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    846897            END DO 
    847898 
    848899         CASE ( 'I' )                                  ! ice U-V point (I-point) 
    849                IF (narea .ne. (jpnij - jpni + 1)) THEN 
     900               IF (nimpp .ne. 1) THEN 
    850901                  startloop = 1 
    851902               ELSE 
    852903                  startloop = 2 
    853904               ENDIF 
    854                IF (narea .ne. jpnij) THEN 
     905               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    855906                  endloop = nlci 
    856907               ELSE 
    … …  
    858909               ENDIF 
    859910               DO ji = startloop , endloop 
    860                   ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     911                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    861912                  pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    862913               END DO 
    863914 
    864915         CASE ( 'J' )                                  ! first ice U-V point 
    865                IF (narea .ne. (jpnij - jpni + 1)) THEN 
     916               IF (nimpp .ne. 1) THEN 
    866917                  startloop = 1 
    867918               ELSE 
    868919                  startloop = 2 
    869920               ENDIF 
    870                IF (narea .ne. jpnij) THEN 
     921               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    871922                  endloop = nlci 
    872923               ELSE 
    … …  
    874925               ENDIF 
    875926               DO ji = startloop , endloop 
    876                   ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     927                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    877928                  pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 
    878929               END DO 
    879930 
    880931         CASE ( 'K' )                                  ! second ice U-V point 
    881                IF (narea .ne. (jpnij - jpni + 1)) THEN 
     932               IF (nimpp .ne. 1) THEN 
    882933                  startloop = 1 
    883934               ELSE 
    884935                  startloop = 2 
    885936               ENDIF 
    886                IF (narea .ne. jpnij) THEN 
     937               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    887938                  endloop = nlci 
    888939               ELSE 
    … …  
    890941               ENDIF 
    891942               DO ji = startloop, endloop 
    892                   ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     943                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    893944                  pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 
    894945               END DO 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r4645 r4924  
    20262026      ijpjm1 = 3 
    20272027      ! 
     2028      znorthloc(:,:,:) = 0 
    20282029      DO jk = 1, jpk 
    20292030         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    … …  
    20362037      itaille = jpi * jpk * ijpj 
    20372038 
    2038  
    20392039      IF ( l_north_nogather ) THEN 
    20402040         ! 
    20412041        ztabr(:,:,:) = 0 
     2042        ztabl(:,:,:) = 0 
     2043 
    20422044        DO jk = 1, jpk 
    20432045           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    20442046              ij = jj - nlcj + ijpj 
    2045               DO ji = 1, nlci 
     2047              DO ji = nfsloop, nfeloop 
    20462048                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 
    20472049              END DO 
    … …  
    20502052 
    20512053         DO jr = 1,nsndto 
    2052             IF (isendto(jr) .ne. narea) CALL mppsend( 5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr) ) 
     2054            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2055              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
     2056            ENDIF 
    20532057         END DO 
    20542058         DO jr = 1,nsndto 
    2055             iproc = isendto(jr) 
    2056             ildi = nldit (iproc) 
    2057             ilei = nleit (iproc) 
    2058             iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 
    2059             IF(isendto(jr) .ne. narea) THEN 
    2060               CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 
     2059            iproc = nfipproc(isendto(jr),jpnj) 
     2060            IF(iproc .ne. -1) THEN 
     2061               ilei = nleit (iproc+1) 
     2062               ildi = nldit (iproc+1) 
     2063               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2064            ENDIF 
     2065            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2066              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    20612067              DO jk = 1, jpk 
    20622068                 DO jj = 1, ijpj 
    2063                     DO ji = 1, ilei 
     2069                    DO ji = ildi, ilei 
    20642070                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 
    20652071                    END DO 
    20662072                 END DO 
    20672073              END DO 
    2068            ELSE 
     2074           ELSE IF (iproc .eq. (narea-1)) THEN 
    20692075              DO jk = 1, jpk 
    20702076                 DO jj = 1, ijpj 
    2071                     DO ji = 1, ilei 
     2077                    DO ji = ildi, ilei 
    20722078                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
    20732079                    END DO 
    … …  
    20782084         IF (l_isend) THEN 
    20792085            DO jr = 1,nsndto 
    2080                IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2086               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2087                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2088               ENDIF     
    20812089            END DO 
    20822090         ENDIF 
    20832091         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2084          ! 
    20852092         DO jk = 1, jpk 
    20862093            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    … …  
    21902197         ! 
    21912198         ztabr(:,:) = 0 
     2199         ztabl(:,:) = 0 
     2200 
    21922201         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    21932202            ij = jj - nlcj + ijpj 
    2194             DO ji = 1, nlci 
     2203              DO ji = nfsloop, nfeloop 
    21952204               ztabl(ji,ij) = pt2d(ji,jj) 
    21962205            END DO 
    … …  
    21982207 
    21992208         DO jr = 1,nsndto 
    2200             IF (isendto(jr) .ne. narea) CALL mppsend(5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 
     2209            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2210               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 
     2211            ENDIF 
    22012212         END DO 
    22022213         DO jr = 1,nsndto 
    2203             iproc = isendto(jr) 
    2204             ildi = nldit (iproc) 
    2205             ilei = nleit (iproc) 
    2206             iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 
    2207             IF(isendto(jr) .ne. narea) THEN 
    2208               CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 
     2214            iproc = nfipproc(isendto(jr),jpnj) 
     2215            IF(iproc .ne. -1) THEN 
     2216               ilei = nleit (iproc+1) 
     2217               ildi = nldit (iproc+1) 
     2218               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2219            ENDIF 
     2220            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2221              CALL mpprecv(5, zfoldwk, itaille, iproc) 
    22092222              DO jj = 1, ijpj 
    2210                  DO ji = 1, ilei 
     2223                 DO ji = ildi, ilei 
    22112224                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 
    22122225                 END DO 
    22132226              END DO 
    2214             ELSE 
     2227            ELSE IF (iproc .eq. (narea-1)) THEN 
    22152228              DO jj = 1, ijpj 
    2216                  DO ji = 1, ilei 
     2229                 DO ji = ildi, ilei 
    22172230                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
    22182231                 END DO 
    … …  
    22222235         IF (l_isend) THEN 
    22232236            DO jr = 1,nsndto 
    2224                IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2237               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2238                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2239               ENDIF 
    22252240            END DO 
    22262241         ENDIF 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r3294 r4924  
    177177       
    178178#endif 
     179      nfilcit(:,:) = ilcit(:,:) 
    179180      IF( irestj == 0 )   irestj = jpnj 
    180181 
    … …  
    255256         END DO 
    256257      ENDIF 
     258      nfiimpp(:,:)=iimppt(:,:) 
    257259 
    258260      IF( jpnj > 1 ) THEN 
    … …  
    270272         ii = 1 + MOD( jn-1, jpni ) 
    271273         ij = 1 + (jn-1) / jpni 
     274         nfipproc(ii,ij) = jn - 1 
    272275         nimppt(jn) = iimppt(ii,ij) 
    273276         njmppt(jn) = ijmppt(ii,ij) 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r4747 r4924  
    152152#endif 
    153153 
     154      nfilcit(:,:) = ilci(:,:) 
     155 
    154156      IF(lwp) WRITE(numout,*) 
    155157      IF(lwp) WRITE(numout,*) ' mpp_init2: defines mpp subdomains' 
    … …  
    183185         END DO 
    184186      ENDIF 
     187      nfiimpp(:,:) = iimppt(:,:) 
    185188 
    186189      IF( jpnj > 1 )THEN 
    … …  
    203206         ili = ilci(ii,ij) 
    204207         ilj = ilcj(ii,ij) 
    205  
    206208         ibondj(ii,ij) = -1 
    207209         IF( jarea >  jpni          )   ibondj(ii,ij) = 0 
    208210         IF( jarea >  (jpnj-1)*jpni )   ibondj(ii,ij) = 1 
    209211         IF( jpnj  == 1             )   ibondj(ii,ij) = 2 
    210  
    211212         ibondi(ii,ij) = 0 
    212213         IF( MOD(jarea,jpni) == 1 )   ibondi(ii,ij) = -1 
    … …  
    316317      END DO 
    317318 
     319      nfipproc(:,:) = ipproc(:,:) 
     320 
     321 
    318322      ! Control 
    319323      IF(icont+1 /= jpnij) THEN 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r4624 r4924  
    208208      !----------------------------------------------------------------------- 
    209209 
     210      !Initalise all values in namelist arrays 
     211      enactfiles(:) = '' 
     212      coriofiles(:) = '' 
     213      profbfiles(:) = '' 
     214      slafilesact(:) = '' 
     215      slafilespas(:) = '' 
     216      slafbfiles(:) = '' 
     217      sstfiles(:)   = '' 
     218      sstfbfiles(:) = '' 
     219      seaicefiles(:) = '' 
    210220      velcurfiles(:) = '' 
    211221      veladcpfiles(:) = '' 
     222      velavcurfiles(:) = '' 
     223      velhrcurfiles(:) = '' 
     224      velavadcpfiles(:) = '' 
     225      velhradcpfiles(:) = '' 
     226      velfbfiles(:) = '' 
     227      velcurfiles(:) = '' 
     228      veladcpfiles(:) = '' 
     229      endailyavtypes(:) = -1 
     230      endailyavtypes(1) = 820 
     231      ln_profb_ena(:) = .FALSE. 
     232      ln_profb_enatim(:) = .TRUE. 
     233      ln_velfb_av(:) = .FALSE. 
     234      ln_ignmis = .FALSE. 
    212235      CALL ini_date( dobsini ) 
    213236      CALL fin_date( dobsend ) 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r3294 r4924  
    286286         IF ( llaction ) THEN 
    287287             
    288             kinfo = OASIS_Rcv 
    289288            pdata(nldi:nlei, nldj:nlej,jc) = exfld(:,:) 
    290289             
    … …  
    304303               WRITE(numout,*) '****************' 
    305304            ENDIF 
     305 
     306            ! Ideally we would not reuse kinfo, but define a separate variable 
     307            ! for use as the return code from this routine to avoid confusion 
     308            ! with the return code previously obtained from the coupler. 
     309            kinfo = OASIS_Rcv 
    306310             
    307311         ELSE 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r4371 r4924  
    4040      LOGICAL              ::   ln_clim     ! climatology or not (T/F) 
    4141      CHARACTER(len = 8)   ::   cltype      ! type of data file 'daily', 'monthly' or yearly' 
    42       CHARACTER(len = 34) ::   wname       ! generic name of a NetCDF weights file to be used, blank if not 
     42      CHARACTER(len = 256) ::   wname       ! generic name of a NetCDF weights file to be used, blank if not 
    4343      CHARACTER(len = 34)  ::   vcomp       ! symbolic component name if a vector that needs rotation 
    4444      !                                     ! a string starting with "U" or "V" for each component    
    … …  
    473473            !       forcing record :    1  
    474474            !                             
    475             ztmp = REAL( nday, wp ) / REAL( nyear_len(1), wp ) + 0.5 + REAL( it_offset, wp ) 
     475            ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 
     476           &       + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 
    476477            sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 
    477478            ! swap at the middle of the year 
    478             IF( llbefore ) THEN   ;   sdjf%nrec_a(2) = nsec1jan000 - NINT(0.5 * rday) * nyear_len(0) 
    479             ELSE                  ;   sdjf%nrec_a(2) = nsec1jan000 + NINT(0.5 * rday) * nyear_len(1)    
     479            IF( llbefore ) THEN   ;   sdjf%nrec_a(2) = nsec1jan000 - (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(0) + & 
     480                                    & INT(ztmp) * NINT( 0.5 * rday) * nyear_len(1)  
     481            ELSE                  ;   sdjf%nrec_a(2) = nsec1jan000 + (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(1) + & 
     482                                    & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2)  
    480483            ENDIF 
    481484         ELSE                                    ! no time interpolation 
    … …  
    501504            !       forcing record :  nmonth  
    502505            !                             
    503             ztmp = REAL( nday, wp ) / REAL( nmonth_len(nmonth), wp ) + 0.5 + REAL( it_offset, wp ) 
     506            ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 
     507           &       + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 
    504508            imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 
    505509            IF( sdjf%cltype == 'monthly' ) THEN   ;   sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r4666 r4924  
    566566      zcoef_dqsb   = rhoa * cpa * Cice 
    567567      zcoef_frca   = 1.0  - 0.3 
     568      ! MV 2014 the proper cloud fraction (mean summer months from the CLIO climato, NH+SH) is 0.19 
     569      zcoef_frca   = 1.0  - 0.19 
    568570 
    569571!!gm brutal.... 
    … …  
    651653               p_qsr(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
    652654               ! Long  Wave (lw) 
    653                ! iovino 
    654                IF( ff(ji,jj) .GT. 0._wp ) THEN 
    655                   z_qlw(ji,jj,jl) = ( 0.95 * sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
    656                ELSE 
    657                   z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
    658                ENDIF 
     655               z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
    659656               ! lw sensitivity 
    660657               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3                                                
    … …  
    671668                  &                         * (  11637800. * EXP( -5897.8 / pst(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    672669               ! Latent heat sensitivity for ice (Dqla/Dt) 
    673                p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) ) 
     670               ! MV we also have to cap the sensitivity if the flux is zero 
     671               IF ( p_qla(ji,jj,jl) .GT. 0.0 ) THEN 
     672                  p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) ) 
     673               ELSE 
     674                  p_dqla(ji,jj,jl) = 0.0 
     675               ENDIF 
     676                              
    674677               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 
    675678               z_dqsb(ji,jj,jl) = zcoef_dqsb * z_wnds_t(ji,jj) 
    … …  
    823826           sqrt_Cd=kappa/((kappa/sqrt_Cd_n10) - zpsi_m) ; Cd=sqrt_Cd*sqrt_Cd; 
    824827         ELSE 
    825            !! Shifting the wind speed to 10m and neutral stability : 
    826            U_n10 = dU10*1./(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) !  L & Y eq. (9a) 
     828           !! Shifting the wind speed to 10m and neutral stability :  L & Y eq. (9a) 
     829           !   In very rare low-wind conditions, the old way of estimating the 
     830           !   neutral wind speed at 10m leads to a negative value that causes the code 
     831           !   to crash. To prevent this a threshold of 0.25m/s is now imposed. 
     832           U_n10 = MAX( 0.25 , dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ) 
    827833 
    828834           !! Updating the neutral 10m transfer coefficients : 
    … …  
    959965         zpsi_m  = psi_m(zeta_u) 
    960966         !! 
    961          !! Shifting the wind speed to 10m and neutral stability : (L & Y eq.(9a)) 
    962 !        U_n10 = dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - psi_m(zeta_u))) 
    963          U_n10 = dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) 
     967         !! Shifting the wind speed to 10m and neutral stability : L & Y eq.(9a) 
     968         !   In very rare low-wind conditions, the old way of estimating the 
     969         !   neutral wind speed at 10m leads to a negative value that causes the code 
     970         !   to crash. To prevent this a threshold of 0.25m/s is now imposed. 
     971         U_n10 = MAX( 0.25 , dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ) 
    964972         !! 
    965973         !! Shifting temperature and humidity at zu :          (L & Y eq. (9b-9c)) 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r4624 r4924  
    13741374            END SELECT 
    13751375         CASE( 'mixed oce-ice'        )    
    1376             ztmp1(:,:) = ( tsn(:,:,1,1) + rt0 ) * zfr_l(:,:)  
     1376            ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)  
    13771377            DO jl=1,jpl 
    13781378               ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r4666 r4924  
    5858      !!                =1 global mean of emp set to zero at each nn_fsbc time step 
    5959      !!                =2 annual global mean corrected from previous year 
     60      !!                =3 global mean of emp set to zero at each nn_fsbc time step 
     61      !!                   & spread out over erp area depending its sign 
    6062      !! Note: if sea ice is embedded it is taken into account when computing the budget  
    6163      !!---------------------------------------------------------------------- 
    … …  
    8284            IF( kn_fwb == 1 )   WRITE(numout,*) '          instantaneously set to zero' 
    8385            IF( kn_fwb == 2 )   WRITE(numout,*) '          adjusted from previous year budget' 
    84          ENDIF 
     86            IF( kn_fwb == 3 )   WRITE(numout,*) '          fwf set to zero and spread out over erp area' 
     87         ENDIF 
     88         ! 
     89         IF( kn_fwb == 3 .AND. nn_sssr /= 2 )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) 
    8590         ! 
    8691         area = glob_sum( e1e2t(:,:) )           ! interior global domain surface 
    … …  
    143148         ENDIF 
    144149         ! 
     150      CASE ( 3 )                             !==  global fwf set to zero and spread out over erp area  ==! 
     151         ! 
     152         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
     153            ztmsk_pos(:,:) = tmask_i(:,:)                      ! Select <0 and >0 area of erp 
     154            WHERE( erp < 0._wp )   ztmsk_pos = 0._wp 
     155            ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) 
     156            ! 
     157            zsurf_neg = glob_sum( e1e2t(:,:)*ztmsk_neg(:,:) )  ! Area filled by <0 and >0 erp  
     158            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
     159            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
     160            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - snwice_fmass(:,:) ) ) / area 
     161            !             
     162            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 
     163                zsurf_tospread      = zsurf_pos 
     164                ztmsk_tospread(:,:) = ztmsk_pos(:,:) 
     165            ELSE                             ! spread out over <0 erp area to increase precipitation 
     166                zsurf_tospread      = zsurf_neg 
     167                ztmsk_tospread(:,:) = ztmsk_neg(:,:) 
     168            ENDIF 
     169            ! 
     170            zsum_fwf   = glob_sum( e1e2t(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area 
     171!!gm :  zsum_fwf   = z_fwf * area   ???  it is right?  I think so.... 
     172            z_fwf_nsrf =  zsum_fwf / ( zsurf_tospread + rsmall ) 
     173            !                                                  ! weight to respect erp field 2D structure  
     174            zsum_erp   = glob_sum( ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) 
     175            z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) 
     176            !                                                  ! final correction term to apply 
     177            zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) 
     178            ! 
     179!!gm   ===>>>>  lbc_lnk should be useless as all the computation is done over the whole domain ! 
     180            CALL lbc_lnk( zerp_cor, 'T', 1. ) 
     181            ! 
     182            emp(:,:) = emp(:,:) + zerp_cor(:,:) 
     183            qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:)  ! account for change to the heat budget due to fw correction 
     184            erp(:,:) = erp(:,:) + zerp_cor(:,:) 
     185            ! 
     186            IF( nprint == 1 .AND. lwp ) THEN                   ! control print 
     187               IF( z_fwf < 0._wp ) THEN 
     188                  WRITE(numout,*)'   z_fwf < 0' 
     189                  WRITE(numout,*)'   SUM(erp+)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' 
     190               ELSE 
     191                  WRITE(numout,*)'   z_fwf >= 0' 
     192                  WRITE(numout,*)'   SUM(erp-)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' 
     193               ENDIF 
     194               WRITE(numout,*)'   SUM(empG)     = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' 
     195               WRITE(numout,*)'   z_fwf         = ', z_fwf      ,' Kg/m2/s' 
     196               WRITE(numout,*)'   z_fwf_nsrf    = ', z_fwf_nsrf ,' Kg/m2/s' 
     197               WRITE(numout,*)'   MIN(zerp_cor) = ', MINVAL(zerp_cor)  
     198               WRITE(numout,*)'   MAX(zerp_cor) = ', MAXVAL(zerp_cor)  
     199            ENDIF 
     200         ENDIF 
     201         ! 
    145202      CASE DEFAULT                           !==  you should never be there  ==! 
    146          CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1 or 2' ) 
     203         CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' ) 
    147204         ! 
    148205      END SELECT 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r4724 r4924  
    5959   USE prtctl          ! Print control 
    6060   USE lib_fortran     !  
     61   USE cpl_oasis3, ONLY : lk_cpl 
    6162 
    6263#if defined key_bdy  
    … …  
    6869 
    6970   PUBLIC sbc_ice_lim  ! routine called by sbcmod.F90 
     71   PUBLIC lim_prt_state 
    7072    
    7173   !! * Substitutions 
    … …  
    133135      INTEGER, INTENT(in) ::   kblk    ! type of bulk (=3 CLIO, =4 CORE) 
    134136      !! 
    135       INTEGER  ::   jl      ! dummy loop index 
     137      INTEGER  ::   ji, jj, jl, jk      ! dummy loop index 
    136138      REAL(wp) ::   zcoef   ! local scalar 
    137139      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice_os, zalb_ice_cs  ! albedo of the ice under overcast/clear sky 
    … …  
    146148      REAL(wp), POINTER, DIMENSION(:,:) :: z_dqns_ice_all  ! Mean d(qns)/dT over all categories 
    147149      REAL(wp), POINTER, DIMENSION(:,:) :: z_dqla_ice_all  ! Mean d(qla)/dT over all categories 
     150      REAL(wp) ::   ztmelts           ! clem 2014: for HC diags 
     151      REAL(wp) ::   epsi20 = 1.e-20   ! 
    148152      !!---------------------------------------------------------------------- 
    149153 
    … …  
    152156      IF( nn_timing == 1 )  CALL timing_start('sbc_ice_lim') 
    153157 
    154       CALL wrk_alloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs ) 
    155  
    156 #if defined key_coupled 
    157       IF ( ln_cpl .OR. ln_iceflx_ave .OR. ln_iceflx_linear ) CALL wrk_alloc( jpi,jpj,jpl, zalb_ice) 
    158       IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) & 
    159          &   CALL wrk_alloc( jpi,jpj, ztem_ice_all, zalb_ice_all, z_qsr_ice_all, z_qns_ice_all, z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all) 
    160 #endif 
     158      CALL wrk_alloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs, zalb_ice ) 
     159 
     160      IF( lk_cpl ) THEN 
     161         IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) & 
     162            &   CALL wrk_alloc( jpi, jpj, ztem_ice_all , zalb_ice_all  , z_qsr_ice_all, z_qns_ice_all,  & 
     163            &                            z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all) 
     164      ENDIF 
    161165 
    162166      IF( kt == nit000 ) THEN 
    … …  
    168172         ! 
    169173         IF( ln_nicep ) THEN      ! control print at a given point 
    170             jiindx = 177   ;   jjindx = 112 
     174            jiindx = 15    ;   jjindx =  44 
    171175            IF(lwp) WRITE(numout,*) ' The debugging point is : jiindx : ',jiindx, ' jjindx : ',jjindx 
    172176         ENDIF 
    … …  
    176180      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only  ! 
    177181         !                                     !----------------------! 
    178          !                                           !  Bulk Formulea ! 
     182         !                                           !  Bulk Formulae ! 
    179183         !                                           !----------------! 
    180184         ! 
    181185         u_oce(:,:) = ssu_m(:,:) * umask(:,:,1)                     ! mean surface ocean current at ice velocity point 
    182186         v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1)                    ! (C-grid dynamics :  U- & V-points as the ocean) 
    183          ! 
    184          t_bo(:,:) = tfreez( sss_m ) +  rt0          ! masked sea surface freezing temperature [Kelvin] 
    185          !                                           ! (set to rt0 over land) 
     187 
     188         ! masked sea surface freezing temperature [Kelvin] 
     189         t_bo(:,:) = ( tfreez( sss_m ) +  rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) ) 
     190 
    186191         CALL albedo_ice( t_su, ht_i, ht_s, zalb_ice_cs, zalb_ice_os )  ! ... ice albedo 
    187192 
    … …  
    192197         IF ( ln_cpl ) zalb_ice (:,:,:) = 0.5 * ( zalb_ice_cs (:,:,:) +  zalb_ice_os (:,:,:) ) 
    193198          
    194 #if defined key_coupled 
    195          IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) THEN 
    196             ! 
    197             ! Compute mean albedo and temperature 
    198             zalb_ice_all (:,:) = fice_ice_ave ( zalb_ice (:,:,:) )  
    199             ztem_ice_all (:,:) = fice_ice_ave ( tn_ice   (:,:,:) )  
    200             ! 
     199         IF( lk_cpl ) THEN 
     200            IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) THEN 
     201               ! 
     202               ! Compute mean albedo and temperature 
     203               zalb_ice_all (:,:) = fice_ice_ave ( zalb_ice (:,:,:) )  
     204               ztem_ice_all (:,:) = fice_ice_ave ( tn_ice   (:,:,:) )  
     205               ! 
     206            ENDIF 
    201207         ENDIF 
    202 #endif 
    203208                                               ! Bulk formulea - provides the following fields: 
    204209         ! utau_ice, vtau_ice : surface ice stress                     (U- & V-points)   [N/m2] 
    … …  
    218223            !          
    219224         CASE( 4 )                                       ! CORE bulk formulation 
    220             CALL blk_ice_core( t_su , u_ice     , v_ice     , zalb_ice_cs,               & 
     225            ! MV 2014 
     226            ! We must account for cloud fraction in the computation of the albedo 
     227            ! The present ref just uses the clear sky value 
     228            ! The overcast sky value is 0.06 higher, and polar skies are mostly overcast 
     229            ! CORE has no cloud fraction, hence we must prescribe it 
     230            ! Mean summer cloud fraction computed from CLIO = 0.81 
     231            zalb_ice(:,:,:) = 0.19 * zalb_ice_cs(:,:,:) + 0.81 * zalb_ice_os(:,:,:) 
     232            ! Following line, we replace zalb_ice_cs by simply zalb_ice 
     233            CALL blk_ice_core( t_su , u_ice     , v_ice     , zalb_ice   ,               & 
    221234               &                      utau_ice  , vtau_ice  , qns_ice    , qsr_ice   ,   & 
    222235               &                      qla_ice   , dqns_ice  , dqla_ice   ,               & 
    … …  
    239252 
    240253         ! Average over all categories 
    241 #if defined key_coupled 
     254         IF( lk_cpl ) THEN 
    242255         IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) THEN 
    243256 
    … …  
    269282            END IF 
    270283         END IF 
    271 #endif 
     284         ENDIF 
    272285         !                                           !----------------------! 
    273286         !                                           ! LIM-3  time-stepping ! 
    … …  
    277290         ! 
    278291         !                                           ! Store previous ice values 
    279 !!gm : remark   old_...   should becomes ...b  as tn versus tb   
    280          old_a_i  (:,:,:)   = a_i  (:,:,:)     ! ice area 
    281          old_e_i  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
    282          old_v_i  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
    283          old_v_s  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
    284          old_e_s  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
    285          old_smv_i(:,:,:)   = smv_i(:,:,:)     ! salt content 
    286          old_oa_i (:,:,:)   = oa_i (:,:,:)     ! areal age content 
    287          ! 
    288          old_u_ice(:,:) = u_ice(:,:) 
    289          old_v_ice(:,:) = v_ice(:,:) 
    290          !                                           ! intialisation to zero    !!gm is it truly necessary ??? 
     292         a_i_b  (:,:,:)   = a_i  (:,:,:)     ! ice area 
     293         e_i_b  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
     294         v_i_b  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
     295         v_s_b  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
     296         e_s_b  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
     297         smv_i_b(:,:,:)   = smv_i(:,:,:)     ! salt content 
     298         oa_i_b (:,:,:)   = oa_i (:,:,:)     ! areal age content 
     299         u_ice_b(:,:)     = u_ice(:,:) 
     300         v_ice_b(:,:)     = v_ice(:,:) 
     301 
     302         ! trends    !!gm is it truly necessary ??? 
    291303         d_a_i_thd  (:,:,:)   = 0._wp   ;   d_a_i_trp  (:,:,:)   = 0._wp 
    292304         d_v_i_thd  (:,:,:)   = 0._wp   ;   d_v_i_trp  (:,:,:)   = 0._wp 
    … …  
    296308         d_smv_i_thd(:,:,:)   = 0._wp   ;   d_smv_i_trp(:,:,:)   = 0._wp 
    297309         d_oa_i_thd (:,:,:)   = 0._wp   ;   d_oa_i_trp (:,:,:)   = 0._wp 
    298          ! 
    299          d_u_ice_dyn(:,:) = 0._wp 
    300          d_v_ice_dyn(:,:) = 0._wp 
    301          ! 
    302          sfx    (:,:) = 0._wp   ;   sfx_thd  (:,:) = 0._wp 
    303          sfx_bri(:,:) = 0._wp   ;   sfx_mec  (:,:) = 0._wp   ;   sfx_res  (:,:) = 0._wp 
    304          fhbri  (:,:) = 0._wp   ;   fheat_mec(:,:) = 0._wp   ;   fheat_res(:,:) = 0._wp 
    305          fhmec  (:,:) = 0._wp   ;    
    306          fmmec  (:,:) = 0._wp 
    307          fmmflx (:,:) = 0._wp      
    308          focea2D(:,:) = 0._wp 
    309          fsup2D (:,:) = 0._wp 
    310  
    311          ! used in limthd.F90 
    312          rdvosif(:,:) = 0._wp   ! variation of ice volume at surface 
    313          rdvobif(:,:) = 0._wp   ! variation of ice volume at bottom 
    314          fdvolif(:,:) = 0._wp   ! total variation of ice volume 
    315          rdvonif(:,:) = 0._wp   ! lateral variation of ice volume 
    316          fstric (:,:) = 0._wp   ! part of solar radiation transmitted through the ice 
    317          ffltbif(:,:) = 0._wp   ! linked with fstric 
    318          qfvbq  (:,:) = 0._wp   ! linked with fstric 
    319          rdm_snw(:,:) = 0._wp   ! variation of snow mass per unit area 
    320          rdm_ice(:,:) = 0._wp   ! variation of ice mass per unit area 
    321          hicifp (:,:) = 0._wp   ! daily thermodynamic ice production.  
    322          ! 
    323          diag_sni_gr(:,:) = 0._wp   ;   diag_lat_gr(:,:) = 0._wp 
    324          diag_bot_gr(:,:) = 0._wp   ;   diag_dyn_gr(:,:) = 0._wp 
    325          diag_bot_me(:,:) = 0._wp   ;   diag_sur_me(:,:) = 0._wp 
    326          diag_res_pr(:,:) = 0._wp   ;   diag_trp_vi(:,:) = 0._wp 
     310         d_u_ice_dyn(:,:)     = 0._wp   ;   d_v_ice_dyn(:,:)     = 0._wp 
     311 
     312         ! salt, heat and mass fluxes 
     313         sfx    (:,:) = 0._wp   ; 
     314         sfx_bri(:,:) = 0._wp   ;  
     315         sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp 
     316         sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
     317         sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
     318         sfx_res(:,:) = 0._wp 
     319 
     320         wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
     321         wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp 
     322         wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp 
     323         wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp 
     324         wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp 
     325         wfx_spr(:,:) = 0._wp   ;    
     326 
     327         hfx_in (:,:) = 0._wp   ;   hfx_out(:,:) = 0._wp 
     328         hfx_thd(:,:) = 0._wp   ;    
     329         hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
     330         hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp 
     331         hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp 
     332         hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
     333         hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
     334         hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
     335 
     336         ! 
     337         fhld  (:,:)    = 0._wp  
     338         fmmflx(:,:)    = 0._wp      
     339         ! part of solar radiation transmitted through the ice 
     340         ftr_ice(:,:,:) = 0._wp 
     341 
     342         ! diags 
     343         diag_trp_vi  (:,:) = 0._wp  ; diag_trp_vs(:,:) = 0._wp  ;  diag_trp_ei(:,:) = 0._wp  ;  diag_trp_es(:,:) = 0._wp 
     344         diag_heat_dhc(:,:) = 0._wp   
     345 
    327346         ! dynamical invariants 
    328347         delta_i(:,:) = 0._wp       ;   divu_i(:,:) = 0._wp       ;   shear_i(:,:) = 0._wp 
    … …  
    352371         ENDIF 
    353372!                         !- Change old values for new values 
    354                           old_u_ice(:,:)   = u_ice (:,:) 
    355                           old_v_ice(:,:)   = v_ice (:,:) 
    356                           old_a_i(:,:,:)   = a_i (:,:,:) 
    357                           old_v_s(:,:,:)   = v_s (:,:,:) 
    358                           old_v_i(:,:,:)   = v_i (:,:,:) 
    359                           old_e_s(:,:,:,:) = e_s (:,:,:,:) 
    360                           old_e_i(:,:,:,:) = e_i (:,:,:,:) 
    361                           old_oa_i(:,:,:)  = oa_i(:,:,:) 
    362                           old_smv_i(:,:,:) = smv_i (:,:,:) 
     373                          u_ice_b(:,:)     = u_ice(:,:) 
     374                          v_ice_b(:,:)     = v_ice(:,:) 
     375                          a_i_b  (:,:,:)   = a_i (:,:,:) 
     376                          v_s_b  (:,:,:)   = v_s (:,:,:) 
     377                          v_i_b  (:,:,:)   = v_i (:,:,:) 
     378                          e_s_b  (:,:,:,:) = e_s (:,:,:,:) 
     379                          e_i_b  (:,:,:,:) = e_i (:,:,:,:) 
     380                          oa_i_b (:,:,:)   = oa_i (:,:,:) 
     381                          smv_i_b(:,:,:)   = smv_i(:,:,:) 
    363382  
    364383         ! ---------------------------------------------- 
    … …  
    375394                          zcoef = rdt_ice /rday           !  Ice natural aging 
    376395                          oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * zcoef 
    377                           CALL lim_var_glo2eqv            ! this CALL is maybe not necessary (Martin) 
    378396         IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermodyn. - ' )   ! control print 
    379397                          CALL lim_itd_th( kt )           !  Remap ice categories, lateral accretion  ! 
    … …  
    391409         !                                           ! Diagnostics and outputs  
    392410         IF (ln_limdiaout) CALL lim_diahsb 
    393 !clem # if ! defined key_iomput 
     411 
    394412                          CALL lim_wri( 1  )              ! Ice outputs  
    395 !clem # endif 
     413 
    396414         IF( kt == nit000 .AND. ln_rstart )   & 
    397415            &             CALL iom_close( numrir )        ! clem: close input ice restart file 
    … …  
    413431       
    414432!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    415       ! 
    416       CALL wrk_dealloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs ) 
    417  
    418 #if defined key_coupled 
    419       IF ( ln_cpl .OR. ln_iceflx_ave .OR. ln_iceflx_linear ) CALL wrk_dealloc( jpi,jpj,jpl, zalb_ice) 
    420       IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) & 
    421          &    CALL wrk_dealloc( jpi,jpj, ztem_ice_all, zalb_ice_all, z_qsr_ice_all, z_qns_ice_all, z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all) 
    422 #endif 
     433      CALL wrk_dealloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs, zalb_ice ) 
     434 
     435      IF( lk_cpl ) THEN 
     436         IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) & 
     437            &    CALL wrk_dealloc( jpi, jpj, ztem_ice_all , zalb_ice_all , z_qsr_ice_all, z_qns_ice_all,   & 
     438            &                                z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all) 
     439      ENDIF 
    423440      ! 
    424441      IF( nn_timing == 1 )  CALL timing_stop('sbc_ice_lim') 
    … …  
    456473                  !WRITE(numout,*) ' at_i     ', at_i(ji,jj) 
    457474                  !WRITE(numout,*) ' Point - category', ji, jj, jl 
    458                   !WRITE(numout,*) ' a_i *** a_i_old ', a_i      (ji,jj,jl), old_a_i  (ji,jj,jl) 
    459                   !WRITE(numout,*) ' v_i *** v_i_old ', v_i      (ji,jj,jl), old_v_i  (ji,jj,jl) 
     475                  !WRITE(numout,*) ' a_i *** a_i_b   ', a_i      (ji,jj,jl), a_i_b  (ji,jj,jl) 
     476                  !WRITE(numout,*) ' v_i *** v_i_b   ', v_i      (ji,jj,jl), v_i_b  (ji,jj,jl) 
    460477                  !WRITE(numout,*) ' d_a_i_thd/trp   ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 
    461478                  !WRITE(numout,*) ' d_v_i_thd/trp   ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 
    … …  
    534551!                 WRITE(numout,*) ' sst                  : ', sst_m(ji,jj) 
    535552!                 WRITE(numout,*) ' sss                  : ', sss_m(ji,jj) 
    536 !                 WRITE(numout,*) ' s_i_newice           : ', s_i_newice(ji,jj,1:jpl) 
    537553!                 WRITE(numout,*)  
    538554                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    … …  
    568584               !DO jl = 1, jpl 
    569585                  !WRITE(numout,*) ' Category no: ', jl 
    570                   !WRITE(numout,*) ' a_i        : ', a_i      (ji,jj,jl) , ' old_a_i    : ', old_a_i  (ji,jj,jl)    
     586                  !WRITE(numout,*) ' a_i        : ', a_i      (ji,jj,jl) , ' a_i_b      : ', a_i_b  (ji,jj,jl)    
    571587                  !WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl) , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    572                   !WRITE(numout,*) ' v_i        : ', v_i      (ji,jj,jl) , ' old_v_i    : ', old_v_i  (ji,jj,jl)    
     588                  !WRITE(numout,*) ' v_i        : ', v_i      (ji,jj,jl) , ' v_i_b      : ', v_i_b  (ji,jj,jl)    
    573589                  !WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl) , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    574590                  !WRITE(numout,*) ' ' 
    … …  
    591607               !WRITE(numout,*) ' sst       : ', sst_m(ji,jj) 
    592608               !WRITE(numout,*) ' sss       : ', sss_m(ji,jj) 
    593                !WRITE(numout,*) ' qcmif     : ', qcmif(ji,jj) 
    594                !WRITE(numout,*) ' qldif     : ', qldif(ji,jj) 
    595                !WRITE(numout,*) ' qcmif     : ', qcmif(ji,jj) / rdt_ice 
    596                !WRITE(numout,*) ' qldif     : ', qldif(ji,jj) / rdt_ice 
    597                !WRITE(numout,*) ' qfvbq     : ', qfvbq(ji,jj) 
    598                !WRITE(numout,*) ' qdtcn     : ', qdtcn(ji,jj) 
    599                !WRITE(numout,*) ' qfvbq / dt: ', qfvbq(ji,jj) / rdt_ice 
    600                !WRITE(numout,*) ' qdtcn / dt: ', qdtcn(ji,jj) / rdt_ice 
    601                !WRITE(numout,*) ' fdtcn     : ', fdtcn(ji,jj)  
    602                !WRITE(numout,*) ' fhmec     : ', fhmec(ji,jj)  
    603                !WRITE(numout,*) ' fheat_mec : ', fheat_mec(ji,jj)  
    604                !WRITE(numout,*) ' fheat_res : ', fheat_res(ji,jj)  
    605                !WRITE(numout,*) ' fhbri     : ', fhbri(ji,jj)  
    606609               ! 
    607610               !CALL lim_prt_state( kt, ji, jj, 2, '   ') 
    … …  
    759762               WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    760763               WRITE(numout,*) ' d_u_ice_dyn   : ', d_u_ice_dyn(ji,jj), ' d_v_ice_dyn   : ', d_v_ice_dyn(ji,jj) 
    761                WRITE(numout,*) ' old_u_ice     : ', old_u_ice(ji,jj)  , ' old_v_ice     : ', old_v_ice(ji,jj)   
     764               WRITE(numout,*) ' u_ice_b       : ', u_ice_b(ji,jj)    , ' v_ice_b       : ', v_ice_b(ji,jj)   
    762765               WRITE(numout,*) 
    763766                
    … …  
    769772                  WRITE(numout,*) ' t_su       : ', t_su(ji,jj,jl)             , ' t_s        : ', t_s(ji,jj,1,jl) 
    770773                  WRITE(numout,*) ' sm_i       : ', sm_i(ji,jj,jl)             , ' o_i        : ', o_i(ji,jj,jl) 
    771                   WRITE(numout,*) ' a_i        : ', a_i(ji,jj,jl)              , ' old_a_i    : ', old_a_i(ji,jj,jl)    
     774                  WRITE(numout,*) ' a_i        : ', a_i(ji,jj,jl)              , ' a_i_b      : ', a_i_b(ji,jj,jl)    
    772775                  WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl)        , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    773                   WRITE(numout,*) ' v_i        : ', v_i(ji,jj,jl)              , ' old_v_i    : ', old_v_i(ji,jj,jl)    
     776                  WRITE(numout,*) ' v_i        : ', v_i(ji,jj,jl)              , ' v_i_b      : ', v_i_b(ji,jj,jl)    
    774777                  WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl)        , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    775                   WRITE(numout,*) ' v_s        : ', v_s(ji,jj,jl)              , ' old_v_s    : ', old_v_s(ji,jj,jl)   
     778                  WRITE(numout,*) ' v_s        : ', v_s(ji,jj,jl)              , ' v_s_b      : ', v_s_b(ji,jj,jl)   
    776779                  WRITE(numout,*) ' d_v_s_trp  : ', d_v_s_trp(ji,jj,jl)        , ' d_v_s_thd  : ', d_v_s_thd(ji,jj,jl) 
    777                   WRITE(numout,*) ' e_i1       : ', e_i(ji,jj,1,jl)/1.0e9      , ' old_ei1    : ', old_e_i(ji,jj,1,jl)/1.0e9  
     780                  WRITE(numout,*) ' e_i1       : ', e_i(ji,jj,1,jl)/1.0e9      , ' ei1        : ', e_i_b(ji,jj,1,jl)/1.0e9  
    778781                  WRITE(numout,*) ' de_i1_trp  : ', d_e_i_trp(ji,jj,1,jl)/1.0e9, ' de_i1_thd  : ', d_e_i_thd(ji,jj,1,jl)/1.0e9 
    779                   WRITE(numout,*) ' e_i2       : ', e_i(ji,jj,2,jl)/1.0e9      , ' old_ei2    : ', old_e_i(ji,jj,2,jl)/1.0e9   
     782                  WRITE(numout,*) ' e_i2       : ', e_i(ji,jj,2,jl)/1.0e9      , ' ei2_b      : ', e_i_b(ji,jj,2,jl)/1.0e9   
    780783                  WRITE(numout,*) ' de_i2_trp  : ', d_e_i_trp(ji,jj,2,jl)/1.0e9, ' de_i2_thd  : ', d_e_i_thd(ji,jj,2,jl)/1.0e9 
    781                   WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' old_e_snow : ', old_e_s(ji,jj,1,jl)  
     784                  WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' e_snow_b   : ', e_s_b(ji,jj,1,jl)  
    782785                  WRITE(numout,*) ' d_e_s_trp  : ', d_e_s_trp(ji,jj,1,jl)      , ' d_e_s_thd  : ', d_e_s_thd(ji,jj,1,jl) 
    783                   WRITE(numout,*) ' smv_i      : ', smv_i(ji,jj,jl)            , ' old_smv_i  : ', old_smv_i(ji,jj,jl)    
     786                  WRITE(numout,*) ' smv_i      : ', smv_i(ji,jj,jl)            , ' smv_i_b    : ', smv_i_b(ji,jj,jl)    
    784787                  WRITE(numout,*) ' d_smv_i_trp: ', d_smv_i_trp(ji,jj,jl)      , ' d_smv_i_thd: ', d_smv_i_thd(ji,jj,jl)  
    785                   WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' old_oa_i   : ', old_oa_i(ji,jj,jl) 
     788                  WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' oa_i_b     : ', oa_i_b(ji,jj,jl) 
    786789                  WRITE(numout,*) ' d_oa_i_trp : ', d_oa_i_trp(ji,jj,jl)       , ' d_oa_i_thd : ', d_oa_i_thd(ji,jj,jl) 
    787790               END DO !jl 
    … …  
    790793               WRITE(numout,*) ' - Heat / FW fluxes ' 
    791794               WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ ' 
    792                WRITE(numout,*) ' emp        : ', emp      (ji,jj) 
    793                WRITE(numout,*) ' sfx        : ', sfx      (ji,jj) 
    794                WRITE(numout,*) ' sfx_thd    : ', sfx_thd(ji,jj) 
    795                WRITE(numout,*) ' sfx_bri    : ', sfx_bri  (ji,jj) 
    796                WRITE(numout,*) ' sfx_mec    : ', sfx_mec  (ji,jj) 
    797                WRITE(numout,*) ' sfx_res    : ', sfx_res(ji,jj) 
    798                WRITE(numout,*) ' fmmec      : ', fmmec    (ji,jj) 
    799                WRITE(numout,*) ' fhmec      : ', fhmec    (ji,jj) 
    800                WRITE(numout,*) ' fhbri      : ', fhbri    (ji,jj) 
    801                WRITE(numout,*) ' fheat_mec  : ', fheat_mec(ji,jj) 
     795               WRITE(numout,*) ' - Heat fluxes in and out the ice ***' 
     796               WRITE(numout,*) ' qsr_ini       : ', pfrld(ji,jj) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) 
     797               WRITE(numout,*) ' qns_ini       : ', pfrld(ji,jj) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) 
     798               WRITE(numout,*) 
    802799               WRITE(numout,*)  
    803800               WRITE(numout,*) ' sst        : ', sst_m(ji,jj)   
    … …  
    829826               WRITE(numout,*) ' qsr       : ', qsr(ji,jj) 
    830827               WRITE(numout,*) ' qns       : ', qns(ji,jj) 
    831                WRITE(numout,*) ' fdtcn     : ', fdtcn(ji,jj) 
    832                WRITE(numout,*) ' qcmif     : ', qcmif(ji,jj) * r1_rdtice 
    833                WRITE(numout,*) ' qldif     : ', qldif(ji,jj) * r1_rdtice 
     828               WRITE(numout,*) 
     829               WRITE(numout,*) ' hfx_mass     : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj) 
     830               WRITE(numout,*) ' hfx_in       : ', hfx_in(ji,jj) 
     831               WRITE(numout,*) ' hfx_out      : ', hfx_out(ji,jj) 
     832               WRITE(numout,*) ' dhc          : ', diag_heat_dhc(ji,jj)               
     833               WRITE(numout,*) 
     834               WRITE(numout,*) ' hfx_dyn      : ', hfx_dyn(ji,jj) 
     835               WRITE(numout,*) ' hfx_thd      : ', hfx_thd(ji,jj) 
     836               WRITE(numout,*) ' hfx_res      : ', hfx_res(ji,jj) 
     837               WRITE(numout,*) ' fhtur        : ', fhtur(ji,jj)  
     838               WRITE(numout,*) ' qlead        : ', qlead(ji,jj) * r1_rdtice 
    834839               WRITE(numout,*) 
    835840               WRITE(numout,*) ' - Salt fluxes at bottom interface ***' 
    836841               WRITE(numout,*) ' emp       : ', emp    (ji,jj) 
    837                WRITE(numout,*) ' sfx_bri   : ', sfx_bri(ji,jj) 
    838842               WRITE(numout,*) ' sfx       : ', sfx    (ji,jj) 
    839843               WRITE(numout,*) ' sfx_res   : ', sfx_res(ji,jj) 
    840                WRITE(numout,*) ' sfx_mec   : ', sfx_mec(ji,jj) 
    841                WRITE(numout,*) ' - Heat fluxes at bottom interface ***' 
    842                WRITE(numout,*) ' fheat_res : ', fheat_res(ji,jj) 
     844               WRITE(numout,*) ' sfx_bri   : ', sfx_bri(ji,jj) 
     845               WRITE(numout,*) ' sfx_dyn   : ', sfx_dyn(ji,jj) 
    843846               WRITE(numout,*) 
    844847               WRITE(numout,*) ' - Momentum fluxes ' 
    845848               WRITE(numout,*) ' utau      : ', utau(ji,jj)  
    846849               WRITE(numout,*) ' vtau      : ', vtau(ji,jj) 
    847             ENDIF 
     850            ENDIF  
    848851            WRITE(numout,*) ' ' 
    849852            ! 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r4724 r4924  
    5353   USE agrif_lim2_update 
    5454# endif 
     55 
     56#if defined key_bdy  
     57   USE bdyice_lim       ! unstructured open boundary data  (bdy_ice_lim routine) 
     58#endif 
    5559 
    5660   IMPLICIT NONE 
    … …  
    205209                           CALL lim_trp_2      ( kt )      ! Ice transport   ( Advection/diffusion ) 
    206210           IF( ln_limdmp ) CALL lim_dmp_2      ( kt )      ! Ice damping  
     211#if defined key_bdy 
     212                           CALL bdy_ice_lim( kt ) ! bdy ice thermo 
     213#endif 
    207214         END IF 
    208215#if defined key_coupled 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r4726 r4924  
    4848   REAL(wp), PUBLIC ::   rdivisf                     !: flag to test if fwf apply on divergence 
    4949 
    50    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rzisf_tbl              !:depth of ice shelf base  ???? 
    51    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rhisf_tbl, rhisf_tbl_0 !:depth of ice shelf base  ???? 
    52    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  r1_hisf_tbl            !:1/depth of ice shelf base  ???? 
    53    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ralpha                 !:proportion of bottom cell influenced by boundary layer  
    54    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 ? 
     50   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rzisf_tbl              !:depth of calving front (shallowest point) nn_isf ==2/3 
     51   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rhisf_tbl, rhisf_tbl_0 !:thickness of tbl 
     52   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  r1_hisf_tbl            !:1/thickness of tbl 
     53   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ralpha                 !:proportion of bottom cell influenced by tbl  
     54   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5555   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    5656   INTEGER(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r4666 r4924  
    192192  
    193193      fmmflx(:,:) = 0.0_wp                        ! freezing-melting array initialisation 
     194       
     195      taum(:,:) = 0.0_wp                           ! Initialise taum for use in gls in case of reduced restart 
    194196 
    195197      !                                            ! restartability    

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90

    r4624 r4924  
    203203      ! 
    204204      !                                      !==  structure function value at uw- and vw-points  ==! 
    205       zhu(:,:) = 1._wp / zhu(:,:)                   ! hu --> 1/hu 
    206       zhv(:,:) = 1._wp / zhv(:,:) 
     205      DO jj = 1, jpjm1 
     206         DO ji = 1, fs_jpim1   ! vector opt. 
     207            zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
     208            zhv(ji,jj) = 1._wp / zhv(ji,jj) 
     209         END DO 
     210      END DO 
     211      ! 
    207212      zpsi_uw(:,:,:) = 0._wp 
    208213      zpsi_vw(:,:,:) = 0._wp 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r4666 r4924  
    129129      IF( kt == nit000 ) THEN                     ! Set the forcing field at nit000 - 1 
    130130         !                                        ! ----------------------------------- 
     131         qsr_hc(:,:,:) = 0.e0 
     132         ! 
    131133         IF( ln_rstart .AND.    &                    ! Restart: read in restart file 
    132134              & iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r4747 r4924  
    168168               ! 
    169169               ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    170                IF ( miku(ji,jj) + 2 .LE. mbku(ji,jj) ) THEN 
     170               IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    171171                  bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) )   & 
    172172                               &            + ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) ) & 
    173173                               &          * zecu * (1._wp - umask(ji,jj,1)) 
    174174               END IF 
    175                IF ( mikv(ji,jj) + 2 .LE. mbkv(ji,jj) ) THEN 
     175               IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    176176                  bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) )   & 
    177177                               &            + ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) ) & 
    178                                &          * zecv 
     178                               &          * zecv * (1._wp - vmask(ji,jj,1)) 
    179179               END IF 
    180180               ! (ISF) ======================================================================== 
    … …  
    194194               ! (ISF) END ==================================================================== 
    195195               ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    196                IF ( miku(ji,jj) + 2 .LE. mbku(ji,jj) ) THEN 
     196               IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    197197                  tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) )   & 
    198198                               &            + ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) ) ) & 
    199199                               &          * zecu * (1._wp - umask(ji,jj,1)) 
    200200               END IF 
    201                IF ( mikv(ji,jj) + 2 .LE. mbkv(ji,jj) ) THEN 
     201               IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    202202                  tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) )   & 
    203203                               &            + ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) ) ) & 
    … …  
    209209         ! 
    210210         CALL lbc_lnk( bfrua, 'U', 1. )   ;   CALL lbc_lnk( bfrva, 'V', 1. )      ! Lateral boundary condition 
    211          CALL lbc_lnk( tfrua, 'U', 1. )   ;   CALL lbc_lnk( tfrva, 'V', 1. )      ! Lateral boundary condition 
    212211         ! 
    213212         IF(ln_ctl)   CALL prt_ctl( tab2d_1=bfrua, clinfo1=' bfr  - u: ', mask1=umask,        & 
    … …  
    300299         bfrua(:,:) = - bfrcoef2d(:,:) 
    301300         bfrva(:,:) = - bfrcoef2d(:,:) 
    302          ! 
    303          IF(ln_tfr2d) THEN 
    304             ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
    305             CALL iom_open('tfr_coef.nc',inum) 
    306             CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 
    307             CALL iom_close(inum) 
    308             tfrcoef2d(:,:) = rn_tfri1 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 
    309          ELSE 
    310             tfrcoef2d(:,:) = rn_tfri1  ! initialize tfrcoef2d to the namelist variable 
    311          ENDIF 
    312          ! 
    313          tfrua(:,:) = - tfrcoef2d(:,:) 
    314          tfrva(:,:) = - tfrcoef2d(:,:) 
    315301         ! 
    316302      CASE( 2 ) 
    … …  
    354340            bfrcoef2d(:,:) = rn_bfri2  ! initialize bfrcoef2d to the namelist variable 
    355341         ENDIF 
    356  
    357          IF(ln_tfr2d) THEN 
    358             ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
    359             CALL iom_open('tfr_coef.nc',inum) 
    360             CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! bfrcoef2d is used as tmp array 
    361             CALL iom_close(inum) 
    362             ! 
    363             tfrcoef2d(:,:) = rn_tfri2 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 
    364          ELSE 
    365             tfrcoef2d(:,:) = rn_tfri2  ! initialize tfrcoef2d to the namelist variable 
    366          ENDIF 
    367342         ! 
    368343         IF ( ln_loglayer.AND.(.NOT.lk_vvl) ) THEN ! set "log layer" bottom friction once for all 
    … …  
    381356                  bfrcoef2d(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 
    382357                  bfrcoef2d(ji,jj) = MIN(bfrcoef2d(ji,jj), rn_bfri2_max) 
    383                   ikbt = mikt(ji,jj) 
    384                   ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_tfrz0 ))**2._wp 
    385                   tfrcoef2d(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
    386                   tfrcoef2d(ji,jj) = MIN(tfrcoef2d(ji,jj), rn_tfri2_max) 
    387358               END DO 
    388359            END DO 
    … …  
    447418             zminbfr = MIN(  zminbfr, MIN( zfru, ABS( bfrcoef2d(ji,jj) ) )  ) 
    448419             zmaxbfr = MAX(  zmaxbfr, MIN( zfrv, ABS( bfrcoef2d(ji,jj) ) )  ) 
    449 ! (ISF) 
    450              ikbu = miku(ji,jj)       ! deepest ocean level at u- and v-points 
    451              ikbv = mikv(ji,jj) 
    452              zfru = 0.5 * fse3u(ji,jj,ikbu) / rdt 
    453              zfrv = 0.5 * fse3v(ji,jj,ikbv) / rdt 
    454              IF( ABS( tfrcoef2d(ji,jj) ) > zfru ) THEN 
    455                 IF( ln_ctl ) THEN 
    456                    WRITE(numout,*) 'BFR ', narea, nimpp+ji, njmpp+jj, ikbu 
    457                    WRITE(numout,*) 'BFR ', ABS( tfrcoef2d(ji,jj) ), zfru 
    458                 ENDIF 
    459                 ictu = ictu + 1 
    460              ENDIF 
    461              IF( ABS( tfrcoef2d(ji,jj) ) > zfrv ) THEN 
    462                  IF( ln_ctl ) THEN 
    463                      WRITE(numout,*) 'BFR ', narea, nimpp+ji, njmpp+jj, ikbv 
    464                      WRITE(numout,*) 'BFR ', tfrcoef2d(ji,jj), zfrv 
    465                  ENDIF 
    466                  ictv = ictv + 1 
    467              ENDIF 
    468              zmintfr = MIN(  zmintfr, MIN( zfru, ABS( tfrcoef2d(ji,jj) ) )  ) 
    469              zmaxtfr = MAX(  zmaxtfr, MIN( zfrv, ABS( tfrcoef2d(ji,jj) ) )  ) 
    470  
    471420         END DO 
    472421      END DO 
    … …  
    476425         CALL mpp_min( zminbfr ) 
    477426         CALL mpp_max( zmaxbfr ) 
    478          CALL mpp_min( zmintfr ) 
    479          CALL mpp_max( zmaxtfr ) 
    480427      ENDIF 
    481428      IF( .NOT.ln_bfrimp) THEN 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r4624 r4924  
    12581258               en  (:,:,:) = rn_emin 
    12591259               mxln(:,:,:) = 0.001         
     1260               avt_k (:,:,:) = avt (:,:,:) 
     1261               avm_k (:,:,:) = avm (:,:,:) 
     1262               avmu_k(:,:,:) = avmu(:,:,:) 
     1263               avmv_k(:,:,:) = avmv(:,:,:) 
    12601264               DO jit = nit000 + 1, nit000 + 10   ;   CALL zdf_gls( jit )   ;   END DO 
    12611265            ENDIF 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r4724 r4924  
    124124      IF(lwp) WRITE(numout,*) 
    125125      IF(lwp) WRITE(numout,*) '   convection :' 
     126      ! 
     127      IF( ln_zdfnpc )   CALL ctl_stop( ' zdf_init: non penetrative convective scheme is not working',   & 
     128         &                                       ' set ln_zdfnpc to FALSE' ) 
     129      ! 
    126130      ioptio = 0 
    127131      IF( ln_zdfnpc ) THEN 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r4645 r4924  
    8686   USE sbctide, ONLY: lk_tide 
    8787   USE crsini          ! initialise grid coarsening utility 
    88    USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges  
     88   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
    8989 
    9090   IMPLICIT NONE 
    … …  
    568568      ENDIF 
    569569      ! 
    570       IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   & 
    571          &                                               'with the IOM Input/Output manager. '         ,   & 
    572          &                                               'Compile with key_iomput enabled' ) 
    573       ! 
    574570      IF( 1_wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ',  & 
    575571         &                                               'f2003 standard. '                              ,  & 
    … …  
    803799          !loop over the other north-fold processes to find the processes 
    804800          !managing the points belonging to the sxT-dxT range 
    805           DO jn = jpnij - jpni +1, jpnij 
    806              IF ( njmppt(jn) == njmppmax ) THEN 
     801   
     802          DO jn = 1, jpni 
    807803                !sxT is the first point (in the global domain) of the jn 
    808804                !process 
    809                 sxT = nimppt(jn) 
     805                sxT = nfiimpp(jn, jpnj) 
    810806                !dxT is the last point (in the global domain) of the jn 
    811807                !process 
    812                 dxT = nimppt(jn) + nlcit(jn) - 1 
     808                dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 
    813809                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 
    814810                   nsndto = nsndto + 1 
    815                    isendto(nsndto) = jn 
     811                     isendto(nsndto) = jn 
    816812                ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN 
    817813                   nsndto = nsndto + 1 
    818                    isendto(nsndto) = jn 
     814                     isendto(nsndto) = jn 
    819815                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 
    820816                   nsndto = nsndto + 1 
    821                    isendto(nsndto) = jn 
     817                     isendto(nsndto) = jn 
    822818                END IF 
    823              END IF 
    824819          END DO 
     820          nfsloop = 1 
     821          nfeloop = nlci 
     822          DO jn = 2,jpni-1 
     823           IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN 
     824              IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN 
     825                 nfsloop = nldi 
     826              ENDIF 
     827              IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN 
     828                 nfeloop = nlei 
     829              ENDIF 
     830           ENDIF 
     831        END DO 
     832 
    825833      ENDIF 
    826834      l_north_nogather = .TRUE. 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r4724 r4924  
    9898      ALLOCATE(rhd (jpi,jpj,jpk) ,                                         & 
    9999         &     rhop(jpi,jpj,jpk) ,                                         & 
     100         &     rke(jpi,jpj,jpk)  ,                                         & 
    100101         &     sshb(jpi,jpj)     , sshn(jpi,jpj)   , ssha(jpi,jpj)   ,     & 
    101102         &     ub_b(jpi,jpj)     , un_b(jpi,jpj)   , ua_b(jpi,jpj)   ,     & 

  • branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/step.F90

    r4724 r4924  
    252252            &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
    253253      ELSE                                                  ! centered hpg  (eos then time stepping) 
    254          IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    255                              CALL tra_nxt( kstp )                ! tracer fields at next time step 
    256254         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    257                              CALL eos    ( tsb, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    258          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
     255                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
     256         IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    259257         &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    260258         &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
    261259         ENDIF 
     260         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
     261                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    262262      ENDIF 
    263263 
    … …  
    306306      IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    307307 
    308       IF( lrst_oce .AND. ln_diahsb )   CALL dia_hsb_rst( kstp, 'WRITE' ) 
    309308      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    310309      ! Control and restarts 
Note: See TracChangeset for help on using the changeset viewer.