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 7256 for branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC – NEMO

Ignore:
Timestamp:
2016-11-18T08:18:45+01:00 (8 years ago)
Author:
cbricaud
Message:

phaze NEMO routines in CRS branch with nemo_v3_6_STABLE branch at rev 7213 (09-09-2016) (merge -r 5519:7213 )

Location:
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC
Files:
1 deleted
78 edited

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r5602 r7256  
    658658 
    659659      DO jk = 1, jpkm1 
    660          fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 
     660        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 
    661661      END DO 
    662662 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r5602 r7256  
    430430      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    431431      CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files 
     432      CHARACTER(len = 256)::   clname                           ! temporary file name 
    432433      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    433434                                                                ! =F => baroclinic velocities in 3D boundary data 
    … …  
    669670            ! sea ice 
    670671            IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 
    671  
    672                ! Test for types of ice input (lim2 or lim3)  
    673                CALL iom_open ( bn_a_i%clname, inum ) 
    674                id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     672               ! Test for types of ice input (lim2 or lim3) 
     673               ! Build file name to find dimensions  
     674               clname=TRIM(bn_a_i%clname) 
     675               IF( .NOT. bn_a_i%ln_clim ) THEN    
     676                                                  WRITE(clname, '(a,"_y",i4.4)' ) TRIM( bn_a_i%clname ), nyear    ! add year 
     677                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname        ), nmonth   ! add month 
     678               ELSE 
     679                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( bn_a_i%clname ), nmonth   ! add month 
     680               ENDIF 
     681               IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 
     682               &                                  WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname        ), nday     ! add day 
     683               ! 
     684               CALL iom_open  ( clname, inum ) 
     685               id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
    675686               CALL iom_close ( inum ) 
    676                !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 
    677                !CALL iom_open ( bn_a_i%clname, inum ) 
    678                !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     687 
    679688                IF ( zndims == 4 ) THEN 
    680689                 ll_bdylim3 = .TRUE.   ! lim3 input 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r5602 r7256  
    4949      !!---------------------------------------------------------------------- 
    5050      INTEGER,                      INTENT(in) ::   kt   ! Main time step counter 
    51       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
    52       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pub2d, pvb2d 
    53       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phur, phvr 
    54       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh 
     51      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
     52      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pub2d, pvb2d 
     53      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: phur, phvr 
     54      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pssh 
    5555      !! 
    5656      INTEGER                                  ::   ib_bdy ! Loop counter 
    … …  
    9292      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    9393      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    94       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
     94      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
    9595      !! 
    9696      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    147147      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    148148      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    149       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    150       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr  
     149      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 
     150      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pssh, phur, phvr  
    151151 
    152152      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    … …  
    237237      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    238238      INTEGER,                      INTENT(in) ::   ib_bdy  ! number of current open boundary set 
    239       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    240       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d  
     239      REAL(wp), DIMENSION(:,:),    INTENT(inout) :: pua2d, pva2d 
     240      REAL(wp), DIMENSION(:,:),    INTENT(in) :: pub2d, pvb2d  
    241241      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version 
    242242 
    … …  
    271271      !! 
    272272      !!---------------------------------------------------------------------- 
    273       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level 
     273      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zssh ! Sea level 
    274274      !! 
    275275      INTEGER  ::   ib_bdy, ib, igrd                        ! local integers 
    276       INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       " 
     276      INTEGER  ::   ii, ij, zcoef, ip, jp   !   "       " 
    277277 
    278278      igrd = 1                       ! Everything is at T-points here 
    … …  
    283283            ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    284284            ! Set gradient direction: 
    285             zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  ) 
    286             zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1) 
    287             IF ( zcoef1+zcoef2 == 0 ) THEN 
    288                ! corner 
    289 !               zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) +  tmask(ii,ij-1,1) +  tmask(ii,ij+1,1) 
    290 !               zssh(ii,ij) = zssh(ii-1,ij  ) * tmask(ii-1,ij  ,1) + & 
    291 !                 &           zssh(ii+1,ij  ) * tmask(ii+1,ij  ,1) + & 
    292 !                 &           zssh(ii  ,ij-1) * tmask(ii  ,ij-1,1) + & 
    293 !                 &           zssh(ii  ,ij+1) * tmask(ii  ,ij+1,1) 
    294                zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
    295                zssh(ii,ij) = zssh(ii-1,ij  ) * bdytmask(ii-1,ij  ) + & 
    296                  &           zssh(ii+1,ij  ) * bdytmask(ii+1,ij  ) + & 
    297                  &           zssh(ii  ,ij-1) * bdytmask(ii  ,ij-1) + & 
    298                  &           zssh(ii  ,ij+1) * bdytmask(ii  ,ij+1) 
    299                zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 
     285            zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
     286            IF ( zcoef == 0 ) THEN 
     287               zssh(ii,ij) = 0._wp 
    300288            ELSE 
    301289               ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r5602 r7256  
    107107      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    108108      REAL(wp) ::   ztmelts, zdh 
     109#if  defined key_lim2 && ! defined key_lim2_vp && defined key_agrif 
     110     USE ice_2, vt_s => hsnm 
     111     USE ice_2, vt_i => hicm 
     112#endif 
    109113 
    110114      !!------------------------------------------------------------------------------ 
    … …  
    115119      ! 
    116120#if defined key_lim2 
    117       DO jb = 1, idx%nblen(jgrd) 
     121      DO jb = 1, idx%nblenrim(jgrd) 
    118122         ji    = idx%nbi(jb,jgrd) 
    119123         jj    = idx%nbj(jb,jgrd) 
    … …  
    135139 
    136140      DO jl = 1, jpl 
    137          DO jb = 1, idx%nblen(jgrd) 
     141         DO jb = 1, idx%nblenrim(jgrd) 
    138142            ji    = idx%nbi(jb,jgrd) 
    139143            jj    = idx%nbj(jb,jgrd) 
    … …  
    171175 
    172176      DO jl = 1, jpl 
    173          DO jb = 1, idx%nblen(jgrd) 
     177         DO jb = 1, idx%nblenrim(jgrd) 
    174178            ji    = idx%nbi(jb,jgrd) 
    175179            jj    = idx%nbj(jb,jgrd) 
    … …  
    324328                
    325329               jgrd = 2      ! u velocity 
    326                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     330               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    327331                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    328332                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    … …  
    353357                
    354358               jgrd = 3      ! v velocity 
    355                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     359               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    356360                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    357361                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r4990 r7256  
    7676      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    7777      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    78       INTEGER  ::   iw, ie, is, in, inum, id_dummy         !   -       - 
     78      INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy         !   -       - 
    7979      INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    8080      INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
    … …  
    777777!      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    778778!      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    779       iw = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
    780       ie = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
    781       is = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
    782       in = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
     779      iwe = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
     780      ies = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
     781      iso = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
     782      ino = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
    783783 
    784784      ALLOCATE( nbondi_bdy(nb_bdy)) 
    … …  
    853853               ENDIF 
    854854               ! check if point is in local domain 
    855                IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    856                   & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in       ) THEN 
     855               IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     856                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
    857857                  ! 
    858858                  icount = icount  + 1 
    … …  
    890890         com_south_b = 0 
    891891         com_north_b = 0 
     892 
    892893         DO igrd = 1, jpbgrd 
    893894            icount  = 0 
    … …  
    896897               DO ib = 1, nblendta(igrd,ib_bdy) 
    897898                  ! check if point is in local domain and equals ir 
    898                   IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    899                      & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in .AND.   & 
     899                  IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     900                     & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND.   & 
    900901                     & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    901902                     ! 
    … …  
    15941595            ELSE 
    15951596               ! This is a corner 
    1596                WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
     1597               IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
    15971598               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) 
    15981599               itest=itest+1 
    … …  
    16081609            ELSE 
    16091610               ! This is a corner 
    1610                WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
     1611               IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
    16111612               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) 
    16121613               itest=itest+1 
    … …  
    16381639            ELSE 
    16391640               ! This is a corner 
    1640                WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
     1641               IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
    16411642               CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) 
    16421643               itest=itest+1 
    … …  
    16521653            ELSE 
    16531654               ! This is a corner 
    1654                WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
     1655               IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
    16551656               CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) 
    16561657               itest=itest+1 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r5602 r7256  
    416416      ! Absolute time from model initialization:    
    417417      IF( PRESENT(kit) ) THEN   
    418          z_arg = ( kt + (kit+0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt 
     418         z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt 
    419419      ELSE                               
    420420         z_arg = ( kt + time_add ) * rdt 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r4990 r7256  
    9191      ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 
    9292      ! ----------------------------------------------------------------------- 
    93       z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+rdivisf*fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
     93      z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
    9494      IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain 
    9595 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r5602 r7256  
    6060 
    6161                             indic = 0                ! reset to no error condition 
    62       IF( kstp == nit000 )   CALL iom_init( "nemo")   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
     62      IF( kstp == nit000 )   CALL iom_init( cxios_context )   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    6363      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    64                              CALL iom_setkt( kstp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp 
     64                             CALL iom_setkt( kstp - nit000 + 1, cxios_context )   ! say to iom that we are at time step kstp 
    6565 
    6666      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r7217 r7256  
    185185      ! Horizontal diffusion 
    186186#if defined key_traldf_c3d 
    187    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 3D coefficients ** at T-,U-,V-,W-points 
     187      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 3D coefficients ** at T-,U-,V-,W-points 
    188188#elif defined key_traldf_c2d 
    189    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 2D coefficients ** at T-,U-,V-,W-points 
     189      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 2D coefficients ** at T-,U-,V-,W-points 
    190190#elif defined key_traldf_c1d 
    191    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 1D coefficients ** at T-,U-,V-,W-points 
     191      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 1D coefficients ** at T-,U-,V-,W-points 
    192192#else 
    193    REAL(wp), PUBLIC                                      ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 0D coefficients ** at T-,U-,V-,W-points 
    194 #endif 
     193      REAL(wp), PUBLIC                                      ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 0D coefficients ** at T-,U-,V-,W-points 
     194#endif 
     195      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap_crs 
    195196 
    196197      ! Vertical diffusion 
    … …  
    323324#if defined key_traldf_c3d 
    324325      ALLOCATE( ahtt_crs(jpi_crs,jpj_crs,jpk) , ahtu_crs(jpi_crs,jpj_crs,jpk) , & 
    325               & ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 
     326              & ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , & 
    326327#elif defined key_traldf_c2d 
    327328      ALLOCATE( ahtt_crs(jpi_crs,jpj_crs    ) , ahtu_crs(jpi_crs,jpj_crs    ) , & 
    328               & ahtv_crs(jpi_crs,jpj_crs    ) , ahtw_crs(jpi_crs,jpj_crs    ) , STAT=ierr(13) ) 
     329              & ahtv_crs(jpi_crs,jpj_crs    ) , ahtw_crs(jpi_crs,jpj_crs    ) , & 
    329330#elif defined key_traldf_c1d 
    330       ALLOCATE( ahtt_crs(        jpk) , ahtu_crs(        jpk) , ahtv_crs(        jpk) , ahtw_crs(        jpk) , STAT=ierr(13) ) 
    331 #endif 
     331      ALLOCATE( ahtt_crs(        jpk) , ahtu_crs(        jpk) , ahtv_crs(        jpk) , ahtw_crs(        jpk) , & 
     332#endif 
     333              & r_fact_lap_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 
    332334 
    333335     ALLOCATE( tsb_crs(jpi_crs,jpj_crs,jpk,jpts), tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsa_crs(jpi_crs,jpj_crs,jpk,jpts),  & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r7222 r7256  
    460460                           ijis = mis_crs(ji) 
    461461                           ijie = mie_crs(ji) 
    462                            zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
    463                            zsfcrs = SUM(                                 zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     462                           zflcrs = SUM( ztabtmp(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     463                           zsfcrs = SUM(                                   zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
    464464                           p_fld_crs(ji,jj,jk) = zflcrs 
    465465                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90

    r7222 r7256  
    2525   USE crsdom 
    2626   USE domvvl 
    27    USE domvvl_crs 
    2827   USE crslbclnk 
    2928   USE iom 
    3029   USE zdfmxl_crs 
    3130   USE eosbn2 
    32    USE zdfevd_crs 
    3331   USE zdftke 
    34    USE zdftke_crs 
    3532 
    3633   USE ieee_arithmetic 
    … …  
    197194      CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 
    198195      CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) 
    199       CALL iom_put("e2e3u_crs",e2e3u_crs) 
    200       CALL iom_put("e2e3u_msk",e2e3u_msk) 
    201       CALL iom_put("e1e3v_crs",e1e3v_crs) 
    202       CALL iom_put("e1e3v_msk",e1e3v_msk) 
     196      !cbr CALL iom_put("e2e3u_crs",e2e3u_crs) 
     197      !CALL iom_put("e2e3u_msk",e2e3u_msk) 
     198      !CALL iom_put("e1e3v_crs",e1e3v_crs) 
     199      !CALL iom_put("e1e3v_msk",e1e3v_msk) 
    203200 
    204201      ! vertical scale factors                                                                                  
    … …  
    233230      ! volume and facvol 
    234231      CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, ocean_volume_crs_t, facvol_t ) 
    235       CALL iom_put("cvol_crs_t",ocean_volume_crs_t) 
     232      !cbr CALL iom_put("cvol_crs_t",ocean_volume_crs_t) 
    236233      ! 
    237234      bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:)*tmask_crs(:,:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    r7217 r7256  
    8888     ! 
    8989 
    90       REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    91       READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
    92 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
    93  
    94       REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    95       READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
    96 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
    97       IF(lwm) WRITE ( numond, namcrs ) 
    98  
     90     REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
     91     READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
     92901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
     93 
     94     REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
     95     READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
     96902  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
     97     IF(lwm) WRITE ( numond, namcrs ) 
     98 
     99     IF( .NOT. lk_crs )ln_crs_top = .FALSE.   
     100  
    99101     IF(lwp) THEN 
    100102        WRITE(numout,*) 
    … …  
    104106        WRITE(numout,*) '   create (=1) a mesh file or not (=0)   nn_msh_crs = ', nn_msh_crs 
    105107        WRITE(numout,*) '   type of Kz coarsening (0,1,2)         nn_crs_kz  = ', nn_crs_kz 
    106         WRITE(numout,*) '   wn coarsened or computed using hdivn  ln_crs_wn  = ', ln_crs_wn 
     108 
     109        IF( ln_crs_wn )THEN  
     110           WRITE(numout,*) '   vertical velocities are coarsened ' 
     111        ELSE 
     112           WRITE(numout,*) '   computed using hdivn ' 
     113        ENDIF 
     114 
     115        IF( .NOT. lk_crs )ln_crs_top = .FALSE.   
     116 
     117        IF( ln_crs_top )THEN ; WRITE(numout,*) '   coarsning of physics activated for outputs and BGC model' 
     118        ELSE                 ; WRITE(numout,*) '   coarsning of physics activated only for outputs'    
     119        ENDIF 
    107120 
    108121        SELECT CASE ( nn_crs_kz ) 
    … …  
    113126           CASE ( 4 ) ; WRITE(numout,*) '   coarsene KZ with MEDIANE(KZ)' 
    114127       END SELECT 
     128 
    115129     ENDIF 
    116130               

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r5602 r7256  
    211211      REAL(wp) ::   zztmp   
    212212      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    213       ! reading initial file 
    214       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    215       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    216       CHARACTER(len=100)            ::   cn_dir 
    217       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    218       INTEGER  ::   ios=0 
    219  
    220       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    221       ! 
    222  
    223       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    224       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    225 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    226       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    227       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    228 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    229       IF(lwm) WRITE ( numond, namtsd ) 
    230213      ! 
    231214      !!---------------------------------------------------------------------- 
    … …  
    233216      IF( nn_timing == 1 )   CALL timing_start('dia_ar5_init') 
    234217      ! 
    235       CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta ) 
     218      CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 
    236219      !                                      ! allocate dia_ar5 arrays 
    237220      IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
    … …  
    249232      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    250233 
    251       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    252       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    253       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     234      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     235      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     236      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    254237      CALL iom_close( inum ) 
     238 
    255239      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    256240      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    … …  
    267251      ENDIF 
    268252      ! 
    269       CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta ) 
     253      CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 
    270254      ! 
    271255      IF( nn_timing == 1 )   CALL timing_stop('dia_ar5_init') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r5602 r7256  
    196196                  DO ji = 1,jpi 
    197197                     ! Elevation 
    198                      ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
    199 #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 
     198                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj)         
     199                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 
     200                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 
    203201                  END DO 
    204202               END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r5602 r7256  
    3838   PUBLIC   dia_hsb        ! routine called by step.F90 
    3939   PUBLIC   dia_hsb_init   ! routine called by nemogcm.F90 
    40    PUBLIC   dia_hsb_rst    ! routine called by step.F90 
    4140 
    4241   LOGICAL, PUBLIC ::   ln_diahsb   !: check the heat and salt budgets 
    … …  
    8685      !!--------------------------------------------------------------------------- 
    8786      IF( nn_timing == 1 )   CALL timing_start('dia_hsb')       
     87      ! 
    8888      CALL wrk_alloc( jpi,jpj,   z2d0, z2d1 ) 
    8989      ! 
    … …  
    9393      ! 1 - Trends due to forcing ! 
    9494      ! ------------------------- ! 
    95       z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
     95      z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    … …  
    101101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103           z_frc_trd_t = z_frc_trd_t & 
    104               &   + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 
    105           z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
     103          z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
     104          z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
    106105      ENDIF 
    107106 
    … …  
    175174      ENDDO 
    176175 
    177       ! Substract forcing from heat content, salt content and volume variations 
     176      ! ------------------------ ! 
     177      ! 3 -  Drifts              ! 
     178      ! ------------------------ ! 
    178179      zdiff_v1 = zdiff_v1 - frc_v 
    179180      IF( lk_vvl )   zdiff_v2 = zdiff_v2 - frc_v 
    … …  
    188189 
    189190      ! ----------------------- ! 
    190       ! 3 - Diagnostics writing ! 
     191      ! 4 - Diagnostics writing ! 
    191192      ! ----------------------- ! 
    192193      zvol_tot = 0._wp                    ! total ocean volume (calculated with scale factors) 
    … …  
    201202!!gm end 
    202203 
     204      CALL iom_put(   'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
     205      CALL iom_put(   'bgfrctem' , frc_t    * rau0 * rcp * 1.e-20 )   ! hc  - surface forcing (1.e20 J)  
     206      CALL iom_put(   'bgfrchfx' , frc_t    * rau0 * rcp /  &         ! hc  - surface forcing (W/m2)  
     207         &                       ( surf_tot * kt * rdt )        ) 
     208      CALL iom_put(   'bgfrcsal' , frc_s    * 1.e-9    )              ! sc  - surface forcing (psu*km3)  
    203209 
    204210      IF( lk_vvl ) THEN 
    205         CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature variation (C)  
    206         CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    variation (psu) 
    207         CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content variation (1.e20 J)  
    208         CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content variation (psu*km3) 
    209         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    210         CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t variation (km3)   
    211         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    212         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    213         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     211        CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature drift     (C)  
     212        CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    drift     (pss) 
     213        CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content drift    (1.e20 J)  
     214        CALL iom_put( 'bgheatfx' , zdiff_hc * rau0 * rcp /  &         ! Heat flux drift       (W/m2)  
     215           &                       ( surf_tot * kt * rdt )        ) 
     216        CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content drift    (psu*km3) 
     217        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
     218        CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t drift      (km3)   
    214219      ELSE 
    215         CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content variation (C)  
    216         CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content variation (psu) 
    217         CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content variation (1.e20 J)  
    218         CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content variation (psu*km3) 
    219         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    220         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    221         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    222         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     220        CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content drift    (C)  
     221        CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content drift    (pss) 
     222        CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content drift    (1.e20 J)  
     223        CALL iom_put( 'bgheatfx' , zdiff_hc1 * rau0 * rcp /  &        ! Heat flux drift       (W/m2)  
     224           &                       ( surf_tot * kt * rdt )         ) 
     225        CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content drift    (psu*km3) 
     226        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
    223227        CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot )              ! hc  - error due to free surface (C) 
    224228        CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot )              ! sc  - error due to free surface (psu) 
    … …  
    246250     ! 
    247251     INTEGER ::   ji, jj, jk   ! dummy loop indices 
    248      INTEGER ::   id1          ! local integers 
    249252     !!---------------------------------------------------------------------- 
    250253     ! 
    251254     IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    252255        IF( ln_rstart ) THEN                   !* Read the restart file 
    253            !id1 = iom_varid( numror, 'frc_vol'  , ldstop = .FALSE. ) 
    254256           ! 
    255257           IF(lwp) WRITE(numout,*) '~~~~~~~' 
    … …  
    263265              CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 
    264266           ENDIF 
    265            CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini ) 
    266            CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini ) 
    267            CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini ) 
    268            CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini ) 
     267           CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini(:,:) ) 
     268           CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini(:,:,:) ) 
     269           CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     270           CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    269271           IF( .NOT. lk_vvl ) THEN 
    270               CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    271               CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     272              CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     273              CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    272274           ENDIF 
    273275       ELSE 
    … …  
    314316           CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 
    315317        ENDIF 
    316         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini ) 
    317         CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini ) 
    318         CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 
    319         CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 
     318        CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini(:,:) ) 
     319        CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini(:,:,:) ) 
     320        CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     321        CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    320322        IF( .NOT. lk_vvl ) THEN 
    321            CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    322            CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     323           CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     324           CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    323325        ENDIF 
     326 
    324327        ! 
    325328     ENDIF 
    … …  
    340343      !!             - Compute coefficients for conversion 
    341344      !!--------------------------------------------------------------------------- 
    342       INTEGER ::   jk       ! dummy loop indice 
    343345      INTEGER ::   ierror   ! local integer 
    344346      INTEGER ::   ios 
    … …  
    346348      NAMELIST/namhsb/ ln_diahsb 
    347349      !!---------------------------------------------------------------------- 
    348  
    349       IF(lwp) THEN 
    350          WRITE(numout,*) 
    351          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    352          WRITE(numout,*) '~~~~~~~~ ' 
    353       ENDIF 
    354350 
    355351      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist 
    … …  
    362358      IF(lwm) WRITE ( numond, namhsb ) 
    363359 
    364       ! 
    365       IF(lwp) THEN                   ! Control print 
     360      IF(lwp) THEN 
    366361         WRITE(numout,*) 
    367          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    368          WRITE(numout,*) '~~~~~~~~~~~~' 
    369          WRITE(numout,*) '   Namelist namhsb : set hsb parameters' 
    370          WRITE(numout,*) '      Switch for hsb diagnostic (T) or not (F)  ln_diahsb  = ', ln_diahsb 
    371          WRITE(numout,*) 
    372       ENDIF 
    373  
     362         WRITE(numout,*) 'dia_hsb_init' 
     363         WRITE(numout,*) '~~~~~~~~ ' 
     364         WRITE(numout,*) '  check the heat and salt budgets (T) or not (F)       ln_diahsb = ', ln_diahsb 
     365      ENDIF 
     366      ! 
    374367      IF( .NOT. ln_diahsb )   RETURN 
    375368         !      IF( .NOT. lk_mpp_rep ) & 
    … …  
    384377         &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror ) 
    385378      IF( ierror > 0 ) THEN 
    386          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
    387       ENDIF 
    388  
    389       IF(.NOT. lk_vvl ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) 
    390       IF( ierror > 0 ) THEN 
    391          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
     379         CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     380         RETURN 
     381      ENDIF 
     382 
     383      IF( .NOT. lk_vvl ) THEN 
     384         ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj), STAT=ierror ) 
     385         IF( ierror > 0 )   THEN 
     386            CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     387            RETURN 
     388         ENDIF 
    392389      ENDIF 
    393390 
    … …  
    395392      ! 2 - Time independant variables and file opening ! 
    396393      ! ----------------------------------------------- ! 
    397       IF(lwp) WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 
    398       IF(lwp) WRITE(numout,*) '~~~~~~~' 
    399394      surf(:,:) = e1t(:,:) * e2t(:,:) * tmask_i(:,:)      ! masked surface grid cell area 
    400       surf_tot  = glob_sum( surf(:,:) )                                       ! total ocean surface area 
     395      surf_tot  = glob_sum( surf(:,:) )                   ! total ocean surface area 
    401396 
    402397      IF( lk_bdy ) CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' )          

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r5602 r7256  
    145145      ENDIF 
    146146 
    147       IF( .NOT.lk_vvl ) THEN 
    148          CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
    149          CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
    150          CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
    151          CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
    152       ENDIF 
     147      ! Output of initial vertical scale factor 
     148      CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
     149      CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
     150      CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
     151      ! 
     152      CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     153      CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     154      CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     155      CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     156      IF( iom_use("e3tdef") )   & 
     157         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
     158 
    153159 
    154160      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
    155       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    156161       
    157162      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    243248      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
    244249      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     250                                                            ! Log of eddy diff coef 
     251      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
     252      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    245253 
    246254      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    307315         CALL iom_put( "eken", rke )            
    308316      ENDIF 
    309           
     317      ! 
     318      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
     319      ! 
    310320      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    311321         z3d(:,:,jpk) = 0.e0 
    … …  
    438448      zdt = rdt 
    439449      IF( nacc == 1 ) zdt = rdtmin 
    440       IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!) 
    441       ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time) 
    442       ENDIF 
     450      clop = "x"         ! no use of the mask value (require less cpu time, and otherwise the model crashes) 
    443451#if defined key_diainstant 
    444452      zsto = nwrite * zdt 
    … …  
    10201028         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
    10211029            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
     1030         CALL histdef( id_i, "vovvle3t", "T point thickness"         , "m"      ,   &   ! t-point depth 
     1031            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    10221032      END IF 
    10231033 
    … …  
    10501060      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress 
    10511061      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress 
     1062      IF( lk_vvl ) THEN 
     1063         CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth        
     1064         CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )!  T-cell thickness   
     1065      END IF 
    10521066 
    10531067      ! 3. Close the file 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r5602 r7256  
    158158         CASE ( 025 )                                ! ORCA_R025 configuration 
    159159            !                                        ! ======================= 
     160            isrow = 1207 - jpjglo                    !  eORCA025 R025 - Using full isf­extended   
     161                                                     !  domain for reference. - Adjust j­indices 
    160162            ncsnr(1)   = 1    ; ncstt(1)   = 0               ! Caspian + Aral sea 
    161             ncsi1(1)   = 1330 ; ncsj1(1)   = 645 
    162             ncsi2(1)   = 1400 ; ncsj2(1)   = 795 
     163            ncsi1(1)   = 1330 ; ncsj1(1)   = 831 - isrow 
     164            ncsi2(1)   = 1400 ; ncsj2(1)   = 981 - isrow 
    163165            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
    164166            !                                         
    165167            ncsnr(2)   = 1    ; ncstt(2)   = 0               ! Azov Sea  
    166             ncsi1(2)   = 1284 ; ncsj1(2)   = 722 
    167             ncsi2(2)   = 1304 ; ncsj2(2)   = 747 
     168            ncsi1(2)   = 1284 ; ncsj1(2)   = 908 - isrow 
     169            ncsi2(2)   = 1304 ; ncsj2(2)   = 933 - isrow 
    168170            ncsir(2,1) = 1    ; ncsjr(2,1) = 1 
     171            ! 
     172            ncsnr(3)   = 1    ; ncstt(3)   = 0               ! Great Lakes 
     173            ncsi1(3)   = 775  ; ncsj1(3)   = 866 - isrow 
     174            ncsi2(3)   = 848  ; ncsj2(3)   = 931 - isrow 
     175            ncsir(3,1) = 1    ; ncsjr(3,1) = 1 
     176            !    
     177            ncsnr(4)   = 1    ; ncstt(4)   = 0               ! Lake Victoria 
     178            ncsi1(4)   = 1270 ; ncsj1(4)   = 661 - isrow 
     179            ncsi2(4)   = 1295 ; ncsj2(4)   = 696 - isrow 
     180            ncsir(4,1) = 1    ; ncsjr(4,1) = 1 
     181            !         
    169182            ! 
    170183         END SELECT 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r5002 r7256  
    7373      !!---------------------------------------------------------------------- 
    7474      ! 
     75      ! max number of seconds between each restart 
     76      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 
     77         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   & 
     78            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 
     79      ENDIF 
    7580      ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 
    7681      IF( MOD( rday     , rdttra(1) ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 
    … …  
    238243               nday_year = 1 
    239244               nsec_year = ndt05 
    240                IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN   ! test integer 4 max value 
    241                   CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ',   & 
    242                      &           'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', & 
    243                      & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' ) 
    244                ENDIF 
    245245               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 
    246246               IF( nleapy == 1 )   CALL day_mth 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r5602 r7256  
    169169            ! 
    170170            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u = 20 km) 
    171             ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
     171            ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
    172172            IF(lwp) WRITE(numout,*) 
    173173            IF(lwp) WRITE(numout,*) '             orca_r1: Gibraltar : e2u reduced to 20 km' 
    174174 
    175175            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
    176             ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
     176            ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
    177177            IF(lwp) WRITE(numout,*) 
    178178            IF(lwp) WRITE(numout,*) '             orca_r1: Bhosporus : e2u reduced to 10 km' 
    179179 
    180180            ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
    181             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
     181            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
    182182            IF(lwp) WRITE(numout,*) 
    183183            IF(lwp) WRITE(numout,*) '             orca_r1: Lombok : e1v reduced to 10 km' 
    184184 
    185185            ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
    186             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
     186            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
    187187            IF(lwp) WRITE(numout,*) 
    188188            IF(lwp) WRITE(numout,*) '             orca_r1: Sumba : e1v reduced to 8 km' 
    189189 
    190190            ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
    191             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
     191            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
    192192            IF(lwp) WRITE(numout,*) 
    193193            IF(lwp) WRITE(numout,*) '             orca_r1: Ombai : e1v reduced to 13 km' 
    194194 
    195195            ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
    196             ij0 = 124 + isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
     196            ij0 = 164 - isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
    197197            IF(lwp) WRITE(numout,*) 
    198198            IF(lwp) WRITE(numout,*) '             orca_r1: Timor Passage : e1v reduced to 20 km' 
    199199 
    200200            ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
    201             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
     201            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
    202202            IF(lwp) WRITE(numout,*) 
    203203            IF(lwp) WRITE(numout,*) '             orca_r1: W Halmahera : e1v reduced to 30 km' 
    204204 
    205205            ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
    206             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
     206            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
    207207            IF(lwp) WRITE(numout,*) 
    208208            IF(lwp) WRITE(numout,*) '             orca_r1: E Halmahera : e1v reduced to 50 km' 
    … …  
    544544         IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN    ! for EEL6 configuration only 
    545545            IF( .NOT. Agrif_Root() ) THEN 
    546               zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 
     546              zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m)   &  
     547                    &           / (ra * rad) 
    547548            ENDIF 
    548549         ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r5602 r7256  
    413413         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    414414         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait  
    415          ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     415         ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    416416 
    417417         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    418418         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait  
    419          ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     419         ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    420420 
    421421         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    422422         ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top)  
    423          ij0 = 149 + isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     423         ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    424424 
    425425         IF(lwp) WRITE(numout,*) '      Lombok ' 
    426426         ii0 =  44           ;   ii1 =  44        ! Lombok Strait  
    427          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     427         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    428428 
    429429         IF(lwp) WRITE(numout,*) '      Ombai ' 
    430430         ii0 =  53           ;   ii1 =  53        ! Ombai Strait  
    431          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     431         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    432432 
    433433         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    434434         ii0 =  56           ;   ii1 =  56        ! Timor Passage  
    435          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     435         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    436436 
    437437         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    438438         ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait  
    439          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     439         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    440440 
    441441         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    442442         ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait  
    443          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     443         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    444444         ! 
    445445      ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r5602 r7256  
    665665         ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
    666666      END DO 
    667  
    668       ! Write outputs 
    669       ! ============= 
    670       CALL iom_put(     "e3t" , fse3t_n  (:,:,:) ) 
    671       CALL iom_put(     "e3u" , fse3u_n  (:,:,:) ) 
    672       CALL iom_put(     "e3v" , fse3v_n  (:,:,:) ) 
    673       CALL iom_put(     "e3w" , fse3w_n  (:,:,:) ) 
    674       CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) ) 
    675       IF( iom_use("e3tdef") )   & 
    676          CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    677667 
    678668      ! write restart file 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r4990 r7256  
    215215         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    216216         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
     217         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
     218         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )      
    217219      ENDIF 
    218220       

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r5602 r7256  
    219219         &  ppsur == pp_to_be_computed           ) THEN 
    220220         ! 
     221#if defined key_agrif 
     222         za1  = (  ppdzmin - pphmax / FLOAT(jpkdta-1)  )                                                   & 
     223            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * (  LOG( COSH( (jpkdta - ppkth) / ppacr) )& 
     224            &                                                      - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     225#else 
    221226         za1  = (  ppdzmin - pphmax / FLOAT(jpkm1)  )                                                      & 
    222227            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * (  LOG( COSH( (jpk - ppkth) / ppacr) )      & 
    223228            &                                                   - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     229#endif 
    224230         za0  = ppdzmin - za1 *              TANH( (1-ppkth) / ppacr ) 
    225231         zsur =   - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr )  ) 
    … …  
    236242              WRITE(numout,*) '            Uniform grid with ',jpk-1,' layers' 
    237243              WRITE(numout,*) '            Total depth    :', zhmax 
     244#if defined key_agrif 
     245              WRITE(numout,*) '            Layer thickness:', zhmax/(jpkdta-1) 
     246#else 
    238247              WRITE(numout,*) '            Layer thickness:', zhmax/(jpk-1) 
     248#endif 
    239249         ELSE 
    240250            IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN 
    … …  
    260270      ! Reference z-coordinate (depth - scale factor at T- and W-points) 
    261271      ! ====================== 
    262       IF( ppkth == 0._wp ) THEN            !  uniform vertical grid        
     272      IF( ppkth == 0._wp ) THEN            !  uniform vertical grid  
     273#if defined key_agrif 
     274         za1 = zhmax / FLOAT(jpkdta-1)  
     275#else 
    263276         za1 = zhmax / FLOAT(jpk-1)  
     277#endif 
    264278         DO jk = 1, jpk 
    265279            zw = FLOAT( jk ) 
    … …  
    18701884             iim1 = MAX( ji-1, 1 ) 
    18711885             ijm1 = MAX( jj-1, 1 ) 
    1872              IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) +              & 
    1873         &         bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 
    1874                zenv(ji,jj) = rn_sbot_min 
     1886             IF( ( + bathy(iim1,ijp1) + bathy(ji,ijp1) + bathy(iip1,ijp1)  & 
     1887                &  + bathy(iim1,jj  )                  + bathy(iip1,jj  )  & 
     1888                &  + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1)  ) > 0._wp ) THEN 
     1889                zenv(ji,jj) = rn_sbot_min 
    18751890             ENDIF 
    18761891           ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r5602 r7256  
    9797      IF( nn_timing == 1 )  CALL timing_start('div_cur') 
    9898      ! 
    99       CALL wrk_alloc( jpi  , jpj+2, zwu               ) 
    100       CALL wrk_alloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     99      CALL wrk_alloc( jpi  , jpj+2, zwu  ) 
     100      CALL wrk_alloc( jpi+2, jpj  , zwv ) 
    101101      ! 
    102102      IF( kt == nit000 ) THEN 
    … …  
    236236      CALL lbc_lnk( hdivn, 'T', 1. )   ;   CALL lbc_lnk( rotn , 'F', 1. )    ! lateral boundary cond. (no sign change) 
    237237      ! 
    238       CALL wrk_dealloc( jpi  , jpj+2, zwu               ) 
    239       CALL wrk_dealloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     238      CALL wrk_dealloc( jpi  , jpj+2, zwu ) 
     239      CALL wrk_dealloc( jpi+2, jpj  , zwv ) 
    240240      ! 
    241241      IF( nn_timing == 1 )  CALL timing_stop('div_cur') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r5602 r7256  
    266266               ! Add volume filter correction: compatibility with tracer advection scheme 
    267267               ! => time filter + conservation correction (only at the first level) 
    268                fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
    269                               &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     268               IF ( nn_isf == 0) THEN   ! if no ice shelf melting 
     269                  fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
     270                                 &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     271               ELSE                     ! if ice shelf melting 
     272                  DO jj = 1,jpj 
     273                     DO ji = 1,jpi 
     274                        jk = mikt(ji,jj) 
     275                        fse3t_b(ji,jj,jk) = fse3t_b(ji,jj,jk) - atfp * rdt * r1_rau0                       & 
     276                                          &                          * ( (emp_b(ji,jj)    - emp(ji,jj)   ) & 
     277                                          &                            - (rnf_b(ji,jj)    - rnf(ji,jj)   ) & 
     278                                          &                            + (fwfisf_b(ji,jj) - fwfisf(ji,jj)) ) * tmask(ji,jj,jk) 
     279                     END DO 
     280                  END DO 
     281               END IF 
    270282            ENDIF 
    271283            ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r5602 r7256  
    187187      ! 
    188188                                                       ! time offset in steps for bdy data update 
    189       IF (.NOT.ln_bt_fw) THEN ; noffset=-2*nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
     189      IF (.NOT.ln_bt_fw) THEN ; noffset=-nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
    190190      ! 
    191191      IF( kt == nit000 ) THEN                !* initialisation 
    … …  
    454454      !                                         ! Surface net water flux and rivers 
    455455      IF (ln_bt_fw) THEN 
    456          zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 
     456         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 
    457457      ELSE 
    458458         zssh_frc(:,:) = zraur * z1_2 * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
    459                 &                        + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) )       ) 
     459                &                        + fwfisf(:,:) + fwfisf_b(:,:)                     ) 
    460460      ENDIF 
    461461#if defined key_asminc 
    … …  
    465465      ENDIF 
    466466#endif 
    467       !                                   !* Fill boundary data arrays with AGRIF 
    468       !                                   ! ------------------------------------- 
     467      !                                   !* Fill boundary data arrays for AGRIF 
     468      !                                   ! ------------------------------------ 
    469469#if defined key_agrif 
    470470         IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) 
    … …  
    523523         ! Update only tidal forcing at open boundaries 
    524524#if defined key_tide 
    525          IF ( lk_bdy .AND. lk_tide )      CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
    526          IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset ) 
     525         IF ( lk_bdy .AND. lk_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
     526         IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, time_offset=noffset ) 
    527527#endif 
    528528         ! 
    … …  
    900900#if defined key_agrif 
    901901      ! Save time integrated fluxes during child grid integration 
    902       ! (used to update coarse grid transports) 
    903       ! Useless with 2nd order momentum schemes 
     902      ! (used to update coarse grid transports at next time step) 
    904903      ! 
    905904      IF ( (.NOT.Agrif_Root()).AND.(ln_bt_fw) ) THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r5602 r7256  
    323323            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
    324324            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    325                &                                      / ( ze3va * rau0 )  
     325               &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1) 
    326326#else 
    327327            va(ji,jj,1) = vb(ji,jj,1) & 
    328328               &                   + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    329                &                                                       / ( fse3v(ji,jj,1) * rau0     ) ) 
     329               &                                      / ( fse3v(ji,jj,1) * rau0     ) * vmask(ji,jj,1) ) 
    330330#endif 
    331331         END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r5602 r7256  
    3131   USE bdydyn2d        ! bdy_ssh routine 
    3232#if defined key_agrif 
    33    USE agrif_opa_update 
    3433   USE agrif_opa_interp 
    3534#endif 
    … …  
    268267      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    269268         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
    270          IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 
     269         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:)    - emp(:,:)    & 
     270                                &                                 - rnf_b(:,:)    + rnf(:,:)    & 
     271                                &                                 + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) 
    271272         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    272273      ENDIF 
    273       ! 
    274       ! Update velocity at AGRIF zoom boundaries 
    275 #if defined key_agrif 
    276       IF ( .NOT.Agrif_Root() ) CALL Agrif_Update_Dyn( kt ) 
    277 #endif 
    278274      ! 
    279275      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask, ovlap=1 ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    r5602 r7256  
    120120      ! first entry with narea for this processor is left hand interior index 
    121121      ! last  entry                               is right hand interior index 
    122       jj = jpj/2 
     122      jj = nlcj/2 
    123123      nicbdi = -1 
    124124      nicbei = -1 
    … …  
    136136      ! 
    137137      ! repeat for j direction 
    138       ji = jpi/2 
     138      ji = nlci/2 
    139139      nicbdj = -1 
    140140      nicbej = -1 
    … …  
    153153      ! special for east-west boundary exchange we save the destination index 
    154154      i1 = MAX( nicbdi-1, 1) 
    155       i3 = INT( src_calving(i1,jpj/2) ) 
     155      i3 = INT( src_calving(i1,nlcj/2) ) 
    156156      jj = INT( i3/nicbpack ) 
    157157      ricb_left = REAL( i3 - nicbpack*jj, wp ) 
    158158      i1 = MIN( nicbei+1, jpi ) 
    159       i3 = INT( src_calving(i1,jpj/2) ) 
     159      i3 = INT( src_calving(i1,nlcj/2) ) 
    160160      jj = INT( i3/nicbpack ) 
    161161      ricb_right = REAL( i3 - nicbpack*jj, wp ) 
    … …  
    196196         WRITE(numicb,*) 'berg left       ', ricb_left 
    197197         WRITE(numicb,*) 'berg right      ', ricb_right 
    198          jj = jpj/2 
     198         jj = nlcj/2 
    199199         WRITE(numicb,*) "central j line:" 
    200200         WRITE(numicb,*) "i processor" 
    … …  
    202202         WRITE(numicb,*) "i point" 
    203203         WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) 
    204          ji = jpi/2 
     204         ji = nlci/2 
    205205         WRITE(numicb,*) "central i line:" 
    206206         WRITE(numicb,*) "j processor" 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r7217 r7256  
    100100      CHARACTER(len=*), INTENT(in)  :: cdname 
    101101#if defined key_iomput 
    102       TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
    103       CHARACTER(len=19) :: cldate  
    104       CHARACTER(len=10) :: clname 
    105       INTEGER           ::   ji 
     102#if ! defined key_xios2 
     103      TYPE(xios_time)     :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
     104      CHARACTER(len=19)   :: cldate  
     105#else 
     106      TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0) 
     107      TYPE(xios_date)     :: start_date 
     108#endif 
     109      CHARACTER(len=10)   :: clname 
     110      INTEGER             :: ji 
    106111      ! 
    107112      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
    108113      !!---------------------------------------------------------------------- 
    109  
     114#if ! defined key_xios2 
    110115      ALLOCATE( z_bnds(jpk,2) ) 
     116#else 
     117      ALLOCATE( z_bnds(2,jpk) ) 
     118#endif 
    111119 
    112120      clname = cdname 
    … …  
    116124 
    117125      ! calendar parameters 
     126#if ! defined key_xios2 
    118127      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    119128      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") 
    … …  
    123132      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
    124133      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    125  
     134#else 
     135      ! Calendar type is now defined in xml file  
     136      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     137      CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 
     138          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     139      CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), & 
     140          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     141      CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), & 
     142          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     143      END SELECT 
     144#endif 
    126145      ! horizontal grid definition 
     146 
    127147      CALL set_scalar 
    128148 
    … …  
    176196 
    177197      ! Add vertical grid bounds 
     198#if ! defined key_xios2 
    178199      z_bnds(:      ,1) = gdepw_1d(:) 
    179200      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
    180201      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     202#else 
     203      z_bnds(1      ,:) = gdepw_1d(:) 
     204      z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     205      z_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     206#endif 
     207 
    181208      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
    182209      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
    183210      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
    184       z_bnds(:    ,2) = gdept_1d(:) 
    185       z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
    186       z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     211 
     212#if ! defined key_xios2 
     213      z_bnds(:    ,2)  = gdept_1d(:) 
     214      z_bnds(2:jpk,1)  = gdept_1d(1:jpkm1) 
     215      z_bnds(1    ,1)  = gdept_1d(1) - e3w_1d(1) 
     216#else 
     217      z_bnds(2,:    )  = gdept_1d(:) 
     218      z_bnds(1,2:jpk)  = gdept_1d(1:jpkm1) 
     219      z_bnds(1,1    )  = gdept_1d(1) - e3w_1d(1) 
     220#endif 
    187221      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     222 
    188223 
    189224# if defined key_floats 
    … …  
    11621197      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    11631198      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    1164       LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    1165  
     1199#if ! defined key_xios2 
     1200     LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
     1201#else 
     1202      LOGICAL,  DIMENSION(:) , OPTIONAL, INTENT(in) ::   mask 
     1203#endif 
     1204 
     1205#if ! defined key_xios2 
    11661206      IF ( xios_is_valid_domain     (cdid) ) THEN 
    11671207         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11701210            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
    11711211            &    bounds_lat=bounds_lat, area=area ) 
    1172       ENDIF 
    1173  
     1212     ENDIF 
    11741213      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    11751214         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11791218            &    bounds_lat=bounds_lat, area=area ) 
    11801219      ENDIF 
     1220 
     1221#else 
     1222      IF ( xios_is_valid_domain     (cdid) ) THEN 
     1223         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1224            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1225            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1226            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 
     1227     ENDIF 
     1228      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
     1229         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1230            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1231            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1232            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 
     1233      ENDIF 
     1234#endif 
    11811235      CALL xios_solve_inheritance() 
    11821236 
    11831237   END SUBROUTINE iom_set_domain_attr 
     1238 
     1239#if defined key_xios2 
     1240  SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 
     1241     CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1242     INTEGER                  , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj 
     1243 
     1244     IF ( xios_is_valid_zoom_domain     (cdid) ) THEN 
     1245         CALL xios_set_zoom_domain_attr     ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni,    & 
     1246           &   nj=nj) 
     1247    ENDIF 
     1248  END SUBROUTINE iom_set_zoom_domain_attr 
     1249#endif 
    11841250 
    11851251 
    … …  
    11891255      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
    11901256      IF ( PRESENT(paxis) ) THEN 
     1257#if ! defined key_xios2 
    11911258         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
    11921259         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1260#else 
     1261         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1262         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1263#endif 
    11931264      ENDIF 
    11941265      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    … …  
    11971268   END SUBROUTINE iom_set_axis_attr 
    11981269 
    1199  
    12001270   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 
    12011271      CHARACTER(LEN=*)          , INTENT(in) ::   cdid 
    1202       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op 
    1203       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset 
    1204       IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    1205       IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1272#if ! defined key_xios2 
     1273      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_op 
     1274      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_offset 
     1275#else 
     1276      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_op 
     1277      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_offset 
     1278#endif 
     1279      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr       & 
     1280    &     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1281      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr  & 
     1282    &                    ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    12061283      CALL xios_solve_inheritance() 
    12071284   END SUBROUTINE iom_set_field_attr 
    1208  
    12091285 
    12101286   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 
    … …  
    12191295   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 
    12201296      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid 
    1221       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq 
     1297      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix 
     1298#if ! defined key_xios2 
     1299      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::    output_freq 
     1300#else 
     1301      TYPE(xios_duration)   ,OPTIONAL , INTENT(out) :: output_freq 
     1302#endif   
    12221303      LOGICAL                                 ::   llexist1,llexist2,llexist3 
    12231304      !--------------------------------------------------------------------- 
    12241305      IF( PRESENT( name        ) )   name = ''          ! default values 
    12251306      IF( PRESENT( name_suffix ) )   name_suffix = '' 
     1307#if ! defined key_xios2 
    12261308      IF( PRESENT( output_freq ) )   output_freq = '' 
     1309#else 
     1310      IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0) 
     1311#endif 
    12271312      IF ( xios_is_valid_file     (cdid) ) THEN 
    12281313         CALL xios_solve_inheritance() 
    … …  
    12451330      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    12461331      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask 
     1332#if ! defined key_xios2 
    12471333      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask ) 
    12481334      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask ) 
     1335#else 
     1336      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask ) 
     1337      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 
     1338#endif 
    12491339      CALL xios_solve_inheritance() 
    12501340   END SUBROUTINE iom_set_grid_attr 
    … …  
    12881378      ni=nlei-nldi+1 ; nj=nlej-nldj+1 
    12891379 
    1290       CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1380#if ! defined key_xios2 
     1381     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1382#else 
     1383     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1384#endif      
    12911385      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    12921386      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    … …  
    13021396         END SELECT 
    13031397         ! 
     1398#if ! defined key_xios2 
    13041399         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. ) 
     1400#else 
     1401         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. ) 
     1402#endif   
    13051403         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 
    13061404      ENDIF 
    … …  
    14361534      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
    14371535 
     1536      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1537#if ! defined key_xios2 
    14381538      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    14391539      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    … …  
    14411541         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    14421542      ! 
    1443       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    14441543      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1544#else 
     1545! Pas teste : attention aux indices ! 
     1546      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1547      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1548      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1549         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1550       CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
     1551#endif 
     1552 
    14451553      CALL iom_update_file_name('ptr') 
    14461554      ! 
    … …  
    14561564      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    14571565      !!---------------------------------------------------------------------- 
     1566#if ! defined key_xios2 
    14581567      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
     1568#else 
     1569      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 
     1570#endif 
    14591571      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
    14601572       
    14611573      zz=REAL(narea,wp) 
    14621574      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1463  
     1575       
    14641576   END SUBROUTINE set_scalar 
    14651577 
    … …  
    14851597      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings 
    14861598      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings 
     1599#if  defined key_xios2 
     1600      TYPE(xios_duration)            ::   f_op, f_of 
     1601#endif 
     1602  
    14871603      !!---------------------------------------------------------------------- 
    14881604      !  
    14891605      ! frequency of the call of iom_put (attribut: freq_op) 
    1490       WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 
    1491       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts') 
    1492       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op = cl1//'ts', freq_offset='0ts') 
    1493       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
    1494       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
     1606#if ! defined key_xios2 
     1607      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 
     1608      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op=cl1//'ts', freq_offset='0ts') 
     1609      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op=cl1//'ts', freq_offset='0ts') 
     1610      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1611      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1612#else 
     1613      f_op%timestep = 1        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 
     1614      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of) 
     1615      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of) 
     1616      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of) 
     1617      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of) 
     1618#endif 
    14951619        
    14961620      ! output file names (attribut: name) 
    … …  
    15141638         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    15151639         CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
     1640#if ! defined key_xios2 
    15161641         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 
     1642#else 
     1643         CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 
     1644#endif 
    15171645         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    15181646         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 
    … …  
    15941722               ENDIF 
    15951723               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 
     1724#if ! defined key_xios2 
    15961725               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 
     1726#else 
     1727               CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 
     1728#endif 
    15971729               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         ) 
    15981730               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 
    … …  
    16231755      REAL(wp)           ::   zsec 
    16241756      LOGICAL            ::   llexist 
    1625       !!---------------------------------------------------------------------- 
     1757#if  defined key_xios2 
     1758      TYPE(xios_duration)   ::   output_freq  
     1759#endif       
     1760      !!---------------------------------------------------------------------- 
     1761 
    16261762 
    16271763      DO jn = 1,2 
    1628  
     1764#if ! defined key_xios2 
    16291765         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq ) 
     1766#else 
     1767         output_freq = xios_duration(0,0,0,0,0,0) 
     1768         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq ) 
     1769#endif 
    16301770         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname ) 
    16311771 
    … …  
    16381778            END DO 
    16391779 
     1780#if ! defined key_xios2 
    16401781            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16411782            DO WHILE ( idx /= 0 )  
    … …  
    16501791               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16511792            END DO 
    1652  
     1793#else 
     1794            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1795            DO WHILE ( idx /= 0 )  
     1796              IF ( output_freq%timestep /= 0) THEN 
     1797                  WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts'  
     1798                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1799              ELSE IF ( output_freq%hour /= 0 ) THEN 
     1800                  WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h'  
     1801                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1802              ELSE IF ( output_freq%day /= 0 ) THEN 
     1803                  WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d'  
     1804                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1805              ELSE IF ( output_freq%month /= 0 ) THEN    
     1806                  WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m'  
     1807                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1808              ELSE IF ( output_freq%year /= 0 ) THEN    
     1809                  WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y'  
     1810                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1811              ELSE 
     1812                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   & 
     1813                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 
     1814              ENDIF 
     1815              clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 
     1816              idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1817            END DO 
     1818#endif 
    16531819            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 
    16541820            DO WHILE ( idx /= 0 )  
    … …  
    16791845            END DO 
    16801846 
     1847            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    16811848            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    16821849            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    17261893      ENDIF 
    17271894       
     1895!$AGRIF_DO_NOT_TREAT       
     1896! Should be fixed in the conv 
    17281897      IF( llfull ) THEN  
    17291898         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 
    … …  
    17361905         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run 
    17371906      ENDIF 
     1907!$AGRIF_END_DO_NOT_TREAT       
    17381908 
    17391909   END FUNCTION iom_sdate 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r5602 r7256  
    1111   !!                            the BDY/OBC communications 
    1212   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add a C1D case   
     13   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_mpp_mpi 
    … …  
    2425 
    2526   INTERFACE lbc_lnk_multi 
    26       MODULE PROCEDURE mpp_lnk_2d_9 
     27      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2728   END INTERFACE 
    2829 
    … …  
    8081   END INTERFACE 
    8182 
     83   INTERFACE lbc_lnk_multi 
     84      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     85   END INTERFACE 
     86 
    8287   INTERFACE lbc_bdy_lnk 
    8388      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    8792      MODULE PROCEDURE lbc_lnk_2d_e 
    8893   END INTERFACE 
     94    
     95   TYPE arrayptr 
     96      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     97   END TYPE arrayptr 
     98   PUBLIC   arrayptr 
    8999 
    90100   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    91101   PUBLIC   lbc_lnk_e  
     102   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    92103   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    93104   PUBLIC   lbc_lnk_icb 
    … …  
    171182      ! 
    172183   END SUBROUTINE lbc_lnk_2d 
     184    
     185   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     186      !! 
     187      INTEGER :: num_fields 
     188      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     189      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     190      !                                                               ! = T , U , V , F , W and I points 
     191      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     192      !                                                               ! =  1. , the sign is kept 
     193      ! 
     194      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     195      ! 
     196      DO ii = 1, num_fields 
     197        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     198      END DO      
     199      ! 
     200   END SUBROUTINE lbc_lnk_2d_multiple 
     201 
     202   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     203      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     204      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     205      !!--------------------------------------------------------------------- 
     206      ! Second 2D array on which the boundary condition is applied 
     207      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     208      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     209      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     210      ! define the nature of ptab array grid-points 
     211      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     212      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     213      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     214      ! =-1 the sign change across the north fold boundary 
     215      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     216      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     217      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     218      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     219      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     220      !! 
     221      !!--------------------------------------------------------------------- 
     222 
     223      !!The first array 
     224      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     225 
     226      !! Look if more arrays to process 
     227      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     228      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     229      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     230      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     231      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     232      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     233      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     234      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     235 
     236   END SUBROUTINE lbc_lnk_2d_9 
     237 
     238 
     239 
     240 
    173241 
    174242#else 
    … …  
    372440      !     
    373441   END SUBROUTINE lbc_lnk_2d 
     442    
     443   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     444      !! 
     445      INTEGER :: num_fields 
     446      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     447      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     448      !                                                               ! = T , U , V , F , W and I points 
     449      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     450      !                                                               ! =  1. , the sign is kept 
     451      ! 
     452      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     453      ! 
     454      DO ii = 1, num_fields 
     455        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     456      END DO      
     457      ! 
     458   END SUBROUTINE lbc_lnk_2d_multiple 
     459 
     460   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     461      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     462      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     463      !!--------------------------------------------------------------------- 
     464      ! Second 2D array on which the boundary condition is applied 
     465      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     466      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     467      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     468      ! define the nature of ptab array grid-points 
     469      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     470      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     471      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     472      ! =-1 the sign change across the north fold boundary 
     473      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     474      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     475      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     476      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     477      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     478      !! 
     479      !!--------------------------------------------------------------------- 
     480 
     481      !!The first array 
     482      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     483 
     484      !! Look if more arrays to process 
     485      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     486      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     487      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     488      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     489      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     490      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     491      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     492      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     493 
     494   END SUBROUTINE lbc_lnk_2d_9 
     495 
    374496 
    375497#endif 
    … …  
    441563   !!====================================================================== 
    442564END MODULE lbclnk 
     565 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6772 r7256  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
    … …  
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
    … …  
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mppscatter, mppgather, mppgatheri 
    7578   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    7881   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7982   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     83   PUBLIC   mpprank 
    8084 
    8185   TYPE arrayptr 
    8286      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8387   END TYPE arrayptr 
     88   PUBLIC   arrayptr 
    8489    
    8590   !! * Interfaces 
    … …  
    105110   INTERFACE mpp_maxloc 
    106111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     112   END INTERFACE 
     113 
     114   INTERFACE mpp_max_multiple 
     115      MODULE PROCEDURE mppmax_real_multiple 
    107116   END INTERFACE 
    108117 
    … …  
    298307      ENDIF 
    299308 
     309#if defined key_agrif 
     310      IF (Agrif_Root()) THEN 
     311         CALL Agrif_MPI_Init(mpi_comm_opa) 
     312      ELSE 
     313         CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 
     314      ENDIF 
     315#endif 
     316 
    300317      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    301318      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
    … …  
    724741      ! ----------------------- 
    725742      ! 
    726       DO ii = 1 , num_fields 
    727743         !First Array 
    728          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    729             ! 
    730             SELECT CASE ( jpni ) 
    731             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    732             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    733             END SELECT 
    734             ! 
    735          ENDIF 
    736          ! 
    737       END DO 
     744      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     745         ! 
     746         SELECT CASE ( jpni ) 
     747         CASE ( 1 )     ;    
     748             DO ii = 1 , num_fields   
     749                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     750             END DO 
     751         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     752         END SELECT 
     753         ! 
     754      ENDIF 
     755        ! 
    738756       
    739757      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    … …  
    17031721   END SUBROUTINE mppmax_real 
    17041722 
     1723   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1724      !!---------------------------------------------------------------------- 
     1725      !!                  ***  routine mppmax_real  *** 
     1726      !! 
     1727      !! ** Purpose :   Maximum 
     1728      !! 
     1729      !!---------------------------------------------------------------------- 
     1730      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1731      INTEGER , INTENT(in   )           ::   NUM 
     1732      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1733      !! 
     1734      INTEGER  ::   ierror, localcomm 
     1735      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1736      !!---------------------------------------------------------------------- 
     1737      ! 
     1738      CALL wrk_alloc(NUM , zwork) 
     1739      localcomm = mpi_comm_opa 
     1740      IF( PRESENT(kcom) )   localcomm = kcom 
     1741      ! 
     1742      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1743      ptab = zwork 
     1744      CALL wrk_dealloc(NUM , zwork) 
     1745      ! 
     1746   END SUBROUTINE mppmax_real_multiple 
     1747 
    17051748 
    17061749   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    … …  
    25972640   END SUBROUTINE mpp_lbc_north_2d 
    25982641 
     2642   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2643      !!--------------------------------------------------------------------- 
     2644      !!                   ***  routine mpp_lbc_north_2d  *** 
     2645      !! 
     2646      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2647      !!              in mpp configuration in case of jpn1 > 1 
     2648      !!              (for multiple 2d arrays ) 
     2649      !! 
     2650      !! ** Method  :   North fold condition and mpp with more than one proc 
     2651      !!              in i-direction require a specific treatment. We gather 
     2652      !!              the 4 northern lines of the global domain on 1 processor 
     2653      !!              and apply lbc north-fold on this sub array. Then we 
     2654      !!              scatter the north fold array back to the processors. 
     2655      !! 
     2656      !!---------------------------------------------------------------------- 
     2657      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2658      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2659      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2660      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2661      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2662      !!                                                             ! =  1. , the sign is kept 
     2663      INTEGER ::   ji, jj, jr, jk 
     2664      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2665      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2666      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2667      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2668      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2669      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2670      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2671      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2672      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2673      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2674      INTEGER :: istatus(mpi_status_size) 
     2675      INTEGER :: iflag 
     2676      !!---------------------------------------------------------------------- 
     2677      ! 
     2678      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   &  
     2679            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2680      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2681      ! 
     2682      ijpj   = 4 
     2683      ijpjm1 = 3 
     2684      ! 
     2685       
     2686      DO jk = 1, num_fields 
     2687         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2688            ij = jj - nlcj + ijpj 
     2689            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2690         END DO 
     2691      END DO 
     2692      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2693      itaille = jpi * ijpj 
     2694                                                                   
     2695      IF ( l_north_nogather ) THEN 
     2696         ! 
     2697         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2698         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2699         ! 
     2700         ztabr(:,:,:) = 0 
     2701         ztabl(:,:,:) = 0 
     2702 
     2703         DO jk = 1, num_fields 
     2704            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2705               ij = jj - nlcj + ijpj 
     2706               DO ji = nfsloop, nfeloop 
     2707                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2708               END DO 
     2709            END DO 
     2710         END DO 
     2711 
     2712         DO jr = 1,nsndto 
     2713            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2714               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2715            ENDIF 
     2716         END DO 
     2717         DO jr = 1,nsndto 
     2718            iproc = nfipproc(isendto(jr),jpnj) 
     2719            IF(iproc .ne. -1) THEN 
     2720               ilei = nleit (iproc+1) 
     2721               ildi = nldit (iproc+1) 
     2722               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2723            ENDIF 
     2724            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2725              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2726              DO jk = 1 , num_fields 
     2727                 DO jj = 1, ijpj 
     2728                    DO ji = ildi, ilei 
     2729                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2730                    END DO 
     2731                 END DO 
     2732              END DO 
     2733            ELSE IF (iproc .eq. (narea-1)) THEN 
     2734              DO jk = 1, num_fields 
     2735                 DO jj = 1, ijpj 
     2736                    DO ji = ildi, ilei 
     2737                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2738                    END DO 
     2739                 END DO 
     2740              END DO 
     2741            ENDIF 
     2742         END DO 
     2743         IF (l_isend) THEN 
     2744            DO jr = 1,nsndto 
     2745               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2746                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2747               ENDIF 
     2748            END DO 
     2749         ENDIF 
     2750         ! 
     2751         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2752            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2753         END DO 
     2754         ! 
     2755         DO jk = 1, num_fields 
     2756            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2757               ij = jj - nlcj + ijpj 
     2758               DO ji = 1, nlci 
     2759                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2760               END DO 
     2761            END DO 
     2762         END DO 
     2763          
     2764         ! 
     2765      ELSE 
     2766         ! 
     2767         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2768            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2769         ! 
     2770         ztab(:,:,:) = 0.e0 
     2771         DO jk = 1, num_fields 
     2772            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2773               iproc = nrank_north(jr) + 1 
     2774               ildi = nldit (iproc) 
     2775               ilei = nleit (iproc) 
     2776               iilb = nimppt(iproc) 
     2777               DO jj = 1, ijpj 
     2778                  DO ji = ildi, ilei 
     2779                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2780                  END DO 
     2781               END DO 
     2782            END DO 
     2783         END DO 
     2784          
     2785         DO ji = 1, num_fields 
     2786            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2787         END DO 
     2788         ! 
     2789         DO jk = 1, num_fields 
     2790            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2791               ij = jj - nlcj + ijpj 
     2792               DO ji = 1, nlci 
     2793                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2794               END DO 
     2795            END DO 
     2796         END DO 
     2797         ! 
     2798         ! 
     2799      ENDIF 
     2800      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2801      DEALLOCATE( ztabl, ztabr ) 
     2802      ! 
     2803   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25992804 
    26002805   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r5601 r7256  
    201201       
    202202#endif 
    203       IF(lwp) THEN 
    204          WRITE(numout,*) 
    205          WRITE(numout,*) '           defines mpp subdomains' 
    206          WRITE(numout,*) '           ----------------------' 
    207          WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
    208          WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
    209          ifreq = 4 
    210          il1   = 1 
    211          DO jn = 1, (jpni-1)/ifreq+1 
    212             il2 = MIN( jpni, il1+ifreq-1 ) 
    213             WRITE(numout,*) 
    214             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    215             DO jj = jpnj, 1, -1 
    216                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    217                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    218                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    219                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    220             END DO 
    221             WRITE(numout,9201) (ji,ji = il1,il2) 
    222             il1 = il1+ifreq 
    223          END DO 
    224  9200    FORMAT('     ***',20('*************',a3)) 
    225  9203    FORMAT('     *     ',20('         *   ',a3)) 
    226  9201    FORMAT('        ',20('   ',i3,'          ')) 
    227  9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    228       ENDIF 
    229  
    230       zidom = nreci 
    231       DO ji = 1, jpni 
    232          zidom = zidom + ilcit(ji,1) - nreci 
    233       END DO 
    234       IF(lwp) WRITE(numout,*) 
    235       IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
    236        
    237       zjdom = nrecj 
    238       DO jj = 1, jpnj 
    239          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    240       END DO 
    241       IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
    242       IF(lwp) WRITE(numout,*) 
    243        
    244203 
    245204      !  2. Index arrays for subdomains 
    … …  
    313272         nlejt(jn) = nlej 
    314273      END DO 
    315        
    316  
    317       ! 4. From global to local 
     274 
     275      ! 4. Subdomain print 
     276      ! ------------------ 
     277       
     278      IF(lwp) WRITE(numout,*) 
     279      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     280      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     281      IF(lwp) WRITE(numout,*) 
     282      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     283      IF(lwp) WRITE(numout,*) 
     284      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     285      zidom = nreci 
     286      DO ji = 1, jpni 
     287         zidom = zidom + ilcit(ji,1) - nreci 
     288      END DO 
     289      IF(lwp) WRITE(numout,*) 
     290      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     291 
     292      zjdom = nrecj 
     293      DO jj = 1, jpnj 
     294         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     295      END DO 
     296      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     297      IF(lwp) WRITE(numout,*) 
     298 
     299      IF(lwp) THEN 
     300         ifreq = 4 
     301         il1   = 1 
     302         DO jn = 1, (jpni-1)/ifreq+1 
     303            il2 = MIN( jpni, il1+ifreq-1 ) 
     304            WRITE(numout,*) 
     305            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     306            DO jj = jpnj, 1, -1 
     307               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     308               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     309               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     310               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     311               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     312            END DO 
     313            WRITE(numout,9201) (ji,ji = il1,il2) 
     314            il1 = il1+ifreq 
     315         END DO 
     316 9200     FORMAT('     ***',20('*************',a3)) 
     317 9203     FORMAT('     *     ',20('         *   ',a3)) 
     318 9201     FORMAT('        ',20('   ',i3,'          ')) 
     319 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     320 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     321      ENDIF 
     322 
     323      ! 5. From global to local 
    318324      ! ----------------------- 
    319325 
    … …  
    322328 
    323329 
    324       ! 5. Subdomain neighbours 
     330      ! 6. Subdomain neighbours 
    325331      ! ---------------------- 
    326332 
    … …  
    445451         WRITE(numout,*) ' nimpp  = ', nimpp 
    446452         WRITE(numout,*) ' njmpp  = ', njmpp 
    447          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    448          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    449          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    450          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     453         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     454         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     455         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     456         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     457         WRITE(numout,*) 
    451458      ENDIF 
    452459 
    … …  
    455462      ! Prepare mpp north fold 
    456463 
    457       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     464      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    458465         CALL mpp_ini_north 
    459       END IF 
     466         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     467      ENDIF 
    460468 
    461469      ! Prepare NetCDF output file (if necessary) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r6772 r7256  
    309309         ENDIF 
    310310 
     311         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    311312         isurf = 0 
    312313         DO jj = 1, ilj 
    … …  
    315316            END DO 
    316317         END DO 
     318 
    317319         IF(isurf /= 0) THEN 
    318320            icont = icont + 1 
    … …  
    326328 
    327329      nfipproc(:,:) = ipproc(:,:) 
    328  
    329330 
    330331      ! Control 
    … …  
    434435      ii = iin(narea) 
    435436      ij = ijn(narea) 
     437 
     438      ! set default neighbours 
     439      noso = ioso(ii,ij) 
     440      nowe = iowe(ii,ij) 
     441      noea = ioea(ii,ij) 
     442      nono = iono(ii,ij)  
     443      npse = iose(ii,ij) 
     444      npsw = iosw(ii,ij) 
     445      npne = ione(ii,ij) 
     446      npnw = ionw(ii,ij) 
     447 
     448      ! check neighbours location 
    436449      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    437450         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    517530      IF (lwp) THEN 
    518531         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     532         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    519533         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    520534         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    529543      END IF 
    530544 
    531       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    532  
    533       ! Prepare mpp north fold 
    534  
    535       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    536          CALL mpp_ini_north 
    537          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    538       ENDIF 
    539  
    540545      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    541546      ! In this case the important thing is that npolj /= 0 
    … …  
    554559      ENDIF 
    555560 
     561      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     562 
     563      IF(lwp) THEN 
     564         WRITE(numout,*) ' nproc  = ', nproc 
     565         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     566         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     567         WRITE(numout,*) ' nbondi = ', nbondi 
     568         WRITE(numout,*) ' nbondj = ', nbondj 
     569         WRITE(numout,*) ' npolj  = ', npolj 
     570         WRITE(numout,*) ' nperio = ', nperio 
     571         WRITE(numout,*) ' nlci   = ', nlci 
     572         WRITE(numout,*) ' nlcj   = ', nlcj 
     573         WRITE(numout,*) ' nimpp  = ', nimpp 
     574         WRITE(numout,*) ' njmpp  = ', njmpp 
     575         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     576         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     577         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     578         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     579         WRITE(numout,*) 
     580      ENDIF 
     581 
     582      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     583 
     584      ! Prepare mpp north fold 
     585 
     586      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     587         CALL mpp_ini_north 
     588         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     589      ENDIF 
     590 
    556591      ! Prepare NetCDF output file (if necessary) 
    557592      CALL mpp_init_ioipsl 
    558593 
    559       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    560  
    561       IF(lwp) THEN 
    562          WRITE(numout,*) ' nproc=  ',nproc 
    563          WRITE(numout,*) ' nowe=   ',nowe 
    564          WRITE(numout,*) ' noea=   ',noea 
    565          WRITE(numout,*) ' nono=   ',nono 
    566          WRITE(numout,*) ' noso=   ',noso 
    567          WRITE(numout,*) ' nbondi= ',nbondi 
    568          WRITE(numout,*) ' nbondj= ',nbondj 
    569          WRITE(numout,*) ' npolj=  ',npolj 
    570          WRITE(numout,*) ' nperio= ',nperio 
    571          WRITE(numout,*) ' nlci=   ',nlci 
    572          WRITE(numout,*) ' nlcj=   ',nlcj 
    573          WRITE(numout,*) ' nimpp=  ',nimpp 
    574          WRITE(numout,*) ' njmpp=  ',njmpp 
    575          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    576          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    577          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    578          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    579       ENDIF 
    580594 
    581595   END SUBROUTINE mpp_init2 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r4990 r7256  
    157157         END DO 
    158158      ENDIF 
     159 
     160      ! ORCA R1: Take the minimum between aeiw  and aeiv0 
     161      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 
     162         DO jj = 2, jpjm1 
     163            DO ji = fs_2, fs_jpim1   ! vector opt. 
     164               aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 
     165            END DO 
     166         END DO 
     167      ENDIF 
     168 
    159169      CALL lbc_lnk( aeiw, 'W', 1. )      ! lateral boundary condition on aeiw  
    160170 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6772 r7256  
    189189            DO jj = 2, jpjm1 
    190190               DO ji = fs_2, fs_jpim1   ! vector opt. 
    191                   IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    192                   IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
    193                   IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
    194                   IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    195                   IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
    196                   IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
     191               zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj)  , hmlpt  (ji+1,jj  ), 5._wp)   & 
     192                  &            - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       )   ) 
     193               zhmlpv(ji,jj) = ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp)   & 
     194                  &            - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)       )   ) 
    197195               ENDDO 
    198196            ENDDO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp_crs.F90

    r6772 r7256  
    329329      CALL crs_lbc_lnk( wslpi_crs, 'W', -1. )      ;      CALL crs_lbc_lnk( wslpj_crs, 'W', -1. ) 
    330330      ! 
    331       CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
    332       CALL iom_put("uslp_crs",uslp_crs) 
    333       CALL iom_put("vslp_crs",vslp_crs) 
    334       CALL iom_swap( "nemo" )    ! swap on the coarse grid 
     331      !CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
     332      !CALL iom_put("uslp_crs",uslp_crs) 
     333      !CALL iom_put("vslp_crs",vslp_crs) 
     334      !CALL iom_swap( "nemo" )    ! swap on the coarse grid 
    335335      ! 
    336336      CALL wrk_dealloc( jpi_crs,jpj_crs,jpk, zwz, zww, zdzr, zgru, zgrv ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r4147 r7256  
    4141 
    4242   REAL(wp), PUBLIC ::   rldf                        !: multiplicative factor of diffusive coefficient 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap 
    4344                                                     !: Needed to define the ratio between passive and active tracer diffusion coef.  
    4445 
    … …  
    9293      !!                 ***  FUNCTION ldftra_oce_alloc  *** 
    9394     !!---------------------------------------------------------------------- 
    94      INTEGER, DIMENSION(3) :: ierr 
     95     INTEGER, DIMENSION(4) :: ierr 
    9596     !!---------------------------------------------------------------------- 
    9697     ierr(:) = 0 
    … …  
    116117# endif 
    117118#endif 
     119      ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 
    118120      ldftra_oce_alloc = MAXVAL( ierr ) 
    119121      IF( ldftra_oce_alloc /= 0 )   CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90

    r3294 r7256  
    1313!   'key_traldf_c3d' :                 aht: 3D coefficient 
    1414#       define   fsahtt(i,j,k)   rldf * ahtt(i,j,k) 
    15 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) 
     15#       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) * r_fact_lap(i,j,k) 
    1616#       define   fsahtv(i,j,k)   rldf * ahtv(i,j,k) 
    1717#       define   fsahtw(i,j,k)   rldf * ahtw(i,j,k) 
    … …  
    1919!   'key_traldf_c2d' :                 aht: 2D coefficient 
    2020#       define   fsahtt(i,j,k)   rldf * ahtt(i,j) 
    21 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j) 
     21#       define   fsahtu(i,j,k)   rldf * ahtu(i,j) * r_fact_lap(i,j,k) 
    2222#       define   fsahtv(i,j,k)   rldf * ahtv(i,j) 
    2323#       define   fsahtw(i,j,k)   rldf * ahtw(i,j) 
    … …  
    2525!   'key_traldf_c1d' :                aht: 1D coefficient 
    2626#       define   fsahtt(i,j,k)   rldf * ahtt(k) 
    27 #       define   fsahtu(i,j,k)   rldf * ahtu(k) 
     27#       define   fsahtu(i,j,k)   rldf * ahtu(k) * r_fact_lap(i,j,k) 
    2828#       define   fsahtv(i,j,k)   rldf * ahtv(k) 
    2929#       define   fsahtw(i,j,k)   rldf * ahtw(k) 
    … …  
    3131!   Default option :             aht: Constant coefficient 
    3232#      define   fsahtt(i,j,k)   rldf * aht0 
    33 #      define   fsahtu(i,j,k)   rldf * aht0 
     33#      define   fsahtu(i,j,k)   rldf * aht0 * r_fact_lap(i,j,k) 
    3434#      define   fsahtv(i,j,k)   rldf * aht0 
    3535#      define   fsahtw(i,j,k)   rldf * aht0 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r4624 r7256  
    99   !!             -   ! 2001-06  (M. Vancoppenolle) LIM 3.0 
    1010   !!             -   ! 2006-08  (G. Madec)  cleaning for surface module 
     11   !!            3.6  ! 2016-01  (C. Rousset) new parameterization for sea ice albedo 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2930 
    3031   INTEGER  ::   albd_init = 0      !: control flag for initialization 
    31    REAL(wp) ::   zzero     = 0.e0   ! constant values 
    32    REAL(wp) ::   zone      = 1.e0   !    "       " 
    33  
    34    REAL(wp) ::   c1     = 0.05    ! constants values 
    35    REAL(wp) ::   c2     = 0.10    !    "        " 
    36    REAL(wp) ::   rmue   = 0.40    !  cosine of local solar altitude 
    37  
     32   
     33   REAL(wp) ::   rmue     = 0.40    !  cosine of local solar altitude 
     34   REAL(wp) ::   ralb_oce = 0.066   ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
     35   REAL(wp) ::   c1       = 0.05    ! snow thickness (only for nn_ice_alb=0) 
     36   REAL(wp) ::   c2       = 0.10    !  "        " 
     37   REAL(wp) ::   rcloud   = 0.06    ! cloud effect on albedo (only-for nn_ice_alb=0) 
     38  
    3839   !                             !!* namelist namsbc_alb 
    39    REAL(wp) ::   rn_cloud         !  cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 
    40 #if defined key_lim3 
    41    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    42 #else 
    43    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    44 #endif 
    45    REAL(wp) ::   rn_alphd         !  coefficients for linear interpolation used to compute 
    46    REAL(wp) ::   rn_alphdi        !  albedo between two extremes values (Pyane, 1972) 
    47    REAL(wp) ::   rn_alphc         !  
     40   INTEGER  ::   nn_ice_alb 
     41   REAL(wp) ::   rn_albice 
    4842 
    4943   !!---------------------------------------------------------------------- 
    … …  
    5953      !!           
    6054      !! ** Purpose :   Computation of the albedo of the snow/ice system  
    61       !!                as well as the ocean one 
    6255      !!        
    63       !! ** Method  : - Computation of the albedo of snow or ice (choose the  
    64       !!                rignt one by a large number of tests 
    65       !!              - Computation of the albedo of the ocean 
    66       !! 
    67       !! References :   Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     56      !! ** Method  :   Two schemes are available (from namelist parameter nn_ice_alb) 
     57      !!                  0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 
     58      !!                  1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 
     59      !!                                                                           and Grenfell & Perovich (JGR 2004) 
     60      !!                Description of scheme 1: 
     61      !!                  1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 
     62      !!                     which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 
     63      !!                     0-5cm  : linear function of ice thickness 
     64      !!                     5-150cm: log    function of ice thickness 
     65      !!                     > 150cm: constant 
     66      !!                  2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 
     67      !!                     i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 
     68      !!                  3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 
     69      !!                     i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 
     70      !!                  4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 
     71      !! 
     72      !! ** Note    :   The parameterization from Shine & Henderson-Sellers presents several misconstructions: 
     73      !!                  1) ice albedo when ice thick. tends to 0 is different than ocean albedo 
     74      !!                  2) for small ice thick. covered with some snow (<3cm?), albedo is larger  
     75      !!                     under melting conditions than under freezing conditions 
     76      !!                  3) the evolution of ice albedo as a function of ice thickness shows   
     77      !!                     3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 
     78      !! 
     79      !! References :   Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     80      !!                Brandt et al. 2005, J. Climate, vol 18 
     81      !!                Grenfell & Perovich 2004, JGR, vol 109  
    6882      !!---------------------------------------------------------------------- 
    6983      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_ice      !  ice surface temperature (Kelvin) 
    … …  
    7387      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   pa_ice_os   !  albedo of ice under overcast sky 
    7488      !! 
    75       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    76       INTEGER  ::   ijpl          ! number of ice categories (3rd dim of ice input arrays) 
    77       REAL(wp) ::   zalbpsnm      ! albedo of ice under clear sky when snow is melting 
    78       REAL(wp) ::   zalbpsnf      ! albedo of ice under clear sky when snow is freezing 
    79       REAL(wp) ::   zalbpsn       ! albedo of snow/ice system when ice is coverd by snow 
    80       REAL(wp) ::   zalbpic       ! albedo of snow/ice system when ice is free of snow 
    81       REAL(wp) ::   zithsn        ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 
    82       REAL(wp) ::   zitmlsn       ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 
    83       REAL(wp) ::   zihsc1        ! = 1 hsn <= c1 ; = 0 hsn > c1 
    84       REAL(wp) ::   zihsc2        ! = 1 hsn >= c2 ; = 0 hsn < c2 
    85       !! 
    86       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalbfz    ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zficeth   !  function of ice thickness 
     89      INTEGER  ::   ji, jj, jl         ! dummy loop indices 
     90      INTEGER  ::   ijpl               ! number of ice categories (3rd dim of ice input arrays) 
     91      REAL(wp)            ::   ralb_im, ralb_sf, ralb_sm, ralb_if 
     92      REAL(wp)            ::   zswitch, z1_c1, z1_c2 
     93      REAL(wp)                            ::   zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 
     94      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb, zalb_it             ! intermediate variable & albedo of ice (snow free) 
    8895      !!--------------------------------------------------------------------- 
    89        
     96 
    9097      ijpl = SIZE( pt_ice, 3 )                     ! number of ice categories 
    91  
    92       CALL wrk_alloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     98       
     99      CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    93100 
    94101      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    95102 
    96       !--------------------------- 
    97       !  Computation of  zficeth 
    98       !--------------------------- 
    99       ! ice free of snow and melts 
    100       WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalbfz(:,:,:) = rn_albice 
    101       ELSE WHERE                                              ;   zalbfz(:,:,:) = rn_alphdi 
    102       END  WHERE 
    103  
    104       WHERE     ( 1.5  < ph_ice                     )  ;  zficeth = zalbfz 
    105       ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zficeth = 0.472  + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 
    106       ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zficeth = 0.2467 + 0.7049 * ph_ice              & 
    107          &                                                                 - 0.8608 * ph_ice * ph_ice     & 
    108          &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
    109       ELSE WHERE                                       ;  zficeth = 0.1    + 3.6    * ph_ice 
    110       END WHERE 
    111  
    112 !!gm old code 
    113 !      DO jl = 1, ijpl 
    114 !         DO jj = 1, jpj 
    115 !            DO ji = 1, jpi 
    116 !               IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
    117 !                  zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
    118 !               ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
    119 !                  zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
    120 !               ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
    121 !                  zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
    122 !                     &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
    123 !                     &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
    124 !               ELSE 
    125 !                  zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
    126 !               ENDIF 
    127 !            END DO 
    128 !         END DO 
    129 !      END DO 
    130 !!gm end old code 
    131        
    132       !-----------------------------------------------  
    133       !    Computation of the snow/ice albedo system  
    134       !-------------------------- --------------------- 
    135        
    136       !    Albedo of snow-ice for clear sky. 
    137       !-----------------------------------------------     
    138       DO jl = 1, ijpl 
    139          DO jj = 1, jpj 
    140             DO ji = 1, jpi 
    141                !  Case of ice covered by snow.              
    142                !                                        !  freezing snow         
    143                zihsc1   = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
    144                zalbpsnf = ( 1.0 - zihsc1 ) * (  zficeth(ji,jj,jl)                                             & 
    145                   &                           + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1  )   & 
    146                   &     +         zihsc1   * rn_alphd   
    147                !                                        !  melting snow                 
    148                zihsc2   = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 
    149                zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 )   & 
    150                   &     +         zihsc2   *   rn_alphc  
    151                ! 
    152                zitmlsn  =  MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) )    
    153                zalbpsn  =  zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 
    154              
    155                !  Case of ice free of snow. 
    156                zalbpic  = zficeth(ji,jj,jl)  
    157              
    158                ! albedo of the system    
    159                zithsn   = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 
    160                pa_ice_cs(ji,jj,jl) =  zithsn * zalbpsn + ( 1.0 - zithsn ) *  zalbpic 
     103       
     104      SELECT CASE ( nn_ice_alb ) 
     105 
     106      !------------------------------------------ 
     107      !  Shine and Henderson-Sellers (1985) 
     108      !------------------------------------------ 
     109      CASE( 0 ) 
     110        
     111         ralb_sf = 0.80       ! dry snow 
     112         ralb_sm = 0.65       ! melting snow 
     113         ralb_if = 0.72       ! bare frozen ice 
     114         ralb_im = rn_albice  ! bare puddled ice  
     115          
     116         !  Computation of ice albedo (free of snow) 
     117         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb(:,:,:) = ralb_im 
     118         ELSE WHERE                                              ;   zalb(:,:,:) = ralb_if 
     119         END  WHERE 
     120       
     121         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     122         ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = 0.472  + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 
     123         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zalb_it = 0.2467 + 0.7049 * ph_ice              & 
     124            &                                                                 - 0.8608 * ph_ice * ph_ice     & 
     125            &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
     126         ELSE WHERE                                       ;  zalb_it = 0.1    + 3.6    * ph_ice 
     127         END WHERE 
     128      
     129         DO jl = 1, ijpl 
     130            DO jj = 1, jpj 
     131               DO ji = 1, jpi 
     132                  ! freezing snow 
     133                  ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 
     134                  !                                        !  freezing snow         
     135                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
     136                  zalb_sf   = ( 1._wp - zswitch ) * (  zalb_it(ji,jj,jl)  & 
     137                     &                           + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1  )   & 
     138                     &        +         zswitch   * ralb_sf   
     139 
     140                  ! melting snow 
     141                  ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 
     142                  zswitch   = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 
     143                  zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 )   & 
     144                      &     +         zswitch   *   ralb_sm  
     145                  ! 
     146                  ! snow albedo 
     147                  zswitch  =  MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     148                  zalb_st  =  zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     149                
     150                  ! Ice/snow albedo 
     151                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     152                  pa_ice_cs(ji,jj,jl) =  zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 
     153                  ! 
     154               END DO 
    161155            END DO 
    162156         END DO 
    163       END DO 
    164        
    165       !    Albedo of snow-ice for overcast sky. 
    166       !----------------------------------------------   
    167       pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud       ! Oberhuber correction 
    168       ! 
    169       CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     157 
     158         pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud       ! Oberhuber correction for overcast sky 
     159 
     160      !------------------------------------------ 
     161      !  New parameterization (2016) 
     162      !------------------------------------------ 
     163      CASE( 1 )  
     164 
     165         ralb_im = rn_albice  ! bare puddled ice 
     166! compilation of values from literature 
     167         ralb_sf = 0.85      ! dry snow 
     168         ralb_sm = 0.75      ! melting snow 
     169         ralb_if = 0.60      ! bare frozen ice 
     170! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 
     171!         ralb_sf = 0.85       ! dry snow 
     172!         ralb_sm = 0.72       ! melting snow 
     173!         ralb_if = 0.65       ! bare frozen ice 
     174! Brandt et al 2005 (East Antarctica) 
     175!         ralb_sf = 0.87      ! dry snow 
     176!         ralb_sm = 0.82      ! melting snow 
     177!         ralb_if = 0.54      ! bare frozen ice 
     178!  
     179         !  Computation of ice albedo (free of snow) 
     180         z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) )  
     181         z1_c2 = 1. / 0.05 
     182         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb = ralb_im 
     183         ELSE WHERE                                              ;   zalb = ralb_if 
     184         END  WHERE 
     185          
     186         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     187         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = zalb     + ( 0.18 - zalb     ) * z1_c1 *  & 
     188            &                                                                     ( LOG(1.5) - LOG(ph_ice) ) 
     189         ELSE WHERE                                       ;  zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 
     190         END WHERE 
     191 
     192         z1_c1 = 1. / 0.02 
     193         z1_c2 = 1. / 0.03 
     194         !  Computation of the snow/ice albedo 
     195         DO jl = 1, ijpl 
     196            DO jj = 1, jpj 
     197               DO ji = 1, jpi 
     198                  zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 
     199                  zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 
     200 
     201                   ! snow albedo 
     202                  zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     203                  zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     204 
     205                  ! Ice/snow albedo    
     206                  zswitch             = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     207                  pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch *  zalb_it(ji,jj,jl) 
     208 
     209              END DO 
     210            END DO 
     211         END DO 
     212         ! Effect of the clouds (2d order polynomial) 
     213         pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 );  
     214 
     215      END SELECT 
     216       
     217      CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    170218      ! 
    171219   END SUBROUTINE albedo_ice 
    … …  
    181229      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pa_oce_cs   !  albedo of ocean under clear sky 
    182230      !! 
    183       REAL(wp) ::   zcoef   ! local scalar 
    184       !!---------------------------------------------------------------------- 
    185       ! 
    186       zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )      ! Parameterization of Briegled and Ramanathan, 1982  
    187       pa_oce_cs(:,:) = zcoef                
    188       pa_oce_os(:,:)  = 0.06                         ! Parameterization of Kondratyev, 1969 and Payne, 1972 
     231      REAL(wp) :: zcoef  
     232      !!---------------------------------------------------------------------- 
     233      ! 
     234      zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )   ! Parameterization of Briegled and Ramanathan, 1982 
     235      pa_oce_cs(:,:) = zcoef  
     236      pa_oce_os(:,:) = 0.06                       ! Parameterization of Kondratyev, 1969 and Payne, 1972 
    189237      ! 
    190238   END SUBROUTINE albedo_oce 
    … …  
    200248      !!---------------------------------------------------------------------- 
    201249      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    202       NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc 
     250      NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice  
    203251      !!---------------------------------------------------------------------- 
    204252      ! 
    … …  
    219267         WRITE(numout,*) '~~~~~~~' 
    220268         WRITE(numout,*) '   Namelist namsbc_alb : albedo ' 
    221          WRITE(numout,*) '      correction for snow and ice albedo                  rn_cloud  = ', rn_cloud 
    222          WRITE(numout,*) '      albedo of melting ice in the arctic and antarctic   rn_albice = ', rn_albice 
    223          WRITE(numout,*) '      coefficients for linear                             rn_alphd  = ', rn_alphd 
    224          WRITE(numout,*) '      interpolation used to compute albedo                rn_alphdi = ', rn_alphdi 
    225          WRITE(numout,*) '      between two extremes values (Pyane, 1972)           rn_alphc  = ', rn_alphc 
     269         WRITE(numout,*) '      choose the albedo parameterization                  nn_ice_alb = ', nn_ice_alb 
     270         WRITE(numout,*) '      albedo of bare puddled ice                          rn_albice  = ', rn_albice 
    226271      ENDIF 
    227272      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r5602 r7256  
    3232   PUBLIC   fld_map    ! routine called by tides_init 
    3333   PUBLIC   fld_read, fld_fill   ! called by sbc... modules 
     34   PUBLIC   fld_clopn 
    3435 
    3536   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations 
    … …  
    815816         imonth = kmonth 
    816817         iday = kday 
     818         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
     819            isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 )   
     820            llprevmth  = isec_week > nsec_month             ! longer time since beginning of the week than the month 
     821            llprevyr   = llprevmth .AND. nmonth == 1 
     822            iyear  = nyear  - COUNT((/llprevyr /)) 
     823            imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) 
     824            iday   = nday   + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) 
     825         ENDIF 
    817826      ELSE                                                  ! use current day values 
    818827         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
    … …  
    12811290      CHARACTER(LEN=*)          , INTENT(in   ) ::   lsmfile ! land sea mask file name 
    12821291      !!  
    1283       REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta,zfieldo                  ! temporary array of values on input grid 
     1292      REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta                          ! temporary array of values on input grid 
    12841293      INTEGER, DIMENSION(3)                     ::   rec1,recn                             ! temporary arrays for start and length 
    12851294      INTEGER, DIMENSION(3)                     ::   rec1_lsm,recn_lsm                     ! temporary arrays for start and length in case of seaoverland 
    … …  
    13471356 
    13481357 
    1349          itmpi=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),1) 
    1350          itmpj=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),2) 
     1358         itmpi=jpi2_lsm-jpi1_lsm+1 
     1359         itmpj=jpj2_lsm-jpj1_lsm+1 
    13511360         itmpz=kk 
    13521361         ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5602 r7256  
    8080   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
    8181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    8485#endif 
    … …  
    144145#endif 
    145146#if defined key_lim3 
    146          &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
    147          &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
    148          &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
     147         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
     148         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
     149         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    149150#endif 
    150151         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5602 r7256  
    684684      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    685685 
     686      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     687      DO jl = 1, jpl 
     688         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     689                                   ! but then qemp_ice should also include sublimation  
     690      END DO 
     691 
    686692      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    687693#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6772 r7256  
    4444   USE sbc_ice         ! Surface boundary condition: ice fields 
    4545   USE lib_fortran     ! to use key_nosignedzero 
    46    USE sbcapr 
    4746#if defined key_lim3 
    4847   USE ice, ONLY       : u_ice, v_ice, jpl, pfrld, a_i_b 
    4948   USE limthd_dh       ! for CALL lim_thd_snwblow 
    5049#elif defined key_lim2 
    51    USE ice_2, ONLY     : u_ice, v_ice, pfrld 
     50   USE ice_2, ONLY     : u_ice, v_ice 
    5251   USE par_ice_2 
    5352#endif 
    … …  
    8483   REAL(wp), PARAMETER ::   Cice =    1.4e-3      ! iovi 1.63e-3     ! transfer coefficient over ice 
    8584   REAL(wp), PARAMETER ::   albo =    0.066       ! ocean albedo assumed to be constant 
    86    REAL(wp), PARAMETER ::   rgas =  287.1         ! gas const. dry air (J/kg/K) 
    87    REAL(wp), PARAMETER ::   rvap =  461.51        ! gas const. vapour  (J/kg/K) 
    8885 
    8986   !                                  !!* Namelist namsbc_core : CORE bulk parameters 
    … …  
    9491   REAL(wp) ::   rn_zqt      ! z(q,t) : height of humidity and temperature measurements 
    9592   REAL(wp) ::   rn_zu       ! z(u)   : height of wind measurements 
    96    ! 
    97    LOGICAL  ::   ln_tair_celsius  !: logical flag for Read Tair: Tair in NEMO is Kelvin 
    98    LOGICAL  ::   ln_humi_rel      !: logical flag for Read relative humidity (T) or specific humidity (F) 
    99    LOGICAL  ::   ln_cohum_arc     !: logical flag for Correction of Humidity in the Arctic Ocean 
    100    LOGICAL  ::   ln_cotair_arc    !: logical flag for Correction of Air Temperature in the Arctic Ocean 
    101    LOGICAL  ::   ln_corad_antar   !: logical flag for Correction of radiatives fluxes in the Southern Ocean 
    102  
    10393 
    10494   !! * Substitutions 
    … …  
    153143      INTEGER  ::   ios      ! Local integer output status for namelist read 
    154144      ! 
    155       INTEGER  ::   ji,jj 
    156       REAL(wp) ::   zzlat, zzlat1, zzlat2, zfm, zfrld 
    157       REAL(wp) ::   zmin,zmax 
    158       REAL(wp), DIMENSION(:,:), POINTER :: xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair 
    159       REAL(wp), DIMENSION(:,:), POINTER :: zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr 
    160       
    161145      CHARACTER(len=100) ::  cn_dir   !   Root directory for location of core files 
    162146      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i     ! array of namelist informations on the fields to read 
    … …  
    167151         &                  sn_wndi, sn_wndj, sn_humi  , sn_qsr ,           & 
    168152         &                  sn_qlw , sn_tair, sn_prec  , sn_snow,           & 
    169          &                  sn_tdif, rn_zqt,  rn_zu , ln_tair_celsius,   & 
    170          &                  ln_humi_rel  , ln_cohum_arc,      & 
    171          &                  ln_cotair_arc, ln_corad_antar 
    172  
    173       !!--------------------------------------------------------------------- 
    174       ! 
    175       CALL wrk_alloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
    176       CALL wrk_alloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
     153         &                  sn_tdif, rn_zqt,  rn_zu 
     154      !!--------------------------------------------------------------------- 
     155      ! 
    177156      !                                         ! ====================== ! 
    178157      IF( kt == nit000 ) THEN                   !  First call kt=nit000  ! 
    … …  
    215194         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_core', 'flux formulation for ocean surface boundary condition', 'namsbc_core' ) 
    216195         ! 
    217          ! 
    218          IF(lwp) WRITE(numout,*) 'sbc_blk_core: jfld = ',jfld 
    219          IF( ln_cohum_arc   ) CALL ctl_warn( 'sbc_blk_core: correction of humidity in arctic' ) 
    220          IF( ln_cotair_arc  ) CALL ctl_warn( 'sbc_blk_core: correction of air temperature in arctic' ) 
    221          IF( ln_corad_antar ) CALL ctl_warn( 'sbc_blk_core: correction of short radiation in antartic' ) 
    222          IF( ln_humi_rel    ) CALL ctl_warn( 'sbc_blk_core: use relative humidity instead of specific humidity') 
    223          IF( ln_tair_celsius) CALL ctl_warn( 'sbc_blk_core: Tair is read in Celsius') 
    224          IF(lwp) WRITE(numout,*) 'sbc_blk_core: rn_pfac = ',rn_pfac 
    225          ! 
    226196         sfx(:,:) = 0._wp                          ! salt flux; zero unless ice is present (computed in limsbc(_2).F90) 
    227197         ! 
    … …  
    229199 
    230200      CALL fld_read( kt, nn_fsbc, sf )             ! input fields provided at the current time-step 
    231  
    232       !========================================= 
    233       !  ONLINE CORRECTIONS 
    234       !========================================= 
    235       ! 
    236       ! Correction of Tair 
    237       ! 
    238       IF( ln_tair_celsius .AND. MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    239          sf(jp_tair)%fnow = sf(jp_tair)%fnow + 273.15_wp  ! Conversion of the Temperature °C --> Kelvin 
    240       ENDIF 
    241       ! 
    242       ! Correction of SW and LW in the Southern Ocean 
    243       ! 
    244       IF( ln_corad_antar .AND. .NOT. sf(jp_qsr)%ln_tint .AND. MOD( kt-1, 86400/INT(rdt) ) == 0 ) THEN 
    245          z_qsr(:,:) = 0.8 * sf(jp_qsr)%fnow(:,:,1) 
    246          xyt(:,:) = 0.e0 ; zzlat1 = -65. ; zzlat2 = -60. 
    247          DO jj = 1, jpj 
    248             DO ji = 1, jpi 
    249                zzlat = gphit(ji,jj) 
    250                IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 ) THEN 
    251                   xyt(ji,jj) = (zzlat2-zzlat)/(zzlat2-zzlat1) 
    252                ELSE IF ( zzlat < zzlat1 ) THEN 
    253                   xyt(ji,jj) = 1 
    254                ENDIF 
    255             END DO 
    256          END DO 
    257          IF(lwp) WRITE(numout,*) 'Correc ln_corad_antar' 
    258          z_qsr1(:,:) = z_qsr(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_qsr)%fnow(:,:,1) 
    259          sf(jp_qsr)%fnow(:,:,1) = z_qsr1(:,:) 
    260       ENDIF 
    261  
    262       IF( MOD( kt-1, nn_fsbc ) == 0 )THEN 
    263          ! 
    264          IF ( nmonth >= 5 .AND. nmonth <= 9 ) THEN 
    265             ! 
    266             ! Correction of Humidity in the Arctic Ocean 
    267             ! 
    268             IF( ln_cohum_arc ) THEN 
    269                z_hum(:,:) = 0.85 * sf(jp_humi)%fnow(:,:,1) 
    270                xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
    271                DO jj = 1, jpj 
    272                   DO ji = 1, jpi 
    273                      zzlat = gphit(ji,jj) 
    274 #if defined key_lim2 ||  defined key_lim3  
    275                      IF ( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld = 0 ; ENDIF 
    276 #endif 
    277                      IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
    278                         xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
    279                      ELSE IF ( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
    280                         xyt(ji,jj) = 1._wp 
    281                      ENDIF 
    282                   ENDDO 
    283                ENDDO 
    284                IF(lwp) WRITE(numout,*) 'Correc ln_cohum_arc' 
    285                sf(jp_humi)%fnow(:,:,1) = z_hum(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_humi)%fnow(:,:,1) 
    286             ENDIF 
    287             ! 
    288             ! Correction of Air Temperature in the Arctic Ocean 
    289             ! 
    290             IF( ln_cotair_arc ) THEN 
    291                z_tair(:,:) = sf(jp_tair)%fnow(:,:,1) - 2.0 
    292                xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
    293                DO jj = 1, jpj 
    294                   DO ji = 1, jpi 
    295                      zzlat = gphit(ji,jj) 
    296 #if defined key_lim2 ||  defined key_lim3  
    297                      IF( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld=0 ; ENDIF 
    298 #endif 
    299                      IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
    300                         xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
    301                      ELSE IF( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
    302                         xyt(ji,jj) = 1._wp 
    303                      ENDIF 
    304                   END DO 
    305                ENDDO 
    306                IF(lwp) WRITE(numout,*) 'Correc ln_cotair_arc' 
    307                sf(jp_tair)%fnow(:,:,1) = z_tair(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_tair)%fnow(:,:,1) 
    308             ENDIF 
    309             ! 
    310          ENDIF ! 5 <= nmonth <= 9 
    311  
    312          ! 
    313       ENDIF ! IF MOD( kt-1, nn_fsbc ) 
    314  
    315       DO jj=1,jpj 
    316          DO ji=1,jpi 
    317             sf(jp_humi)%fnow(ji,jj,1) = MAX( MIN( sf(jp_humi)%fnow(ji,jj,1) ,1.0 ) , 0.0 ) 
    318             sf(jp_prec)%fnow(ji,jj,1) = MAX(      sf(jp_prec)%fnow(ji,jj,1) ,0.0 ) 
    319             sf(jp_qsr )%fnow(ji,jj,1) = MAX(      sf(jp_qsr )%fnow(ji,jj,1) ,0.0 ) 
    320             sf(jp_qlw )%fnow(ji,jj,1) = MAX(      sf(jp_qlw )%fnow(ji,jj,1) ,0.0 ) 
    321          ENDDO 
    322       END DO 
    323  
    324       ! 
    325       !========================================= 
    326       ! END OF ONLINE CORRECTIONS 
    327       !========================================= 
    328       ! 
    329201 
    330202      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    … …  
    334206      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN 
    335207         qlw_ice(:,:,1)   = sf(jp_qlw)%fnow(:,:,1)  
    336          qsr_ice(:,:,1)   = sf(jp_qsr)%fnow(:,:,1) 
     208         IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) 
     209         ELSE                ; qsr_ice(:,:,1) =          sf(jp_qsr)%fnow(:,:,1) 
     210         ENDIF 
    337211         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)          
    338212         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1) 
    … …  
    343217      ENDIF 
    344218#endif 
    345       ! 
    346       CALL wrk_dealloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
    347       CALL wrk_dealloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
    348219      ! 
    349220   END SUBROUTINE sbc_blk_core 
    … …  
    388259      REAL(wp), DIMENSION(:,:), POINTER ::   zt_zu             ! air temperature at wind speed height 
    389260      REAL(wp), DIMENSION(:,:), POINTER ::   zq_zu             ! air spec. hum.  at wind speed height 
    390       REAL(wp), DIMENSION(:,:), POINTER ::   zqatm , zpatm     ! specific humidity and mean sea level pressure (Pa) 
    391       REAL(wp) :: vt, vp, vq, zqa, zq0, zq1, zq2, zee 
    392261      !!--------------------------------------------------------------------- 
    393262      ! 
    … …  
    395264      ! 
    396265      CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    397       CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ,zqatm, zpatm ) 
     266      CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    398267      ! 
    399268      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    447316      ! ... specific humidity at SST and IST 
    448317      zqsatw(:,:) = zcoef_qsatw * EXP( -5107.4 / zst(:,:) ) 
    449       ! 
    450       IF ( ln_humi_rel ) THEN 
    451          zq0    = rvap / rgas - 1.0 
    452          zq1    = rgas / rvap 
    453          zq2    = 1.0 - zq1 
    454          zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant  here) 
    455          IF ( ln_apr_dyn ) zpatm(:,:) = apr(:,:) 
    456          DO jj = 1 , jpj 
    457             DO ji = 1 , jpi 
    458                vt  = sf(jp_tair)%fnow(ji,jj,1) - rt0  ! air temperature (Celsius) 
    459                vp  = zpatm(ji,jj) / 100.              ! mean sea level pressure (mb or hPa) 
    460                vq  = sf(jp_humi)%fnow(ji,jj,1)        ! relative humidity (fraction of 1) 
    461                ! Convert RH at the air/sea interface in specific humidity (kg/kg) 
    462                ! Teten's formula for qsat (mb) 
    463                zqa = ( 1.0007 + 3.46e-6 * vp) * 6.1121 * EXP( 17.502 * vt / ( 240.97+vt ) ) 
    464                zee = zqa * vq                         ! vapour partial pressure (mb) 
    465                vq  = zq1 * zee / ( vp - zq2 * zee )   ! specific humidity (kg/kg) 
    466                zqatm(ji,jj) = vq 
    467             ENDDO 
    468          ENDDO 
    469       ELSE 
    470          zqatm(:,:)=sf(jp_humi)%fnow(:,:,1) 
    471       ENDIF 
    472       ! 
     318 
    473319      ! ... NCAR Bulk formulae, computation of Cd, Ch, Ce at T-point : 
    474       CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, zqatm, wndm,   & 
     320      CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, sf(jp_humi)%fnow, wndm,   & 
    475321         &               Cd, Ch, Ce, zt_zu, zq_zu ) 
    476322     
    … …  
    510356      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 
    511357         !! q_air and t_air are (or "are almost") given at 10m (wind reference height) 
    512          !zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
    513           zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - zqatm(:,:)              )*wndm(:,:) ) ! Evaporation 
     358         zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
    514359         zqsb (:,:) =                     cpa*rhoa*Ch(:,:)*( zst   (:,:) - sf(jp_tair)%fnow(:,:,1) )*wndm(:,:)   ! Sensible Heat 
    515360      ELSE 
    … …  
    560405         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
    561406         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     407         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
     408         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
     409         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
     410         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
    562411      ENDIF 
    563412      ! 
    … …  
    571420      ! 
    572421      CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    573       CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu, zqatm, zpatm ) 
     422      CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    574423      ! 
    575424      IF( nn_timing == 1 )  CALL timing_stop('blk_oce_core') 
    … …  
    594443      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
    595444      !!--------------------------------------------------------------------- 
    596  
     445      ! 
    597446      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_tau') 
    598447      ! 
    … …  
    687536      REAL(wp) ::   zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
    688537      REAL(wp) ::   zztmp, z1_lsub                               ! temporary variable 
    689       REAL(wp) ::   ztamr,zmt1,zmt2,zmt3,zev,zes 
    690538      !! 
    691539      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
    … …  
    694542      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
    695543      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw       ! evaporation and snw distribution after wind blowing (LIM3) 
    696       REAL(wp), DIMENSION(:,:)  , POINTER ::   zqatm, zpatm , ztatm            ! specific humidity 
    697544      !!--------------------------------------------------------------------- 
    698545      ! 
    … …  
    700547      ! 
    701548      CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb )  
    702       CALL wrk_alloc( jpi,jpj, zqatm, zpatm, ztatm ) 
    703   
    704      IF ( ln_humi_rel ) THEN 
    705          zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant here) 
    706          IF (ln_apr_dyn) zpatm(:,:) = apr(:,:) 
    707          DO jj=1,jpj 
    708             DO ji=1,jpi 
    709                ztatm (ji,jj) = sf(jp_tair)%fnow(ji,jj,1)                   ! air temperature in Kelvins 
    710                ztamr = ztatm(ji,jj) - rtt                                  ! Saturation water vapour 
    711                zmt1  = SIGN( 17.269,  ztamr ) 
    712                zmt2  = SIGN( 21.875,  ztamr ) 
    713                zmt3  = SIGN( 28.200, -ztamr ) 
    714                zes   = 611.0 * EXP(  ABS( ztamr ) * MIN ( zmt1, zmt2 )   & 
    715                   &                / ( ztatm(ji,jj) - 35.86  + MAX( 0.e0, zmt3 ) )  ) 
    716                zev = sf(jp_humi)%fnow(ji,jj,1) * zes                       ! vapour pressure 
    717                zqatm(ji,jj) = 0.622 * zev / ( zpatm(ji,jj) - 0.378 * zev ) ! specific humidity 
    718             ENDDO 
    719          ENDDO 
    720       ELSE 
    721          zqatm(:,:) = sf(jp_humi)%fnow(:,:,1) 
    722       ENDIF 
    723549 
    724550      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    754580               ! Latent Heat 
    755581               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * wndm_ice(ji,jj)   &                            
    756                   &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - zqatm(ji,jj)  ) ) 
     582                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    757583              ! Latent heat sensitivity for ice (Dqla/Dt) 
    758584               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
    … …  
    788614      ! --- evaporation --- ! 
    789615      z1_lsub = 1._wp / Lsub 
    790       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    791       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    792       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     616      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
     617      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
     618      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
    793619 
    794620      ! --- evaporation minus precipitation --- ! 
    … …  
    814640      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    815641 
     642      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     643      DO jl = 1, jpl 
     644         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
     645                                   ! But we do not have Tice => consider it at 0°C => evap=0  
     646      END DO 
     647 
    816648      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    817649#endif 
    … …  
    839671      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_flx') 
    840672       
    841       CALL wrk_dealloc( jpi,jpj, zqatm, zpatm, ztatm ) 
    842673   END SUBROUTINE blk_ice_core_flx 
    843674#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r5602 r7256  
    10291029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    10301030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1031         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10311032         CALL iom_put( 'ssu_m', ssu_m ) 
    10321033      ENDIF 
    … …  
    10341035         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    10351036         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1037         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10361038         CALL iom_put( 'ssv_m', ssv_m ) 
    10371039      ENDIF 
    … …  
    13331335      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13341336      !! 
    1335       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1336       !!              ocean-ice system. 
     1337      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13371338      !! 
    13381339      !! ** Method  :   transform the fields received from the atmosphere into 
    13391340      !!             surface heat and fresh water boundary condition for the  
    13401341      !!             ice-ocean system. The following fields are provided: 
    1341       !!              * total non solar, solar and freshwater fluxes (qns_tot,  
     1342      !!               * total non solar, solar and freshwater fluxes (qns_tot,  
    13421343      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux) 
    13431344      !!             NB: emp_tot include runoffs and calving. 
    1344       !!              * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
     1345      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
    13451346      !!             emp_ice = sublimation - solid precipitation as liquid 
    13461347      !!             precipitation are re-routed directly to the ocean and  
    1347       !!             runoffs and calving directly enter the ocean. 
    1348       !!              * solid precipitation (sprecip), used to add to qns_tot  
     1348      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90) 
     1349      !!               * solid precipitation (sprecip), used to add to qns_tot  
    13491350      !!             the heat lost associated to melting solid precipitation 
    13501351      !!             over the ocean fraction. 
    1351       !!       ===>> CAUTION here this changes the net heat flux received from 
    1352       !!             the atmosphere 
    1353       !! 
    1354       !!                  - the fluxes have been separated from the stress as 
    1355       !!                 (a) they are updated at each ice time step compare to 
    1356       !!                 an update at each coupled time step for the stress, and 
    1357       !!                 (b) the conservative computation of the fluxes over the 
    1358       !!                 sea-ice area requires the knowledge of the ice fraction 
    1359       !!                 after the ice advection and before the ice thermodynamics, 
    1360       !!                 so that the stress is updated before the ice dynamics 
    1361       !!                 while the fluxes are updated after it. 
     1352      !!               * heat content of rain, snow and evap can also be provided, 
     1353      !!             otherwise heat flux associated with these mass flux are 
     1354      !!             guessed (qemp_oce, qemp_ice) 
     1355      !! 
     1356      !!             - the fluxes have been separated from the stress as 
     1357      !!               (a) they are updated at each ice time step compare to 
     1358      !!               an update at each coupled time step for the stress, and 
     1359      !!               (b) the conservative computation of the fluxes over the 
     1360      !!               sea-ice area requires the knowledge of the ice fraction 
     1361      !!               after the ice advection and before the ice thermodynamics, 
     1362      !!               so that the stress is updated before the ice dynamics 
     1363      !!               while the fluxes are updated after it. 
     1364      !! 
     1365      !! ** Details 
     1366      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1367      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1368      !! 
     1369      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1370      !! 
     1371      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1372      !!                                                                      river runoff (rnf) is provided but not included here 
    13621373      !! 
    13631374      !! ** Action  :   update at each nf_ice time step: 
    13641375      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13651376      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice 
    1366       !!                   emp_tot            total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 
    1367       !!                   emp_ice            ice sublimation - solid precipitation over the ice 
    1368       !!                   dqns_ice           d(non-solar heat flux)/d(Temperature) over the ice 
    1369       !!                   sprecip             solid precipitation over the ocean   
     1377      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1378      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1379      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1380      !!                   sprecip           solid precipitation over the ocean   
    13701381      !!---------------------------------------------------------------------- 
    13711382      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    … …  
    13761387      ! 
    13771388      INTEGER ::   jl         ! dummy loop index 
    1378       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
    1379       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
    1380       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
    1381       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
     1389      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1390      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
     1391      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1392      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13821393      !!---------------------------------------------------------------------- 
    13831394      ! 
    13841395      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13851396      ! 
    1386       CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1387       CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1397      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1398      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1399      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1400      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13881401 
    13891402      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    13921405      ! 
    13931406      !                                                      ! ========================= ! 
    1394       !                                                      !    freshwater budget      !   (emp) 
     1407      !                                                      !    freshwater budget      !   (emp_tot) 
    13951408      !                                                      ! ========================= ! 
    13961409      ! 
    1397       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1398       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1399       !                                                           ! solid Precipitation                     (sprecip) 
    1400       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1410      !                                                           ! solid Precipitation                                (sprecip) 
     1411      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1412      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1413      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    14011414      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    1402       CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1403          zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    1404          ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    1405          zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1406          zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    1407             CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
     1415      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
     1416         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1417         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
     1418         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1419         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1420               CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
    14081421         IF( iom_use('hflx_rain_cea') )   & 
    1409             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from liq. precip.  
    1410          IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
    1411             ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1422            &  CALL iom_put( 'hflx_rain_cea',   frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:)                                            )  ! heat flux from liq. precip.  
    14121423         IF( iom_use('evap_ao_cea'  ) )   & 
    1413             CALL iom_put( 'evap_ao_cea'  , ztmp                   )   ! ice-free oce evap (cell average) 
     1424            &  CALL iom_put( 'evap_ao_cea'  ,   frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)                )  ! ice-free oce evap (cell average) 
    14141425         IF( iom_use('hflx_evap_cea') )   & 
    1415             CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    1416       CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
     1426            &  CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) )  ! heat flux from from evap (cell average) 
     1427      CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14171428         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1418          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1429         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14191430         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14201431         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14211432      END SELECT 
    14221433 
    1423       IF( iom_use('subl_ai_cea') )   & 
    1424          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1425       !    
    1426       !                                                           ! runoffs and calving (put in emp_tot) 
     1434#if defined key_lim3 
     1435      ! zsnw = snow fraction over ice after wind blowing 
     1436      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1437       
     1438      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1439      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1440      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1441 
     1442      ! --- evaporation over ocean (used later for qemp) --- ! 
     1443      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1444 
     1445      ! --- evaporation over ice (kg/m2/s) --- ! 
     1446      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1447      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1448      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1449      zdevap_ice(:,:) = 0._wp 
     1450       
     1451      ! --- runoffs (included in emp later on) --- ! 
     1452      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1453 
     1454      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1455      IF( srcv(jpr_cal)%laction ) THEN  
     1456         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1457         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1458         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1459      ENDIF 
     1460 
     1461      IF( ln_mixcpl ) THEN 
     1462         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1463         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1464         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1465         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1466         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1467         DO jl=1,jpl 
     1468            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
     1469            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
     1470         ENDDO 
     1471      ELSE 
     1472         emp_tot(:,:) =         zemp_tot(:,:) 
     1473         emp_ice(:,:) =         zemp_ice(:,:) 
     1474         emp_oce(:,:) =         zemp_oce(:,:)      
     1475         sprecip(:,:) =         zsprecip(:,:) 
     1476         tprecip(:,:) =         ztprecip(:,:) 
     1477         DO jl=1,jpl 
     1478            evap_ice (:,:,jl) = zevap_ice (:,:) 
     1479            devap_ice(:,:,jl) = zdevap_ice(:,:) 
     1480         ENDDO 
     1481      ENDIF 
     1482 
     1483      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1484                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1485      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1486      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
     1487#else 
     1488      ! runoffs and calving (put in emp_tot) 
    14271489      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    14281490      IF( srcv(jpr_cal)%laction ) THEN  
    … …  
    14431505      ENDIF 
    14441506 
    1445          CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
    1446       IF( iom_use('snow_ao_cea') )   & 
    1447          CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:)             )   ! Snow        over ice-free ocean  (cell average) 
    1448       IF( iom_use('snow_ai_cea') )   & 
    1449          CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
     1507      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1508                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1509      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1510      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
     1511#endif 
    14501512 
    14511513      !                                                      ! ========================= ! 
    14521514      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    14531515      !                                                      ! ========================= ! 
    1454       CASE( 'oce only' )                                     ! the required field is directly provided 
    1455          zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    1456       CASE( 'conservative' )                                      ! the required fields are directly provided 
    1457          zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1516      CASE( 'oce only' )         ! the required field is directly provided 
     1517         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1518      CASE( 'conservative' )     ! the required fields are directly provided 
     1519         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14581520         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14591521            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    14601522         ELSE 
    1461             ! Set all category values equal for the moment 
    14621523            DO jl=1,jpl 
    1463                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1524               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    14641525            ENDDO 
    14651526         ENDIF 
    1466       CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1467          zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1527      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1528         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    14681529         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14691530            DO jl=1,jpl 
    … …  
    14721533            ENDDO 
    14731534         ELSE 
    1474             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1535            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    14751536            DO jl=1,jpl 
    14761537               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    … …  
    14781539            ENDDO 
    14791540         ENDIF 
    1480       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1541      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    14811542! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    14821543         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14831544         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    14841545            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1485             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1546            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    14861547      END SELECT 
    14871548!!gm 
    … …  
    14931554!! similar job should be done for snow and precipitation temperature 
    14941555      !                                      
    1495       IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    1496          ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1497          zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    1498          IF( iom_use('hflx_cal_cea') )   & 
    1499             CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    1500       ENDIF 
    1501  
    1502       ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
    1503       IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    1504  
    1505 #if defined key_lim3 
    1506       CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
    1507  
    1508       ! --- evaporation --- ! 
    1509       ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
    1510       ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
    1511       !                 but it is incoherent WITH the ice model   
    1512       DO jl=1,jpl 
    1513          evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
    1514       ENDDO 
    1515       zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
    1516  
    1517       ! --- evaporation minus precipitation --- ! 
    1518       emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
    1519  
     1556      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1557         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1558                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1559         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1560      ENDIF 
     1561 
     1562#if defined key_lim3       
    15201563      ! --- non solar flux over ocean --- ! 
    15211564      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    15231566      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15241567 
    1525       ! --- heat flux associated with emp --- ! 
    1526       zsnw(:,:) = 0._wp 
    1527       CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
    1528       zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    1529          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    1530          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
    1531       qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    1532          &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1533  
    1534       ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1568      ! --- heat flux associated with emp (W/m2) --- ! 
     1569      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1570         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1571         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1572!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1573!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1574      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1575                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
     1576       
     1577      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15351578      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15361579 
    1537       ! --- total non solar flux --- ! 
    1538       zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1580      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     1581      DO jl = 1, jpl 
     1582         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
     1583      END DO 
     1584 
     1585      ! --- total non solar flux (including evap/precip) --- ! 
     1586      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
    15391587 
    15401588      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15431591         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15441592         DO jl=1,jpl 
    1545             qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1593            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
     1594            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
    15461595         ENDDO 
    15471596         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15481597         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1549 !!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1598         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
    15501599      ELSE 
    15511600         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    15521601         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    15531602         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
    1554          qprec_ice(:,:)   = zqprec_ice(:,:) 
    1555          qemp_oce (:,:)   = zqemp_oce (:,:) 
    1556       ENDIF 
    1557  
    1558       CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1603         qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
     1604         qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
     1605         qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
     1606         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
     1607      ENDIF 
     1608 
     1609      ! some more outputs 
     1610      IF( iom_use('hflx_snow_cea') )    CALL iom_put('hflx_snow_cea',   sprecip(:,:) * ( zcptn(:,:) - Lfus ) )                       ! heat flux from snow (cell average) 
     1611      IF( iom_use('hflx_rain_cea') )    CALL iom_put('hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )                 ! heat flux from rain (cell average) 
     1612      IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 
     1613      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) )           ! heat flux from snow (cell average) 
     1614 
    15591615#else 
    1560  
    15611616      ! clem: this formulation is certainly wrong... but better than it was... 
    15621617      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    15631618         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    15641619         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1565          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1620         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    15661621 
    15671622     IF( ln_mixcpl ) THEN 
    … …  
    15751630         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    15761631      ENDIF 
    1577  
    15781632#endif 
    15791633 
    … …  
    16261680 
    16271681#if defined key_lim3 
    1628       CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16291682      ! --- solar flux over ocean --- ! 
    16301683      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16341687      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16351688      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
    1636  
    1637       CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16381689#endif 
    16391690 
    … …  
    16861737      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    16871738 
    1688       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1689       CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1739      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1740      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1741      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1742      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    16901743      ! 
    16911744      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17431796                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    17441797                  ELSEWHERE 
    1745                      ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     1798                     ztmp3(:,:,1) = rt0 
    17461799                  END WHERE 
    17471800               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    … …  
    17741827      !                                                      ! ------------------------- ! 
    17751828      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1776          SELECT CASE( sn_snd_alb%cldes ) 
    1777          CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
    1778          CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1779          CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1829          SELECT CASE( sn_snd_alb%cldes ) 
     1830          CASE( 'ice' ) 
     1831             SELECT CASE( sn_snd_alb%clcat ) 
     1832             CASE( 'yes' )    
     1833                ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1834             CASE( 'no' ) 
     1835                WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1836                   ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 
     1837                ELSEWHERE 
     1838                   ztmp1(:,:) = albedo_oce_mix(:,:) 
     1839                END WHERE 
     1840             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 
     1841             END SELECT 
     1842          CASE( 'weighted ice' )   ; 
     1843             SELECT CASE( sn_snd_alb%clcat ) 
     1844             CASE( 'yes' )    
     1845                ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1846             CASE( 'no' ) 
     1847                WHERE( fr_i (:,:) > 0. ) 
     1848                   ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 
     1849                ELSEWHERE 
     1850                   ztmp1(:,:) = 0. 
     1851                END WHERE 
     1852             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 
     1853             END SELECT 
     1854          CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
    17801855         END SELECT 
    1781          CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    1782       ENDIF 
     1856 
     1857         SELECT CASE( sn_snd_alb%clcat ) 
     1858            CASE( 'yes' )    
     1859               CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode 
     1860            CASE( 'no'  )    
     1861               CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )  
     1862         END SELECT 
     1863      ENDIF 
     1864 
    17831865      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean 
    17841866         ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r5602 r7256  
    108108         ! 
    109109         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    110             z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
     110            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    111111            zcoef = z_fwf * rcp 
    112112            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
    … …  
    162162            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    163163            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    164             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
     164            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    165165            !             
    166166            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r5602 r7256  
    103103                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 ) 
    104104          
    105          fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
     105         CALL eos_fzp( sss_m(:,:), fr_i(:,:) )       ! sea surface freezing temperature [Celcius] 
     106         fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 
    106107 
    107108         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)          

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r5602 r7256  
    110110      INTEGER  ::   jl                 ! dummy loop index 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    112       REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    113112      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    114113      !!---------------------------------------------------------------------- 
    … …  
    126125          
    127126         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    128          t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
    129           
     127         CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 
     128         t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
     129           
    130130         ! Mask sea ice surface temperature (set to rt0 over land) 
    131131         DO jl = 1, jpl 
    … …  
    196196         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    197197         !---------------------------------------------------------------------------------------- 
    198          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     198         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    199199         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    200200 
    … …  
    202202         CASE( jp_clio )                                       ! CLIO bulk formulation 
    203203            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    204             ! (zalb_ice) is computed within the bulk routine 
    205             CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
    206             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    207             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     204            ! (alb_ice) is computed within the bulk routine 
     205                                 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 
     206            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     207            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    208208         CASE( jp_core )                                       ! CORE bulk formulation 
    209209            ! albedo depends on cloud fraction because of non-linear spectral effects 
    210             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    211             CALL blk_ice_core_flx( t_su, zalb_ice ) 
    212             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    213             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     210            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     211                                 CALL blk_ice_core_flx( t_su, alb_ice ) 
     212            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     213            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    214214         CASE ( jp_purecpl ) 
    215215            ! albedo depends on cloud fraction because of non-linear spectral effects 
    216             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    217                                  CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    218             ! clem: evap_ice is forced to 0 in coupled mode for now  
    219             !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
    220             evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
    221             IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     216            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     217                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     218            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    222219         END SELECT 
    223          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     220         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    224221 
    225222         !----------------------------! 
    … …  
    232229         CALL lim_sbc_flx( kt )                     ! Update surface ocean mass, heat and salt fluxes 
    233230         ! 
    234          IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
     231         IF(ln_limdiaout) CALL lim_diahsb( kt )     ! Diagnostics and outputs  
    235232         ! 
    236233         CALL lim_wri( 1 )                          ! Ice outputs  
    … …  
    264261      !!---------------------------------------------------------------------- 
    265262      INTEGER :: ierr 
     263      INTEGER :: ji, jj 
    266264      !!---------------------------------------------------------------------- 
    267265      IF(lwp) WRITE(numout,*) 
    … …  
    312310         numit = nit000 - 1 
    313311      ENDIF 
    314       CALL lim_var_agg(1) 
     312      CALL lim_var_agg(2) 
    315313      CALL lim_var_glo2eqv 
    316314      ! 
    317315      CALL lim_sbc_init                 ! ice surface boundary condition    
     316      ! 
     317      IF( ln_limdiaout) CALL lim_diahsb_init  ! initialization for diags 
    318318      ! 
    319319      fr_i(:,:)     = at_i(:,:)         ! initialisation of sea-ice fraction 
    320320      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
     321      ! 
     322      DO jj = 1, jpj 
     323         DO ji = 1, jpi 
     324            IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
     325            ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
     326            ENDIF 
     327        ENDDO 
     328      ENDDO  
    321329      ! 
    322330      nstart = numit  + nn_fsbc       
    … …  
    342350      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    343351      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
    344          &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     352         &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    345353      !!------------------------------------------------------------------- 
    346354      !                     
    … …  
    363371         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    364372         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    365          WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     373         WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
     374         WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
    366375         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    367376         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    578587      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    579588      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    580       sfx_res(:,:) = 0._wp 
     589      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
    581590       
    582591      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    594603      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    595604      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    596       hfx_err_dif(:,:) = 0._wp   ; 
    597  
     605      hfx_err_dif(:,:) = 0._wp 
     606      wfx_err_sub(:,:) = 0._wp 
     607       
    598608      afx_tot(:,:) = 0._wp   ; 
    599609      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r5602 r7256  
    150150 
    151151         ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    152          tfu(:,:) = eos_fzp( sss_m ) +  rt0  
     152         CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 
     153         tfu(:,:) = tfu(:,:) + rt0 
    153154 
    154155         zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r5602 r7256  
    5353   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5454   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    55 #if defined key_agrif 
    56    ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals 
    57    REAL(wp),    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    58                                                                                           !: (first wet level and last level include in the tbl) 
    59 #else 
    6055   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    61 #endif 
    6256 
    6357 
    … …  
    9286    REAL(wp)                     ::   rmin 
    9387    REAL(wp)                     ::   zhk 
    94     CHARACTER(len=256)           ::   cfisf, cvarzisf, cvarhisf   ! name for isf file 
     88    REAL(wp)                     ::   zt_frz, zpress 
     89    CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
    9590    CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    9691    CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    … …  
    176171              DO jj = 1, jpj 
    177172                  jk = 2 
    178                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     173                  DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    179174                  misfkt(ji,jj) = jk-1 
    180175               END DO 
    … …  
    194189         END IF 
    195190          
     191         ! save initial top boundary layer thickness          
    196192         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
     193 
     194      END IF 
     195 
     196      !                                            ! ---------------------------------------- ! 
     197      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
     198         !                                         ! ---------------------------------------- ! 
     199         fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
     200         risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
     201         ! 
     202      ENDIF 
     203 
     204      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    197205 
    198206         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    … …  
    205213 
    206214               ! determine the deepest level influenced by the boundary layer 
    207                ! test on tmask useless ????? 
    208215               DO jk = ikt, mbkt(ji,jj) 
    209216                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    … …  
    217224            END DO 
    218225         END DO 
    219           
    220       END IF 
    221  
    222       !                                            ! ---------------------------------------- ! 
    223       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    224          !                                         ! ---------------------------------------- ! 
    225          fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
    226          risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    227          ! 
    228       ENDIF 
    229  
    230       IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    231  
    232226 
    233227         ! compute salf and heat flux 
    … …  
    270264         END IF 
    271265         ! compute tsc due to isf 
    272          ! WARNING water add at temp = 0C, correction term is added in trasbc, maybe better here but need a 3D variable). 
    273          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp ! 
     266         ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
     267!         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     268         zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
     269         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
    274270          
    275271         ! salt effect already take into account in vertical advection 
    276272         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    277            
     273 
     274         ! output 
     275         IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
     276         IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
     277 
     278         ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
     279         fwfisf(:,:) = rdivisf * fwfisf(:,:)          
     280  
    278281         ! lbclnk 
    279282         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    … …  
    295298         ENDIF 
    296299         !  
    297          ! output 
    298          CALL iom_put('qisf'  , qisf) 
    299          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    300300      END IF 
    301301   
    … …  
    370370             ! Calculate freezing temperature 
    371371                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    372                 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
     372                CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    373373                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    374374             ENDDO 
    … …  
    452452      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    453453! Calculate freezing temperature 
    454       zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
     454      CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    455455 
    456456       
    … …  
    472472 
    473473                     nit = nit + 1 
    474                      IF (nit .GE. 100) THEN 
    475                         !WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b,zgammat, rn_gammat0, rn_tfri2, nn_gammablk, ji,jj 
    476                         !WRITE(numout,*) "sbcisf : too many iteration ... ", (zhtflx - zhtflx_b)/zhtflx 
    477                         CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    478                      END IF 
     474                     IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     475 
    479476! save gammat and compute zhtflx_b 
    480477                     zgammat2d(ji,jj)=zgammat 
    … …  
    794791               ! test on tmask useless ????? 
    795792               DO jk = ikt, mbkt(ji,jj) 
    796 !                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     793                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    797794               END DO 
    798795               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r5602 r7256  
    179179 
    180180      !                          ! Checks: 
    181       IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
     181      IF( nn_isf .EQ. 0 ) THEN                      ! variable initialisation if no ice shelf  
    182182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    183          fwfisf  (:,:) = 0.0_wp 
    184          fwfisf_b(:,:) = 0.0_wp 
     183         fwfisf  (:,:)   = 0.0_wp ; fwfisf_b  (:,:)   = 0.0_wp 
     184         risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 
     185         rdivisf       = 0.0_wp 
    185186      END IF 
    186187      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    … …  
    339340         emp_b(:,:) = emp(:,:) 
    340341         sfx_b(:,:) = sfx(:,:) 
     342         IF ( ln_rnf ) THEN 
     343            rnf_b    (:,:  ) = rnf    (:,:  ) 
     344            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     345         ENDIF 
    341346      ENDIF 
    342347      !                                            ! ---------------------------------------- ! 
    … …  
    455460      !                                                ! ---------------------------------------- ! 
    456461      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    457          CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
     462         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
     463         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    458464         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    459465                                                                ! (includes virtual salt flux beneath ice  

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r5602 r7256  
    5252   REAL(wp)                   ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5353   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    54    REAL(wp)                  ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
    5555 
    5656   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    … …  
    109109      ! 
    110110      CALL wrk_alloc( jpi,jpj, ztfrz) 
    111  
    112       !                                            ! ---------------------------------------- ! 
    113       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    114          !                                         ! ---------------------------------------- ! 
    115          rnf_b    (:,:  ) = rnf    (:,:  )               ! Swap the ocean forcing fields except at nit000 
    116          rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    117          ! 
    118       ENDIF 
    119  
     111      ! 
    120112      !                                            !-------------------! 
    121113      !                                            !   Update runoff   ! 
    … …  
    125117      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    126118      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    127       ! 
    128       ! Runoff reduction only associated to the ORCA2_LIM configuration 
    129       ! when reading the NetCDF file runoff_1m_nomask.nc 
    130       IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
    131          WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    132             sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
    133          END WHERE 
    134       ENDIF 
    135119      ! 
    136120      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    r5602 r7256  
    3131CONTAINS 
    3232 
    33    SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) 
     33   SUBROUTINE upd_tide( kt, kit, time_offset ) 
    3434      !!---------------------------------------------------------------------- 
    3535      !!                 ***  ROUTINE upd_tide  *** 
    … …  
    4242      !!----------------------------------------------------------------------       
    4343      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index 
    44       INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T only) 
    45       INTEGER, INTENT(in), OPTIONAL ::   kbaro   ! number of sub-time-step           (lk_dynspg_ts=T only) 
    46       INTEGER, INTENT(in), OPTIONAL ::   koffset ! time offset in number  
    47                                                  ! of sub-time-steps                 (lk_dynspg_ts=T only) 
     44      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T) 
     45      INTEGER, INTENT(in), OPTIONAL ::   time_offset ! time offset in number  
     46                                                     ! of internal steps             (lk_dynspg_ts=F) 
     47                                                     ! of external steps             (lk_dynspg_ts=T) 
    4848      ! 
    4949      INTEGER  ::   joffset      ! local integer 
    … …  
    5757      ! 
    5858      joffset = 0 
    59       IF( PRESENT( koffset ) )   joffset = koffset 
     59      IF( PRESENT( time_offset ) )   joffset = time_offset 
    6060      ! 
    61       IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   THEN 
    62          zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp ) 
     61      IF( PRESENT( kit ) )   THEN 
     62         zt = zt + ( kit +  joffset - 1 ) * rdt / REAL( nn_baro, wp ) 
    6363      ELSE 
    6464         zt = zt + joffset * rdt 
    … …  
    7474      IF( ln_tide_ramp ) THEN         ! linear increase if asked 
    7575         zt = ( kt - nit000 ) * rdt 
    76          IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   zt = zt + kit * rdt / REAL( kbaro, wp ) 
     76         IF( PRESENT( kit ) )   zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp ) 
    7777         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  ) 
    7878         pot_astro(:,:) = zramp * pot_astro(:,:) 
    … …  
    8686  !!---------------------------------------------------------------------- 
    8787CONTAINS 
    88   SUBROUTINE upd_tide( kt, kit, kbaro, koffset )          ! Empty routine 
     88  SUBROUTINE upd_tide( kt, kit, time_offset )  ! Empty routine 
    8989    INTEGER, INTENT(in)           ::   kt      !  integer  arg, dummy routine 
    9090    INTEGER, INTENT(in), OPTIONAL ::   kit     !  optional arg, dummy routine 
    91     INTEGER, INTENT(in), OPTIONAL ::   kbaro   !  optional arg, dummy routine 
    92     INTEGER, INTENT(in), OPTIONAL ::   koffset !  optional arg, dummy routine 
     91    INTEGER, INTENT(in), OPTIONAL ::   time_offset !  optional arg, dummy routine 
    9392    WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 
    9493  END SUBROUTINE upd_tide 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r4624 r7256  
    9292      IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 
    9393         IF( sol_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 
     94         gcx (:,:) = 0.e0 
     95         gcxb(:,:) = 0.e0 
    9496      ENDIF 
    9597 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r5488 r7256  
    849849 
    850850 
    851    REAL(wp) FUNCTION sto_par_flt_fac( kpasses ) 
     851   FUNCTION sto_par_flt_fac( kpasses ) 
    852852      !!---------------------------------------------------------------------- 
    853853      !!                  ***  FUNCTION sto_par_flt_fac  *** 
    … …  
    858858      !!---------------------------------------------------------------------- 
    859859      INTEGER, INTENT(in) :: kpasses 
     860      REAL(wp) :: sto_par_flt_fac 
    860861      !! 
    861862      INTEGER :: jpasses, ji, jj, jflti, jfltj 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6101 r7256  
    2222   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
    2323   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
     24   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
    2425   !!---------------------------------------------------------------------- 
    2526 
    … …  
    991992 
    992993 
    993    FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     994   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
    994995      !!---------------------------------------------------------------------- 
    995996      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10051006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10061007      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1007       REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1008      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
    10081009      ! 
    10091010      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    10171018         DO jj = 1, jpj 
    10181019            DO ji = 1, jpi 
    1019                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1020               zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp )           ! square root salinity 
    10201021               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10211022                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10381039         nstop = nstop + 1 
    10391040         ! 
    1040       END SELECT 
    1041       ! 
    1042    END FUNCTION eos_fzp_2d 
    1043  
    1044   FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1041      END SELECT       
     1042      ! 
     1043  END SUBROUTINE eos_fzp_2d 
     1044 
     1045  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    10451046      !!---------------------------------------------------------------------- 
    10461047      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10541055      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10551056      !!---------------------------------------------------------------------- 
    1056       REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
    1057       REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
    1058       REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1057      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
     1058      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
     1059      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
    10591060      ! 
    10601061      REAL(wp) :: zs   ! local scalars 
    … …  
    10651066      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    10661067         ! 
    1067          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1068         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity 
    10681069         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10691070                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10861087      END SELECT 
    10871088      ! 
    1088    END FUNCTION eos_fzp_0d 
     1089   END SUBROUTINE eos_fzp_0d 
    10891090 
    10901091 
    … …  
    12551256            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12561257         ENDIF 
     1258      ENDIF 
     1259      ! 
     1260      ! Consistency check on ln_useCT and nn_eos 
     1261      IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 
     1262         CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 
     1263      ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 
     1264         CALL ctl_stop("ln_useCT should be set to False if using TEOS-80 or simplified equation of state (nn_eos=0 or nn_eos=1)") 
    12571265      ENDIF 
    12581266      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r5602 r7256  
    173173         END DO  
    174174      END DO  
    175       zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 
     175      CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 
    176176      DO jk = 1, jpk 
    177177         DO jj = 1, jpj 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r4990 r7256  
    212212      CHARACTER(len=3) ::   cdtype 
    213213      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn 
    214       WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
     214      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', & 
     215          &  kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
    215216   END SUBROUTINE tra_adv_eiv 
    216217#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r5602 r7256  
    173173            DO jj = 2, jpjm1 
    174174               DO ji = fs_2, fs_jpim1   ! vector opt. 
    175                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    176175                  ! total intermediate advective trends 
    177                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    178                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    179                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     176                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     177                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     178                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    180179                  ! update and guess with monotonic sheme 
    181                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra  * tmask(ji,jj,jk) 
    182                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     180                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     181                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    183182               END DO 
    184183            END DO 
    … …  
    326325      CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
    327326      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
    328       CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
     327      CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    329328      ! 
    330329      IF( kt == kit000 )  THEN 
    … …  
    410409            DO jj = 2, jpjm1 
    411410               DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                   zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    413411                  ! total intermediate advective trends 
    414                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    415                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    416                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     412                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     413                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     414                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    417415                  ! update and guess with monotonic sheme 
    418                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
    419                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     416                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     417                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    420418               END DO 
    421419            END DO 
    … …  
    438436         ! -------------------------------------------------- 
    439437         ! antidiffusive flux on i and j 
    440  
    441  
    442          DO jk = 1, jpkm1 
    443  
     438         ! 
     439         DO jk = 1, jpkm1 
     440            ! 
    444441            DO jj = 1, jpjm1 
    445442               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    472469         ! 
    473470         ztrs(:,:,:,1) = ptb(:,:,:,jn) 
     471         ztrs(:,:,1,2) = ptb(:,:,1,jn) 
     472         ztrs(:,:,1,3) = ptb(:,:,1,jn) 
    474473         zwzts(:,:,:) = 0._wp 
    475474 
    … …  
    564563      ! 
    565564                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
    566                    CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
     565                   CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    567566                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    568567      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    … …  
    571570      ! 
    572571   END SUBROUTINE tra_adv_tvd_zts 
     572 
    573573 
    574574   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r5602 r7256  
    6868      ! 
    6969      rldf = 1     ! For active tracers the  
     70      r_fact_lap(:,:,:) = 1.0 
    7071 
    7172      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    … …  
    214215      IF( ierr == 1 )   CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 
    215216      IF( ierr == 2 )   CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 
     217      IF( ln_traldf_grif .AND. ln_isfcav         )   & 
     218           CALL ctl_stop( ' ice shelf and traldf_grif not tested') 
    216219      IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso )   & 
    217220           CALL ctl_stop( '          eddy induced velocity on tracers',   & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r6772 r7256  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
     30   USE sbcisf          ! ice shelf melting/freezing 
    3031   USE zdf_oce         ! ocean vertical mixing 
    3132   USE domvvl          ! variable volume 
    … …  
    4647   USE timing          ! Timing 
    4748#if defined key_agrif 
    48    USE agrif_opa_update 
    4949   USE agrif_opa_interp 
    5050#endif 
    … …  
    112112      ! Update after tracer on domain lateral boundaries 
    113113      !  
     114#if defined key_agrif 
     115      CALL Agrif_tra                     ! AGRIF zoom boundaries 
     116#endif 
     117      ! 
    114118      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    115119      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    … …  
    117121#if defined key_bdy  
    118122      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    119 #endif 
    120 #if defined key_agrif 
    121       CALL Agrif_tra                     ! AGRIF zoom boundaries 
    122123#endif 
    123124  
    … …  
    150151         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    151152         ENDIF 
    152       ENDIF  
    153       ! 
    154 #if defined key_agrif 
    155       ! Update tracer at AGRIF zoom boundaries 
    156       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
    157 #endif       
    158       ! 
    159       ! trends computation 
     153      ENDIF      
     154      ! 
     155     ! trends computation 
    160156      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    161157         DO jk = 1, jpkm1 
    … …  
    281277 
    282278      !!      
    283       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     279      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf   ! local logical 
    284280      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    285281      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    297293         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    298294         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     295         IF (nn_isf .GE. 1) THEN  
     296            ll_isf = .TRUE.            ! active  tracers case  and  ice shelf melting/freezing 
     297         ELSE 
     298            ll_isf = .FALSE. 
     299         END IF 
    299300      ELSE                           
    300301         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    301302         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    302303         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
     304         ll_isf     = .FALSE.          ! passive tracers or NO ice shelf melting/freezing 
    303305      ENDIF 
    304306      ! 
    … …  
    323325                  ztc_f  = ztc_n  + atfp * ztc_d 
    324326                  ! 
    325                   IF( jk == 1 ) THEN           ! first level  
    326                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     327                  IF( jk == mikt(ji,jj) ) THEN           ! first level  
     328                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
     329                            &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
     330                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
    327331                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    328332                  ENDIF 
    329333 
    330                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     334                  ! solar penetration (temperature only) 
     335                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    331336                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    332337 
    333                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     338                  ! river runoff 
     339                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    334340                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    335341                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     342 
     343                  ! ice shelf 
     344                  IF( ll_isf ) THEN 
     345                     ! level fully include in the Losch_2008 ice shelf boundary layer 
     346                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
     347                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     348                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
     349                     ! level partially include in Losch_2008 ice shelf boundary layer  
     350                     IF ( jk == misfkb(ji,jj) )                                                   & 
     351                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     352                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
     353                  END IF 
    336354 
    337355                  ze3t_f = 1.e0 / ze3t_f 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r5602 r7256  
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            4.0  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     12   !!            3.4  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     13   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    9394      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    9495      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
     96      !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 
    9597      !!---------------------------------------------------------------------- 
    9698      ! 
    … …  
    101103      REAL(wp) ::   zchl, zcoef, zfact   ! local scalars 
    102104      REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
    103       REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    104105      REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
     106      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
     107      REAL(wp) ::   zlogc, zlogc2, zlogc3  
    105108      REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
    106       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
    107       !!---------------------------------------------------------------------- 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 
     110      !!-------------------------------------------------------------------------- 
    108111      ! 
    109112      IF( nn_timing == 1 )  CALL timing_start('tra_qsr') 
    110113      ! 
    111114      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    112       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     115      CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    113116      ! 
    114117      IF( kt == nit000 ) THEN 
    … …  
    183186            !                                             ! ------------------------- ! 
    184187            ! Set chlorophyl concentration 
    185             IF( nn_chldta == 1 .OR. lk_vvl ) THEN            !*  Variable Chlorophyll or ocean volume 
    186                ! 
    187                IF( nn_chldta == 1 ) THEN                             !*  Variable Chlorophyll 
    188                   ! 
    189                   CALL fld_read( kt, 1, sf_chl )                         ! Read Chl data and provides it at the current time step 
    190                   !          
    191 !CDIR COLLAPSE 
     188            IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN    !*  Variable Chlorophyll or ocean volume 
     189               ! 
     190               IF( nn_chldta == 1 ) THEN        !*  2D Variable Chlorophyll 
     191                  ! 
     192                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     193                  DO jk = 1, nksr + 1 
     194                     zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1)  
     195                  ENDDO 
     196                  ! 
     197               ELSE IF( nn_chldta == 2 ) THEN    !*   -3-D Variable Chlorophyll 
     198                  ! 
     199                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     200!CDIR NOVERRCHK   ! 
     201                  DO jj = 1, jpj 
    192202!CDIR NOVERRCHK 
    193                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    194 !CDIR NOVERRCHK 
    195                      DO ji = 1, jpi 
    196                         zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    197                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    198                         zekb(ji,jj) = rkrgb(1,irgb) 
    199                         zekg(ji,jj) = rkrgb(2,irgb) 
    200                         zekr(ji,jj) = rkrgb(3,irgb) 
    201                      END DO 
    202                   END DO 
    203                ELSE                                            ! Variable ocean volume but constant chrlorophyll 
    204                   zchl = 0.05                                     ! constant chlorophyll 
    205                   irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
    206                   zekb(:,:) = rkrgb(1,irgb)                       ! Separation in R-G-B depending of the chlorophyll  
    207                   zekg(:,:) = rkrgb(2,irgb) 
    208                   zekr(:,:) = rkrgb(3,irgb) 
     203                     DO ji = 1, jpi 
     204                        zchl    = sf_chl(1)%fnow(ji,jj,1) 
     205                        zCtot   = 40.6  * zchl**0.459 
     206                        zze     = 568.2 * zCtot**(-0.746) 
     207                        IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
     208                        zlogc   = LOG( zchl ) 
     209                        zlogc2  = zlogc * zlogc 
     210                        zlogc3  = zlogc * zlogc * zlogc 
     211                        zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
     212                        zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
     213                        zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
     214                        zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
     215                        zCze    = 1.12  * (zchl)**0.803  
     216                        DO jk = 1, nksr + 1 
     217                           zpsi = fsdept(ji,jj,jk) / zze 
     218                           zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
     219                        END DO 
     220                        ! 
     221                      END DO 
     222                   END DO 
     223                     ! 
     224               ELSE                              !* Variable ocean volume but constant chrlorophyll 
     225                  DO jk = 1, nksr + 1 
     226                     zchl3d(:,:,jk) = 0.05  
     227                  ENDDO 
    209228               ENDIF 
    210229               ! 
    211                zcoef  = ( 1. - rn_abs ) / 3.e0                        ! equi-partition in R-G-B 
     230               zcoef  = ( 1. - rn_abs ) / 3.e0                        !  equi-partition in R-G-B 
    212231               ze0(:,:,1) = rn_abs  * qsr(:,:) 
    213232               ze1(:,:,1) = zcoef * qsr(:,:) 
    … …  
    217236               ! 
    218237               DO jk = 2, nksr+1 
     238                  ! 
     239                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of vertical profile of Chl 
     240!CDIR NOVERRCHK 
     241                     DO ji = 1, jpi 
     242                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
     243                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     244                        zekb(ji,jj) = rkrgb(1,irgb) 
     245                        zekg(ji,jj) = rkrgb(2,irgb) 
     246                        zekr(ji,jj) = rkrgb(3,irgb) 
     247                     END DO 
     248                  END DO 
    219249!CDIR NOVERRCHK 
    220250                  DO jj = 1, jpj 
    … …  
    233263                  END DO 
    234264               END DO 
    235                ! clem: store attenuation coefficient of the first ocean level 
    236                IF ( ln_qsr_ice ) THEN 
    237                   DO jj = 1, jpj 
    238                      DO ji = 1, jpi 
    239                         zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
    240                         zzc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
    241                         zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    242                         zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    243                         fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    244                      END DO 
    245                   END DO 
    246                ENDIF 
    247265               ! 
    248266               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    … …  
    251269               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    252270               CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
     271               ! 
     272               IF ( ln_qsr_ice ) THEN    ! store attenuation coefficient of the first ocean level 
     273!CDIR NOVERRCHK 
     274                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
     275!CDIR NOVERRCHK 
     276                     DO ji = 1, jpi 
     277                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 
     278                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     279                        zekb(ji,jj) = rkrgb(1,irgb) 
     280                        zekg(ji,jj) = rkrgb(2,irgb) 
     281                        zekr(ji,jj) = rkrgb(3,irgb) 
     282                     END DO 
     283                  END DO 
     284                  !  
     285                  DO jj = 1, jpj 
     286                     DO ji = 1, jpi 
     287                        zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
     288                        zc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
     289                        zc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
     290                        zc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
     291                        fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2  + zc3  ) * tmask(ji,jj,2)  
     292                     END DO 
     293                  END DO 
     294                  ! 
     295               ENDIF 
    253296               ! 
    254297            ELSE                                                 !*  Constant Chlorophyll 
    … …  
    256299                  qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    257300               END DO 
    258                ! clem: store attenuation coefficient of the first ocean level 
    259                IF ( ln_qsr_ice ) THEN 
     301               ! store attenuation coefficient of the first ocean level 
     302               IF( ln_qsr_ice ) THEN 
    260303                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    261304               ENDIF 
    … …  
    339382      ! 
    340383      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    341       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     384      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    342385      ! 
    343386      IF( nn_timing == 1 )  CALL timing_stop('tra_qsr') 
    … …  
    405448         WRITE(numout,*) '      bio-model            light penetration   ln_qsr_bio = ', ln_qsr_bio 
    406449         WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice 
    407          WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)    nn_chldta  = ', nn_chldta 
     450         WRITE(numout,*) '      RGB : Chl data (=1/2) or cst value (=0)  nn_chldta  = ', nn_chldta 
    408451         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs = ', rn_abs 
    409452         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    … …  
    429472         IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr =  1  
    430473         IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr =  2 
    431          IF( ln_qsr_2bd                      )   nqsr =  3 
    432          IF( ln_qsr_bio                      )   nqsr =  4 
     474         IF( ln_qsr_rgb .AND. nn_chldta == 2 )   nqsr =  3 
     475         IF( ln_qsr_2bd                      )   nqsr =  4 
     476         IF( ln_qsr_bio                      )   nqsr =  5 
    433477         ! 
    434478         IF(lwp) THEN                   ! Print the choice 
    435479            WRITE(numout,*) 
    436480            IF( nqsr ==  1 )   WRITE(numout,*) '         R-G-B   light penetration - Constant Chlorophyll' 
    437             IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - Chl data ' 
    438             IF( nqsr ==  3 )   WRITE(numout,*) '         2 bands light penetration' 
    439             IF( nqsr ==  4 )   WRITE(numout,*) '         bio-model light penetration' 
     481            IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - 2D Chl data ' 
     482            IF( nqsr ==  3 )   WRITE(numout,*) '         R-G-B   light penetration - 3D Chl data ' 
     483            IF( nqsr ==  4 )   WRITE(numout,*) '         2 bands light penetration' 
     484            IF( nqsr ==  5 )   WRITE(numout,*) '         bio-model light penetration' 
    440485         ENDIF 
    441486         ! 
    … …  
    460505            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    461506            ! 
    462             IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
     507            IF( nn_chldta == 1  .OR. nn_chldta == 2 ) THEN           !* Chl data : set sf_chl structure 
    463508               IF(lwp) WRITE(numout,*) 
    464509               IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5602 r7256  
    120120      REAL(wp) ::   zfact, z1_e3t, zdep 
    121121      REAL(wp) ::   zalpha, zhk 
    122       REAL(wp) ::  zt_frz, zpress 
    123122      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    124123      !!---------------------------------------------------------------------- 
    … …  
    159158         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    160159            zfact = 1._wp 
     160            sbc_tsc(:,:,:) = 0._wp 
    161161            sbc_tsc_b(:,:,:) = 0._wp 
    162162         ENDIF 
    … …  
    232232               DO jk = ikt, ikb - 1 
    233233               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    234 !                  zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    235                   zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    236234               ! compute trend 
    237235                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    238                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    239                      &               - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 
    240                      &           * r1_hisf_tbl(ji,jj) 
     236                     &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
    241237                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    242238                     &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    … …  
    245241               ! level partially include in ice shelf boundary layer  
    246242               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    247 !               zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 
    248                zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 
    249243               ! compute trend 
    250244               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    251                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    252                   &                  - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) &  
    253                   &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
     245                  &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    254246               tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    255247                  &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
    … …  
    287279         END DO   
    288280      ENDIF 
    289   
     281 
     282      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     283      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     284 
    290285      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    291286         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    r5602 r7256  
    117117      ! 
    118118      SELECT CASE( ktrd ) 
    119          CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
    120          CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
    121          CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
    122          CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
    123          CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
    124          CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
    125          CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
    126          CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
    127          CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
    128          CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
     119        CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
     120        CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
     121        CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
     122        CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
     123        CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
     124        CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
     125        CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
     126        CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
     127        CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
     128        CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
    129129                                 !                                   ! wind stress trends 
    130                                  CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
    131                            z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
    132                            z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
    133                            zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
    134                            DO jj = 2, jpj 
    135                               DO ji = 2, jpi 
    136                                  zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
    137                                  &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
    138                               END DO 
    139                            END DO 
    140                                  CALL iom_put( "ketrd_tau", zke2d ) 
    141                                  CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
    142          CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
     130                                CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
     131                     z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
     132                     z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
     133                     zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
     134                     DO jj = 2, jpj 
     135                         DO ji = 2, jpi 
     136                           zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
     137                            &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
     138                         END DO 
     139                     END DO 
     140                                CALL iom_put( "ketrd_tau", zke2d ) 
     141                                CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
     142        CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
    143143!!gm TO BE DONE properly 
    144144!!gm only valid if ln_bfrimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... 
    … …  
    162162!         ENDIF 
    163163!!gm end 
    164          CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
     164        CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
    165165!! a faire !!!!  idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! 
    166166!! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf.... 
    … …  
    184184!                              CALL iom_put( "ketrd_bfri", zke2d ) 
    185185!         ENDIF 
    186          CASE( jpdyn_ken )   ;   ! kinetic energy 
    187                            ! called in dynnxt.F90 before asselin time filter 
    188                            ! with putrd=ua and pvtrd=va 
    189                            zke(:,:,:) = 0.5_wp * zke(:,:,:) 
    190                            CALL iom_put( "KE", zke ) 
    191                            ! 
    192                            CALL ken_p2k( kt , zke ) 
    193                            CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
     186        CASE( jpdyn_ken )   ;   ! kinetic energy 
     187                    ! called in dynnxt.F90 before asselin time filter 
     188                    ! with putrd=ua and pvtrd=va 
     189                    zke(:,:,:) = 0.5_wp * zke(:,:,:) 
     190                    CALL iom_put( "KE", zke ) 
     191                    ! 
     192                    CALL ken_p2k( kt , zke ) 
     193                      CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
    194194         ! 
    195195      END SELECT 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

    r5602 r7256  
    165165 
    166166 
    167       SELECT CASE( ktrd ) 
    168       CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
     167      SELECT CASE( ktrd ) 
     168      CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
    169169!!gm : to be completed !  
    170 !        IF( .... 
     170!         IF( .... 
    171171!!gm end 
    172       CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
    173          !                                   ! regroup iso-neutral diffusion in one term 
     172      CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
     173         !                                   ! regroup iso-neutral diffusion in one term 
    174174         tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) ) 
    175175         smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) ) 
    … …  
    811811 
    812812 
    813       nkstp     = nit000 - 1              ! current time step indicator initialization 
     813      nkstp     = nit000 - 1              ! current time step indicator initialization 
    814814 
    815815 
    … …  
    851851      IF( nn_ctls == 1 ) THEN 
    852852         CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    853          READ ( inum ) nbol 
     853         READ ( inum, * ) nbol 
    854854         CLOSE( inum ) 
    855855      END IF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

    r5602 r7256  
    1515 
    1616   !                                                !* mixed layer trend indices 
    17    INTEGER, PUBLIC, PARAMETER ::   jpltrd = 11      !: number of mixed-layer trends arrays 
     17   INTEGER, PUBLIC, PARAMETER ::   jpltrd = 12      !: number of mixed-layer trends arrays 
    1818   INTEGER, PUBLIC            ::   jpktrd           !: max level for mixed-layer trends diag. 
    1919   ! 
    … …  
    2828   INTEGER, PUBLIC, PARAMETER ::   jpmxl_for =  9   !: forcing  
    2929   INTEGER, PUBLIC, PARAMETER ::   jpmxl_dmp = 10   !: internal restoring trend 
    30    INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11   !: asselin trend (**MUST BE THE LAST ONE**) 
    31    INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12   !: asselin trend (**MUST BE THE LAST ONE**) 
     30   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11  !: iso-neutral diffusion:"pure" vertical diffusion 
     31   INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12  !: asselin trend (**MUST BE THE LAST ONE**) 
    3232   !                                                            !!* Namelist namtrd_mxl:  trend diagnostics in the mixed layer * 
    3333   INTEGER           , PUBLIC ::   nn_ctls  = 0                  !: control surface type for trends vertical integration 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

    r5602 r7256  
    9999                                   CALL wrk_alloc( jpi, jpj, z2d ) 
    100100                                   z2d(:,:) = wn(:,:,1) * ( & 
    101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
    102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
    103                                       &                  ) / fse3t(:,:,1) 
     101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
     102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
     103                                       &             ) / fse3t(:,:,1) 
    104104                                   CALL iom_put( "petrd_sad" , z2d ) 
    105105                                   CALL wrk_dealloc( jpi, jpj, z2d ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r4990 r7256  
    4343   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    4444   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en              !: now turbulent kinetic energy   [m2/s2] 
    4548  
    4649   !!---------------------------------------------------------------------- 
    … …  
    6063         &     tfrua(jpi, jpj), tfrva(jpi, jpj)              ,      & 
    6164         &     avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk)           ,      & 
    62          &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           , STAT = zdf_oce_alloc ) 
     65         &     avmv  (jpi,jpj,jpk), avt   (jpi,jpj,jpk)      ,      & 
     66         &     avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk)      ,      &  
     67         &     avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk)      ,      & 
     68         &     en    (jpi,jpj,jpk), STAT = zdf_oce_alloc ) 
    6369         ! 
    6470      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r5602 r7256  
    177177                  &                             +  0.15 * zrau(ji,jj)          * zmskd2(ji,jj)  ) 
    178178               ! add to the eddy viscosity coef. previously computed 
     179# if defined key_zdftmx_new 
     180               ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 
     181               avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 
     182# else 
    179183               avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 
     184# endif 
    180185               avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 
    181186               avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r5602 r7256  
    4242   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag 
    4343   ! 
    44    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
    4544   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    4645   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k   ! not enhanced Kz 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k   ! not enhanced Kz 
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k  ! not enhanced Kz 
    50    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmv_k  ! not enhanced Kz 
    5146   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    5247   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
    … …  
    120115      !!                ***  FUNCTION zdf_gls_alloc  *** 
    121116      !!---------------------------------------------------------------------- 
    122       ALLOCATE( en(jpi,jpj,jpk),  mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
    123          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                    & 
    124          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk),                    & 
    125          &      ustars2(jpi,jpj), ustarb2(jpi,jpj)                      , STAT= zdf_gls_alloc ) 
     117      ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
     118         &      ustars2(jpi,jpj) , ustarb2(jpi,jpj)   , STAT= zdf_gls_alloc ) 
    126119         ! 
    127120      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc ) 
    … …  
    329322      !  
    330323      ! One level below 
    331       en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     324      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 
     325          &            / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
    332326      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
    333327      z_elem_a(:,:,2) = 0._wp  
    … …  
    350344      z_elem_a(:,:,2) = 0._wp 
    351345      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
    352       zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
     346      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 
     347           &                      * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
    353348 
    354349      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6101 r7256  
    2727 
    2828   PUBLIC   zdf_mxl       ! called by step.F90 
     29   PUBLIC   zdf_mxl_alloc ! Used in zdf_tke_init 
    2930 
    3031   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
    … …  
    7980      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8081      ! 
    81       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    82       INTEGER  ::   iikn, iiki, ikt, imkt  ! local integer 
    83       REAL(wp) ::   zN2_c        ! local scalar 
     82      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     83      INTEGER  ::   iikn, iiki, ikt ! local integer 
     84      REAL(wp) ::   zN2_c           ! local scalar 
    8485      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    8586      REAL(wp), POINTER, DIMENSION(:,:) ::   z2d   ! 2D workspace 
    … …  
    118119         DO jj = 1, jpj 
    119120            DO ji = 1, jpi 
    120                imkt = mikt(ji,jj) 
    121                IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
     121               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    122122            END DO 
    123123         END DO 
    … …  
    128128            iiki = imld(ji,jj) 
    129129            iikn = nmln(ji,jj) 
    130             imkt = mikt(ji,jj) 
    131             hmld (ji,jj) = ( fsdepw(ji,jj,iiki  ) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! Turbocline depth  
    132             hmlp (ji,jj) = ( fsdepw(ji,jj,iikn  ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
    133             hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
     130            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
     131            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth 
     132            hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    134133         END DO 
    135134      END DO 
    136       CALL iom_put("hmlpt",hmlpt) 
    137  
    138       IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    139          CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    140          CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
    141          z2d(:,:)=REAL(nmln,wp)  
    142          CALL iom_put( "nmln"  , z2d )   ! turbocline depth 
     135      ! no need to output in offline mode 
     136      IF( .NOT.lk_offline ) THEN    
     137         IF ( iom_use("mldr10_1") ) THEN 
     138            IF( ln_isfcav ) THEN 
     139               CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     140            ELSE 
     141               CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     142            END IF 
     143         END IF 
     144         IF ( iom_use("mldkz5") ) THEN 
     145            IF( ln_isfcav ) THEN 
     146               CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     147            ELSE 
     148               CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     149            END IF 
     150         END IF 
    143151      ENDIF 
    144152       

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90

    r4624 r7256  
    162162                  &                               + avmv(ji,jj,jk) + avmv(ji,jj-1,jk)  )   & 
    163163                  &          + avtb(jk) * tmask(ji,jj,jk) 
    164                !                                            ! Add the background coefficient on eddy viscosity 
     164            END DO 
     165         END DO 
     166         DO jj = 2, jpjm1                                   ! Add the background coefficient on eddy viscosity 
     167            DO ji = 2, jpim1 
    165168               avmu(ji,jj,jk) = avmu(ji,jj,jk) + avmb(jk) * umask(ji,jj,jk) 
    166169               avmv(ji,jj,jk) = avmv(ji,jj,jk) + avmb(jk) * vmask(ji,jj,jk) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r6101 r7256  
    5353   USE timing         ! Timing 
    5454   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     55#if defined key_agrif 
     56   USE agrif_opa_interp 
     57   USE agrif_opa_update 
     58#endif 
     59 
     60 
    5561 
    5662   IMPLICIT NONE 
    … …  
    8591   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    8692 
    87    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy   [m2/s2] 
    8893   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8994   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    90    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
    91    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9295#if defined key_c1d 
    9396   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    115118         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    116119#endif 
    117          &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
    118          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
    119          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
     120         &      htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc      ) 
    120121         ! 
    121122      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    … …  
    189190      avmv_k(:,:,:) = avmv(:,:,:)  
    190191      ! 
     192#if defined key_agrif 
     193      ! Update child grid f => parent grid  
     194      IF( .NOT.Agrif_Root() )   CALL Agrif_Update_Tke( kt )      ! children only 
     195#endif       
     196     !  
    191197   END SUBROUTINE zdf_tke 
    192198 
    … …  
    317323                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    318324                  !                                           ! TKE Langmuir circulation source term 
    319                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     325                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
     326                     &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    320327               END DO 
    321328            END DO 
    … …  
    350357            DO ji = fs_2, fs_jpim1   ! vector opt. 
    351358               zcof   = zfact1 * tmask(ji,jj,jk) 
     359# if defined key_zdftmx_new 
     360               ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
     361               zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) )   &  ! upper diagonal 
     362                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
     363               zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) )   &  ! lower diagonal 
     364                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     365# else 
    352366               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    353367                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    354368               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    355369                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     370# endif 
    356371                  !                                                           ! shear prod. at w-point weightened by mask 
    357372               zesh2  =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 
    … …  
    710725      !!---------------------------------------------------------------------- 
    711726      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    712       INTEGER ::   ios 
     727      INTEGER ::   ios, ierr 
    713728      !! 
    714729      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,   & 
    … …  
    728743      ! 
    729744      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number 
     745# if defined key_zdftmx_new 
     746      ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 
     747      rn_emin  = 1.e-10_wp 
     748      rmxl_min = 1.e-03_wp 
     749      IF(lwp) THEN                  ! Control print 
     750         WRITE(numout,*) 
     751         WRITE(numout,*) 'zdf_tke_init :  New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 
     752         WRITE(numout,*) '~~~~~~~~~~~~' 
     753      ENDIF 
     754# else 
    730755      rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity 
     756# endif 
    731757      ! 
    732758      IF(lwp) THEN                    !* Control print 
    … …  
    768794      ENDIF 
    769795       
    770       IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln  
     796      IF( nn_etau == 2  ) THEN 
     797          ierr = zdf_mxl_alloc() 
     798          nmln(:,:) = nlb10           ! Initialization of nmln 
     799      ENDIF 
    771800 
    772801      !                               !* depth of penetration of surface tke 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r5602 r7256  
    561561   END SUBROUTINE zdf_tmx_init 
    562562 
     563#elif defined key_zdftmx_new 
     564   !!---------------------------------------------------------------------- 
     565   !!   'key_zdftmx_new'               Internal wave-driven vertical mixing 
     566   !!---------------------------------------------------------------------- 
     567   !!   zdf_tmx       : global     momentum & tracer Kz with wave induced Kz 
     568   !!   zdf_tmx_init  : global     momentum & tracer Kz with wave induced Kz 
     569   !!---------------------------------------------------------------------- 
     570   USE oce            ! ocean dynamics and tracers variables 
     571   USE dom_oce        ! ocean space and time domain variables 
     572   USE zdf_oce        ! ocean vertical physics variables 
     573   USE zdfddm         ! ocean vertical physics: double diffusive mixing 
     574   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     575   USE eosbn2         ! ocean equation of state 
     576   USE phycst         ! physical constants 
     577   USE prtctl         ! Print control 
     578   USE in_out_manager ! I/O manager 
     579   USE iom            ! I/O Manager 
     580   USE lib_mpp        ! MPP library 
     581   USE wrk_nemo       ! work arrays 
     582   USE timing         ! Timing 
     583   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     584 
     585   IMPLICIT NONE 
     586   PRIVATE 
     587 
     588   PUBLIC   zdf_tmx         ! called in step module  
     589   PUBLIC   zdf_tmx_init    ! called in nemogcm module  
     590   PUBLIC   zdf_tmx_alloc   ! called in nemogcm module 
     591 
     592   LOGICAL, PUBLIC, PARAMETER ::   lk_zdftmx = .TRUE.    !: wave-driven mixing flag 
     593 
     594   !                       !!* Namelist  namzdf_tmx : internal wave-driven mixing * 
     595   INTEGER  ::  nn_zpyc     ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 
     596   LOGICAL  ::  ln_mevar    ! variable (=T) or constant (=F) mixing efficiency 
     597   LOGICAL  ::  ln_tsdiff   ! account for differential T/S wave-driven mixing (=T) or not (=F) 
     598 
     599   REAL(wp) ::  r1_6 = 1._wp / 6._wp 
     600 
     601   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ebot_tmx     ! power available from high-mode wave breaking (W/m2) 
     602   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   epyc_tmx     ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 
     603   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ecri_tmx     ! power available from low-mode, critical slope wave breaking (W/m2) 
     604   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbot_tmx     ! WKB decay scale for high-mode energy dissipation (m) 
     605   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hcri_tmx     ! decay scale for low-mode critical slope dissipation (m) 
     606   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   emix_tmx     ! local energy density available for mixing (W/kg) 
     607   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bflx_tmx     ! buoyancy flux Kz * N^2 (W/kg) 
     608   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   pcmap_tmx    ! vertically integrated buoyancy flux (W/m2) 
     609   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_ratio    ! S/T diffusivity ratio (only for ln_tsdiff=T) 
     610   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_wave     ! Internal wave-induced diffusivity 
     611 
     612   !! * Substitutions 
     613#  include "zdfddm_substitute.h90" 
     614#  include "domzgr_substitute.h90" 
     615#  include "vectopt_loop_substitute.h90" 
     616   !!---------------------------------------------------------------------- 
     617   !! NEMO/OPA 4.0 , NEMO Consortium (2016) 
     618   !! $Id$ 
     619   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     620   !!---------------------------------------------------------------------- 
     621CONTAINS 
     622 
     623   INTEGER FUNCTION zdf_tmx_alloc() 
     624      !!---------------------------------------------------------------------- 
     625      !!                ***  FUNCTION zdf_tmx_alloc  *** 
     626      !!---------------------------------------------------------------------- 
     627      ALLOCATE(     ebot_tmx(jpi,jpj),  epyc_tmx(jpi,jpj),  ecri_tmx(jpi,jpj)    ,   & 
     628      &             hbot_tmx(jpi,jpj),  hcri_tmx(jpi,jpj),  emix_tmx(jpi,jpj,jpk),   & 
     629      &         bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk),   &  
     630      &         zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc     ) 
     631      ! 
     632      IF( lk_mpp             )   CALL mpp_sum ( zdf_tmx_alloc ) 
     633      IF( zdf_tmx_alloc /= 0 )   CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 
     634   END FUNCTION zdf_tmx_alloc 
     635 
     636 
     637   SUBROUTINE zdf_tmx( kt ) 
     638      !!---------------------------------------------------------------------- 
     639      !!                  ***  ROUTINE zdf_tmx  *** 
     640      !!                    
     641      !! ** Purpose :   add to the vertical mixing coefficients the effect of 
     642      !!              breaking internal waves. 
     643      !! 
     644      !! ** Method  : - internal wave-driven vertical mixing is given by: 
     645      !!                  Kz_wave = min(  100 cm2/s, f(  Reb = emix_tmx /( Nu * N^2 )  ) 
     646      !!              where emix_tmx is the 3D space distribution of the wave-breaking  
     647      !!              energy and Nu the molecular kinematic viscosity. 
     648      !!              The function f(Reb) is linear (constant mixing efficiency) 
     649      !!              if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 
     650      !! 
     651      !!              - Compute emix_tmx, the 3D power density that allows to compute 
     652      !!              Reb and therefrom the wave-induced vertical diffusivity. 
     653      !!              This is divided into three components: 
     654      !!                 1. Bottom-intensified low-mode dissipation at critical slopes 
     655      !!                     emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 
     656      !!                                   / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 
     657      !!              where hcri_tmx is the characteristic length scale of the bottom  
     658      !!              intensification, ecri_tmx a map of available power, and H the ocean depth. 
     659      !!                 2. Pycnocline-intensified low-mode dissipation 
     660      !!                     emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 
     661      !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 
     662      !!              where epyc_tmx is a map of available power, and nn_zpyc 
     663      !!              is the chosen stratification-dependence of the internal wave 
     664      !!              energy dissipation. 
     665      !!                 3. WKB-height dependent high mode dissipation 
     666      !!                     emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 
     667      !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 
     668      !!              where hbot_tmx is the characteristic length scale of the WKB bottom  
     669      !!              intensification, ebot_tmx is a map of available power, and z_wkb is the 
     670      !!              WKB-stretched height above bottom defined as 
     671      !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 
     672      !!                                 / SUM( sqrt(rn2(z'))    * e3w(z')    ) 
     673      !! 
     674      !!              - update the model vertical eddy viscosity and diffusivity:  
     675      !!                     avt  = avt  +    av_wave 
     676      !!                     avm  = avm  +    av_wave 
     677      !!                     avmu = avmu + mi(av_wave) 
     678      !!                     avmv = avmv + mj(av_wave) 
     679      !! 
     680      !!              - if namelist parameter ln_tsdiff = T, account for differential mixing: 
     681      !!                     avs  = avt  +    av_wave * diffusivity_ratio(Reb) 
     682      !! 
     683      !! ** Action  : - Define emix_tmx used to compute internal wave-induced mixing 
     684      !!              - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing     
     685      !! 
     686      !! References :  de Lavergne et al. 2015, JPO; 2016, in prep. 
     687      !!---------------------------------------------------------------------- 
     688      INTEGER, INTENT(in) ::   kt   ! ocean time-step  
     689      ! 
     690      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     691      REAL(wp) ::   ztpc         ! scalar workspace 
     692      REAL(wp), DIMENSION(:,:)  , POINTER ::  zfact     ! Used for vertical structure 
     693      REAL(wp), DIMENSION(:,:)  , POINTER ::  zhdep     ! Ocean depth 
     694      REAL(wp), DIMENSION(:,:,:), POINTER ::  zwkb      ! WKB-stretched height above bottom 
     695      REAL(wp), DIMENSION(:,:,:), POINTER ::  zweight   ! Weight for high mode vertical distribution 
     696      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_t     ! Molecular kinematic viscosity (T grid) 
     697      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_w     ! Molecular kinematic viscosity (W grid) 
     698      REAL(wp), DIMENSION(:,:,:), POINTER ::  zReb      ! Turbulence intensity parameter 
     699      !!---------------------------------------------------------------------- 
     700      ! 
     701      IF( nn_timing == 1 )   CALL timing_start('zdf_tmx') 
     702      ! 
     703      CALL wrk_alloc( jpi,jpj,       zfact, zhdep ) 
     704      CALL wrk_alloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     705 
     706      !                          ! ----------------------------- ! 
     707      !                          !  Internal wave-driven mixing  !  (compute zav_wave) 
     708      !                          ! ----------------------------- ! 
     709      !                              
     710      !                        !* Critical slope mixing: distribute energy over the time-varying ocean depth, 
     711      !                                                 using an exponential decay from the seafloor. 
     712      DO jj = 1, jpj                ! part independent of the level 
     713         DO ji = 1, jpi 
     714            zhdep(ji,jj) = fsdepw(ji,jj,mbkt(ji,jj)+1)       ! depth of the ocean 
     715            zfact(ji,jj) = rau0 * (  1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) )  ) 
     716            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 
     717         END DO 
     718      END DO 
     719 
     720      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     721         emix_tmx(:,:,jk) = zfact(:,:) * (  EXP( ( fsde3w(:,:,jk  ) - zhdep(:,:) ) / hcri_tmx(:,:) )                      & 
     722            &                             - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) )  ) * wmask(:,:,jk)   & 
     723            &                          / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     724      END DO 
     725 
     726      !                        !* Pycnocline-intensified mixing: distribute energy over the time-varying  
     727      !                        !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 
     728 
     729      SELECT CASE ( nn_zpyc ) 
     730 
     731      CASE ( 1 )               ! Dissipation scales as N (recommended) 
     732 
     733         zfact(:,:) = 0._wp 
     734         DO jk = 2, jpkm1              ! part independent of the level 
     735            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     736         END DO 
     737 
     738         DO jj = 1, jpj 
     739            DO ji = 1, jpi 
     740               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     741            END DO 
     742         END DO 
     743 
     744         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     745            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     746         END DO 
     747 
     748      CASE ( 2 )               ! Dissipation scales as N^2 
     749 
     750         zfact(:,:) = 0._wp 
     751         DO jk = 2, jpkm1              ! part independent of the level 
     752            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     753         END DO 
     754 
     755         DO jj= 1, jpj 
     756            DO ji = 1, jpi 
     757               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     758            END DO 
     759         END DO 
     760 
     761         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     762            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     763         END DO 
     764 
     765      END SELECT 
     766 
     767      !                        !* WKB-height dependent mixing: distribute energy over the time-varying  
     768      !                        !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 
     769       
     770      zwkb(:,:,:) = 0._wp 
     771      zfact(:,:) = 0._wp 
     772      DO jk = 2, jpkm1 
     773         zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     774         zwkb(:,:,jk) = zfact(:,:) 
     775      END DO 
     776 
     777      DO jk = 2, jpkm1 
     778         DO jj = 1, jpj 
     779            DO ji = 1, jpi 
     780               IF( zfact(ji,jj) /= 0 )   zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) )   & 
     781                                            &           * tmask(ji,jj,jk) / zfact(ji,jj) 
     782            END DO 
     783         END DO 
     784      END DO 
     785      zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 
     786 
     787      zweight(:,:,:) = 0._wp 
     788      DO jk = 2, jpkm1 
     789         zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk)                    & 
     790            &   * (  EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) )  ) 
     791      END DO 
     792 
     793      zfact(:,:) = 0._wp 
     794      DO jk = 2, jpkm1              ! part independent of the level 
     795         zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 
     796      END DO 
     797 
     798      DO jj = 1, jpj 
     799         DO ji = 1, jpi 
     800            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     801         END DO 
     802      END DO 
     803 
     804      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     805         emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk)   & 
     806            &                                / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     807      END DO 
     808 
     809 
     810      ! Calculate molecular kinematic viscosity 
     811      znu_t(:,:,:) = 1.e-4_wp * (  17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem)  & 
     812         &                                  + 0.02305_wp * tsn(:,:,:,jp_sal)  ) * tmask(:,:,:) * r1_rau0 
     813      DO jk = 2, jpkm1 
     814         znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 
     815      END DO 
     816 
     817      ! Calculate turbulence intensity parameter Reb 
     818      DO jk = 2, jpkm1 
     819         zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 
     820      END DO 
     821 
     822      ! Define internal wave-induced diffusivity 
     823      DO jk = 2, jpkm1 
     824         zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6   ! This corresponds to a constant mixing efficiency of 1/6 
     825      END DO 
     826 
     827      IF( ln_mevar ) THEN              ! Variable mixing efficiency case : modify zav_wave in the 
     828         DO jk = 2, jpkm1              ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 
     829            DO jj = 1, jpj 
     830               DO ji = 1, jpi 
     831                  IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 
     832                     zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     833                  ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 
     834                     zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     835                  ENDIF 
     836               END DO 
     837            END DO 
     838         END DO 
     839      ENDIF 
     840 
     841      DO jk = 2, jpkm1                 ! Bound diffusivity by molecular value and 100 cm2/s 
     842         zav_wave(:,:,jk) = MIN(  MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp  ) * wmask(:,:,jk) 
     843      END DO 
     844 
     845      IF( kt == nit000 ) THEN        !* Control print at first time-step: diagnose the energy consumed by zav_wave 
     846         ztpc = 0._wp 
     847         DO jk = 2, jpkm1 
     848            DO jj = 1, jpj 
     849               DO ji = 1, jpi 
     850                  ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj)   & 
     851                     &         * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
     852               END DO 
     853            END DO 
     854         END DO 
     855         IF( lk_mpp )   CALL mpp_sum( ztpc ) 
     856         ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing  
     857  
     858         IF(lwp) THEN 
     859            WRITE(numout,*) 
     860            WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 
     861            WRITE(numout,*) '~~~~~~~ ' 
     862            WRITE(numout,*) 
     863            WRITE(numout,*) '      Total power consumption by av_wave: ztpc =  ', ztpc * 1.e-12_wp, 'TW' 
     864         ENDIF 
     865      ENDIF 
     866 
     867      !                          ! ----------------------- ! 
     868      !                          !   Update  mixing coefs  !                           
     869      !                          ! ----------------------- ! 
     870      !       
     871      IF( ln_tsdiff ) THEN          !* Option for differential mixing of salinity and temperature 
     872         DO jk = 2, jpkm1              ! Calculate S/T diffusivity ratio as a function of Reb 
     873            DO jj = 1, jpj 
     874               DO ji = 1, jpi 
     875                  zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp *                                                                  & 
     876                      &   TANH(    0.92_wp * (   LOG10(  MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 )  ) - 0.60_wp   )    )   & 
     877                      &                 ) * wmask(ji,jj,jk) 
     878               END DO 
     879            END DO 
     880         END DO 
     881         CALL iom_put( "av_ratio", zav_ratio ) 
     882         DO jk = 2, jpkm1           !* update momentum & tracer diffusivity with wave-driven mixing 
     883            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 
     884            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     885            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     886         END DO 
     887         ! 
     888      ELSE                          !* update momentum & tracer diffusivity with wave-driven mixing 
     889         DO jk = 2, jpkm1 
     890            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     891            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     892            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     893         END DO 
     894      ENDIF 
     895 
     896      DO jk = 2, jpkm1              !* update momentum diffusivity at wu and wv points 
     897         DO jj = 2, jpjm1 
     898            DO ji = fs_2, fs_jpim1  ! vector opt. 
     899               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     900               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
     901            END DO 
     902         END DO 
     903      END DO 
     904      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )      ! lateral boundary condition 
     905 
     906      !                             !* output internal wave-driven mixing coefficient 
     907      CALL iom_put( "av_wave", zav_wave ) 
     908                                    !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx),  
     909                                    !  vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 
     910      IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 
     911         bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 
     912         pcmap_tmx(:,:) = 0._wp 
     913         DO jk = 2, jpkm1 
     914            pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 
     915         END DO 
     916         pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 
     917         CALL iom_put( "bflx_tmx", bflx_tmx ) 
     918         CALL iom_put( "pcmap_tmx", pcmap_tmx ) 
     919      ENDIF 
     920      CALL iom_put( "bn2", rn2 ) 
     921      CALL iom_put( "emix_tmx", emix_tmx ) 
     922       
     923      CALL wrk_dealloc( jpi,jpj,       zfact, zhdep ) 
     924      CALL wrk_dealloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     925 
     926      IF(ln_ctl)   CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 
     927      ! 
     928      IF( nn_timing == 1 )   CALL timing_stop('zdf_tmx') 
     929      ! 
     930   END SUBROUTINE zdf_tmx 
     931 
     932 
     933   SUBROUTINE zdf_tmx_init 
     934      !!---------------------------------------------------------------------- 
     935      !!                  ***  ROUTINE zdf_tmx_init  *** 
     936      !!                      
     937      !! ** Purpose :   Initialization of the wave-driven vertical mixing, reading 
     938      !!              of input power maps and decay length scales in netcdf files. 
     939      !! 
     940      !! ** Method  : - Read the namzdf_tmx namelist and check the parameters 
     941      !! 
     942      !!              - Read the input data in NetCDF files : 
     943      !!              power available from high-mode wave breaking (mixing_power_bot.nc) 
     944      !!              power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 
     945      !!              power available from critical slope wave-breaking (mixing_power_cri.nc) 
     946      !!              WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 
     947      !!              decay scale for critical slope wave-breaking (decay_scale_cri.nc) 
     948      !! 
     949      !! ** input   : - Namlist namzdf_tmx 
     950      !!              - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 
     951      !!              decay_scale_bot.nc decay_scale_cri.nc 
     952      !! 
     953      !! ** Action  : - Increase by 1 the nstop flag is setting problem encounter 
     954      !!              - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 
     955      !! 
     956      !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 
     957      !!          
     958      !!---------------------------------------------------------------------- 
     959      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     960      INTEGER  ::   inum         ! local integer 
     961      INTEGER  ::   ios 
     962      REAL(wp) ::   zbot, zpyc, zcri   ! local scalars 
     963      !! 
     964      NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 
     965      !!---------------------------------------------------------------------- 
     966      ! 
     967      IF( nn_timing == 1 )  CALL timing_start('zdf_tmx_init') 
     968      ! 
     969      REWIND( numnam_ref )              ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 
     970      READ  ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 
     971901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 
     972      ! 
     973      REWIND( numnam_cfg )              ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 
     974      READ  ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 
     975902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 
     976      IF(lwm) WRITE ( numond, namzdf_tmx_new ) 
     977      ! 
     978      IF(lwp) THEN                  ! Control print 
     979         WRITE(numout,*) 
     980         WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 
     981         WRITE(numout,*) '~~~~~~~~~~~~' 
     982         WRITE(numout,*) '   Namelist namzdf_tmx_new : set wave-driven mixing parameters' 
     983         WRITE(numout,*) '      Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 
     984         WRITE(numout,*) '      Variable (T) or constant (F) mixing efficiency            = ', ln_mevar 
     985         WRITE(numout,*) '      Differential internal wave-driven mixing (T) or not (F)   = ', ln_tsdiff 
     986      ENDIF 
     987       
     988      ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 
     989      ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should  
     990      ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 
     991      avmb(:) = 1.4e-6_wp        ! viscous molecular value 
     992      avtb(:) = 1.e-10_wp        ! very small diffusive minimum (background avt is specified in zdf_tmx)     
     993      avtb_2d(:,:) = 1.e0_wp     ! uniform  
     994      IF(lwp) THEN                  ! Control print 
     995         WRITE(numout,*) 
     996         WRITE(numout,*) '   Force the background value applied to avm & avt in TKE to be everywhere ',   & 
     997            &               'the viscous molecular value & a very small diffusive value, resp.' 
     998      ENDIF 
     999       
     1000      IF( .NOT.lk_zdfddm )   CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 
     1001       
     1002      !                             ! allocate tmx arrays 
     1003      IF( zdf_tmx_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 
     1004      ! 
     1005      !                             ! read necessary fields 
     1006      CALL iom_open('mixing_power_bot',inum)       ! energy flux for high-mode wave breaking [W/m2] 
     1007      CALL iom_get  (inum, jpdom_data, 'field', ebot_tmx, 1 )  
     1008      CALL iom_close(inum) 
     1009      ! 
     1010      CALL iom_open('mixing_power_pyc',inum)       ! energy flux for pynocline-intensified wave breaking [W/m2] 
     1011      CALL iom_get  (inum, jpdom_data, 'field', epyc_tmx, 1 ) 
     1012      CALL iom_close(inum) 
     1013      ! 
     1014      CALL iom_open('mixing_power_cri',inum)       ! energy flux for critical slope wave breaking [W/m2] 
     1015      CALL iom_get  (inum, jpdom_data, 'field', ecri_tmx, 1 ) 
     1016      CALL iom_close(inum) 
     1017      ! 
     1018      CALL iom_open('decay_scale_bot',inum)        ! spatially variable decay scale for high-mode wave breaking [m] 
     1019      CALL iom_get  (inum, jpdom_data, 'field', hbot_tmx, 1 ) 
     1020      CALL iom_close(inum) 
     1021      ! 
     1022      CALL iom_open('decay_scale_cri',inum)        ! spatially variable decay scale for critical slope wave breaking [m] 
     1023      CALL iom_get  (inum, jpdom_data, 'field', hcri_tmx, 1 ) 
     1024      CALL iom_close(inum) 
     1025 
     1026      ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 
     1027      epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 
     1028      ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 
     1029 
     1030      ! Set once for all to zero the first and last vertical levels of appropriate variables 
     1031      emix_tmx (:,:, 1 ) = 0._wp 
     1032      emix_tmx (:,:,jpk) = 0._wp 
     1033      zav_ratio(:,:, 1 ) = 0._wp 
     1034      zav_ratio(:,:,jpk) = 0._wp 
     1035      zav_wave (:,:, 1 ) = 0._wp 
     1036      zav_wave (:,:,jpk) = 0._wp 
     1037 
     1038      zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 
     1039      zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 
     1040      zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 
     1041      IF(lwp) THEN 
     1042         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 
     1043         WRITE(numout,*) '      Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 
     1044         WRITE(numout,*) '      Critical slope wave-breaking energy:        ', zcri * 1.e-12_wp, 'TW' 
     1045      ENDIF 
     1046      ! 
     1047      IF( nn_timing == 1 )  CALL timing_stop('zdf_tmx_init') 
     1048      ! 
     1049   END SUBROUTINE zdf_tmx_init 
     1050 
    5631051#else 
    5641052   !!---------------------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r7217 r7256  
    8383   USE crsini          ! initialise grid coarsening utility 
    8484   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
    85    USE trabbl_crs 
     85   !cbr USE trabbl_crs 
    8686   USE sbc_oce, ONLY: lk_oasis 
    8787   USE stopar 
    … …  
    164164          ENDIF 
    165165 
     166#if defined key_agrif 
     167          CALL Agrif_Regrid() 
     168#endif 
     169 
    166170         DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    167171#if defined key_agrif 
    168             CALL Agrif_Step( stp )           ! AGRIF: time stepping 
     172            CALL stp                         ! AGRIF: time stepping 
    169173#else 
    170174            CALL stp( istp )                 ! standard time stepping 
    … …  
    195199      ! 
    196200#if defined key_agrif 
    197       CALL Agrif_ParentGrid_To_ChildGrid() 
    198       IF( lk_diaobs ) CALL dia_obs_wri 
    199       IF( nn_timing == 1 )   CALL timing_finalize 
    200       CALL Agrif_ChildGrid_To_ParentGrid() 
     201      IF( .NOT. Agrif_Root() ) THEN 
     202         CALL Agrif_ParentGrid_To_ChildGrid() 
     203         IF( lk_diaobs ) CALL dia_obs_wri 
     204         IF( nn_timing == 1 )   CALL timing_finalize 
     205         CALL Agrif_ChildGrid_To_ParentGrid() 
     206      ENDIF 
    201207#endif 
    202208      IF( nn_timing == 1 )   CALL timing_finalize 
    … …  
    342348         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    343349#endif 
    344       ENDIF 
     350      ENDIF          
    345351         jpk = jpkdta                                             ! third dim 
     352#if defined key_agrif 
     353         ! simple trick to use same vertical grid as parent 
     354         ! but different number of levels:  
     355         ! Save maximum number of levels in jpkdta, then define all vertical grids 
     356         ! with this number. 
     357         ! Suppress once vertical online interpolation is ok 
     358         IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 
     359#endif 
    346360         jpim1 = jpi-1                                            ! inner domain indices 
    347361         jpjm1 = jpj-1                                            !   "           " 
    … …  
    438452      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme 
    439453      ! 
    440       IF( ln_crs_top .AND. lk_trabbl     )  THEN 
    441                             CALL dom_grid_crs  
    442                             CALL tra_bbl_init_crs   ! advective (and/or diffusive) bottom boundary layer scheme 
    443                             CALL dom_grid_glo 
    444       ENDIF 
     454      !cbr IF( ln_crs_top .AND. lk_trabbl     )  THEN 
     455      !                      CALL dom_grid_crs  
     456      !                      CALL tra_bbl_init_crs   ! advective (and/or diffusive) bottom boundary layer scheme 
     457      !                      CALL dom_grid_glo 
     458      !ENDIF 
    445459      ! 
    446460                            CALL tra_dmp_init   ! internal damping trends- tracers 
    … …  
    468482      IF( ln_crs_top )      CALL dom_grid_crs 
    469483                            CALL     trc_init 
    470                             CALL ldf_tra_crs_init 
     484      IF( ln_crs_top )      CALL ldf_tra_crs_init 
    471485      IF( ln_crs_top )      CALL dom_grid_glo 
    472486#endif 
    … …  
    735749      INTEGER :: ifac, jl, inu 
    736750      INTEGER, PARAMETER :: ntest = 14 
    737       INTEGER :: ilfax(ntest) 
    738       ! 
    739       ! lfax contains the set of allowed factors. 
    740       data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    741          &                            128,   64,   32,   16,    8,   4,   2  / 
    742       !!---------------------------------------------------------------------- 
     751      INTEGER, DIMENSION(ntest) :: ilfax 
     752      ! 
     753      ! ilfax contains the set of allowed factors. 
     754      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
     755      !!---------------------------------------------------------------------- 
     756      ! ilfax contains the set of allowed factors. 
     757      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    743758 
    744759      ! Clear the error flag and initialise output vars 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90

    r7217 r7256  
    5151 
    5252#if defined key_agrif 
    53    SUBROUTINE stp( ) 
     53   RECURSIVE SUBROUTINE stp( ) 
    5454      INTEGER             ::   kstp   ! ocean time-step index 
    5555#else 
    … …  
    8282#if defined key_agrif 
    8383      kstp = nit000 + Agrif_Nb_Step() 
    84 !      IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
    85 !      IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 
     84      IF ( lk_agrif_debug ) THEN 
     85         IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
     86         IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 
     87      ENDIF 
     88 
    8689      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
     90 
    8791# if defined key_iomput 
    8892      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    … …  
    113117      ! Update stochastic parameters and random T/S fluctuations 
    114118      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    115                         CALL sto_par( kstp )          ! Stochastic parameters 
     119       IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters 
     120       IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations 
    116121 
    117122      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    155160      ! 
    156161      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    157          IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    158162                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    159163         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    191195          ! Note that the computation of vertical velocity above, hence "after" sea level 
    192196          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
    193             IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    194197                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    195198            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    203206                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    204207                                  va(:,:,:) = 0.e0 
    205           IF(  ln_asmiau .AND. & 
     208          IF(  lk_asminc .AND. ln_asmiau .AND. & 
    206209             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
    207210          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
    … …  
    277280                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    278281 
    279       IF(  ln_asmiau .AND. & 
     282      IF(  lk_asminc .AND. ln_asmiau .AND. & 
    280283         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    281284                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    … …  
    299302         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    300303                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    301             IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    302304                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    303305            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
    … …  
    310312      ELSE                                                  ! centered hpg  (eos then time stepping) 
    311313         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    312             IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    313314                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    314315         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
    … …  
    343344                               va(:,:,:) = 0.e0 
    344345 
    345         IF(  ln_asmiau .AND. & 
     346        IF(  lk_asminc .AND. ln_asmiau .AND. & 
    346347           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    347348        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
    … …  
    364365                               CALL ssh_swp( kstp )         ! swap of sea surface height 
    365366      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    366  
     367      ! 
    367368      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    368       IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    369  
    370       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    371       ! Control and restarts 
     369 
     370      IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
     371      IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
     372 
     373#if defined key_agrif 
     374      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     375      ! AGRIF 
     376      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     377                               CALL Agrif_Integrate_ChildGrids( stp )   
     378 
     379      IF ( Agrif_NbStepint().EQ.0 ) THEN 
     380                               CALL Agrif_Update_Tra()      ! Update active tracers 
     381                               CALL Agrif_Update_Dyn()      ! Update momentum 
     382      ENDIF 
     383#endif 
     384      IF( lk_diaobs        )   CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
     385 
     386      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     387      ! Control 
    372388      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    373389                               CALL stp_ctl( kstp, indic ) 
    … …  
    381397         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    382398      ENDIF 
    383       IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
    384399 
    385400      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    396411      ! 
    397412      IF( nn_timing == 1 .AND.  kstp == nit000  )   CALL timing_reset 
     413      !      
    398414      ! 
    399415   END SUBROUTINE stp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r6772 r7256  
    117117#if defined key_agrif 
    118118   USE agrif_opa_sponge ! Momemtum and tracers sponges 
     119   USE agrif_opa_update ! Update (2-way nesting) 
    119120#endif 
    120121#if defined key_top 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r6101 r7256  
    1717   USE dom_oce         ! ocean space and time domain variables  
    1818   USE sol_oce         ! ocean space and time domain variables  
     19   USE sbc_oce         ! surface boundary conditions variables 
    1920   USE in_out_manager  ! I/O manager 
    2021   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    2223   USE dynspg_oce      ! pressure gradient schemes  
    2324   USE c1d             ! 1D vertical configuration 
     25 
    2426 
    2527   IMPLICIT NONE 
    … …  
    5254      INTEGER, INTENT( inout ) ::   kindic  ! indicator of solver convergence 
    5355      !! 
     56      CHARACTER(len = 32) ::        clfname ! time stepping output file name 
    5457      INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    5558      INTEGER  ::   ii, ij, ik              ! temporary integers 
    … …  
    6366         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6467         WRITE(numout,*) '~~~~~~~' 
    65          ! open time.step file 
    66          CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     68         ! open time.step file with special treatment for SAS 
     69         IF ( nn_components == jp_iam_sas ) THEN 
     70            clfname = 'time.step.sas' 
     71         ELSE 
     72            clfname = 'time.step' 
     73         ENDIF 
     74         CALL ctl_opn( numstp, TRIM(clfname), 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    6775      ENDIF 
    6876 
    … …  
    136144            WRITE(numout,*) '          output of last fields in numwso' 
    137145         ENDIF 
    138          WHERE( tsn(:,:,:,jp_sal) .LE. 0. )  tsn(:,:,:,jp_sal) = 0.1 
     146         kindic = -3 
    139147      ENDIF 
    1401489500  FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 
Note: See TracChangeset for help on using the changeset viewer.