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 9987 for branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC – NEMO

Ignore:
Timestamp:
2018-07-23T11:33:03+02:00 (6 years ago)
Author:
emmafiedler
Message:

Merge with GO6 FOAMv14 package branch r9288

Location:
branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC
Files:
113 edited
4 copied

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ASM/asmbkg.F90

    r7960 r9987  
    119119            CALL iom_rstput( kt, nitbkg_r, inum, 'en'     , en                ) 
    120120#endif 
    121             CALL iom_rstput( kt, nitbkg_r, inum, 'gcx'    , gcx               ) 
     121!            CALL iom_rstput( kt, nitbkg_r, inum, 'gcx'    , gcx               ) 
     122            CALL iom_rstput( kt, nitbkg_r, inum, 'avt'    , avt               ) 
    122123            ! 
    123124            CALL iom_close( inum ) 
    … …  
    153154            CALL iom_rstput( kt, nitdin_r, inum, 'tn'     , tsn(:,:,:,jp_tem) ) 
    154155            CALL iom_rstput( kt, nitdin_r, inum, 'sn'     , tsn(:,:,:,jp_sal) ) 
     156            CALL iom_rstput( kt, nitdin_r, inum, 'avt'    , avt     ) 
    155157            CALL iom_rstput( kt, nitdin_r, inum, 'sshn'   , sshn              ) 
    156158#if defined key_lim2 || defined key_lim3 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r9486 r9987  
    3939   USE ice_2            ! LIM2 
    4040#endif 
     41#if defined key_cice && defined key_asminc 
     42   USE sbc_ice, ONLY : & ! CICE Ice model variables 
     43   & ndaice_da, nfresh_da, nfsalt_da 
     44#endif 
    4145   USE sbc_oce          ! Surface boundary condition variables. 
    4246 
    … …  
    131135         &                 ln_asmdin, ln_asmiau,                           & 
    132136         &                 nitbkg, nitdin, nitiaustr, nitiaufin, niaufn,   & 
    133          &                 ln_salfix, salfixmin, nn_divdmp 
     137         &                 ln_salfix, salfixmin, nn_divdmp,                & 
     138         &                 ln_seaiceinc, ln_temnofreeze 
    134139      !!---------------------------------------------------------------------- 
    135140 
    … …  
    656661 
    657662      DO jk = 1, jpkm1 
    658          fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 
     663        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 
    659664      END DO 
    660665 
    … …  
    890895            ENDIF 
    891896 
     897         ELSE 
     898#if defined key_asminc 
     899            ssh_iau(:,:) = 0.0 
     900#endif 
    892901         ENDIF 
    893902 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r7960 r9987  
    2424   USE phycst         ! physical constant 
    2525   USE in_out_manager  ! I/O manager 
     26   USE zdfddm 
     27   USE zdf_oce 
    2628 
    2729   IMPLICIT NONE 
    … …  
    4244   !! * Substitutions 
    4345#  include "domzgr_substitute.h90" 
     46#  include "zdfddm_substitute.h90" 
    4447   !!---------------------------------------------------------------------- 
    4548   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    7578      INTEGER  ::   ji, jj, jk                      ! dummy loop arguments 
    7679      REAL(wp) ::   zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass 
     80      REAL(wp) ::   zaw, zbw, zrw 
    7781      ! 
    7882      REAL(wp), POINTER, DIMENSION(:,:)     :: zarea_ssh , zbotpres       ! 2D workspace  
     83      REAL(wp), POINTER, DIMENSION(:,:)     :: pe                         ! 2D workspace  
    7984      REAL(wp), POINTER, DIMENSION(:,:,:)   :: zrhd , zrhop               ! 3D workspace 
    8085      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsn                       ! 4D workspace 
    8186      !!-------------------------------------------------------------------- 
    8287      IF( nn_timing == 1 )   CALL timing_start('dia_ar5') 
     88 
     89      !Call to init moved to here so that we can call iom_use in the 
     90      !initialisation 
     91      IF( kt == nit000 )     CALL dia_ar5_init 
    8392  
    84       CALL wrk_alloc( jpi , jpj              , zarea_ssh , zbotpres ) 
     93      CALL wrk_alloc( jpi , jpj              , zarea_ssh , zbotpres, pe ) 
    8594      CALL wrk_alloc( jpi , jpj , jpk        , zrhd      , zrhop    ) 
    8695      CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn                 ) 
    … …  
    95104      CALL iom_put( 'voltot', zvol               ) 
    96105      CALL iom_put( 'sshtot', zvolssh / area_tot ) 
     106      CALL iom_put( 'sshdyn', sshn(:,:) - (zvolssh / area_tot) ) 
    97107 
    98108      !                      
    99       ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem)                    ! thermosteric ssh 
    100       ztsn(:,:,:,jp_sal) = sn0(:,:,:) 
    101       CALL eos( ztsn, zrhd, fsdept_n(:,:,:) )                       ! now in situ density using initial salinity 
    102       ! 
    103       zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice 
    104       DO jk = 1, jpkm1 
    105          zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 
    106       END DO 
    107       IF( .NOT.lk_vvl ) THEN 
    108          IF ( ln_isfcav ) THEN 
    109             DO ji=1,jpi 
    110                DO jj=1,jpj 
    111                   zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     109      IF( iom_use('sshthster')) THEN 
     110         ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem)                    ! thermosteric ssh 
     111         ztsn(:,:,:,jp_sal) = sn0(:,:,:) 
     112         CALL eos( ztsn, zrhd, fsdept_n(:,:,:) )                       ! now in situ density using initial salinity 
     113         ! 
     114         zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice 
     115         DO jk = 1, jpkm1 
     116            zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 
     117         END DO 
     118         IF( .NOT.lk_vvl ) THEN 
     119            IF ( ln_isfcav ) THEN 
     120               DO ji=1,jpi 
     121                  DO jj=1,jpj 
     122                     zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     123                  END DO 
    112124               END DO 
    113             END DO 
    114          ELSE 
    115             zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     125            ELSE 
     126               zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     127            END IF 
    116128         END IF 
    117       END IF 
    118129      !                                          
    119       zarho = SUM( area(:,:) * zbotpres(:,:) )  
    120       IF( lk_mpp )   CALL mpp_sum( zarho ) 
    121       zssh_steric = - zarho / area_tot 
    122       CALL iom_put( 'sshthster', zssh_steric ) 
     130         zarho = SUM( area(:,:) * zbotpres(:,:) )  
     131         IF( lk_mpp )   CALL mpp_sum( zarho ) 
     132         zssh_steric = - zarho / area_tot 
     133         CALL iom_put( 'sshthster', zssh_steric ) 
     134      ENDIF 
    123135       
    124136      !                                         ! steric sea surface height 
    … …  
    190202      CALL iom_put( 'temptot', ztemp ) 
    191203      CALL iom_put( 'saltot' , zsal  ) 
    192       ! 
    193       CALL wrk_dealloc( jpi , jpj              , zarea_ssh , zbotpres ) 
     204 
     205      IF( iom_use( 'tnpeo' )) THEN     
     206      ! Work done against stratification by vertical mixing 
     207      ! Exclude points where rn2 is negative as convection kicks in here and 
     208      ! work is not being done against stratification 
     209          pe(:,:) = 0._wp 
     210          IF( lk_zdfddm ) THEN 
     211             DO ji=1,jpi 
     212                DO jj=1,jpj 
     213                   DO jk=1,jpk 
     214                      zrw =   ( fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk) )   & 
     215                         &  / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 
     216                      ! 
     217                      zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw 
     218                      zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw 
     219                      ! 
     220                      pe(ji, jj) = pe(ji, jj) - MIN(0._wp, rn2(ji,jj,jk)) * & 
     221                           &       grav * (avt(ji,jj,jk) * zaw * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) )  & 
     222                           &       - fsavs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) ) 
     223 
     224                   ENDDO 
     225                ENDDO 
     226             ENDDO 
     227          ELSE 
     228             DO ji=1,jpi 
     229                DO jj=1,jpj 
     230                   DO jk=1,jpk 
     231                       pe(ji,jj) = pe(ji,jj) + avt(ji, jj, jk) * MIN(0._wp,rn2(ji, jj, jk)) * rau0 * fse3w(ji, jj, jk) 
     232                   ENDDO 
     233                ENDDO 
     234             ENDDO 
     235          ENDIF 
     236          CALL iom_put( 'tnpeo', pe ) 
     237      ENDIF 
     238      ! 
     239      CALL wrk_dealloc( jpi , jpj              , zarea_ssh , zbotpres, pe ) 
    194240      CALL wrk_dealloc( jpi , jpj , jpk        , zrhd      , zrhop    ) 
    195241      CALL wrk_dealloc( jpi , jpj , jpk , jpts , ztsn                 ) 
    … …  
    211257      REAL(wp) ::   zztmp   
    212258      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 ) 
    230259      ! 
    231260      !!---------------------------------------------------------------------- 
    … …  
    233262      IF( nn_timing == 1 )   CALL timing_start('dia_ar5_init') 
    234263      ! 
    235       CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta ) 
     264      CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 
    236265      !                                      ! allocate dia_ar5 arrays 
    237266      IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
    … …  
    249278      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    250279 
    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 ) 
    254       CALL iom_close( inum ) 
    255       sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    256       sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    257       IF( ln_zps ) THEN               ! z-coord. partial steps 
    258          DO jj = 1, jpj               ! interpolation of salinity at the last ocean level (i.e. the partial step) 
    259             DO ji = 1, jpi 
    260                ik = mbkt(ji,jj) 
    261                IF( ik > 1 ) THEN 
    262                   zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    263                   sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 
    264                ENDIF 
     280      IF( iom_use('sshthster')) THEN 
     281         CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     282         CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     283         CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
     284         CALL iom_close( inum ) 
     285 
     286         sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
     287         sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
     288         IF( ln_zps ) THEN               ! z-coord. partial steps 
     289            DO jj = 1, jpj               ! interpolation of salinity at the last ocean level (i.e. the partial step) 
     290               DO ji = 1, jpi 
     291                  ik = mbkt(ji,jj) 
     292                  IF( ik > 1 ) THEN 
     293                     zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
     294                     sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 
     295                  ENDIF 
     296               END DO 
    265297            END DO 
    266          END DO 
     298         ENDIF 
    267299      ENDIF 
    268300      ! 
    269       CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta ) 
     301      CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 
    270302      ! 
    271303      IF( nn_timing == 1 )   CALL timing_stop('dia_ar5_init') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90

    r7960 r9987  
    124124 
    125125    CASE DEFAULT 
    126        IF(lwp) WRITE(numout,*) ' E R R O R : bad cd_type in dia_wri_dimg ' 
    127        STOP 'dia_wri_dimg' 
     126     
     127       WRITE(numout,*) 'dia_wri_dimg : E R R O R : bad cd_type in dia_wri_dimg' 
     128       CALL ctl_stop( 'STOP', 'dia_wri_dimg :bad cd_type in dia_wri_dimg ' ) 
    128129 
    129130    END SELECT 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r7960 r9987  
    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 
    … …  
    200199!      ENDIF 
    201200!!gm end 
    202  
    203201 
    204202      IF( lk_vvl ) THEN 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r7960 r9987  
    99   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation 
    1010   !!            3.6  ! 2014-12  (C. Ethe) use of IOM 
     11   !!            3.6  ! 2016-06  (T. Graham) Addition of diagnostics for CMIP6 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2122   USE dom_oce          ! ocean space and time domain 
    2223   USE phycst           ! physical constants 
     24   USE ldftra_oce  
    2325   ! 
    2426   USE iom              ! IOM library 
    … …  
    3840   PUBLIC   dia_ptr_init   ! call in step module 
    3941   PUBLIC   dia_ptr        ! call in step module 
     42   PUBLIC   dia_ptr_ohst_components        ! called from tra_ldf/tra_adv routines 
    4043 
    4144   !                                  !!** namelist  namptr  ** 
    42    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf   !: Heat TRansports (adv, diff, overturn.) 
    43    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf   !: Salt TRansports (adv, diff, overturn.) 
    44     
     45   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_adv, htr_ldf, htr_eiv, htr_vt   !: Heat TRansports (adv, diff, Bolus.) 
     46   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   str_adv, str_ldf, str_eiv, str_vs   !: Salt TRansports (adv, diff, Bolus.) 
     47   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_ove, str_ove   !: heat Salt TRansports ( overturn.) 
     48   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_btr, str_btr   !: heat Salt TRansports ( barotropic ) 
    4549 
    4650   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F) 
    4751   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation 
    48    INTEGER        ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)  
     52   INTEGER, PUBLIC ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)  
    4953 
    5054   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    7781      ! 
    7882      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    79       REAL(wp) ::   zv, zsfc               ! local scalar 
     83      REAL(wp) ::   zsfc,zvfc               ! local scalar 
    8084      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
    8185      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace 
    8286      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
    8387      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
    84       CHARACTER( len = 10 )  :: cl1 
     88      REAL(wp), DIMENSION(jpj)     ::  vsum   ! 1D workspace 
     89      REAL(wp), DIMENSION(jpj,jpts)     ::  tssum   ! 1D workspace 
     90  
     91      ! 
     92      !overturning calculation 
     93      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   sjk  , r1_sjk ! i-mean i-k-surface and its inverse 
     94      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   v_msf, sn_jk  , tn_jk ! i-mean T and S, j-Stream-Function 
     95      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zvn   ! 3D workspace 
     96 
     97 
     98      CHARACTER( len = 12 )  :: cl1 
    8599      !!---------------------------------------------------------------------- 
    86100      ! 
    … …  
    88102 
    89103      ! 
     104      z3d(:,:,:) = 0._wp 
    90105      IF( PRESENT( pvtr ) ) THEN 
    91106         IF( iom_use("zomsfglo") ) THEN    ! effective MSF 
    92107            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport 
    93             DO jk = 2, jpkm1  
    94               z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)   ! effective j-Stream-Function (MSF) 
     108            DO jk = jpkm1,1,-1                   !Integrate from bottom up to get 
     109              z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)   ! effective j-Stream-Function (MSF) 
    95110            END DO 
    96111            DO ji = 1, jpi 
    … …  
    100115            CALL iom_put( cl1, z3d * rc_sv ) 
    101116            DO jn = 2, nptr                                    ! by sub-basins 
    102                z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) )  
    103                DO jk = 2, jpkm1  
    104                   z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)    ! effective j-Stream-Function (MSF) 
     117               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) )  
     118               DO jk = jpkm1,1,-1 
     119                  z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)    ! effective j-Stream-Function (MSF) 
    105120               END DO 
    106121               DO ji = 1, jpi 
    … …  
    111126            END DO 
    112127         ENDIF 
     128         IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 
     129            ! define fields multiplied by scalar 
     130            zmask(:,:,:) = 0._wp 
     131            zts(:,:,:,:) = 0._wp 
     132            zvn(:,:,:) = 0._wp 
     133            DO jk = 1, jpkm1 
     134               DO jj = 1, jpjm1 
     135                  DO ji = 1, jpi 
     136                     zvfc = e1v(ji,jj) * fse3v(ji,jj,jk) 
     137                     zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc 
     138                     zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc  !Tracers averaged onto V grid 
     139                     zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 
     140                     zvn(ji,jj,jk)        = vn(ji,jj,jk)         * zvfc 
     141                  ENDDO 
     142               ENDDO 
     143             ENDDO 
     144         ENDIF 
     145         IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 
     146             sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 
     147             r1_sjk(:,:,1) = 0._wp 
     148             WHERE( sjk(:,:,1) /= 0._wp )   r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 
     149 
     150             ! i-mean T and S, j-Stream-Function, global 
     151             tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 
     152             sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 
     153             v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 
     154 
     155             htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 
     156             str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 
     157 
     158             z2d(1,:) = htr_ove(:,1) * rc_pwatt        !  (conversion in PW) 
     159             DO ji = 1, jpi 
     160               z2d(ji,:) = z2d(1,:) 
     161             ENDDO 
     162             cl1 = 'sophtove' 
     163             CALL iom_put( TRIM(cl1), z2d ) 
     164             z2d(1,:) = str_ove(:,1) * rc_ggram        !  (conversion in Gg) 
     165             DO ji = 1, jpi 
     166               z2d(ji,:) = z2d(1,:) 
     167             ENDDO 
     168             cl1 = 'sopstove' 
     169             CALL iom_put( TRIM(cl1), z2d ) 
     170             IF( ln_subbas ) THEN 
     171                DO jn = 2, nptr 
     172                    sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
     173                    r1_sjk(:,:,jn) = 0._wp 
     174                    WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
     175 
     176                    ! i-mean T and S, j-Stream-Function, basin 
     177                    tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
     178                    sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
     179                    v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) )  
     180                    htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 
     181                    str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 
     182 
     183                    z2d(1,:) = htr_ove(:,jn) * rc_pwatt !  (conversion in PW) 
     184                    DO ji = 1, jpi 
     185                        z2d(ji,:) = z2d(1,:) 
     186                    ENDDO 
     187                    cl1 = TRIM('sophtove_'//clsubb(jn)) 
     188                    CALL iom_put( cl1, z2d ) 
     189                    z2d(1,:) = str_ove(:,jn) * rc_ggram        ! (conversion in Gg) 
     190                    DO ji = 1, jpi 
     191                        z2d(ji,:) = z2d(1,:) 
     192                    ENDDO 
     193                    cl1 = TRIM('sopstove_'//clsubb(jn)) 
     194                    CALL iom_put( cl1, z2d ) 
     195                END DO 
     196             ENDIF 
     197         ENDIF 
     198         IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 
     199         ! Calculate barotropic heat and salt transport here  
     200             sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 
     201             r1_sjk(:,1,1) = 0._wp 
     202             WHERE( sjk(:,1,1) /= 0._wp )   r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 
     203             
     204            vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 
     205            tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 
     206            tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 
     207            htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 
     208            str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 
     209            z2d(1,:) = htr_btr(:,1) * rc_pwatt        !  (conversion in PW) 
     210            DO ji = 2, jpi 
     211               z2d(ji,:) = z2d(1,:) 
     212            ENDDO 
     213            cl1 = 'sophtbtr' 
     214            CALL iom_put( TRIM(cl1), z2d ) 
     215            z2d(1,:) = str_btr(:,1) * rc_ggram        !  (conversion in Gg) 
     216            DO ji = 2, jpi 
     217              z2d(ji,:) = z2d(1,:) 
     218            ENDDO 
     219            cl1 = 'sopstbtr' 
     220            CALL iom_put( TRIM(cl1), z2d ) 
     221            IF( ln_subbas ) THEN 
     222                DO jn = 2, nptr 
     223                    sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 
     224                    r1_sjk(:,1,jn) = 0._wp 
     225                    WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 
     226                    vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 
     227                    tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 
     228                    tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 
     229                    htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 
     230                    str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 
     231                    z2d(1,:) = htr_btr(:,jn) * rc_pwatt !  (conversion in PW) 
     232                    DO ji = 1, jpi 
     233                        z2d(ji,:) = z2d(1,:) 
     234                    ENDDO 
     235                    cl1 = TRIM('sophtbtr_'//clsubb(jn)) 
     236                    CALL iom_put( cl1, z2d ) 
     237                    z2d(1,:) = str_btr(:,jn) * rc_ggram        ! (conversion in Gg) 
     238                    DO ji = 1, jpi 
     239                        z2d(ji,:) = z2d(1,:) 
     240                    ENDDO 
     241                    cl1 = TRIM('sopstbtr_'//clsubb(jn)) 
     242                    CALL iom_put( cl1, z2d ) 
     243               ENDDO 
     244            ENDIF !ln_subbas 
     245         ENDIF !iom_use("sopstbtr....) 
    113246         ! 
    114247      ELSE 
    … …  
    150283         !                                ! Advective and diffusive heat and salt transport 
    151284         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN    
    152             z2d(1,:) = htr_adv(:) * rc_pwatt        !  (conversion in PW) 
     285            z2d(1,:) = htr_adv(:,1) * rc_pwatt        !  (conversion in PW) 
    153286            DO ji = 1, jpi 
    154287               z2d(ji,:) = z2d(1,:) 
    … …  
    156289            cl1 = 'sophtadv'                  
    157290            CALL iom_put( TRIM(cl1), z2d ) 
    158             z2d(1,:) = str_adv(:) * rc_ggram        ! (conversion in Gg) 
     291            z2d(1,:) = str_adv(:,1) * rc_ggram        ! (conversion in Gg) 
    159292            DO ji = 1, jpi 
    160293               z2d(ji,:) = z2d(1,:) 
    … …  
    162295            cl1 = 'sopstadv' 
    163296            CALL iom_put( TRIM(cl1), z2d ) 
     297            IF( ln_subbas ) THEN 
     298              DO jn=2,nptr 
     299               z2d(1,:) = htr_adv(:,jn) * rc_pwatt        !  (conversion in PW) 
     300               DO ji = 1, jpi 
     301                 z2d(ji,:) = z2d(1,:) 
     302               ENDDO 
     303               cl1 = TRIM('sophtadv_'//clsubb(jn))                  
     304               CALL iom_put( cl1, z2d ) 
     305               z2d(1,:) = str_adv(:,jn) * rc_ggram        ! (conversion in Gg) 
     306               DO ji = 1, jpi 
     307                  z2d(ji,:) = z2d(1,:) 
     308               ENDDO 
     309               cl1 = TRIM('sopstadv_'//clsubb(jn))                  
     310               CALL iom_put( cl1, z2d )               
     311              ENDDO 
     312            ENDIF 
    164313         ENDIF 
    165314         ! 
    166315         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN    
    167             z2d(1,:) = htr_ldf(:) * rc_pwatt        !  (conversion in PW)  
     316            z2d(1,:) = htr_ldf(:,1) * rc_pwatt        !  (conversion in PW)  
    168317            DO ji = 1, jpi 
    169318               z2d(ji,:) = z2d(1,:) 
    … …  
    171320            cl1 = 'sophtldf' 
    172321            CALL iom_put( TRIM(cl1), z2d ) 
    173             z2d(1,:) = str_ldf(:) * rc_ggram        !  (conversion in Gg) 
     322            z2d(1,:) = str_ldf(:,1) * rc_ggram        !  (conversion in Gg) 
    174323            DO ji = 1, jpi 
    175324               z2d(ji,:) = z2d(1,:) 
    … …  
    177326            cl1 = 'sopstldf' 
    178327            CALL iom_put( TRIM(cl1), z2d ) 
    179          ENDIF 
     328            IF( ln_subbas ) THEN 
     329              DO jn=2,nptr 
     330               z2d(1,:) = htr_ldf(:,jn) * rc_pwatt        !  (conversion in PW) 
     331               DO ji = 1, jpi 
     332                 z2d(ji,:) = z2d(1,:) 
     333               ENDDO 
     334               cl1 = TRIM('sophtldf_'//clsubb(jn))                  
     335               CALL iom_put( cl1, z2d ) 
     336               z2d(1,:) = str_ldf(:,jn) * rc_ggram        ! (conversion in Gg) 
     337               DO ji = 1, jpi 
     338                  z2d(ji,:) = z2d(1,:) 
     339               ENDDO 
     340               cl1 = TRIM('sopstldf_'//clsubb(jn))                  
     341               CALL iom_put( cl1, z2d )               
     342              ENDDO 
     343            ENDIF 
     344         ENDIF 
     345 
     346         IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN    
     347            z2d(1,:) = htr_vt(:,1) * rc_pwatt        !  (conversion in PW)  
     348            DO ji = 1, jpi 
     349               z2d(ji,:) = z2d(1,:) 
     350            ENDDO 
     351            cl1 = 'sopht_vt' 
     352            CALL iom_put( TRIM(cl1), z2d ) 
     353            z2d(1,:) = str_vs(:,1) * rc_ggram        !  (conversion in Gg) 
     354            DO ji = 1, jpi 
     355               z2d(ji,:) = z2d(1,:) 
     356            ENDDO 
     357            cl1 = 'sopst_vs' 
     358            CALL iom_put( TRIM(cl1), z2d ) 
     359            IF( ln_subbas ) THEN 
     360              DO jn=2,nptr 
     361               z2d(1,:) = htr_vt(:,jn) * rc_pwatt        !  (conversion in PW) 
     362               DO ji = 1, jpi 
     363                 z2d(ji,:) = z2d(1,:) 
     364               ENDDO 
     365               cl1 = TRIM('sopht_vt_'//clsubb(jn))                  
     366               CALL iom_put( cl1, z2d ) 
     367               z2d(1,:) = str_vs(:,jn) * rc_ggram        ! (conversion in Gg) 
     368               DO ji = 1, jpi 
     369                  z2d(ji,:) = z2d(1,:) 
     370               ENDDO 
     371               cl1 = TRIM('sopst_vs_'//clsubb(jn))                  
     372               CALL iom_put( cl1, z2d )               
     373              ENDDO 
     374            ENDIF 
     375         ENDIF 
     376 
     377#ifdef key_diaeiv 
     378         IF(lk_traldf_eiv) THEN 
     379            IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN  
     380               z2d(1,:) = htr_eiv(:,1) * rc_pwatt        !  (conversion in PW)  
     381               DO ji = 1, jpi 
     382                  z2d(ji,:) = z2d(1,:) 
     383               ENDDO 
     384               cl1 = 'sophteiv' 
     385               CALL iom_put( TRIM(cl1), z2d ) 
     386               z2d(1,:) = str_eiv(:,1) * rc_ggram        !  (conversion in Gg) 
     387               DO ji = 1, jpi 
     388                  z2d(ji,:) = z2d(1,:) 
     389               ENDDO 
     390               cl1 = 'sopsteiv' 
     391               CALL iom_put( TRIM(cl1), z2d ) 
     392               IF( ln_subbas ) THEN 
     393                  DO jn=2,nptr 
     394                     z2d(1,:) = htr_eiv(:,jn) * rc_pwatt        !  (conversion in PW) 
     395                     DO ji = 1, jpi 
     396                        z2d(ji,:) = z2d(1,:) 
     397                     ENDDO 
     398                     cl1 = TRIM('sophteiv_'//clsubb(jn))                  
     399                     CALL iom_put( cl1, z2d ) 
     400                     z2d(1,:) = str_eiv(:,jn) * rc_ggram        ! (conversion in Gg) 
     401                     DO ji = 1, jpi 
     402                        z2d(ji,:) = z2d(1,:) 
     403                     ENDDO 
     404                     cl1 = TRIM('sopsteiv_'//clsubb(jn))  
     405                     CALL iom_put( cl1, z2d )               
     406                  ENDDO 
     407               ENDIF 
     408            ENDIF 
     409            IF( iom_use("zomsfeivglo") ) THEN 
     410               z3d(1,:,:) = ptr_sjk( v_eiv(:,:,:) )  ! zonal cumulative effective transport 
     411               DO jk = jpkm1,1,-1 
     412                 z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)   ! effective j-Stream-Function (MSF) 
     413               END DO 
     414               DO ji = 1, jpi 
     415                  z3d(ji,:,:) = z3d(1,:,:) 
     416               ENDDO 
     417               cl1 = TRIM('zomsfeiv'//clsubb(1) ) 
     418               CALL iom_put( cl1, z3d * rc_sv ) 
     419               IF( ln_subbas ) THEN 
     420                  DO jn = 2, nptr                                    ! by sub-basins 
     421                     z3d(1,:,:) =  ptr_sjk( v_eiv(:,:,:), btmsk(:,:,jn) )  
     422                     DO jk = jpkm1,1,-1 
     423                        z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)    ! effective j-Stream-Function (MSF) 
     424                     END DO 
     425                     DO ji = 1, jpi 
     426                        z3d(ji,:,:) = z3d(1,:,:) 
     427                     ENDDO 
     428                     cl1 = TRIM('zomsfeiv'//clsubb(jn) ) 
     429                     CALL iom_put( cl1, z3d * rc_sv ) 
     430                  END DO 
     431               ENDIF 
     432            ENDIF 
     433         ENDIF 
     434#endif 
    180435         ! 
    181436      ENDIF 
    … …  
    256511         ! Initialise arrays to zero because diatpr is called before they are first calculated 
    257512         ! Note that this means diagnostics will not be exactly correct when model run is restarted. 
    258          htr_adv(:) = 0._wp  ;  str_adv(:) =  0._wp   
    259          htr_ldf(:) = 0._wp  ;  str_ldf(:) =  0._wp  
     513         htr_adv(:,:) = 0._wp  ;  str_adv(:,:) =  0._wp  
     514         htr_ldf(:,:) = 0._wp  ;  str_ldf(:,:) =  0._wp  
     515         htr_eiv(:,:) = 0._wp  ;  str_eiv(:,:) =  0._wp  
     516         htr_vt(:,:) = 0._wp  ;   str_vs(:,:) =  0._wp 
     517         htr_ove(:,:) = 0._wp  ;   str_ove(:,:) =  0._wp 
     518         htr_btr(:,:) = 0._wp  ;   str_btr(:,:) =  0._wp 
    260519         ! 
    261520      ENDIF  
    … …  
    263522   END SUBROUTINE dia_ptr_init 
    264523 
     524   SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva )  
     525      !!---------------------------------------------------------------------- 
     526      !!                    ***  ROUTINE dia_ptr_ohst_components  *** 
     527      !!---------------------------------------------------------------------- 
     528      !! Wrapper for heat and salt transport calculations to calculate them for each basin 
     529      !! Called from all advection and/or diffusion routines 
     530      !!---------------------------------------------------------------------- 
     531      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
     532      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv' 
     533      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion 
     534      INTEGER                                        :: jn    ! 
     535 
     536      IF( cptr == 'adv' ) THEN 
     537         IF( ktra == jp_tem )  htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 
     538         IF( ktra == jp_sal )  str_adv(:,1) = ptr_sj( pva(:,:,:) ) 
     539      ENDIF 
     540      IF( cptr == 'ldf' ) THEN 
     541         IF( ktra == jp_tem )  htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 
     542         IF( ktra == jp_sal )  str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 
     543      ENDIF 
     544      IF( cptr == 'eiv' ) THEN 
     545         IF( ktra == jp_tem )  htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 
     546         IF( ktra == jp_sal )  str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 
     547      ENDIF 
     548      IF( cptr == 'vts' ) THEN 
     549         IF( ktra == jp_tem )  htr_vt(:,1) = ptr_sj( pva(:,:,:) ) 
     550         IF( ktra == jp_sal )  str_vs(:,1) = ptr_sj( pva(:,:,:) ) 
     551      ENDIF 
     552      ! 
     553      IF( ln_subbas ) THEN 
     554         ! 
     555         IF( cptr == 'adv' ) THEN 
     556             IF( ktra == jp_tem ) THEN  
     557                DO jn = 2, nptr 
     558                   htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     559                END DO 
     560             ENDIF 
     561             IF( ktra == jp_sal ) THEN  
     562                DO jn = 2, nptr 
     563                   str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     564                END DO 
     565             ENDIF 
     566         ENDIF 
     567         IF( cptr == 'ldf' ) THEN 
     568             IF( ktra == jp_tem ) THEN  
     569                DO jn = 2, nptr 
     570                    htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     571                 END DO 
     572             ENDIF 
     573             IF( ktra == jp_sal ) THEN  
     574                DO jn = 2, nptr 
     575                   str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     576                END DO 
     577             ENDIF 
     578         ENDIF 
     579         IF( cptr == 'eiv' ) THEN 
     580             IF( ktra == jp_tem ) THEN  
     581                DO jn = 2, nptr 
     582                    htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     583                 END DO 
     584             ENDIF 
     585             IF( ktra == jp_sal ) THEN  
     586                DO jn = 2, nptr 
     587                   str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     588                END DO 
     589             ENDIF 
     590         ENDIF 
     591         IF( cptr == 'vts' ) THEN 
     592             IF( ktra == jp_tem ) THEN  
     593                DO jn = 2, nptr 
     594                    htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     595                 END DO 
     596             ENDIF 
     597             IF( ktra == jp_sal ) THEN  
     598                DO jn = 2, nptr 
     599                   str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     600                END DO 
     601             ENDIF 
     602         ENDIF 
     603         ! 
     604      ENDIF 
     605   END SUBROUTINE dia_ptr_ohst_components 
     606 
    265607 
    266608   FUNCTION dia_ptr_alloc() 
    … …  
    273615      ierr(:) = 0 
    274616      ! 
    275       ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
    276          &      htr_adv(jpj) , str_adv(jpj) ,   & 
    277          &      htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1)  ) 
     617      ALLOCATE( btmsk(jpi,jpj,nptr) ,              & 
     618         &      htr_adv(jpj,nptr) , str_adv(jpj,nptr) ,   & 
     619         &      htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) ,   & 
     620         &      htr_vt(jpj,nptr)  , str_vs(jpj,nptr)  ,   & 
     621         &      htr_ove(jpj,nptr) , str_ove(jpj,nptr) ,   & 
     622         &      htr_btr(jpj,nptr) , str_btr(jpj,nptr) ,   & 
     623         &      htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1)  ) 
    278624         ! 
    279625      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 
    … …  
    402748#endif 
    403749      !!-------------------------------------------------------------------- 
    404       ! 
     750     ! 
    405751      p_fval => p_fval2d 
    406752 
    … …  
    434780#endif 
    435781      ! 
     782 
    436783   END FUNCTION ptr_sjk 
    437784 

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

    r7960 r9987  
    3939   USE zdfmxl          ! mixed layer 
    4040   USE dianam          ! build name of file (routine) 
     41   USE zdftke          ! vertical physics: one-equation scheme  
    4142   USE zdfddm          ! vertical  physics: double diffusion 
    4243   USE diahth          ! thermocline diagnostics 
    … …  
    4647   USE iom 
    4748   USE ioipsl 
    48    USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities      
    49  
     49   USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities     
     50   USE insitu_tem, ONLY: insitu_t, theta2t 
    5051#if defined key_lim2 
    5152   USE limwri_2  
    … …  
    145146      ENDIF 
    146147 
    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 
     148      ! Output of initial vertical scale factor 
     149      CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
     150      CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
     151      CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
     152      ! 
     153      CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     154      CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     155      CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     156      CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     157      IF( iom_use("e3tdef") )   & 
     158         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
     159      CALL iom_put("tpt_dep", fsdept_n(:,:,:) ) 
     160      CALL iom_put("wpt_dep", fsdepw_n(:,:,:) ) 
     161 
    153162 
    154163      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
    155       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    156164       
    157165      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
     166      CALL theta2t ! in-situ temperature conversion 
     167      CALL iom_put( "tinsitu", insitu_t(:,:,:))    ! in-situ temperature 
    158168      CALL iom_put(  "sst", tsn(:,:,1,jp_tem) )    ! surface temperature 
    159169      IF ( iom_use("sbt") ) THEN 
    … …  
    194204         CALL iom_put( "taubot", z2d )            
    195205      ENDIF 
    196           
     206       
    197207      CALL iom_put( "uoce", un(:,:,:)         )    ! 3D i-current 
    198208      CALL iom_put(  "ssu", un(:,:,1)         )    ! surface i-current 
    … …  
    242252      CALL iom_put( "avt" , avt                        )    ! T vert. eddy diff. coef. 
    243253      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
     254      IF( lk_zdftke ) THEN    
     255         CALL iom_put( "tke"      , en                               )    ! TKE budget: Turbulent Kinetic Energy    
     256         CALL iom_put( "tke_niw"  , e_niw                            )    ! TKE budget: Near-inertial waves    
     257      ENDIF  
    244258      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     259                                                            ! Log of eddy diff coef 
     260      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
     261      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    245262 
    246263      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    307324         CALL iom_put( "eken", rke )            
    308325      ENDIF 
    309           
    310       IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
     326      ! 
     327      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
     328      ! 
     329      IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    311330         z3d(:,:,jpk) = 0.e0 
     331         z2d(:,:) = 0.e0 
    312332         DO jk = 1, jpkm1 
    313333            z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 
     334            z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 
    314335         END DO 
    315336         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
     337         CALL iom_put( "u_masstr_vint", z2d )             ! mass transport in i-direction vertical sum 
    316338      ENDIF 
    317339       
    … …  
    376398         CALL iom_put( "v_salttr", 0.5 * z2d )            !  heat transport in j-direction 
    377399      ENDIF 
     400 
     401      ! Vertical integral of temperature 
     402      IF( iom_use("tosmint") ) THEN 
     403         z2d(:,:)=0._wp 
     404         DO jk = 1, jpkm1 
     405            DO jj = 2, jpjm1 
     406               DO ji = fs_2, fs_jpim1   ! vector opt. 
     407                  z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) *  tsn(ji,jj,jk,jp_tem) 
     408               END DO 
     409            END DO 
     410         END DO 
     411         CALL lbc_lnk( z2d, 'T', -1. ) 
     412         CALL iom_put( "tosmint", z2d )  
     413      ENDIF 
     414 
     415      ! Vertical integral of salinity 
     416      IF( iom_use("somint") ) THEN 
     417         z2d(:,:)=0._wp 
     418         DO jk = 1, jpkm1 
     419            DO jj = 2, jpjm1 
     420               DO ji = fs_2, fs_jpim1   ! vector opt. 
     421                  z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 
     422               END DO 
     423            END DO 
     424         END DO 
     425         CALL lbc_lnk( z2d, 'T', -1. ) 
     426         CALL iom_put( "somint", z2d )  
     427      ENDIF 
     428 
     429      CALL iom_put( "bn2", rn2 )  !Brunt-Vaisala buoyancy frequency (N^2) 
    378430      ! 
    379431      CALL wrk_dealloc( jpi , jpj      , z2d ) 
    … …  
    438490      zdt = rdt 
    439491      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 
     492      clop = "x"         ! no use of the mask value (require less cpu time, and otherwise the model crashes) 
    443493#if defined key_diainstant 
    444494      zsto = nwrite * zdt 
    … …  
    10201070         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
    10211071            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
     1072         CALL histdef( id_i, "vovvle3t", "T point thickness"         , "m"      ,   &   ! t-point depth 
     1073            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    10221074      END IF 
    10231075 
    … …  
    10501102      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress 
    10511103      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress 
     1104      IF( lk_vvl ) THEN 
     1105         CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth        
     1106         CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )!  T-cell thickness   
     1107      END IF 
    10521108 
    10531109      ! 3. Close the file 
    … …  
    10621118      ENDIF 
    10631119#endif 
     1120 
     1121      IF (cdfile_name == "output.abort") THEN 
     1122         CALL ctl_stop('MPPSTOP', 'NEMO abort from dia_wri_state') 
     1123      END IF 
    10641124        
    10651125!     IF( nn_timing == 1 )   CALL timing_stop('dia_wri_state') ! not sure this works for routines not called in first timestep 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DIA/diawri_dimg.h90

    r7960 r9987  
    112112    IF( inbsel >  jpk ) THEN 
    113113       IF(lwp) WRITE(numout,*)  ' STOP inbsel =',inbsel,' is larger than jpk=',jpk 
    114        STOP 
     114       CALL ctl_stop('STOP', 'NEMO aborted from dia_wri') 
    115115    ENDIF 
    116116 

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

    r7960 r9987  
    3636   PUBLIC clo_bat      ! routine called in domzgr module 
    3737 
    38    INTEGER, PUBLIC, PARAMETER          ::   jpncs   = 4      !: number of closed sea 
     38   INTEGER, PUBLIC, PARAMETER          ::   jpncs   = 10      !: number of closed sea 
    3939   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncstt            !: Type of closed sea 
    4040   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncsi1, ncsj1     !: south-west closed sea limits (i,j) 
    … …  
    155155            ncsi2(4)   = 76  ;  ncsj2(4)   = 61 
    156156            ncsir(4,1) = 84  ;  ncsjr(4,1) = 59  
    157             !                                        ! ======================= 
    158          CASE ( 025 )                                ! ORCA_R025 configuration 
    159             !                                        ! ======================= 
    160             ncsnr(1)   = 1    ; ncstt(1)   = 0               ! Caspian + Aral sea 
    161             ncsi1(1)   = 1330 ; ncsj1(1)   = 645 
    162             ncsi2(1)   = 1400 ; ncsj2(1)   = 795 
     157            !                                        ! ================================ 
     158         CASE ( 025 )                                ! ORCA_R025 extended configuration 
     159            !                                        ! ================================ 
     160            ncsnr(1)   = 1    ; ncstt(1)   = 0               ! Caspian sea 
     161            ncsi1(1)   = 1330 ; ncsj1(1)   = 831 
     162            ncsi2(1)   = 1375 ; ncsj2(1)   = 981 
    163163            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
    164164            !                                         
    165             ncsnr(2)   = 1    ; ncstt(2)   = 0               ! Azov Sea  
    166             ncsi1(2)   = 1284 ; ncsj1(2)   = 722 
    167             ncsi2(2)   = 1304 ; ncsj2(2)   = 747 
     165            ncsnr(2)   = 1    ; ncstt(2)   = 0               ! Aral sea 
     166            ncsi1(2)   = 1376 ; ncsj1(2)   = 900 
     167            ncsi2(2)   = 1400 ; ncsj2(2)   = 981 
    168168            ncsir(2,1) = 1    ; ncsjr(2,1) = 1 
     169            !                                         
     170            ncsnr(3)   = 1    ; ncstt(3)   = 0               ! Azov Sea  
     171            ncsi1(3)   = 1284 ; ncsj1(3)   = 908 
     172            ncsi2(3)   = 1304 ; ncsj2(3)   = 933 
     173            ncsir(3,1) = 1    ; ncsjr(3,1) = 1 
     174            ! 
     175            ncsnr(4)   = 1    ; ncstt(4)   = 0               ! Lake Superior   
     176            ncsi1(4)   = 781  ; ncsj1(4)   = 904  
     177            ncsi2(4)   = 815  ; ncsj2(4)   = 926  
     178            ncsir(4,1) = 1    ; ncsjr(4,1) = 1  
     179            !  
     180            ncsnr(5)   = 1    ; ncstt(5)   = 0               ! Lake Michigan 
     181            ncsi1(5)   = 795  ; ncsj1(5)   = 871              
     182            ncsi2(5)   = 813  ; ncsj2(5)   = 905  
     183            ncsir(5,1) = 1    ; ncsjr(5,1) = 1  
     184            !  
     185            ncsnr(6)   = 1    ; ncstt(6)   = 0               ! Lake Huron part 1 
     186            ncsi1(6)   = 814  ; ncsj1(6)   = 882              
     187            ncsi2(6)   = 825  ; ncsj2(6)   = 905  
     188            ncsir(6,1) = 1    ; ncsjr(6,1) = 1  
     189            !  
     190            ncsnr(7)   = 1    ; ncstt(7)   = 0               ! Lake Huron part 2 
     191            ncsi1(7)   = 826  ; ncsj1(7)   = 889              
     192            ncsi2(7)   = 833  ; ncsj2(7)   = 905  
     193            ncsir(7,1) = 1    ; ncsjr(7,1) = 1  
     194            !  
     195            ncsnr(8)   = 1    ; ncstt(8)   = 0               ! Lake Erie 
     196            ncsi1(8)   = 816  ; ncsj1(8)   = 871              
     197            ncsi2(8)   = 837  ; ncsj2(8)   = 881  
     198            ncsir(8,1) = 1    ; ncsjr(8,1) = 1  
     199            !  
     200            ncsnr(9)   = 1    ; ncstt(9)   = 0               ! Lake Ontario 
     201            ncsi1(9)   = 831  ; ncsj1(9)   = 882              
     202            ncsi2(9)   = 847  ; ncsj2(9)   = 889  
     203            ncsir(9,1) = 1    ; ncsjr(9,1) = 1  
     204            !  
     205            ncsnr(10)   = 1    ; ncstt(10)   = 0               ! Lake Victoria   
     206            ncsi1(10)   = 1274 ; ncsj1(10)   = 672  
     207            ncsi2(10)   = 1289 ; ncsj2(10)   = 687  
     208            ncsir(10,1) = 1    ; ncsjr(10,1) = 1  
    169209            ! 
    170210         END SELECT 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r7960 r9987  
    355355         &      gdept_0 (jpi,jpj,jpk) , e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) ,                         & 
    356356         &      gdepw_0 (jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , STAT=ierr(4) ) 
     357 
     358      ! Initilaise key variables at risk of being intercepted before properly set up.  
     359      e3t_0(:,:,:) = 0.0 
    357360         ! 
    358361#if defined key_vvl 
    … …  
    368371         &      ehu_b    (jpi,jpj)    , ehv_b  (jpi,jpj),                                                     & 
    369372         &      ehur_b   (jpi,jpj)    , ehvr_b (jpi,jpj),                                  STAT=ierr(5) )                           
     373 
     374      ! Initilaise key variables at risk of being intercepted before properly set up.  
     375      e3t_n(:,:,:) = 0.0 
    370376#endif 
    371377         ! 

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

    r7960 r9987  
    136136      USE ioipsl 
    137137      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
    138          &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
     138         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , ln_rstdate, nn_rstctl,   & 
    139139         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    140140         &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
    … …  
    173173         WRITE(numout,*) '      file prefix restart output      cn_ocerst_out= ', cn_ocerst_out 
    174174         WRITE(numout,*) '      restart output directory        cn_ocerst_outdir= ', cn_ocerst_outdir 
    175          WRITE(numout,*) '      restart logical                 ln_rstart  = ', ln_rstart 
     175         WRITE(numout,*) '      restart logical                 ln_rstart  = ' , ln_rstart 
     176         WRITE(numout,*) '      datestamping of restarts        ln_rstdate  = ', ln_rstdate 
    176177         WRITE(numout,*) '      start with forward time step    nn_euler   = ', nn_euler 
    177178         WRITE(numout,*) '      control of time step            nn_rstctl  = ', nn_rstctl 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r7960 r9987  
    136136      INTEGER  ::   isrow                    ! index for ORCA1 starting row 
    137137      INTEGER , POINTER, DIMENSION(:,:) ::  imsk 
     138      REAL(wp) ::  zphi_drake_passage, zshlat_antarc 
    138139      REAL(wp), POINTER, DIMENSION(:,:) ::  zwf 
    139140      !! 
    … …  
    413414         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    414415         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   
     416         ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    416417 
    417418         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    418419         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   
     420         ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    420421 
    421422         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    422423         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   
     424         ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    424425 
    425426         IF(lwp) WRITE(numout,*) '      Lombok ' 
    426427         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   
     428         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    428429 
    429430         IF(lwp) WRITE(numout,*) '      Ombai ' 
    430431         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   
     432         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    432433 
    433434         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    434435         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   
     436         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    436437 
    437438         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    438439         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   
     440         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    440441 
    441442         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    442443         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   
     444         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    444445         ! 
    445446      ENDIF 
     447      ! 
     448      IF( cp_cfg == "orca" .AND. jp_cfg == 025 .AND. rn_shlat == 0.0 ) THEN    
     449         !                                              ! ORCA_R025 configuration 
     450         !                                              ! Increased lateral friction on parts of Antarctic coastline 
     451         !                                              ! for increased stability 
     452         !                                              ! NB. This only works to do this here if we have free slip  
     453         !                                              ! generally, so fmask is zero at coast points. 
     454         IF(lwp) WRITE(numout,*) 
     455         IF(lwp) WRITE(numout,*) '   orca_r025: increase friction in following regions : ' 
     456         IF(lwp) WRITE(numout,*) '      whole Antarctic coastline: partial slip shlat=1 ' 
     457 
     458         zphi_drake_passage = -58.0_wp 
     459         zshlat_antarc = 1.0_wp 
     460         zwf(:,:) = fmask(:,:,1)          
     461         DO jj = 2, jpjm1 
     462            DO ji = fs_2, fs_jpim1   ! vector opt. 
     463               IF( gphif(ji,jj) .lt. zphi_drake_passage .and. fmask(ji,jj,1) == 0._wp ) THEN 
     464                  fmask(ji,jj,:) = zshlat_antarc * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),   & 
     465                     &                                           zwf(ji-1,jj), zwf(ji,jj-1)  )  ) 
     466               ENDIF 
     467            END DO 
     468         END DO 
     469      END IF 
    446470      ! 
    447471      CALL lbc_lnk( fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask 
    … …  
    526550      IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition' 
    527551      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   using Schchepetkin and O Brian scheme' 
    528       IF( lk_mpp )   CALL ctl_stop( ' mpp version is not yet implemented' ) 
     552      IF( lk_mpp )   CALL ctl_stop('STOP', ' mpp version is not yet implemented' ) 
    529553 
    530554      ! mask for second order calculation of vorticity 
    … …  
    548572         WRITE(numout,*) ' symetric boundary conditions need special' 
    549573         WRITE(numout,*) ' treatment not implemented. we stop.' 
    550          STOP 
     574         CALL ctl_stop('STOP', 'NEMO abort from dom_msk_nsa') 
    551575      ENDIF 
    552576       

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

    r7960 r9987  
    594594         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   - interpolate scale factors and compute depths for next time step' 
    595595      ENDIF 
     596 
    596597      ! 
    597598      ! Time filter and swap of scale factors 
    … …  
    665666         ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
    666667      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 ) 
    677668 
    678669      ! write restart file 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90

    r7960 r9987  
    6868   REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow 
    6969   REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat for ice  
     70#if defined key_cice 
     71   REAL(wp), PUBLIC ::   lsub     =    2.835e+6_wp   !: pure ice latent heat of sublimation                   [J/kg] 
     72#else 
    7073   REAL(wp), PUBLIC ::   lsub     =    2.834e+6_wp   !: pure ice latent heat of sublimation                   [J/kg] 
     74#endif 
    7175   REAL(wp), PUBLIC ::   lfus     =    0.334e+6_wp   !: latent heat of fusion of fresh ice                    [J/kg] 
    7276   REAL(wp), PUBLIC ::   tmut     =    0.054_wp      !: decrease of seawater meltpoint with salinity 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r7960 r9987  
    4444   USE wrk_nemo        ! Memory Allocation 
    4545   USE timing          ! Timing 
     46   USE biaspar         ! bias correction variables 
    4647 
    4748   IMPLICIT NONE 
    … …  
    8485      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8586      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdu, ztrdv 
     87      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   z_rhd_st  ! tmp density storage for pressure corr 
     88      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     ::   z_gru_st  ! tmp ua trends storage for pressure corr 
     89      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     ::   z_grv_st  ! tmp va trends storage for pressure corr 
    8690      !!---------------------------------------------------------------------- 
    8791      ! 
    … …  
    9498      ENDIF 
    9599      ! 
     100      IF ( ln_bias .AND. ln_bias_pc_app ) THEN 
     101 
     102         !Allocate space for tempory variables 
     103         ALLOCATE( z_rhd_st(jpi,jpj,jpk), & 
     104            &      z_gru_st(jpi,jpj),     & 
     105            &      z_grv_st(jpi,jpj)      ) 
     106 
     107         z_rhd_st(:,:,:) = rhd(:,:,:)     ! store orig density  
     108         rhd(:,:,:)      = rhd_pc(:,:,:)  ! use pressure corrected density 
     109         z_gru_st(:,:)   = gru(:,:) 
     110         gru(:,:)        = gru_pc(:,:) 
     111         z_grv_st(:,:)   = grv(:,:) 
     112         grv(:,:)        = grv_pc(:,:) 
     113 
     114      ENDIF 
     115 
    96116      SELECT CASE ( nhpg )      ! Hydrostatic pressure gradient computation 
    97117      CASE (  0 )   ;   CALL hpg_zco    ( kt )      ! z-coordinate 
    … …  
    112132      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' hpg  - Ua: ', mask1=umask,   & 
    113133         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     134      ! 
     135      IF ( ln_bias .AND. ln_bias_pc_app )  THEN 
     136         IF(lwp) THEN  
     137         WRITE(numout,*) " ! restore original density" 
     138         ENDIF 
     139         rhd(:,:,:) = z_rhd_st(:,:,:)     ! restore original density 
     140         gru(:,:)   = z_gru_st(:,:) 
     141         grv(:,:)   = z_grv_st(:,:) 
     142 
     143         !Deallocate tempory variables 
     144         DEALLOCATE( z_rhd_st,     & 
     145            &        z_gru_st,     & 
     146            &        z_grv_st      ) 
     147      ENDIF 
    114148      ! 
    115149      IF( nn_timing == 1 )  CALL timing_stop('dyn_hpg') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90

    r7960 r9987  
    465465            END DO 
    466466         ELSE 
    467             IF(lwp)WRITE(numout,*) ' ldfguv: kahm= 1 or 2, here =', kahm 
    468             IF(lwp)WRITE(numout,*) '         We stop' 
    469             STOP 'ldfguv' 
     467             
     468            WRITE(numout,*) ' ldfguv: kahm= 1 or 2, here =', kahm 
     469            WRITE(numout,*) '         We stop' 
     470            CALL ctl_stop('STOP', 'ldfguv: Unexpected kahm value') 
     471 
    470472         ENDIF 
    471473         !                                             ! =============== 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r7960 r9987  
    166166            ! 
    167167         ENDIF 
     168        IF( l_trddyn )   THEN                      ! Put here so code doesn't crash when doing KE trend but needs to be done properly 
     169            CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv ) 
     170         ENDIF 
    168171         ! 
    169172      ELSE                       ! fixed volume  (add the surface pressure gradient + unweighted time stepping) 

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

    r9188 r9987  
    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 
    … …  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r7960 r9987  
    3838   USE wrk_nemo       ! Memory Allocation 
    3939   USE timing         ! Timing 
     40   USE lib_fortran 
    4041 
    4142 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r7960 r9987  
    3131   USE bdydyn2d        ! bdy_ssh routine 
    3232#if defined key_agrif 
    33    USE agrif_opa_update 
    3433   USE agrif_opa_interp 
    3534#endif 
    … …  
    7574      INTEGER, INTENT(in) ::   kt                      ! time step 
    7675      !  
    77       INTEGER             ::   jk                      ! dummy loop indice 
     76      INTEGER             ::   jk                      ! dummy loop indices 
    7877      REAL(wp)            ::   z2dt, z1_rau0           ! local scalars 
    7978      !!---------------------------------------------------------------------- 
    … …  
    9594      z2dt = 2._wp * rdt                              ! set time step size (Euler/Leapfrog) 
    9695      IF( neuler == 0 .AND. kt == nit000 )   z2dt = rdt 
     96 
     97 
     98#if defined key_asminc 
     99      !                                                ! Include the IAU weighted SSH increment 
     100      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
     101         CALL ssh_asm_inc( kt ) 
     102#if defined key_vvl 
     103! Don't directly adjust ssh but change hdivn at all levels instead 
     104! In trasbc also add in the heat and salt content associated with these changes at each level   
     105        DO jk = 1, jpkm1                                  
     106                 hdivn(:,:,jk) = hdivn(:,:,jk) - ( ssh_iau(:,:) / ( ht_0(:,:) + 1.0 - ssmask(:,:) ) ) * ( e3t_0(:,:,jk) / fse3t_n(:,:,jk) ) * tmask(:,:,jk)  
     107        END DO 
     108      ENDIF 
     109#endif 
     110#endif 
     111 
    97112 
    98113      !                                           !------------------------------! 
    … …  
    124139#endif 
    125140 
    126 #if defined key_asminc 
    127       !                                                ! Include the IAU weighted SSH increment 
    128       IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
    129          CALL ssh_asm_inc( kt ) 
    130          ssha(:,:) = ssha(:,:) + z2dt * ssh_iau(:,:) 
    131       ENDIF 
    132 #endif 
    133141 
    134142      !                                           !------------------------------! 
    … …  
    268276      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    269277         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(:,:) 
     278         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:)    - emp(:,:)    & 
     279                                &                                 - rnf_b(:,:)    + rnf(:,:)    & 
     280                                &                                 + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) 
    271281         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    272282      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 
    278283      ! 
    279284      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask, ovlap=1 ) 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbclv.F90

    r7960 r9987  
    2525   USE icbutl         ! iceberg utility routines 
    2626 
     27   USE sbc_oce        ! for icesheet freshwater input variables 
     28   USE in_out_manager 
     29   USE iom 
     30 
    2731   IMPLICIT NONE 
    2832   PRIVATE 
    … …  
    4852      ! 
    4953      REAL(wp)                        :: zcalving_used, zdist, zfact 
     54      REAL(wp)                        :: zgreenland_calving_sum, zantarctica_calving_sum 
    5055      INTEGER                         :: jn, ji, jj                    ! loop counters 
    5156      INTEGER                         :: imx                           ! temporary integer for max berg class 
    … …  
    5964      zfact = ( (1000._wp)**3 / ( NINT(rday) * nyear_len(1) ) ) * 850._wp 
    6065      berg_grid%calving(:,:) = src_calving(:,:) * tmask_i(:,:) * zfact 
     66 
     67      IF( lk_oasis) THEN 
     68      ! nn_coupled_iceshelf_fluxes uninitialised unless lk_oasis=true 
     69      IF( nn_coupled_iceshelf_fluxes .gt. 0 ) THEN 
     70 
     71        ! Adjust total calving rates so that sum of iceberg calving and iceshelf melting in the northern 
     72        ! and southern hemispheres equals rate of increase of mass of greenland and antarctic ice sheets 
     73        ! to preserve total freshwater conservation in coupled models without an active ice sheet model. 
     74 
     75         zgreenland_calving_sum = SUM( berg_grid%calving(:,:) * greenland_icesheet_mask(:,:) ) 
     76         IF( lk_mpp ) CALL mpp_sum( zgreenland_calving_sum ) 
     77         WHERE( greenland_icesheet_mask(:,:) == 1.0 )                                                                                 & 
     78        &    berg_grid%calving(:,:) = berg_grid%calving(:,:) * greenland_icesheet_mass_rate_of_change * rn_greenland_calving_fraction & 
     79        &                                     / ( zgreenland_calving_sum + 1.0e-10_wp ) 
     80 
     81         ! check 
     82         IF(lwp) WRITE(numout, *) 'Greenland iceberg calving climatology (kg/s) : ',zgreenland_calving_sum 
     83         zgreenland_calving_sum = SUM( berg_grid%calving(:,:) * greenland_icesheet_mask(:,:) ) 
     84         IF( lk_mpp ) CALL mpp_sum( zgreenland_calving_sum ) 
     85         IF(lwp) WRITE(numout, *) 'Greenland iceberg calving adjusted value (kg/s) : ',zgreenland_calving_sum 
     86 
     87         zantarctica_calving_sum = SUM( berg_grid%calving(:,:) * antarctica_icesheet_mask(:,:) ) 
     88         IF( lk_mpp ) CALL mpp_sum( zantarctica_calving_sum ) 
     89         WHERE( antarctica_icesheet_mask(:,:) == 1.0 )                                                                              & 
     90         berg_grid%calving(:,:) = berg_grid%calving(:,:) * antarctica_icesheet_mass_rate_of_change * rn_antarctica_calving_fraction & 
     91        &                           / ( zantarctica_calving_sum + 1.0e-10_wp ) 
     92  
     93         ! check 
     94         IF(lwp) WRITE(numout, *) 'Antarctica iceberg calving climatology (kg/s) : ',zantarctica_calving_sum 
     95         zantarctica_calving_sum = SUM( berg_grid%calving(:,:) * antarctica_icesheet_mask(:,:) ) 
     96         IF( lk_mpp ) CALL mpp_sum( zantarctica_calving_sum ) 
     97         IF(lwp) WRITE(numout, *) 'Antarctica iceberg calving adjusted value (kg/s) : ',zantarctica_calving_sum 
     98 
     99      ENDIF 
     100      ENDIF 
     101    
     102      CALL iom_put( 'berg_calve', berg_grid%calving(:,:) ) 
    61103 
    62104      ! Heat in units of W/m2, and mask (just in case) 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbdia.F90

    r7960 r9987  
    371371      IF( .NOT. ln_bergdia )   RETURN            !!gm useless iom will control whether it is output or not 
    372372      ! 
     373      CALL iom_put( "berg_total_melt"      , berg_grid%floating_melt(:,:)   )   ! Total melt flux to ocean      [kg/m2/s] 
     374      CALL iom_put( "berg_total_heat_flux" , berg_grid%calving_hflx(:,:)    )   ! Total iceberg-ocean heat flux [W/m2] 
    373375      CALL iom_put( "berg_melt"        , berg_melt   (:,:)   )   ! Melt rate of icebergs                     [kg/m2/s] 
    374376      CALL iom_put( "berg_buoy_melt"   , buoy_melt   (:,:)   )   ! Buoyancy component of iceberg melt rate   [kg/m2/s] 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90

    r7960 r9987  
    1212   !!            -    !                            Currently needs a fixed processor 
    1313   !!            -    !                            layout between restarts 
     14   !!            -    !  2015-11  Dave Storkey     Convert icb_rst_read to use IOM so can 
     15   !!                                              read single restart files 
    1416   !!---------------------------------------------------------------------- 
    1517   !!---------------------------------------------------------------------- 
    … …  
    1820   !!---------------------------------------------------------------------- 
    1921   USE par_oce        ! NEMO parameters 
     22   USE phycst         ! for rday 
    2023   USE dom_oce        ! NEMO domain 
    2124   USE in_out_manager ! NEMO IO routines 
     25   USE ioipsl, ONLY : ju2ymds    ! for calendar 
    2226   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular 
    2327   USE netcdf         ! netcdf routines for IO 
     28   USE iom 
    2429   USE icb_oce        ! define iceberg arrays 
    2530   USE icbutl         ! iceberg utility routines 
    … …  
    5762      INTEGER                      ::   idim, ivar, iatt 
    5863      INTEGER                      ::   jn, iunlim_dim, ibergs_in_file 
    59       INTEGER                      ::   iclass 
    60       INTEGER, DIMENSION(1)        ::   istrt, ilngth, idata 
    61       INTEGER, DIMENSION(2)        ::   istrt2, ilngth2 
    62       INTEGER, DIMENSION(nkounts)  ::   idata2 
    63       REAL(wp), DIMENSION(1)       ::   zdata                                         ! need 1d array to read in with 
    64                                                                                             ! start and count arrays 
     64      INTEGER                      ::   ii,ij,iclass 
     65      REAL(wp), DIMENSION(nkounts) ::   zdata       
    6566      LOGICAL                      ::   ll_found_restart 
    6667      CHARACTER(len=256)           ::   cl_path 
    … …  
    7172      !!---------------------------------------------------------------------- 
    7273 
    73       ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts.  
     74      ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts 
     75      ! and are called TRIM(cn_ocerst)//'_icebergs' 
    7476      cl_path = TRIM(cn_ocerst_indir) 
    7577      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 
    76       cl_filename = ' ' 
    77       IF ( lk_mpp ) THEN 
    78          cl_filename = ' ' 
    79          WRITE( cl_filename, '("restart_icebergs_",I4.4,".nc")' ) narea-1 
    80          INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    81       ELSE 
    82          cl_filename = 'restart_icebergs.nc' 
    83          INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    84       ENDIF 
    85  
    86       IF ( .NOT. ll_found_restart) THEN                     ! only do the following if a file was found 
    87          CALL ctl_stop('icebergs: no restart file found') 
    88       ENDIF 
    89  
    90       IF (nn_verbose_level >= 0 .AND. lwp)  & 
    91          WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_path)//TRIM(cl_filename) 
    92  
    93       nret = NF90_OPEN(TRIM(cl_path)//TRIM(cl_filename), NF90_NOWRITE, ncid) 
    94       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_open failed') 
    95  
    96       nret = nf90_inquire(ncid, idim, ivar, iatt, iunlim_dim) 
    97       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_inquire failed') 
    98  
    99       IF( iunlim_dim .NE. -1) THEN 
    100  
    101          nret = nf90_inquire_dimension(ncid, iunlim_dim, cl_dname, ibergs_in_file) 
    102          IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_inq_dimlen failed') 
    103  
    104          nret = NF90_INQ_VARID(ncid, 'number', numberid) 
    105          nret = NF90_INQ_VARID(ncid, 'mass_scaling', nscaling_id) 
    106          nret = NF90_INQ_VARID(ncid, 'xi', nxid) 
    107          nret = NF90_INQ_VARID(ncid, 'yj', nyid) 
    108          nret = NF90_INQ_VARID(ncid, 'lon', nlonid) 
    109          nret = NF90_INQ_VARID(ncid, 'lat', nlatid) 
    110          nret = NF90_INQ_VARID(ncid, 'uvel', nuvelid) 
    111          nret = NF90_INQ_VARID(ncid, 'vvel', nvvelid) 
    112          nret = NF90_INQ_VARID(ncid, 'mass', nmassid) 
    113          nret = NF90_INQ_VARID(ncid, 'thickness', nthicknessid) 
    114          nret = NF90_INQ_VARID(ncid, 'width', nwidthid) 
    115          nret = NF90_INQ_VARID(ncid, 'length', nlengthid) 
    116          nret = NF90_INQ_VARID(ncid, 'year', nyearid) 
    117          nret = NF90_INQ_VARID(ncid, 'day', ndayid) 
    118          nret = NF90_INQ_VARID(ncid, 'mass_of_bits', nmass_of_bits_id) 
    119          nret = NF90_INQ_VARID(ncid, 'heat_density', nheat_density_id) 
    120  
    121          ilngth(1) = 1 
    122          istrt2(1) = 1 
    123          ilngth2(1) = nkounts 
    124          ilngth2(2) = 1 
    125          DO jn=1, ibergs_in_file 
    126  
    127             istrt(1) = jn 
    128             istrt2(2) = jn 
    129  
    130             nret = NF90_GET_VAR(ncid, numberid, idata2, istrt2, ilngth2 ) 
    131             localberg%number(:) = idata2(:) 
    132  
    133             nret = NF90_GET_VAR(ncid, nscaling_id, zdata, istrt, ilngth ) 
    134             localberg%mass_scaling = zdata(1) 
    135  
    136             nret = NF90_GET_VAR(ncid, nlonid, zdata, istrt, ilngth) 
    137             localpt%lon = zdata(1) 
    138             nret = NF90_GET_VAR(ncid, nlatid, zdata, istrt, ilngth) 
    139             localpt%lat = zdata(1) 
    140             IF (nn_verbose_level >= 2 .AND. lwp) THEN 
    141                WRITE(numout,'(a,i5,a,2f10.4,a,i5)') 'icebergs, read_restart_bergs: berg ',jn,' is at ', & 
    142                                               localpt%lon,localpt%lat,' on PE ',narea-1 
     78      cl_filename = TRIM(cn_ocerst_in)//'_icebergs' 
     79      CALL iom_open( TRIM(cl_path)//cl_filename, ncid ) 
     80 
     81      IF( iom_file(ncid)%iduld .GE. 0) THEN 
     82 
     83         ibergs_in_file = iom_file(ncid)%lenuld 
     84         DO jn = 1,ibergs_in_file 
     85 
     86            ! iom_get treats the unlimited dimension as time. Here the unlimited dimension  
     87            ! is the iceberg index, but we can still use the ktime keyword to get the iceberg we want.  
     88 
     89            CALL iom_get( ncid, 'xi'     ,localpt%xi  , ktime=jn ) 
     90            CALL iom_get( ncid, 'yj'     ,localpt%yj  , ktime=jn ) 
     91 
     92            ii = INT( localpt%xi + 0.5 ) 
     93            ij = INT( localpt%yj + 0.5 ) 
     94            ! Only proceed if this iceberg is on the local processor (excluding halos). 
     95            IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND. & 
     96           &     ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1 ) THEN            
     97 
     98               CALL iom_get( ncid, jpdom_unknown, 'number'       , zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) ) 
     99               localberg%number(:) = INT(zdata(:)) 
     100               CALL iom_get( ncid, 'mass_scaling' , localberg%mass_scaling, ktime=jn ) 
     101               CALL iom_get( ncid, 'lon'          , localpt%lon           , ktime=jn ) 
     102               CALL iom_get( ncid, 'lat'          , localpt%lat           , ktime=jn ) 
     103               CALL iom_get( ncid, 'uvel'         , localpt%uvel          , ktime=jn ) 
     104               CALL iom_get( ncid, 'vvel'         , localpt%vvel          , ktime=jn ) 
     105               CALL iom_get( ncid, 'mass'         , localpt%mass          , ktime=jn ) 
     106               CALL iom_get( ncid, 'thickness'    , localpt%thickness     , ktime=jn ) 
     107               CALL iom_get( ncid, 'width'        , localpt%width         , ktime=jn ) 
     108               CALL iom_get( ncid, 'length'       , localpt%length        , ktime=jn ) 
     109               CALL iom_get( ncid, 'year'         , zdata(1)              , ktime=jn ) 
     110               localpt%year = INT(zdata(1)) 
     111               CALL iom_get( ncid, 'day'          , localpt%day           , ktime=jn ) 
     112               CALL iom_get( ncid, 'mass_of_bits' , localpt%mass_of_bits  , ktime=jn ) 
     113               CALL iom_get( ncid, 'heat_density' , localpt%heat_density  , ktime=jn ) 
     114 
     115               ! 
     116               CALL icb_utl_add( localberg, localpt ) 
     117 
    143118            ENDIF 
    144             nret = NF90_GET_VAR(ncid, nxid, zdata, istrt, ilngth) 
    145             localpt%xi = zdata(1) 
    146             nret = NF90_GET_VAR(ncid, nyid, zdata, istrt, ilngth) 
    147             localpt%yj = zdata(1) 
    148             nret = NF90_GET_VAR(ncid, nuvelid, zdata, istrt, ilngth ) 
    149             localpt%uvel = zdata(1) 
    150             nret = NF90_GET_VAR(ncid, nvvelid, zdata, istrt, ilngth ) 
    151             localpt%vvel = zdata(1) 
    152             nret = NF90_GET_VAR(ncid, nmassid, zdata, istrt, ilngth ) 
    153             localpt%mass = zdata(1) 
    154             nret = NF90_GET_VAR(ncid, nthicknessid, zdata, istrt, ilngth ) 
    155             localpt%thickness = zdata(1) 
    156             nret = NF90_GET_VAR(ncid, nwidthid, zdata, istrt, ilngth ) 
    157             localpt%width = zdata(1) 
    158             nret = NF90_GET_VAR(ncid, nlengthid, zdata, istrt, ilngth ) 
    159             localpt%length = zdata(1) 
    160             nret = NF90_GET_VAR(ncid, nyearid, idata, istrt, ilngth ) 
    161             localpt%year = idata(1) 
    162             nret = NF90_GET_VAR(ncid, ndayid, zdata, istrt, ilngth ) 
    163             localpt%day = zdata(1) 
    164             nret = NF90_GET_VAR(ncid, nmass_of_bits_id, zdata, istrt, ilngth ) 
    165             localpt%mass_of_bits = zdata(1) 
    166             nret = NF90_GET_VAR(ncid, nheat_density_id, zdata, istrt, ilngth ) 
    167             localpt%heat_density = zdata(1) 
    168             ! 
    169             CALL icb_utl_add( localberg, localpt ) 
     119 
    170120         END DO 
    171          ! 
    172       ENDIF 
    173  
    174       nret = NF90_INQ_DIMID( ncid, 'c', nc_dim ) 
    175       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_inq_dimid c failed') 
    176  
    177       nret = NF90_INQUIRE_DIMENSION( ncid, nc_dim, cl_dname, iclass ) 
    178       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_inquire_dimension failed') 
    179  
    180       nret = NF90_INQ_VARID(ncid, 'kount'       , nkountid) 
    181       nret = NF90_INQ_VARID(ncid, 'calving'     , ncalvid) 
    182       nret = NF90_INQ_VARID(ncid, 'calving_hflx', ncalvhid) 
    183       nret = NF90_INQ_VARID(ncid, 'stored_ice'  , nsiceid) 
    184       nret = NF90_INQ_VARID(ncid, 'stored_heat' , nsheatid) 
    185  
    186       nstrt3(1) = 1 
    187       nstrt3(2) = 1 
    188       nlngth3(1) = jpi 
    189       nlngth3(2) = jpj 
    190       nlngth3(3) = 1 
    191  
    192       DO jn = 1, iclass 
    193          nstrt3(3) = jn 
    194          nret      = NF90_GET_VAR( ncid, nsiceid , griddata, nstrt3, nlngth3 ) 
    195          berg_grid%stored_ice(:,:,jn) = griddata(:,:,1) 
    196       END DO 
    197  
    198       nret = NF90_GET_VAR( ncid, ncalvid , src_calving          (:,:) ) 
    199       nret = NF90_GET_VAR( ncid, ncalvhid, src_calving_hflx     (:,:) ) 
    200       nret = NF90_GET_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) ) 
    201       nret = NF90_GET_VAR( ncid, nkountid, idata2(:) ) 
    202       num_bergs(:) = idata2(:) 
    203  
    204       ! Finish up 
    205       nret = NF90_CLOSE(ncid) 
    206       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_close failed') 
     121 
     122      ENDIF  
     123 
     124      ! Gridded variables 
     125      CALL iom_get( ncid, jpdom_autoglo,    'calving'     , src_calving  ) 
     126      CALL iom_get( ncid, jpdom_autoglo,    'calving_hflx', src_calving_hflx  ) 
     127      CALL iom_get( ncid, jpdom_autoglo,    'stored_heat' , berg_grid%stored_heat  ) 
     128      CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice'  , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,nclasses/) ) 
     129       
     130      CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) 
     131      num_bergs(:) = INT(zdata(:)) 
    207132 
    208133      ! Sanity check 
    … …  
    211136         WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 
    212137      IF( lk_mpp ) THEN 
    213          CALL mpp_sum(ibergs_in_file) 
     138         ! Only mpp_sum ibergs_in_file if we are reading from multiple restart files.  
     139         IF( INDEX(iom_file(ncid)%name,'icebergs.nc' ) .EQ. 0 ) CALL mpp_sum(ibergs_in_file) 
    214140         CALL mpp_sum(jn) 
    215141      ENDIF 
    … …  
    217143         &                                    ' bergs in the restart file and', jn,' bergs have been read' 
    218144      ! 
     145      ! Finish up 
     146      CALL iom_close( ncid ) 
     147      ! 
    219148      IF( lwp .and. nn_verbose_level >= 0)  WRITE(numout,'(a)') 'icebergs, read_restart_bergs: completed' 
    220149      ! 
    … …  
    231160      INTEGER ::   jn   ! dummy loop index 
    232161      INTEGER ::   ix_dim, iy_dim, ik_dim, in_dim 
    233       CHARACTER(len=256)     :: cl_path 
    234       CHARACTER(len=256)     :: cl_filename 
     162      INTEGER             ::   iyear, imonth, iday 
     163      REAL (wp)           ::   zsec 
     164      REAL (wp)           ::   zfjulday 
     165      CHARACTER(len=256)  :: cl_path 
     166      CHARACTER(len=256)  :: cl_filename 
     167      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character 
    235168      TYPE(iceberg), POINTER :: this 
    236169      TYPE(point)  , POINTER :: pt 
    … …  
    240173      cl_path = TRIM(cn_ocerst_outdir) 
    241174      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 
     175      IF ( ln_rstdate ) THEN 
     176         zfjulday = fjulday + rdttra(1) / rday 
     177         IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday )   zfjulday = REAL(NINT(zfjulday),wp)   ! avoid truncation error 
     178         CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec )            
     179         WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday 
     180      ELSE 
     181         IF( kt > 999999999 ) THEN   ;   WRITE(clkt, *       ) kt 
     182         ELSE                        ;   WRITE(clkt, '(i8.8)') kt 
     183         ENDIF 
     184      ENDIF 
    242185      IF( lk_mpp ) THEN 
    243          WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart_",I4.4,".nc")') TRIM(cexper), kt, narea-1 
     186         WRITE(cl_filename,'(A,"_icebergs_",A,"_restart_",I4.4,".nc")') TRIM(cexper), TRIM(ADJUSTL(clkt)), narea-1 
    244187      ELSE 
    245          WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart.nc")') TRIM(cexper), kt 
     188         WRITE(cl_filename,'(A,"_icebergs_",A,"_restart.nc")') TRIM(cexper), TRIM(ADJUSTL(clkt)) 
    246189      ENDIF 
    247190      IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_path)//TRIM(cl_filename) 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbthm.F90

    r7960 r9987  
    1818   USE dom_oce        ! NEMO domain 
    1919   USE in_out_manager ! NEMO IO routines, numout in particular 
     20   USE iom 
    2021   USE lib_mpp        ! NEMO MPI routines, ctl_stop in particular 
    2122   USE phycst         ! NEMO physical constants 
    … …  
    160161            zmelt    = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt   ! kg/s 
    161162            berg_grid%floating_melt(ii,ij) = berg_grid%floating_melt(ii,ij) + zmelt    * z1_e1e2    ! kg/m2/s 
    162             zheat = zmelt * pt%heat_density              ! kg/s x J/kg = J/s 
     163!            zheat = zmelt * pt%heat_density              ! kg/s x J/kg = J/s 
     164            zheat = zmelt * lfus                           !rma kg/s x J/kg (latent heat of fusion) = J/s 
    163165            berg_grid%calving_hflx (ii,ij) = berg_grid%calving_hflx (ii,ij) + zheat    * z1_e1e2    ! W/m2 
    164166            CALL icb_dia_melt( ii, ij, zMnew, zheat, this%mass_scaling,       & 
    … …  
    208210      IF(.NOT. ln_passive_mode ) THEN 
    209211         emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:) 
    210 !!       qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:)  !!gm heat flux not yet properly coded ==>> need it, SOLVE that! 
     212         qns (:,:) = qns (:,:) - berg_grid%calving_hflx (:,:)   
    211213      ENDIF 
    212214      ! 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ICB/icbtrj.F90

    r7960 r9987  
    1818   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular 
    1919   USE in_out_manager ! NEMO IO, numout in particular 
     20   USE ioipsl, ONLY : ju2ymds    ! for calendar 
    2021   USE netcdf 
    2122   ! 
    … …  
    6061      ! 
    6162      INTEGER                               :: iret 
     63      INTEGER                               :: iyear, imonth, iday 
     64      REAL(wp)                              :: zfjulday, zsec 
    6265      CHARACTER(len=80)                     :: cl_filename 
    6366      TYPE(iceberg), POINTER                :: this 
    6467      TYPE(point)  , POINTER                :: pt 
    65       !!---------------------------------------------------------------------- 
    66  
    67       IF( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",I6.6,"_",I4.4,".nc")') ktend, narea-1 
    68       ELSE                ;   WRITE(cl_filename,'("trajectory_icebergs_",I6.6         ,".nc")') ktend 
     68      CHARACTER(LEN=20)                     :: cldate_ini, cldate_end 
     69      !!---------------------------------------------------------------------- 
     70 
     71      ! compute initial time step date 
     72      CALL ju2ymds( fjulday, iyear, imonth, iday, zsec ) 
     73      WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday 
     74 
     75      ! compute end time step date 
     76      zfjulday = fjulday + rdttra(1) / rday * REAL( nitend - nit000 + 1 , wp) 
     77      IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday )   zfjulday = REAL(NINT(zfjulday),wp)   ! avoid truncation error 
     78      CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec ) 
     79      WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday 
     80 
     81      ! define trajectory output name 
     82      IF( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A,"_",I4.4,".nc")') TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)), narea-1 
     83      ELSE                ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A         ,".nc")') TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)) 
    6984      ENDIF 
    7085      IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) 

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

    r7960 r9987  
    3030   CHARACTER(lc) ::   cn_ocerst_outdir !: restart output directory 
    3131   LOGICAL       ::   ln_rstart        !: start from (F) rest or (T) a restart file 
     32   LOGICAL       ::   ln_rstdate       !: datestamping of restarts 
    3233   LOGICAL       ::   ln_rst_list      !: output restarts at list of times (T) or by frequency (F) 
    3334   INTEGER       ::   nn_no            !: job number 

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

    r7960 r9987  
    9494      CHARACTER(len=*), INTENT(in)  :: cdname 
    9595#if defined key_iomput 
    96       TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
    97       CHARACTER(len=19) :: cldate  
    98       CHARACTER(len=10) :: clname 
    99       INTEGER           ::   ji 
     96#if ! defined key_xios2 
     97      TYPE(xios_time)     :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
     98      CHARACTER(len=19)   :: cldate  
     99#else 
     100      TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0) 
     101      TYPE(xios_date)     :: start_date 
     102#endif 
     103      CHARACTER(len=10)   :: clname 
     104      INTEGER             :: ji 
    100105      ! 
    101106      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
    102107      !!---------------------------------------------------------------------- 
    103  
     108#if ! defined key_xios2 
    104109      ALLOCATE( z_bnds(jpk,2) ) 
     110#else 
     111      ALLOCATE( z_bnds(2,jpk) ) 
     112#endif 
    105113 
    106114      clname = cdname 
    … …  
    110118 
    111119      ! calendar parameters 
     120#if ! defined key_xios2 
    112121      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    113122      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") 
    … …  
    117126      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
    118127      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    119  
     128#else 
     129      ! Calendar type is now defined in xml file  
     130      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     131      CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 
     132          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     133      CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), & 
     134          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     135      CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), & 
     136          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     137      END SELECT 
     138#endif 
    120139      ! horizontal grid definition 
     140 
    121141      CALL set_scalar 
    122142 
    … …  
    170190 
    171191      ! Add vertical grid bounds 
     192#if ! defined key_xios2 
    172193      z_bnds(:      ,1) = gdepw_1d(:) 
    173194      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
    174195      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     196#else 
     197      z_bnds(1      ,:) = gdepw_1d(:) 
     198      z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     199      z_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     200#endif 
     201 
    175202      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
    176203      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
    177204      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
    178       z_bnds(:    ,2) = gdept_1d(:) 
    179       z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
    180       z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     205 
     206#if ! defined key_xios2 
     207      z_bnds(:    ,2)  = gdept_1d(:) 
     208      z_bnds(2:jpk,1)  = gdept_1d(1:jpkm1) 
     209      z_bnds(1    ,1)  = gdept_1d(1) - e3w_1d(1) 
     210#else 
     211      z_bnds(2,:    )  = gdept_1d(:) 
     212      z_bnds(1,2:jpk)  = gdept_1d(1:jpkm1) 
     213      z_bnds(1,1    )  = gdept_1d(1) - e3w_1d(1) 
     214#endif 
    181215      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     216 
    182217 
    183218# if defined key_floats 
    … …  
    193228      ! automatic definitions of some of the xml attributs 
    194229      CALL set_xmlatt 
     230 
     231      CALL set_1point 
    195232 
    196233      ! end file definition 
    … …  
    673710      CHARACTER(LEN=256)             ::   clname      ! file name 
    674711      CHARACTER(LEN=1)               ::   clrankpv, cldmspc      !  
     712      LOGICAL                        ::   ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 
    675713      !--------------------------------------------------------------------- 
    676714      ! 
    … …  
    685723      IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 
    686724      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 
    687       IF( PRESENT(kstart) .AND. idom /= jpdom_unknown   ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 
     725      IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND.  idom /= jpdom_autoglo_xy  ) & 
     726     &           CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') 
    688727 
    689728      luse_jattr = .false. 
    … …  
    718757         ! update idom definition... 
    719758         ! Identify the domain in case of jpdom_auto(glo/dta) definition 
     759         IF( idom == jpdom_autoglo_xy ) THEN 
     760            ll_depth_spec = .TRUE. 
     761            idom = jpdom_autoglo 
     762         ELSE 
     763            ll_depth_spec = .FALSE. 
     764         ENDIF 
    720765         IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN             
    721766            IF( idom == jpdom_autoglo ) THEN   ;   idom = jpdom_global  
    … …  
    771816         istart(idmspc+1) = itime 
    772817 
    773          IF(              PRESENT(kstart)      ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 
     818         IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 
    774819         ELSE 
    775             IF(           idom == jpdom_unknown ) THEN                                       ; icnt(1:idmspc) = idimsz(1:idmspc) 
     820            IF(           idom == jpdom_unknown ) THEN                                                ; icnt(1:idmspc) = idimsz(1:idmspc) 
    776821            ELSE  
    777822               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array 
    … …  
    796841                  ENDIF 
    797842                  IF( PRESENT(pv_r3d) ) THEN 
    798                      IF( idom == jpdom_data ) THEN   ; icnt(3) = jpkdta 
    799                      ELSE                            ; icnt(3) = jpk 
     843                     IF( idom == jpdom_data ) THEN                                  ; icnt(3) = jpkdta 
     844                     ELSE IF( ll_depth_spec .AND. PRESENT(kstart) ) THEN            ; istart(3) = kstart(3); icnt(3) = kcount(3) 
     845                     ELSE                                                           ; icnt(3) = jpk 
    800846                     ENDIF 
    801847                  ENDIF 
    … …  
    9881034   !!---------------------------------------------------------------------- 
    9891035   SUBROUTINE iom_g0d_intatt( kiomid, cdatt, pvar ) 
    990       INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
     1036      INTEGER         , INTENT(in   )                 ::   kiomid    !Identifier of the file 
    9911037      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute 
    9921038      INTEGER         , INTENT(  out)                 ::   pvar      ! read field 
    … …  
    11041150      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    11051151      REAL(wp)        , INTENT(in) ::   pfield0d 
     1152#if ! defined key_xios2 
    11061153      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1154#endif 
    11071155#if defined key_iomput 
     1156#if ! defined key_xios2 
    11081157      zz(:,:)=pfield0d 
    11091158      CALL xios_send_field(cdname, zz) 
    1110       !CALL xios_send_field(cdname, (/pfield0d/))  
     1159#else 
     1160      CALL xios_send_field(cdname, (/pfield0d/))  
     1161#endif 
    11111162#else 
    11121163      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    … …  
    11561207      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    11571208      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    1158       LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    1159  
     1209#if ! defined key_xios2 
     1210     LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
     1211#else 
     1212      LOGICAL,  DIMENSION(:) , OPTIONAL, INTENT(in) ::   mask 
     1213#endif 
     1214 
     1215#if ! defined key_xios2 
    11601216      IF ( xios_is_valid_domain     (cdid) ) THEN 
    11611217         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11641220            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
    11651221            &    bounds_lat=bounds_lat, area=area ) 
    1166       ENDIF 
    1167  
     1222     ENDIF 
    11681223      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    11691224         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11731228            &    bounds_lat=bounds_lat, area=area ) 
    11741229      ENDIF 
     1230 
     1231#else 
     1232      IF ( xios_is_valid_domain     (cdid) ) THEN 
     1233         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1234            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1235            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1236            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 
     1237     ENDIF 
     1238      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
     1239         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1240            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1241            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1242            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 
     1243      ENDIF 
     1244#endif 
    11751245      CALL xios_solve_inheritance() 
    11761246 
    11771247   END SUBROUTINE iom_set_domain_attr 
     1248 
     1249#if defined key_xios2 
     1250  SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 
     1251     CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1252     INTEGER                  , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj 
     1253 
     1254     IF ( xios_is_valid_zoom_domain     (cdid) ) THEN 
     1255         CALL xios_set_zoom_domain_attr     ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni,    & 
     1256           &   nj=nj) 
     1257    ENDIF 
     1258  END SUBROUTINE iom_set_zoom_domain_attr 
     1259#endif 
    11781260 
    11791261 
    … …  
    11831265      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
    11841266      IF ( PRESENT(paxis) ) THEN 
     1267#if ! defined key_xios2 
    11851268         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
    11861269         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1270#else 
     1271         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1272         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1273#endif 
    11871274      ENDIF 
    11881275      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    … …  
    11911278   END SUBROUTINE iom_set_axis_attr 
    11921279 
    1193  
    11941280   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 
    11951281      CHARACTER(LEN=*)          , INTENT(in) ::   cdid 
    1196       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op 
    1197       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset 
    1198       IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    1199       IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1282#if ! defined key_xios2 
     1283      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_op 
     1284      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_offset 
     1285#else 
     1286      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_op 
     1287      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_offset 
     1288#endif 
     1289      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr       & 
     1290    &     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1291      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr  & 
     1292    &                    ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    12001293      CALL xios_solve_inheritance() 
    12011294   END SUBROUTINE iom_set_field_attr 
    1202  
    12031295 
    12041296   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 
    … …  
    12131305   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 
    12141306      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid 
    1215       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq 
     1307      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix 
     1308#if ! defined key_xios2 
     1309      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::    output_freq 
     1310#else 
     1311      TYPE(xios_duration)   ,OPTIONAL , INTENT(out) :: output_freq 
     1312#endif   
    12161313      LOGICAL                                 ::   llexist1,llexist2,llexist3 
    12171314      !--------------------------------------------------------------------- 
    12181315      IF( PRESENT( name        ) )   name = ''          ! default values 
    12191316      IF( PRESENT( name_suffix ) )   name_suffix = '' 
     1317#if ! defined key_xios2 
    12201318      IF( PRESENT( output_freq ) )   output_freq = '' 
     1319#else 
     1320      IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0) 
     1321#endif 
    12211322      IF ( xios_is_valid_file     (cdid) ) THEN 
    12221323         CALL xios_solve_inheritance() 
    … …  
    12391340      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    12401341      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask 
     1342#if ! defined key_xios2 
    12411343      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask ) 
    12421344      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask ) 
     1345#else 
     1346      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask ) 
     1347      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 
     1348#endif 
    12431349      CALL xios_solve_inheritance() 
    12441350   END SUBROUTINE iom_set_grid_attr 
    … …  
    12821388      ni=nlei-nldi+1 ; nj=nlej-nldj+1 
    12831389 
    1284       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) 
     1390#if ! defined key_xios2 
     1391     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) 
     1392#else 
     1393     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) 
     1394#endif      
    12851395      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    12861396      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    … …  
    12961406         END SELECT 
    12971407         ! 
     1408#if ! defined key_xios2 
    12981409         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. ) 
     1410#else 
     1411         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. ) 
     1412#endif   
    12991413         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 
    13001414      ENDIF 
    … …  
    14301544      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
    14311545 
     1546      CALL dom_ngb( -168.7, 65.6, ix, iy, 'T' ) !  i-line that passes across Bering strait to avoid land processor (used in plots) 
     1547#if ! defined key_xios2 
    14321548      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    14331549      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    … …  
    14351551         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    14361552      ! 
    1437       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    14381553      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1554#else 
     1555! Pas teste : attention aux indices ! 
     1556      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1557      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1558      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1559         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1560       CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
     1561#endif 
     1562 
    14391563      CALL iom_update_file_name('ptr') 
    14401564      ! 
    … …  
    14501574      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    14511575      !!---------------------------------------------------------------------- 
     1576#if ! defined key_xios2 
    14521577      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
     1578#else 
     1579      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 
     1580#endif 
    14531581      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
    14541582       
    14551583      zz=REAL(narea,wp) 
    14561584      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1457  
     1585       
    14581586   END SUBROUTINE set_scalar 
     1587 
     1588   SUBROUTINE set_1point 
     1589      !!---------------------------------------------------------------------- 
     1590      !!                     ***  ROUTINE set_1point  *** 
     1591      !! 
     1592      !! ** Purpose :   define zoom grid for scalar fields 
     1593      !! 
     1594      !!---------------------------------------------------------------------- 
     1595      REAL(wp), DIMENSION(1)   ::   zz = 1. 
     1596      INTEGER  :: ix, iy 
     1597      !!---------------------------------------------------------------------- 
     1598      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  Nearest point to north pole should be ocean 
     1599      CALL iom_set_domain_attr('1point', zoom_ibegin=ix, zoom_jbegin=iy) 
     1600 
     1601   END SUBROUTINE set_1point 
     1602 
    14591603 
    14601604 
    … …  
    14791623      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings 
    14801624      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings 
     1625#if  defined key_xios2 
     1626      TYPE(xios_duration)            ::   f_op, f_of 
     1627#endif 
     1628  
    14811629      !!---------------------------------------------------------------------- 
    14821630      !  
    14831631      ! frequency of the call of iom_put (attribut: freq_op) 
    1484       WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 
    1485       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts') 
    1486       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op = cl1//'ts', freq_offset='0ts') 
    1487       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
    1488       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
     1632#if ! defined key_xios2 
     1633      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 
     1634      WRITE(cl1,'(i1)')        2   ;   CALL iom_set_field_attr('trendT_even'      , freq_op=cl1//'ts', freq_offset='0ts') 
     1635      WRITE(cl1,'(i1)')        2   ;   CALL iom_set_field_attr('trendT_odd'       , freq_op=cl1//'ts', freq_offset='-1ts') 
     1636      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op=cl1//'ts', freq_offset='0ts') 
     1637      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op=cl1//'ts', freq_offset='0ts') 
     1638      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1639      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1640#else 
     1641      f_op%timestep = 1        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 
     1642      f_op%timestep = 2        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('trendT_even'      , freq_op=f_op, freq_offset=f_of) 
     1643      f_op%timestep = 2        ;  f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd'       , freq_op=f_op, freq_offset=f_of) 
     1644      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of) 
     1645      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of) 
     1646      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of) 
     1647      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of) 
     1648#endif 
    14891649        
    14901650      ! output file names (attribut: name) 
    … …  
    15081668         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    15091669         CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
     1670#if ! defined key_xios2 
    15101671         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 
     1672#else 
     1673         CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 
     1674#endif 
    15111675         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    15121676         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 
    … …  
    15881752               ENDIF 
    15891753               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 
     1754#if ! defined key_xios2 
    15901755               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 
     1756#else 
     1757               CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 
     1758#endif 
    15911759               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         ) 
    15921760               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 
    … …  
    16171785      REAL(wp)           ::   zsec 
    16181786      LOGICAL            ::   llexist 
    1619       !!---------------------------------------------------------------------- 
     1787#if  defined key_xios2 
     1788      TYPE(xios_duration)   ::   output_freq  
     1789#endif       
     1790      !!---------------------------------------------------------------------- 
     1791 
    16201792 
    16211793      DO jn = 1,2 
    1622  
     1794#if ! defined key_xios2 
    16231795         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq ) 
     1796#else 
     1797         output_freq = xios_duration(0,0,0,0,0,0) 
     1798         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq ) 
     1799#endif 
    16241800         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname ) 
    16251801 
    … …  
    16321808            END DO 
    16331809 
     1810#if ! defined key_xios2 
    16341811            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16351812            DO WHILE ( idx /= 0 )  
    … …  
    16441821               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16451822            END DO 
    1646  
     1823#else 
     1824            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1825            DO WHILE ( idx /= 0 )  
     1826              IF ( output_freq%timestep /= 0) THEN 
     1827                  WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts'  
     1828                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1829              ELSE IF ( output_freq%hour /= 0 ) THEN 
     1830                  WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h'  
     1831                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1832              ELSE IF ( output_freq%day /= 0 ) THEN 
     1833                  WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d'  
     1834                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1835              ELSE IF ( output_freq%month /= 0 ) THEN    
     1836                  WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m'  
     1837                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1838              ELSE IF ( output_freq%year /= 0 ) THEN    
     1839                  WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y'  
     1840                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1841              ELSE 
     1842                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   & 
     1843                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 
     1844              ENDIF 
     1845              clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 
     1846              idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1847            END DO 
     1848#endif 
    16471849            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 
    16481850            DO WHILE ( idx /= 0 )  
    … …  
    16731875            END DO 
    16741876 
     1877            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    16751878            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    16761879            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    17201923      ENDIF 
    17211924       
     1925!$AGRIF_DO_NOT_TREAT       
     1926! Should be fixed in the conv 
    17221927      IF( llfull ) THEN  
    17231928         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 
    … …  
    17301935         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run 
    17311936      ENDIF 
     1937!$AGRIF_END_DO_NOT_TREAT       
    17321938 
    17331939   END FUNCTION iom_sdate 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/IOM/iom_def.F90

    r7960 r9987  
    2626   INTEGER, PARAMETER, PUBLIC ::   jpdom_unknown       = 7   !: No dimension checking 
    2727   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo       = 8   !:  
    28    INTEGER, PARAMETER, PUBLIC ::   jpdom_autodta       = 9   !:  
     28   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo_xy    = 9   !: Automatically set horizontal dimensions only 
     29   INTEGER, PARAMETER, PUBLIC ::   jpdom_autodta       = 10  !:  
    2930 
    3031   INTEGER, PARAMETER, PUBLIC ::   jpioipsl    = 100      !: Use ioipsl (fliocom only) library 
    … …  
    5758      INTEGER                                   ::   nvars    !: number of identified varibles in the file 
    5859      INTEGER                                   ::   iduld    !: id of the unlimited dimension 
     60      INTEGER                                   ::   lenuld   !: length of the unlimited dimension (number of records in file) 
    5961      INTEGER                                   ::   irec     !: writing record position   
    6062      CHARACTER(LEN=32)                         ::   uldname  !: name of the unlimited dimension 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r7960 r9987  
    154154         CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) 
    155155         IF ( iom_file(kiomid)%iduld .GE. 0 ) THEN 
    156            CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld,   & 
    157         &                                               name = iom_file(kiomid)%uldname), clinfo) 
     156           CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld,     &  
     157        &                                               name = iom_file(kiomid)%uldname,  & 
     158        &                                               len  = iom_file(kiomid)%lenuld ), clinfo ) 
    158159         ENDIF 
    159160         IF(lwp) WRITE(numout,*) '                   ---> '//TRIM(cdname)//' OK' 

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

    r7960 r9987  
    2121   USE in_out_manager  ! I/O manager 
    2222   USE iom             ! I/O module 
     23   USE ioipsl, ONLY : ju2ymds    ! for calendar 
    2324   USE eosbn2          ! equation of state            (eos bn2 routine) 
    2425   USE trdmxl_oce      ! ocean active mixed layer tracers trends variables 
    2526   USE divcur          ! hor. divergence and curl      (div & cur routines) 
     27   USE sbc_oce         ! for icesheet freshwater input variables 
    2628 
    2729   IMPLICIT NONE 
    … …  
    5456      !!---------------------------------------------------------------------- 
    5557      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
     58      INTEGER             ::   iyear, imonth, iday 
     59      REAL (wp)           ::   zsec 
     60      REAL (wp)           ::   zfjulday 
    5661      !! 
    5762      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character 
    5863      CHARACTER(LEN=50)   ::   clname   ! ocean output restart file name 
    59       CHARACTER(lc)       ::   clpath   ! full path to ocean output restart file 
     64      CHARACTER(LEN=150)  ::   clpath   ! full path to ocean output restart file 
    6065      !!---------------------------------------------------------------------- 
    6166      ! 
    … …  
    8186      IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 
    8287         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN  
    83             ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    84             IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
    85             ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
     88            IF ( ln_rstdate ) THEN 
     89               zfjulday = fjulday + rdttra(1) / rday 
     90               IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday )   zfjulday = REAL(NINT(zfjulday),wp)   ! avoid truncation error 
     91               CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec )            
     92               WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday 
     93            ELSE 
     94               ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
     95               IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
     96               ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
     97               ENDIF 
    8698            ENDIF 
    8799            ! create the file 
    … …  
    145157                     CALL iom_rstput( kt, nitrst, numrow, 'rhd'    , rhd       ) 
    146158#endif 
     159                     IF( lk_oasis) THEN 
     160                     ! nn_coupled_iceshelf_fluxes uninitialised unless lk_oasis=true 
     161                     IF( nn_coupled_iceshelf_fluxes .eq. 1 ) THEN 
     162                        CALL iom_rstput( kt, nitrst, numrow, 'greenland_icesheet_mass', greenland_icesheet_mass ) 
     163                        CALL iom_rstput( kt, nitrst, numrow, 'greenland_icesheet_timelapsed', greenland_icesheet_timelapsed ) 
     164                        CALL iom_rstput( kt, nitrst, numrow, 'greenland_icesheet_mass_roc', greenland_icesheet_mass_rate_of_change ) 
     165                        CALL iom_rstput( kt, nitrst, numrow, 'antarctica_icesheet_mass', antarctica_icesheet_mass ) 
     166                        CALL iom_rstput( kt, nitrst, numrow, 'antarctica_icesheet_timelapsed', antarctica_icesheet_timelapsed ) 
     167                        CALL iom_rstput( kt, nitrst, numrow, 'antarctica_icesheet_mass_roc', antarctica_icesheet_mass_rate_of_change ) 
     168                     ENDIF 
     169                     ENDIF 
     170 
    147171      IF( kt == nitrst ) THEN 
    148172         CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    … …  
    258282#endif 
    259283      ! 
     284      IF( iom_varid( numror, 'greenland_icesheet_mass', ldstop = .FALSE. ) > 0 )   THEN 
     285         CALL iom_get( numror, 'greenland_icesheet_mass', greenland_icesheet_mass ) 
     286         CALL iom_get( numror, 'greenland_icesheet_timelapsed', greenland_icesheet_timelapsed ) 
     287         CALL iom_get( numror, 'greenland_icesheet_mass_roc', greenland_icesheet_mass_rate_of_change ) 
     288      ELSE 
     289         greenland_icesheet_mass = 0.0  
     290         greenland_icesheet_mass_rate_of_change = 0.0  
     291         greenland_icesheet_timelapsed = 0.0 
     292      ENDIF 
     293      IF( iom_varid( numror, 'antarctica_icesheet_mass', ldstop = .FALSE. ) > 0 )   THEN 
     294         CALL iom_get( numror, 'antarctica_icesheet_mass', antarctica_icesheet_mass ) 
     295         CALL iom_get( numror, 'antarctica_icesheet_timelapsed', antarctica_icesheet_timelapsed ) 
     296         CALL iom_get( numror, 'antarctica_icesheet_mass_roc', antarctica_icesheet_mass_rate_of_change ) 
     297      ELSE 
     298         antarctica_icesheet_mass = 0.0  
     299         antarctica_icesheet_mass_rate_of_change = 0.0  
     300         antarctica_icesheet_timelapsed = 0.0 
     301      ENDIF 
     302 
    260303      IF( neuler == 0 ) THEN                                  ! Euler restart (neuler=0) 
    261304         tsb  (:,:,:,:) = tsn  (:,:,:,:)                             ! all before fields set to now values 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7960 r9987  
    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 
    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 ) 
    … …  
    16811699   END SUBROUTINE mppmax_real 
    16821700 
     1701   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1702      !!---------------------------------------------------------------------- 
     1703      !!                  ***  routine mppmax_real  *** 
     1704      !! 
     1705      !! ** Purpose :   Maximum 
     1706      !! 
     1707      !!---------------------------------------------------------------------- 
     1708      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1709      INTEGER , INTENT(in   )           ::   NUM 
     1710      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1711      !! 
     1712      INTEGER  ::   ierror, localcomm 
     1713      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1714      !!---------------------------------------------------------------------- 
     1715      ! 
     1716      CALL wrk_alloc(NUM , zwork) 
     1717      localcomm = mpi_comm_opa 
     1718      IF( PRESENT(kcom) )   localcomm = kcom 
     1719      ! 
     1720      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1721      ptab = zwork 
     1722      CALL wrk_dealloc(NUM , zwork) 
     1723      ! 
     1724   END SUBROUTINE mppmax_real_multiple 
     1725 
    16831726 
    16841727   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    … …  
    20062049 
    20072050   SUBROUTINE mppstop 
     2051    
     2052#if defined key_oasis3 
     2053   USE mod_oasis      ! coupling routines 
     2054#endif 
     2055 
    20082056      !!---------------------------------------------------------------------- 
    20092057      !!                  ***  routine mppstop  *** 
    … …  
    20152063      !!---------------------------------------------------------------------- 
    20162064      ! 
     2065       
     2066#if defined key_oasis3 
     2067      ! If we're trying to shut down cleanly then we need to consider the fact 
     2068      ! that this could be part of an MPMD configuration - we don't want to 
     2069      ! leave other components deadlocked. 
     2070 
     2071      CALL oasis_abort(nproc,"mppstop","NEMO initiated abort") 
     2072 
     2073 
     2074#else 
     2075       
    20172076      CALL mppsync 
    20182077      CALL mpi_finalize( info ) 
     2078#endif 
     2079 
    20192080      ! 
    20202081   END SUBROUTINE mppstop 
    … …  
    25752636   END SUBROUTINE mpp_lbc_north_2d 
    25762637 
     2638   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2639      !!--------------------------------------------------------------------- 
     2640      !!                   ***  routine mpp_lbc_north_2d  *** 
     2641      !! 
     2642      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2643      !!              in mpp configuration in case of jpn1 > 1 
     2644      !!              (for multiple 2d arrays ) 
     2645      !! 
     2646      !! ** Method  :   North fold condition and mpp with more than one proc 
     2647      !!              in i-direction require a specific treatment. We gather 
     2648      !!              the 4 northern lines of the global domain on 1 processor 
     2649      !!              and apply lbc north-fold on this sub array. Then we 
     2650      !!              scatter the north fold array back to the processors. 
     2651      !! 
     2652      !!---------------------------------------------------------------------- 
     2653      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2654      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2655      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2656      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2657      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2658      !!                                                             ! =  1. , the sign is kept 
     2659      INTEGER ::   ji, jj, jr, jk 
     2660      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2661      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2662      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2663      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2664      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2665      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2666      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2667      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2668      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2669      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2670      INTEGER :: istatus(mpi_status_size) 
     2671      INTEGER :: iflag 
     2672      !!---------------------------------------------------------------------- 
     2673      ! 
     2674      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   &  
     2675            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2676      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2677      ! 
     2678      ijpj   = 4 
     2679      ijpjm1 = 3 
     2680      ! 
     2681       
     2682      DO jk = 1, num_fields 
     2683         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2684            ij = jj - nlcj + ijpj 
     2685            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2686         END DO 
     2687      END DO 
     2688      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2689      itaille = jpi * ijpj 
     2690                                                                   
     2691      IF ( l_north_nogather ) THEN 
     2692         ! 
     2693         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2694         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2695         ! 
     2696         ztabr(:,:,:) = 0 
     2697         ztabl(:,:,:) = 0 
     2698 
     2699         DO jk = 1, num_fields 
     2700            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2701               ij = jj - nlcj + ijpj 
     2702               DO ji = nfsloop, nfeloop 
     2703                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2704               END DO 
     2705            END DO 
     2706         END DO 
     2707 
     2708         DO jr = 1,nsndto 
     2709            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2710               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2711            ENDIF 
     2712         END DO 
     2713         DO jr = 1,nsndto 
     2714            iproc = nfipproc(isendto(jr),jpnj) 
     2715            IF(iproc .ne. -1) THEN 
     2716               ilei = nleit (iproc+1) 
     2717               ildi = nldit (iproc+1) 
     2718               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2719            ENDIF 
     2720            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2721              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2722              DO jk = 1 , num_fields 
     2723                 DO jj = 1, ijpj 
     2724                    DO ji = ildi, ilei 
     2725                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2726                    END DO 
     2727                 END DO 
     2728              END DO 
     2729            ELSE IF (iproc .eq. (narea-1)) THEN 
     2730              DO jk = 1, num_fields 
     2731                 DO jj = 1, ijpj 
     2732                    DO ji = ildi, ilei 
     2733                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2734                    END DO 
     2735                 END DO 
     2736              END DO 
     2737            ENDIF 
     2738         END DO 
     2739         IF (l_isend) THEN 
     2740            DO jr = 1,nsndto 
     2741               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2742                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2743               ENDIF 
     2744            END DO 
     2745         ENDIF 
     2746         ! 
     2747         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2748            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2749         END DO 
     2750         ! 
     2751         DO jk = 1, num_fields 
     2752            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2753               ij = jj - nlcj + ijpj 
     2754               DO ji = 1, nlci 
     2755                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2756               END DO 
     2757            END DO 
     2758         END DO 
     2759          
     2760         ! 
     2761      ELSE 
     2762         ! 
     2763         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2764            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2765         ! 
     2766         ztab(:,:,:) = 0.e0 
     2767         DO jk = 1, num_fields 
     2768            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2769               iproc = nrank_north(jr) + 1 
     2770               ildi = nldit (iproc) 
     2771               ilei = nleit (iproc) 
     2772               iilb = nimppt(iproc) 
     2773               DO jj = 1, ijpj 
     2774                  DO ji = ildi, ilei 
     2775                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2776                  END DO 
     2777               END DO 
     2778            END DO 
     2779         END DO 
     2780          
     2781         DO ji = 1, num_fields 
     2782            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2783         END DO 
     2784         ! 
     2785         DO jk = 1, num_fields 
     2786            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2787               ij = jj - nlcj + ijpj 
     2788               DO ji = 1, nlci 
     2789                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2790               END DO 
     2791            END DO 
     2792         END DO 
     2793         ! 
     2794         ! 
     2795      ENDIF 
     2796      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2797      DEALLOCATE( ztabl, ztabr ) 
     2798      ! 
     2799   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25772800 
    25782801   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    … …  
    36803903      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    36813904      ! 
     3905      IF( cd1 == 'MPPSTOP' ) THEN 
     3906         IF(lwp) WRITE(numout,*)  'E R R O R: Calling mppstop' 
     3907         CALL mppstop() 
     3908      ENDIF 
    36823909      IF( cd1 == 'STOP' ) THEN 
    36833910         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    … …  
    37844011            WRITE(kout,*) 
    37854012         ENDIF 
    3786          STOP 'ctl_opn bad opening' 
     4013         CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening') 
    37874014      ENDIF 
    37884015 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r7960 r9987  
    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 
    … …  
    304263         nlejt(jn) = nlej 
    305264      END DO 
    306        
    307  
    308       ! 4. From global to local 
     265 
     266      ! 4. Subdomain print 
     267      ! ------------------ 
     268       
     269      IF(lwp) WRITE(numout,*) 
     270      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     271      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     272      IF(lwp) WRITE(numout,*) 
     273      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     274      IF(lwp) WRITE(numout,*) 
     275      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     276      zidom = nreci 
     277      DO ji = 1, jpni 
     278         zidom = zidom + ilcit(ji,1) - nreci 
     279      END DO 
     280      IF(lwp) WRITE(numout,*) 
     281      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     282 
     283      zjdom = nrecj 
     284      DO jj = 1, jpnj 
     285         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     286      END DO 
     287      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     288      IF(lwp) WRITE(numout,*) 
     289 
     290      IF(lwp) THEN 
     291         ifreq = 4 
     292         il1   = 1 
     293         DO jn = 1, (jpni-1)/ifreq+1 
     294            il2 = MIN( jpni, il1+ifreq-1 ) 
     295            WRITE(numout,*) 
     296            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     297            DO jj = jpnj, 1, -1 
     298               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     299               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     300               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     301               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     302               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     303            END DO 
     304            WRITE(numout,9201) (ji,ji = il1,il2) 
     305            il1 = il1+ifreq 
     306         END DO 
     307 9200     FORMAT('     ***',20('*************',a3)) 
     308 9203     FORMAT('     *     ',20('         *   ',a3)) 
     309 9201     FORMAT('        ',20('   ',i3,'          ')) 
     310 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     311 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     312      ENDIF 
     313 
     314      ! 5. From global to local 
    309315      ! ----------------------- 
    310316 
    … …  
    313319 
    314320 
    315       ! 5. Subdomain neighbours 
     321      ! 6. Subdomain neighbours 
    316322      ! ---------------------- 
    317323 
    … …  
    436442         WRITE(numout,*) ' nimpp  = ', nimpp 
    437443         WRITE(numout,*) ' njmpp  = ', njmpp 
    438          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    439          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    440          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    441          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     444         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     445         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     446         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     447         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     448         WRITE(numout,*) 
    442449      ENDIF 
    443450 
    … …  
    446453      ! Prepare mpp north fold 
    447454 
    448       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     455      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    449456         CALL mpp_ini_north 
    450       END IF 
     457         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     458      ENDIF 
    451459 
    452460      ! Prepare NetCDF output file (if necessary) 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r7960 r9987  
    318318         ENDIF 
    319319 
     320         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    320321         isurf = 0 
    321          DO jj = 1+jprecj, ilj-jprecj 
    322             DO  ji = 1+jpreci, ili-jpreci 
     322         DO jj = 1, ilj 
     323            DO  ji = 1, ili 
    323324               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 
    324325            END DO 
    325326         END DO 
     327 
    326328         IF(isurf /= 0) THEN 
    327329            icont = icont + 1 
    … …  
    333335 
    334336      nfipproc(:,:) = ipproc(:,:) 
    335  
    336337 
    337338      ! Control 
    … …  
    441442      ii = iin(narea) 
    442443      ij = ijn(narea) 
     444 
     445      ! set default neighbours 
     446      noso = ioso(ii,ij) 
     447      nowe = iowe(ii,ij) 
     448      noea = ioea(ii,ij) 
     449      nono = iono(ii,ij)  
     450      npse = iose(ii,ij) 
     451      npsw = iosw(ii,ij) 
     452      npne = ione(ii,ij) 
     453      npnw = ionw(ii,ij) 
     454 
     455      ! check neighbours location 
    443456      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    444457         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    511524      IF (lwp) THEN 
    512525         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     526         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    513527         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    514528         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    523537      END IF 
    524538 
    525       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    526  
    527       ! Prepare mpp north fold 
    528  
    529       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    530          CALL mpp_ini_north 
    531          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    532       ENDIF 
    533  
    534539      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    535540      ! In this case the important thing is that npolj /= 0 
    … …  
    548553      ENDIF 
    549554 
     555      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     556 
     557      IF(lwp) THEN 
     558         WRITE(numout,*) ' nproc  = ', nproc 
     559         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     560         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     561         WRITE(numout,*) ' nbondi = ', nbondi 
     562         WRITE(numout,*) ' nbondj = ', nbondj 
     563         WRITE(numout,*) ' npolj  = ', npolj 
     564         WRITE(numout,*) ' nperio = ', nperio 
     565         WRITE(numout,*) ' nlci   = ', nlci 
     566         WRITE(numout,*) ' nlcj   = ', nlcj 
     567         WRITE(numout,*) ' nimpp  = ', nimpp 
     568         WRITE(numout,*) ' njmpp  = ', njmpp 
     569         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     570         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     571         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     572         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     573         WRITE(numout,*) 
     574      ENDIF 
     575 
     576      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     577 
     578      ! Prepare mpp north fold 
     579 
     580      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     581         CALL mpp_ini_north 
     582         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     583      ENDIF 
     584 
    550585      ! Prepare NetCDF output file (if necessary) 
    551586      CALL mpp_init_ioipsl 
    552587 
    553       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    554  
    555       IF(lwp) THEN 
    556          WRITE(numout,*) ' nproc=  ',nproc 
    557          WRITE(numout,*) ' nowe=   ',nowe 
    558          WRITE(numout,*) ' noea=   ',noea 
    559          WRITE(numout,*) ' nono=   ',nono 
    560          WRITE(numout,*) ' noso=   ',noso 
    561          WRITE(numout,*) ' nbondi= ',nbondi 
    562          WRITE(numout,*) ' nbondj= ',nbondj 
    563          WRITE(numout,*) ' npolj=  ',npolj 
    564          WRITE(numout,*) ' nperio= ',nperio 
    565          WRITE(numout,*) ' nlci=   ',nlci 
    566          WRITE(numout,*) ' nlcj=   ',nlcj 
    567          WRITE(numout,*) ' nimpp=  ',nimpp 
    568          WRITE(numout,*) ' njmpp=  ',njmpp 
    569          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    570          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    571          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    572          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    573       ENDIF 
    574588 
    575589   END SUBROUTINE mpp_init2 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

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

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r7960 r9987  
    3131   USE in_out_manager               ! I/O manager 
    3232   USE lbclnk                       ! ocean lateral boundary conditions (or mpp link) 
    33  
     33    
    3434   IMPLICIT NONE 
    3535   PRIVATE 
    … …  
    4141   PUBLIC   cpl_freq 
    4242   PUBLIC   cpl_finalize 
     43#if defined key_mpp_mpi 
     44   INCLUDE 'mpif.h' 
     45#endif 
     46    
     47   INTEGER, PARAMETER         :: localRoot  = 0 
     48   LOGICAL                    :: commRank            ! true for ranks doing OASIS communication 
     49#if defined key_cpl_rootexchg 
     50   LOGICAL                    :: rootexchg =.true.   ! logical switch  
     51#else 
     52   LOGICAL                    :: rootexchg =.false.  ! logical switch  
     53#endif  
    4354 
    4455   INTEGER, PUBLIC            ::   OASIS_Rcv  = 1    !: return code if received field 
    … …  
    8293 
    8394   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   exfld   ! Temporary buffer for receiving 
    84  
     95   INTEGER, PUBLIC :: localComm  
     96       
    8597   !!---------------------------------------------------------------------- 
    8698   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    120132      IF ( nerror /= OASIS_Ok ) & 
    121133         CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' ) 
     134      localComm = kl_comm  
    122135      ! 
    123136   END SUBROUTINE cpl_init 
    … …  
    177190      IF( nerror > 0 ) THEN 
    178191         CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld')   ;   RETURN 
    179       ENDIF 
     192      ENDIF       
    180193      ! 
    181194      ! ----------------------------------------------------------------- 
    182195      ! ... Define the partition  
    183196      ! ----------------------------------------------------------------- 
    184        
     197             
    185198      paral(1) = 2                                              ! box partitioning 
    186199      paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1)   ! NEMO lower left corner global offset     
    … …  
    196209      ENDIF 
    197210       
    198       CALL oasis_def_partition ( id_part, paral, nerror ) 
     211      CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo) 
    199212      ! 
    200213      ! ... Announce send variables.  
    … …  
    241254            END DO 
    242255         ENDIF 
    243       END DO 
     256      END DO       
    244257      ! 
    245258      ! ... Announce received variables.  
    … …  
    373386            IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN 
    374387 
    375                CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo )          
     388               CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo )    
    376389                
    377390               llaction =  kinfo == OASIS_Recvd   .OR. kinfo == OASIS_FromRest .OR.   & 
    … …  
    384397                  kinfo = OASIS_Rcv 
    385398                  IF( llfisrt ) THEN  
    386                      pdata(nldi:nlei,nldj:nlej,jc) =                                 exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 
     399                     pdata(nldi:nlei,nldj:nlej,jc) =                                 exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)  
    387400                     llfisrt = .FALSE. 
    388401                  ELSE 
    … …  
    463476         CALL oasis_get_freqs(id, mop, 1, itmp, info) 
    464477#else 
     478#if defined key_oasis3  
     479         itmp(1) = namflddti( id ) 
     480#else 
    465481         CALL oasis_get_freqs(id,      1, itmp, info) 
     482#endif 
    466483#endif 
    467484         cpl_freq = itmp(1) 
    … …  
    514531   END SUBROUTINE oasis_get_localcomm 
    515532 
    516    SUBROUTINE oasis_def_partition(k1,k2,k3) 
     533   SUBROUTINE oasis_def_partition(k1,k2,k3,K4) 
    517534      INTEGER     , INTENT(  out) ::  k1,k3 
    518535      INTEGER     , INTENT(in   ) ::  k2(5) 
     536      INTEGER     , OPTIONAL, INTENT(in   ) ::  k4 
    519537      k1 = k2(1) ; k3 = k2(5) 
    520538      WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...' 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/geo2ocean.F90

    r7960 r9987  
    5151 
    5252   SUBROUTINE repcmo ( pxu1, pyu1, pxv1, pyv1,   & 
    53                        px2 , py2 ) 
     53                       px2 , py2 , kchoix  ) 
    5454      !!---------------------------------------------------------------------- 
    5555      !!                  ***  ROUTINE repcmo  *** 
    … …  
    6868      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   py2          ! j-componante (defined at v-point) 
    6969      !!---------------------------------------------------------------------- 
    70        
    71       ! Change from geographic to stretched coordinate 
    72       ! ---------------------------------------------- 
    73       CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 ) 
    74       CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 ) 
    75        
     70      INTEGER, INTENT( IN ) ::   & 
     71         kchoix   ! type of transformation 
     72                  ! = 1 change from geographic to model grid. 
     73                  ! =-1 change from model to geographic grid 
     74      !!---------------------------------------------------------------------- 
     75  
     76      SELECT CASE (kchoix) 
     77      CASE ( 1) 
     78        ! Change from geographic to stretched coordinate 
     79        ! ---------------------------------------------- 
     80      
     81        CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 ) 
     82        CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 ) 
     83      CASE (-1) 
     84       ! Change from stretched to geographic coordinate 
     85       ! ---------------------------------------------- 
     86      
     87       CALL rot_rep( pxu1, pyu1, 'U', 'ij->e',px2 ) 
     88       CALL rot_rep( pxv1, pyv1, 'V', 'ij->n',py2 ) 
     89     END SELECT 
     90      
    7691   END SUBROUTINE repcmo 
    7792 

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

    r7960 r9987  
    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 
    … …  
    101102   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr_iu              !: ice fraction at NEMO U point 
    102103   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr_iv              !: ice fraction at NEMO V point 
    103     
     104   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sstfrz             !: sea surface freezing temperature 
     105   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tsfc_ice           !: sea-ice surface skin temperature (on categories) 
     106   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   kn_ice             !: sea-ice surface layer thermal conductivity (on cats) 
     107 
    104108   ! variables used in the coupled interface 
    105109   INTEGER , PUBLIC, PARAMETER ::   jpl = ncat 
    106110   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice          ! jpi, jpj 
     111   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  a_p, ht_p ! Meltpond fraction and depth 
     112    
     113   ! 
     114    
     115   ! 
     116#if defined key_asminc 
     117   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ndaice_da          !: NEMO fresh water flux to ocean due to data assim 
     118   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nfresh_da          !: NEMO salt flux to ocean due to data assim 
     119   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nfsalt_da          !: NEMO ice concentration change/second from data assim 
     120#endif 
     121       
    107122#endif 
    108123    
    … …  
    144159#endif 
    145160#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)  ,  & 
     161         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
     162         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
     163         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    149164#endif 
    150165         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 
    … …  
    152167 
    153168#if defined key_cice 
    154       ALLOCATE( qla_ice(jpi,jpj,1)    , qlw_ice(jpi,jpj,1)    , qsr_ice(jpi,jpj,1)    , & 
     169      ALLOCATE( qla_ice(jpi,jpj,ncat) , qlw_ice(jpi,jpj,1)    , qsr_ice(jpi,jpj,1)    , & 
    155170                wndi_ice(jpi,jpj)     , tatm_ice(jpi,jpj)     , qatm_ice(jpi,jpj)     , & 
    156171                wndj_ice(jpi,jpj)     , nfrzmlt(jpi,jpj)      , ss_iou(jpi,jpj)       , & 
    157172                ss_iov(jpi,jpj)       , fr_iu(jpi,jpj)        , fr_iv(jpi,jpj)        , & 
    158173                a_i(jpi,jpj,ncat)     , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 
    159                 STAT= ierr(1) ) 
    160       IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
     174#if defined key_asminc 
     175                ndaice_da(jpi,jpj)    , nfresh_da(jpi,jpj)    , nfsalt_da(jpi,jpj)    , & 
     176#endif 
     177                sstfrz(jpi,jpj)       , STAT= ierr(1) ) 
     178   ! Alex West: Allocating tn_ice with 5 categories.  When NEMO is used with CICE, this variable 
     179   ! represents top layer ice temperature, which is multi-category. 
     180      IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,jpl)  , & 
    161181         &                     v_ice(jpi,jpj)        , fr2_i0(jpi,jpj)       , alb_ice(jpi,jpj,1)    , & 
    162182         &                     emp_ice(jpi,jpj)      , qns_ice(jpi,jpj,1)    , dqns_ice(jpi,jpj,1)   , & 
    163          &                     STAT= ierr(2) ) 
     183         &                     a_p(jpi,jpj,jpl)      , ht_p(jpi,jpj,jpl)     , tsfc_ice(jpi,jpj,jpl) , & 
     184         &                     kn_ice(jpi,jpj,jpl) ,    STAT=ierr(2) ) 
    164185       
    165186#endif 

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

    r7960 r9987  
    125125#endif 
    126126   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask          !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 
     127   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   greenland_icesheet_mass_array, greenland_icesheet_mask 
     128   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   antarctica_icesheet_mass_array, antarctica_icesheet_mask 
    127129 
    128130   !!---------------------------------------------------------------------- 
    … …  
    137139   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3t_m     !: mean (nn_fsbc time-step) sea surface layer thickness       [m] 
    138140   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frq_m     !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] 
     141    
     142   !!---------------------------------------------------------------------- 
     143   !!  Surface scalars of total ice sheet mass for Greenland and Antarctica,  
     144   !! passed from atmosphere to be converted to dvol and hence a freshwater  
     145   !! flux  by using old values. New values are saved in the dump, to become 
     146   !! old values next coupling timestep. Freshwater fluxes split between  
     147   !! sub iceshelf melting and iceberg calving, scalled to flux per second 
     148   !!---------------------------------------------------------------------- 
     149    
     150   REAL(wp), PUBLIC  :: greenland_icesheet_mass, greenland_icesheet_mass_rate_of_change, greenland_icesheet_timelapsed  
     151   REAL(wp), PUBLIC  :: antarctica_icesheet_mass, antarctica_icesheet_mass_rate_of_change, antarctica_icesheet_timelapsed 
     152 
     153   ! sbccpl namelist parameters associated with icesheet freshwater input code. Included here rather than in sbccpl.F90 to  
     154   ! avoid circular dependencies. 
     155   INTEGER, PUBLIC     ::   nn_coupled_iceshelf_fluxes     ! =0 : total freshwater input from iceberg calving and ice shelf basal melting  
     156                                                           ! taken from climatologies used (no action in coupling routines). 
     157                                                           ! =1 :  use rate of change of mass of Greenland and Antarctic icesheets to set the  
     158                                                           ! combined magnitude of the iceberg calving and iceshelf melting freshwater fluxes. 
     159                                                           ! =2 :  specify constant freshwater inputs in this namelist to set the combined 
     160                                                           ! magnitude of iceberg calving and iceshelf melting freshwater fluxes. 
     161   LOGICAL, PUBLIC     ::   ln_iceshelf_init_atmos         ! If true force ocean to initialise iceshelf masses from atmospheric values rather 
     162                                                           ! than values in ocean restart (applicable if nn_coupled_iceshelf_fluxes=1). 
     163   REAL(wp), PUBLIC    ::   rn_greenland_total_fw_flux    ! Constant total rate of freshwater input (kg/s) for Greenland (if nn_coupled_iceshelf_fluxes=2)  
     164   REAL(wp), PUBLIC    ::   rn_greenland_calving_fraction  ! Set fraction of total freshwater flux for iceberg calving - remainder goes to iceshelf melting. 
     165   REAL(wp), PUBLIC    ::   rn_antarctica_total_fw_flux   ! Constant total rate of freshwater input (kg/s) for Antarctica (if nn_coupled_iceshelf_fluxes=2)  
     166   REAL(wp), PUBLIC    ::   rn_antarctica_calving_fraction ! Set fraction of total freshwater flux for iceberg calving - remainder goes to iceshelf melting. 
     167   REAL(wp), PUBLIC    ::   rn_iceshelf_fluxes_tolerance   ! Absolute tolerance for detecting differences in icesheet masses.  
    139168 
    140169   !! * Substitutions 
    … …  
    172201         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) ,      & 
    173202         &      ssv_m  (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) 
     203      ALLOCATE( greenland_icesheet_mass_array(jpi,jpj) , antarctica_icesheet_mass_array(jpi,jpj) ) 
     204      ALLOCATE( greenland_icesheet_mask(jpi,jpj) , antarctica_icesheet_mask(jpi,jpj) ) 
    174205         ! 
    175206#if defined key_vvl 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r7960 r9987  
    9191   REAL(wp) ::   rn_zqt      ! z(q,t) : height of humidity and temperature measurements 
    9292   REAL(wp) ::   rn_zu       ! z(u)   : height of wind measurements 
     93   REAL(wp), PUBLIC :: rn_sfac ! multiplication factor for snow precipitation over sea-ice 
    9394 
    9495   !! * Substitutions 
    … …  
    151152         &                  sn_wndi, sn_wndj, sn_humi  , sn_qsr ,           & 
    152153         &                  sn_qlw , sn_tair, sn_prec  , sn_snow,           & 
    153          &                  sn_tdif, rn_zqt,  rn_zu 
     154         &                  sn_tdif, rn_zqt,  rn_zu, rn_sfac 
    154155      !!--------------------------------------------------------------------- 
    155156      ! 
    … …  
    158159         !                                      ! ====================== ! 
    159160         ! 
     161         rn_sfac = 1._wp       ! Default to one if missing from namelist  
    160162         REWIND( numnam_ref )              ! Namelist namsbc_core in reference namelist : CORE bulk parameters 
    161163         READ  ( numnam_ref, namsbc_core, IOSTAT = ios, ERR = 901) 
    … …  
    206208      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN 
    207209         qlw_ice(:,:,1)   = sf(jp_qlw)%fnow(:,:,1)  
    208          qsr_ice(:,:,1)   = sf(jp_qsr)%fnow(:,:,1) 
     210         IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) 
     211         ELSE                ; qsr_ice(:,:,1) =          sf(jp_qsr)%fnow(:,:,1) 
     212         ENDIF 
    209213         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)          
    210214         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1) 
    … …  
    403407         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
    404408         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     409         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
     410         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
     411         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
     412         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
    405413      ENDIF 
    406414      ! 
    … …  
    608616      ! --- evaporation --- ! 
    609617      z1_lsub = 1._wp / Lsub 
    610       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    611       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    612       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     618      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
     619      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
     620      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
    613621 
    614622      ! --- evaporation minus precipitation --- ! 
    … …  
    633641      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    634642      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     643 
     644      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     645      DO jl = 1, jpl 
     646         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
     647                                   ! But we do not have Tice => consider it at 0°C => evap=0  
     648      END DO 
    635649 
    636650      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  

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

    r7960 r9987  
    3333   USE cpl_oasis3      ! OASIS3 coupling 
    3434   USE geo2ocean       !  
    35    USE oce   , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 
     35   USE oce   , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev,            & 
     36                      CO2Flux_out_cpl, DMS_out_cpl, chloro_out_cpl,            &  
     37                      PCO2a_in_cpl, Dust_in_cpl, & 
     38                      ln_medusa 
    3639   USE albedo          ! 
    3740   USE in_out_manager  ! I/O manager 
    … …  
    4649   USE p4zflx, ONLY : oce_co2 
    4750#endif 
    48 #if defined key_cice 
    49    USE ice_domain_size, only: ncat 
    50 #endif 
    5151#if defined key_lim3 
    5252   USE limthd_dh       ! for CALL lim_thd_snwblow 
    5353#endif 
     54   USE lib_fortran, ONLY: glob_sum 
    5455 
    5556   IMPLICIT NONE 
    … …  
    105106   INTEGER, PARAMETER ::   jpr_e3t1st = 41            ! first T level thickness  
    106107   INTEGER, PARAMETER ::   jpr_fraqsr = 42            ! fraction of solar net radiation absorbed in the first ocean level 
    107    INTEGER, PARAMETER ::   jprcv      = 42            ! total number of fields received 
     108   INTEGER, PARAMETER ::   jpr_ts_ice = 43            ! skin temperature of sea-ice (used for melt-ponds) 
     109   INTEGER, PARAMETER ::   jpr_grnm   = 44            ! Greenland ice mass 
     110   INTEGER, PARAMETER ::   jpr_antm   = 45            ! Antarctic ice mass 
     111   INTEGER, PARAMETER ::   jpr_atm_pco2 = 46          ! Incoming atm CO2 flux 
     112   INTEGER, PARAMETER ::   jpr_atm_dust = 47          ! Incoming atm aggregate dust  
     113   INTEGER, PARAMETER ::   jprcv      = 47            ! total number of fields received 
    108114 
    109115   INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction sent to the atmosphere 
    … …  
    135141   INTEGER, PARAMETER ::   jps_e3t1st = 27            ! first level depth (vvl) 
    136142   INTEGER, PARAMETER ::   jps_fraqsr = 28            ! fraction of solar net radiation absorbed in the first ocean level 
    137    INTEGER, PARAMETER ::   jpsnd      = 28            ! total number of fields sended 
     143   INTEGER, PARAMETER ::   jps_a_p    = 29            ! meltpond fraction   
     144   INTEGER, PARAMETER ::   jps_ht_p   = 30            ! meltpond depth (m)  
     145   INTEGER, PARAMETER ::   jps_kice   = 31            ! ice surface layer thermal conductivity 
     146   INTEGER, PARAMETER ::   jps_sstfrz = 32            ! sea-surface freezing temperature 
     147   INTEGER, PARAMETER ::   jps_fice1  = 33            ! first-order ice concentration (for time-travelling ice coupling) 
     148   INTEGER, PARAMETER ::   jps_bio_co2 = 34           ! MEDUSA air-sea CO2 flux 
     149   INTEGER, PARAMETER ::   jps_bio_dms = 35           ! MEDUSA DMS surface concentration 
     150   INTEGER, PARAMETER ::   jps_bio_chloro = 36        ! MEDUSA chlorophyll surface concentration 
     151   INTEGER, PARAMETER ::   jpsnd      = 36            ! total number of fields sent 
     152 
     153   REAL(wp), PARAMETER :: dms_unit_conv = 1.0e+6      ! Coversion factor to get outgong DMS in standard units for coupling 
     154                                                 ! i.e. specifically nmol/L (= umol/m3) 
    138155 
    139156   !                                                         !!** namelist namsbc_cpl ** 
    … …  
    146163   END TYPE FLD_C 
    147164   ! Send to the atmosphere                           ! 
    148    TYPE(FLD_C) ::   sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2                         
     165   TYPE(FLD_C) ::   sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2, sn_snd_cond, sn_snd_mpnd, sn_snd_sstfrz, sn_snd_thick1 
     166   TYPE(FLD_C) ::   sn_snd_bio_co2, sn_snd_bio_dms, sn_snd_bio_chloro                    
     167 
    149168   ! Received from the atmosphere                     ! 
    150169   TYPE(FLD_C) ::   sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf 
    151    TYPE(FLD_C) ::   sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2                         
     170   TYPE(FLD_C) ::   sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_ts_ice, sn_rcv_grnm, sn_rcv_antm 
     171   TYPE(FLD_C) ::   sn_rcv_atm_pco2, sn_rcv_atm_dust                          
     172 
    152173   ! Other namelist parameters                        ! 
    153174   INTEGER     ::   nn_cplmodel            ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
    … …  
    188209      ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) )  ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 
    189210#endif 
    190       ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 
     211      !ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 
     212      ! Hardwire only two models as nn_cplmodel has not been read in 
     213      ! from the namelist yet. 
     214      ALLOCATE( xcplmask(jpi,jpj,0:2) , STAT=ierr(3) )    
    191215      ! 
    192216      sbc_cpl_alloc = MAXVAL( ierr ) 
    … …  
    216240      REAL(wp), POINTER, DIMENSION(:,:) ::   zacs, zaos 
    217241      !! 
    218       NAMELIST/namsbc_cpl/  sn_snd_temp, sn_snd_alb   , sn_snd_thick, sn_snd_crt   , sn_snd_co2,      & 
    219          &                  sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr,      & 
    220          &                  sn_rcv_qns , sn_rcv_emp   , sn_rcv_rnf  , sn_rcv_cal   , sn_rcv_iceflx,   & 
    221          &                  sn_rcv_co2 , nn_cplmodel  , ln_usecplmask 
     242      NAMELIST/namsbc_cpl/  sn_snd_temp, sn_snd_alb   , sn_snd_thick , sn_snd_crt   , sn_snd_co2,     & 
     243         &                  sn_snd_cond, sn_snd_mpnd  , sn_snd_sstfrz, sn_snd_thick1,                 & 
     244         &                  sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau   , sn_rcv_dqnsdt, sn_rcv_qsr,     & 
     245         &                  sn_rcv_qns , sn_rcv_emp   , sn_rcv_rnf   , sn_rcv_cal   , sn_rcv_iceflx,  & 
     246         &                  sn_rcv_co2 , sn_rcv_grnm  , sn_rcv_antm  , sn_rcv_ts_ice, nn_cplmodel  ,  & 
     247         &                  ln_usecplmask, nn_coupled_iceshelf_fluxes, ln_iceshelf_init_atmos,        & 
     248         &                  rn_greenland_total_fw_flux, rn_greenland_calving_fraction, & 
     249         &                  rn_antarctica_total_fw_flux, rn_antarctica_calving_fraction, rn_iceshelf_fluxes_tolerance 
    222250      !!--------------------------------------------------------------------- 
     251 
     252      ! Add MEDUSA related fields to namelist 
     253      NAMELIST/namsbc_cpl/  sn_snd_bio_co2, sn_snd_bio_dms, sn_snd_bio_chloro,                        & 
     254         &                  sn_rcv_atm_pco2, sn_rcv_atm_dust 
     255 
     256      !!--------------------------------------------------------------------- 
     257 
    223258      ! 
    224259      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_init') 
    … …  
    245280      ENDIF 
    246281      IF( lwp .AND. ln_cpl ) THEN                        ! control print 
    247          WRITE(numout,*)'  received fields (mutiple ice categogies)' 
     282         WRITE(numout,*)'  received fields (mutiple ice categories)' 
    248283         WRITE(numout,*)'      10m wind module                 = ', TRIM(sn_rcv_w10m%cldes  ), ' (', TRIM(sn_rcv_w10m%clcat  ), ')' 
    249284         WRITE(numout,*)'      stress module                   = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')' 
    … …  
    258293         WRITE(numout,*)'      runoffs                         = ', TRIM(sn_rcv_rnf%cldes   ), ' (', TRIM(sn_rcv_rnf%clcat   ), ')' 
    259294         WRITE(numout,*)'      calving                         = ', TRIM(sn_rcv_cal%cldes   ), ' (', TRIM(sn_rcv_cal%clcat   ), ')' 
     295         WRITE(numout,*)'      Greenland ice mass              = ', TRIM(sn_rcv_grnm%cldes  ), ' (', TRIM(sn_rcv_grnm%clcat  ), ')' 
     296         WRITE(numout,*)'      Antarctica ice mass             = ', TRIM(sn_rcv_antm%cldes  ), ' (', TRIM(sn_rcv_antm%clcat  ), ')' 
    260297         WRITE(numout,*)'      sea ice heat fluxes             = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 
    261298         WRITE(numout,*)'      atm co2                         = ', TRIM(sn_rcv_co2%cldes   ), ' (', TRIM(sn_rcv_co2%clcat   ), ')' 
     299         WRITE(numout,*)'      atm pco2                        = ', TRIM(sn_rcv_atm_pco2%cldes), ' (', TRIM(sn_rcv_atm_pco2%clcat), ')' 
     300         WRITE(numout,*)'      atm dust                        = ', TRIM(sn_rcv_atm_dust%cldes), ' (', TRIM(sn_rcv_atm_dust%clcat), ')' 
    262301         WRITE(numout,*)'  sent fields (multiple ice categories)' 
    263302         WRITE(numout,*)'      surface temperature             = ', TRIM(sn_snd_temp%cldes  ), ' (', TRIM(sn_snd_temp%clcat  ), ')' 
    … …  
    268307         WRITE(numout,*)'                      - orientation   = ', sn_snd_crt%clvor 
    269308         WRITE(numout,*)'                      - mesh          = ', sn_snd_crt%clvgrd 
     309         WRITE(numout,*)'      bio co2 flux                    = ', TRIM(sn_snd_bio_co2%cldes), ' (', TRIM(sn_snd_bio_co2%clcat), ')' 
     310         WRITE(numout,*)'      bio dms flux                    = ', TRIM(sn_snd_bio_dms%cldes), ' (', TRIM(sn_snd_bio_dms%clcat), ')' 
     311         WRITE(numout,*)'      bio dms chlorophyll             = ', TRIM(sn_snd_bio_chloro%cldes), ' (', TRIM(sn_snd_bio_chloro%clcat), ')' 
    270312         WRITE(numout,*)'      oce co2 flux                    = ', TRIM(sn_snd_co2%cldes   ), ' (', TRIM(sn_snd_co2%clcat   ), ')' 
     313         WRITE(numout,*)'      ice effective conductivity      = ', TRIM(sn_snd_cond%cldes   ), ' (', TRIM(sn_snd_cond%clcat   ), ')' 
     314         WRITE(numout,*)'      meltponds fraction & depth      = ', TRIM(sn_snd_mpnd%cldes  ), ' (', TRIM(sn_snd_mpnd%clcat   ), ')' 
     315         WRITE(numout,*)'      sea surface freezing temp       = ', TRIM(sn_snd_sstfrz%cldes   ), ' (', TRIM(sn_snd_sstfrz%clcat   ), ')' 
     316 
    271317         WRITE(numout,*)'  nn_cplmodel                         = ', nn_cplmodel 
    272318         WRITE(numout,*)'  ln_usecplmask                       = ', ln_usecplmask 
     319         WRITE(numout,*)'  nn_coupled_iceshelf_fluxes          = ', nn_coupled_iceshelf_fluxes 
     320         WRITE(numout,*)'  ln_iceshelf_init_atmos              = ', ln_iceshelf_init_atmos 
     321         WRITE(numout,*)'  rn_greenland_total_fw_flux         = ', rn_greenland_total_fw_flux 
     322         WRITE(numout,*)'  rn_antarctica_total_fw_flux        = ', rn_antarctica_total_fw_flux 
     323         WRITE(numout,*)'  rn_greenland_calving_fraction       = ', rn_greenland_calving_fraction 
     324         WRITE(numout,*)'  rn_antarctica_calving_fraction      = ', rn_antarctica_calving_fraction 
     325         WRITE(numout,*)'  rn_iceshelf_fluxes_tolerance        = ', rn_iceshelf_fluxes_tolerance 
    273326      ENDIF 
    274327 
    275328      !                                   ! allocate sbccpl arrays 
    276       IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 
     329      !IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 
    277330      
    278331      ! ================================ ! 
    … …  
    337390         srcv(jpr_otx2:jpr_otz2)%clgrid  = 'V'        !           and           V-point 
    338391         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'F'        ! ice components given at F-point 
    339          srcv(jpr_otx1:jpr_otz2)%laction = .TRUE.     ! receive oce components on grid 1 & 2 
     392         !srcv(jpr_otx1:jpr_otz2)%laction = .TRUE.     ! receive oce components on grid 1 & 2 
     393! Currently needed for HadGEM3 - but shouldn't affect anyone else for the moment 
     394         srcv(jpr_otx1)%laction = .TRUE.  
     395         srcv(jpr_oty1)%laction = .TRUE. 
     396! 
    340397         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 only 
    341398      CASE( 'T,I' )  
    … …  
    383440      srcv(jpr_snow)%clname = 'OTotSnow'      ! Snow = solid precipitation 
    384441      srcv(jpr_tevp)%clname = 'OTotEvap'      ! total evaporation (over oce + ice sublimation) 
    385       srcv(jpr_ievp)%clname = 'OIceEvap'      ! evaporation over ice = sublimation 
     442      srcv(jpr_ievp)%clname = 'OIceEvp'      ! evaporation over ice = sublimation 
    386443      srcv(jpr_sbpr)%clname = 'OSubMPre'      ! sublimation - liquid precipitation - solid precipitation  
    387444      srcv(jpr_semp)%clname = 'OISubMSn'      ! ice solid water budget = sublimation - solid precipitation 
    … …  
    396453      CASE default              ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' ) 
    397454      END SELECT 
    398  
     455      !Set the number of categories for coupling of sublimation 
     456      IF ( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = jpl 
     457      ! 
    399458      !                                                      ! ------------------------- ! 
    400459      !                                                      !     Runoffs & Calving     !    
    … …  
    410469      ! 
    411470      srcv(jpr_cal   )%clname = 'OCalving'   ;   IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE. 
     471      srcv(jpr_grnm  )%clname = 'OGrnmass'   ;   IF( TRIM( sn_rcv_grnm%cldes ) == 'coupled' )   srcv(jpr_grnm)%laction = .TRUE. 
     472      srcv(jpr_antm  )%clname = 'OAntmass'   ;   IF( TRIM( sn_rcv_antm%cldes ) == 'coupled' )   srcv(jpr_antm)%laction = .TRUE. 
     473 
    412474 
    413475      !                                                      ! ------------------------- ! 
    … …  
    470532      !                                                      ! ------------------------- ! 
    471533      srcv(jpr_co2 )%clname = 'O_AtmCO2'   ;   IF( TRIM(sn_rcv_co2%cldes   ) == 'coupled' )    srcv(jpr_co2 )%laction = .TRUE. 
     534 
     535 
     536      !                                                      ! --------------------------------------- !     
     537      !                                                      ! Incoming CO2 and DUST fluxes for MEDUSA ! 
     538      !                                                      ! --------------------------------------- !   
     539      srcv(jpr_atm_pco2)%clname = 'OATMPCO2' 
     540 
     541      IF (TRIM(sn_rcv_atm_pco2%cldes) == 'medusa') THEN 
     542        srcv(jpr_atm_pco2)%laction = .TRUE. 
     543      END IF 
     544                
     545      srcv(jpr_atm_dust)%clname = 'OATMDUST'    
     546      IF (TRIM(sn_rcv_atm_dust%cldes) == 'medusa')  THEN 
     547        srcv(jpr_atm_dust)%laction = .TRUE. 
     548      END IF 
     549     
    472550      !                                                      ! ------------------------- ! 
    473551      !                                                      !   topmelt and botmelt     !    
    … …  
    483561         srcv(jpr_topm:jpr_botm)%laction = .TRUE. 
    484562      ENDIF 
     563       
     564#if defined key_cice && ! defined key_cice4 
     565      !                                                      ! ----------------------------- ! 
     566      !                                                      !  sea-ice skin temperature     !    
     567      !                                                      !  used in meltpond scheme      ! 
     568      !                                                      !  May be calculated in Atm     ! 
     569      !                                                      ! ----------------------------- ! 
     570      srcv(jpr_ts_ice)%clname = 'OTsfIce' 
     571      IF ( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' ) srcv(jpr_ts_ice)%laction = .TRUE. 
     572      IF ( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' ) srcv(jpr_ts_ice)%nct = jpl 
     573      !TODO: Should there be a consistency check here? 
     574#endif 
     575 
    485576      !                                                      ! ------------------------------- ! 
    486577      !                                                      !   OPA-SAS coupling - rcv by opa !    
    … …  
    600691      !                                                      ! ------------------------- ! 
    601692      ssnd(jps_toce)%clname = 'O_SSTSST' 
    602       ssnd(jps_tice)%clname = 'O_TepIce' 
     693      ssnd(jps_tice)%clname = 'OTepIce' 
    603694      ssnd(jps_tmix)%clname = 'O_TepMix' 
    604695      SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 
    605696      CASE( 'none'                                 )       ! nothing to do 
    606697      CASE( 'oce only'                             )   ;   ssnd( jps_toce )%laction = .TRUE. 
    607       CASE( 'oce and ice' , 'weighted oce and ice' ) 
     698      CASE( 'oce and ice' , 'weighted oce and ice' , 'oce and weighted ice') 
    608699         ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 
    609700         IF ( TRIM( sn_snd_temp%clcat ) == 'yes' )  ssnd(jps_tice)%nct = jpl 
    … …  
    634725 
    635726      !                                                      ! ------------------------- ! 
    636       !                                                      !  Ice fraction & Thickness !  
     727      !                                                      !  Ice fraction & Thickness  
    637728      !                                                      ! ------------------------- ! 
    638729      ssnd(jps_fice)%clname = 'OIceFrc' 
    639730      ssnd(jps_hice)%clname = 'OIceTck' 
    640731      ssnd(jps_hsnw)%clname = 'OSnwTck' 
     732      ssnd(jps_a_p)%clname  = 'OPndFrc' 
     733      ssnd(jps_ht_p)%clname = 'OPndTck' 
     734      ssnd(jps_fice1)%clname = 'OIceFrd' 
    641735      IF( k_ice /= 0 ) THEN 
    642736         ssnd(jps_fice)%laction = .TRUE.                  ! if ice treated in the ocean (even in climato case) 
     737         ssnd(jps_fice1)%laction = .TRUE.                 ! First-order regridded ice concentration, to be used 
     738                                                     ! in producing atmos-to-ice fluxes 
    643739! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now 
    644740         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 
     741         IF ( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = jpl 
    645742      ENDIF 
    646743       
    … …  
    657754      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' ) 
    658755      END SELECT 
     756 
     757      !                                                      ! ------------------------- ! 
     758      !                                                      ! Ice Meltponds             ! 
     759      !                                                      ! ------------------------- ! 
     760#if defined key_cice && ! defined key_cice4 
     761      ! Meltponds only CICE5  
     762      ssnd(jps_a_p)%clname = 'OPndFrc'    
     763      ssnd(jps_ht_p)%clname = 'OPndTck'    
     764      SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) 
     765      CASE ( 'none' ) 
     766         ssnd(jps_a_p)%laction = .FALSE. 
     767         ssnd(jps_ht_p)%laction = .FALSE. 
     768      CASE ( 'ice only' )  
     769         ssnd(jps_a_p)%laction = .TRUE. 
     770         ssnd(jps_ht_p)%laction = .TRUE. 
     771         IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 
     772            ssnd(jps_a_p)%nct = jpl 
     773            ssnd(jps_ht_p)%nct = jpl 
     774         ELSE 
     775            IF ( jpl > 1 ) THEN 
     776               CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) 
     777            ENDIF 
     778         ENDIF 
     779      CASE ( 'weighted ice' )  
     780         ssnd(jps_a_p)%laction = .TRUE. 
     781         ssnd(jps_ht_p)%laction = .TRUE. 
     782         IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 
     783            ssnd(jps_a_p)%nct = jpl  
     784            ssnd(jps_ht_p)%nct = jpl  
     785         ENDIF 
     786      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes' ) 
     787      END SELECT 
     788#else 
     789      IF( TRIM( sn_snd_mpnd%cldes ) /= 'none' ) THEN 
     790         CALL ctl_stop('Meltponds can only be used with CICEv5') 
     791      ENDIF 
     792#endif 
    659793 
    660794      !                                                      ! ------------------------- ! 
    … …  
    689823      !                                                      ! ------------------------- ! 
    690824      ssnd(jps_co2)%clname = 'O_CO2FLX' ;  IF( TRIM(sn_snd_co2%cldes) == 'coupled' )    ssnd(jps_co2 )%laction = .TRUE. 
     825      ! 
     826 
     827      !                                                      ! ------------------------- ! 
     828      !                                                      !   MEDUSA output fields    ! 
     829      !                                                      ! ------------------------- ! 
     830      ! Surface dimethyl sulphide from Medusa 
     831      ssnd(jps_bio_dms)%clname = 'OBioDMS'    
     832      IF( TRIM(sn_snd_bio_dms%cldes) == 'medusa' )    ssnd(jps_bio_dms )%laction = .TRUE. 
     833 
     834      ! Surface CO2 flux from Medusa 
     835      ssnd(jps_bio_co2)%clname = 'OBioCO2'    
     836      IF( TRIM(sn_snd_bio_co2%cldes) == 'medusa' )    ssnd(jps_bio_co2 )%laction = .TRUE. 
     837       
     838      ! Surface chlorophyll from Medusa 
     839      ssnd(jps_bio_chloro)%clname = 'OBioChlo'    
     840      IF( TRIM(sn_snd_bio_chloro%cldes) == 'medusa' )    ssnd(jps_bio_chloro )%laction = .TRUE. 
     841 
     842      !                                                      ! ------------------------- ! 
     843      !                                                      ! Sea surface freezing temp ! 
     844      !                                                      ! ------------------------- ! 
     845      ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' )  ssnd(jps_sstfrz)%laction = .TRUE. 
     846      ! 
     847      !                                                      ! ------------------------- ! 
     848      !                                                      !    Ice conductivity       ! 
     849      !                                                      ! ------------------------- ! 
     850      ! Note that ultimately we will move to passing an ocean effective conductivity as well so there 
     851      ! will be some changes to the parts of the code which currently relate only to ice conductivity 
     852      ssnd(jps_kice )%clname = 'OIceKn' 
     853      SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) 
     854      CASE ( 'none' ) 
     855         ssnd(jps_kice)%laction = .FALSE. 
     856      CASE ( 'ice only' ) 
     857         ssnd(jps_kice)%laction = .TRUE. 
     858         IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN 
     859            ssnd(jps_kice)%nct = jpl 
     860         ELSE 
     861            IF ( jpl > 1 ) THEN 
     862               CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) 
     863            ENDIF 
     864         ENDIF 
     865      CASE ( 'weighted ice' ) 
     866         ssnd(jps_kice)%laction = .TRUE. 
     867         IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = jpl 
     868      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes' ) 
     869      END SELECT 
     870      ! 
     871       
    691872 
    692873      !                                                      ! ------------------------------- ! 
    … …  
    785966      ncpl_qsr_freq = 86400 / ncpl_qsr_freq 
    786967 
     968      IF( nn_coupled_iceshelf_fluxes .gt. 0 ) THEN 
     969          ! Crude masks to separate the Antarctic and Greenland icesheets. Obviously something 
     970          ! more complicated could be done if required. 
     971          greenland_icesheet_mask = 0.0 
     972          WHERE( gphit >= 0.0 ) greenland_icesheet_mask = 1.0 
     973          antarctica_icesheet_mask = 0.0 
     974          WHERE( gphit < 0.0 ) antarctica_icesheet_mask = 1.0 
     975 
     976          ! initialise other variables 
     977          greenland_icesheet_mass_array(:,:) = 0.0 
     978          antarctica_icesheet_mass_array(:,:) = 0.0 
     979 
     980          IF( .not. ln_rstart ) THEN 
     981             greenland_icesheet_mass = 0.0  
     982             greenland_icesheet_mass_rate_of_change = 0.0  
     983             greenland_icesheet_timelapsed = 0.0 
     984             antarctica_icesheet_mass = 0.0  
     985             antarctica_icesheet_mass_rate_of_change = 0.0  
     986             antarctica_icesheet_timelapsed = 0.0 
     987          ENDIF 
     988 
     989      ENDIF 
     990 
    787991      CALL wrk_dealloc( jpi,jpj, zacs, zaos ) 
    788992      ! 
    … …  
    8431047      !! 
    8441048      LOGICAL  ::   llnewtx, llnewtau      ! update wind stress components and module?? 
    845       INTEGER  ::   ji, jj, jn             ! dummy loop indices 
     1049      INTEGER  ::   ji, jj, jl, jn         ! dummy loop indices 
    8461050      INTEGER  ::   isec                   ! number of seconds since nit000 (assuming rdttra did not change since nit000) 
     1051      INTEGER  ::   ikchoix 
    8471052      REAL(wp) ::   zcumulneg, zcumulpos   ! temporary scalars      
     1053      REAL(wp) ::   zgreenland_icesheet_mass_in, zantarctica_icesheet_mass_in 
     1054      REAL(wp) ::   zgreenland_icesheet_mass_b, zantarctica_icesheet_mass_b 
     1055      REAL(wp) ::   zmask_sum, zepsilon       
    8481056      REAL(wp) ::   zcoef                  ! temporary scalar 
    8491057      REAL(wp) ::   zrhoa  = 1.22          ! Air density kg/m3 
    8501058      REAL(wp) ::   zcdrag = 1.5e-3        ! drag coefficient 
    8511059      REAL(wp) ::   zzx, zzy               ! temporary variables 
    852       REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty, zmsk, zemp, zqns, zqsr 
     1060      REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 
    8531061      !!---------------------------------------------------------------------- 
     1062 
    8541063      ! 
    8551064      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_rcv') 
    8561065      ! 
    857       CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
     1066      CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 ) 
    8581067      ! 
    8591068      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    8931102            IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN   ! 2 components oriented along the local grid 
    8941103               !                                                       ! (geographical to local grid -> rotate the components) 
    895                CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )    
    896                IF( srcv(jpr_otx2)%laction ) THEN 
    897                   CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )    
    898                ELSE   
    899                   CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )   
     1104               IF( srcv(jpr_otx1)%clgrid == 'U' .AND. (.NOT. srcv(jpr_otx2)%laction) ) THEN 
     1105                  ! Temporary code for HadGEM3 - will be removed eventually. 
     1106        ! Only applies when we have only taux on U grid and tauy on V grid 
     1107             DO jj=2,jpjm1 
     1108                DO ji=2,jpim1 
     1109                     ztx(ji,jj)=0.25*vmask(ji,jj,1)                & 
     1110                        *(frcv(jpr_otx1)%z3(ji,jj,1)+frcv(jpr_otx1)%z3(ji-1,jj,1)    & 
     1111                        +frcv(jpr_otx1)%z3(ji,jj+1,1)+frcv(jpr_otx1)%z3(ji-1,jj+1,1)) 
     1112                     zty(ji,jj)=0.25*umask(ji,jj,1)                & 
     1113                        *(frcv(jpr_oty1)%z3(ji,jj,1)+frcv(jpr_oty1)%z3(ji+1,jj,1)    & 
     1114                        +frcv(jpr_oty1)%z3(ji,jj-1,1)+frcv(jpr_oty1)%z3(ji+1,jj-1,1)) 
     1115                ENDDO 
     1116             ENDDO 
     1117                    
     1118             ikchoix = 1 
     1119             CALL repcmo (frcv(jpr_otx1)%z3(:,:,1),zty,ztx,frcv(jpr_oty1)%z3(:,:,1),ztx2,zty2,ikchoix) 
     1120             CALL lbc_lnk (ztx2,'U', -1. ) 
     1121             CALL lbc_lnk (zty2,'V', -1. ) 
     1122             frcv(jpr_otx1)%z3(:,:,1)=ztx2(:,:) 
     1123             frcv(jpr_oty1)%z3(:,:,1)=zty2(:,:) 
     1124          ELSE 
     1125             CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )    
     1126             frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
     1127             IF( srcv(jpr_otx2)%laction ) THEN 
     1128                CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )    
     1129             ELSE 
     1130                CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )  
     1131             ENDIF 
     1132          frcv(jpr_oty1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 2nd grid   
    9001133               ENDIF 
    901                frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
    902                frcv(jpr_oty1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 2nd grid 
    9031134            ENDIF 
    9041135            !                               
    … …  
    9901221      ENDIF 
    9911222 
     1223      IF (ln_medusa) THEN 
     1224        IF( srcv(jpr_atm_pco2)%laction) PCO2a_in_cpl(:,:) = frcv(jpr_atm_pco2)%z3(:,:,1) 
     1225        IF( srcv(jpr_atm_dust)%laction) Dust_in_cpl(:,:) = frcv(jpr_atm_dust)%z3(:,:,1) 
     1226      ENDIF 
     1227 
    9921228#if defined key_cpl_carbon_cycle 
    9931229      !                                                      ! ================== ! 
    … …  
    9951231      !                                                      ! ================== ! 
    9961232      IF( srcv(jpr_co2)%laction )   atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 
     1233#endif 
     1234 
     1235#if defined key_cice && ! defined key_cice4 
     1236      !  ! Sea ice surface skin temp: 
     1237      IF( srcv(jpr_ts_ice)%laction ) THEN 
     1238        DO jl = 1, jpl 
     1239          DO jj = 1, jpj 
     1240            DO ji = 1, jpi 
     1241              IF (frcv(jpr_ts_ice)%z3(ji,jj,jl) > 0.0) THEN 
     1242                tsfc_ice(ji,jj,jl) = 0.0 
     1243              ELSE IF (frcv(jpr_ts_ice)%z3(ji,jj,jl) < -60.0) THEN 
     1244                tsfc_ice(ji,jj,jl) = -60.0 
     1245              ELSE 
     1246                tsfc_ice(ji,jj,jl) = frcv(jpr_ts_ice)%z3(ji,jj,jl) 
     1247              ENDIF 
     1248            END DO 
     1249          END DO 
     1250        END DO 
     1251      ENDIF 
    9971252#endif 
    9981253 
    … …  
    10291284         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    10301285         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1286         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10311287         CALL iom_put( 'ssu_m', ssu_m ) 
    10321288      ENDIF 
    … …  
    10341290         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    10351291         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1292         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10361293         CALL iom_put( 'ssv_m', ssv_m ) 
    10371294      ENDIF 
    … …  
    11101367 
    11111368      ENDIF 
    1112       ! 
    1113       CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
     1369       
     1370      !                                                        ! land ice masses : Greenland 
     1371      zepsilon = rn_iceshelf_fluxes_tolerance 
     1372 
     1373 
     1374      ! See if we need zmask_sum... 
     1375      IF ( srcv(jpr_grnm)%laction .OR. srcv(jpr_antm)%laction ) THEN 
     1376         zmask_sum = glob_sum( tmask(:,:,1) ) 
     1377      ENDIF 
     1378 
     1379      IF( srcv(jpr_grnm)%laction .AND. nn_coupled_iceshelf_fluxes == 1 ) THEN 
     1380         greenland_icesheet_mass_array(:,:) = frcv(jpr_grnm)%z3(:,:,1) 
     1381         ! take average over ocean points of input array to avoid cumulative error over time 
     1382         ! The following must be bit reproducible over different PE decompositions 
     1383         zgreenland_icesheet_mass_in = glob_sum( greenland_icesheet_mass_array(:,:) * tmask(:,:,1) ) 
     1384 
     1385         zgreenland_icesheet_mass_in = zgreenland_icesheet_mass_in / zmask_sum 
     1386         greenland_icesheet_timelapsed = greenland_icesheet_timelapsed + rdt          
     1387 
     1388         IF( ln_iceshelf_init_atmos .AND. kt == 1 ) THEN 
     1389            ! On the first timestep (of an NRUN) force the ocean to ignore the icesheet masses in the ocean restart 
     1390            ! and take them from the atmosphere to avoid problems with using inconsistent ocean and atmosphere restarts. 
     1391            zgreenland_icesheet_mass_b = zgreenland_icesheet_mass_in 
     1392            greenland_icesheet_mass = zgreenland_icesheet_mass_in 
     1393         ENDIF 
     1394 
     1395         IF( ABS( zgreenland_icesheet_mass_in - greenland_icesheet_mass ) > zepsilon ) THEN 
     1396            zgreenland_icesheet_mass_b = greenland_icesheet_mass 
     1397             
     1398            ! Only update the mass if it has increased. 
     1399            IF ( (zgreenland_icesheet_mass_in - greenland_icesheet_mass) > 0.0 ) THEN 
     1400               greenland_icesheet_mass = zgreenland_icesheet_mass_in 
     1401            ENDIF 
     1402             
     1403            IF( zgreenland_icesheet_mass_b /= 0.0 ) & 
     1404           &     greenland_icesheet_mass_rate_of_change = ( greenland_icesheet_mass - zgreenland_icesheet_mass_b ) / greenland_icesheet_timelapsed  
     1405            greenland_icesheet_timelapsed = 0.0_wp        
     1406         ENDIF 
     1407         IF(lwp) WRITE(numout,*) 'Greenland icesheet mass (kg) read in is ', zgreenland_icesheet_mass_in 
     1408         IF(lwp) WRITE(numout,*) 'Greenland icesheet mass (kg) used is    ', greenland_icesheet_mass 
     1409         IF(lwp) WRITE(numout,*) 'Greenland icesheet mass rate of change (kg/s) is ', greenland_icesheet_mass_rate_of_change 
     1410         IF(lwp) WRITE(numout,*) 'Greenland icesheet seconds lapsed since last change is ', greenland_icesheet_timelapsed 
     1411      ELSE IF ( nn_coupled_iceshelf_fluxes == 2 ) THEN 
     1412         greenland_icesheet_mass_rate_of_change = rn_greenland_total_fw_flux 
     1413      ENDIF 
     1414 
     1415      !                                                        ! land ice masses : Antarctica 
     1416      IF( srcv(jpr_antm)%laction .AND. nn_coupled_iceshelf_fluxes == 1 ) THEN 
     1417         antarctica_icesheet_mass_array(:,:) = frcv(jpr_antm)%z3(:,:,1) 
     1418         ! take average over ocean points of input array to avoid cumulative error from rounding errors over time 
     1419         ! The following must be bit reproducible over different PE decompositions 
     1420         zantarctica_icesheet_mass_in = glob_sum( antarctica_icesheet_mass_array(:,:) * tmask(:,:,1) ) 
     1421 
     1422         zantarctica_icesheet_mass_in = zantarctica_icesheet_mass_in / zmask_sum 
     1423         antarctica_icesheet_timelapsed = antarctica_icesheet_timelapsed + rdt          
     1424 
     1425         IF( ln_iceshelf_init_atmos .AND. kt == 1 ) THEN 
     1426            ! On the first timestep (of an NRUN) force the ocean to ignore the icesheet masses in the ocean restart 
     1427            ! and take them from the atmosphere to avoid problems with using inconsistent ocean and atmosphere restarts. 
     1428            zantarctica_icesheet_mass_b = zantarctica_icesheet_mass_in 
     1429            antarctica_icesheet_mass = zantarctica_icesheet_mass_in 
     1430         ENDIF 
     1431 
     1432         IF( ABS( zantarctica_icesheet_mass_in - antarctica_icesheet_mass ) > zepsilon ) THEN 
     1433            zantarctica_icesheet_mass_b = antarctica_icesheet_mass 
     1434             
     1435            ! Only update the mass if it has increased. 
     1436            IF ( (zantarctica_icesheet_mass_in - antarctica_icesheet_mass) > 0.0 ) THEN 
     1437               antarctica_icesheet_mass = zantarctica_icesheet_mass_in 
     1438            END IF 
     1439             
     1440            IF( zantarctica_icesheet_mass_b /= 0.0 ) & 
     1441          &      antarctica_icesheet_mass_rate_of_change = ( antarctica_icesheet_mass - zantarctica_icesheet_mass_b ) / antarctica_icesheet_timelapsed  
     1442            antarctica_icesheet_timelapsed = 0.0_wp        
     1443         ENDIF 
     1444         IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass (kg) read in is ', zantarctica_icesheet_mass_in 
     1445         IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass (kg) used is    ', antarctica_icesheet_mass 
     1446         IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass rate of change (kg/s) is ', antarctica_icesheet_mass_rate_of_change 
     1447         IF(lwp) WRITE(numout,*) 'Antarctica icesheet seconds lapsed since last change is ', antarctica_icesheet_timelapsed 
     1448      ELSE IF ( nn_coupled_iceshelf_fluxes == 2 ) THEN 
     1449         antarctica_icesheet_mass_rate_of_change = rn_antarctica_total_fw_flux 
     1450      ENDIF 
     1451 
     1452      ! 
     1453      CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 ) 
    11141454      ! 
    11151455      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_rcv') 
    … …  
    13331673      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13341674      !! 
    1335       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1336       !!              ocean-ice system. 
     1675      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13371676      !! 
    13381677      !! ** Method  :   transform the fields received from the atmosphere into 
    13391678      !!             surface heat and fresh water boundary condition for the  
    13401679      !!             ice-ocean system. The following fields are provided: 
    1341       !!              * total non solar, solar and freshwater fluxes (qns_tot,  
     1680      !!               * total non solar, solar and freshwater fluxes (qns_tot,  
    13421681      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux) 
    13431682      !!             NB: emp_tot include runoffs and calving. 
    1344       !!              * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
     1683      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
    13451684      !!             emp_ice = sublimation - solid precipitation as liquid 
    13461685      !!             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  
     1686      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90) 
     1687      !!               * solid precipitation (sprecip), used to add to qns_tot  
    13491688      !!             the heat lost associated to melting solid precipitation 
    13501689      !!             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. 
     1690      !!               * heat content of rain, snow and evap can also be provided, 
     1691      !!             otherwise heat flux associated with these mass flux are 
     1692      !!             guessed (qemp_oce, qemp_ice) 
     1693      !! 
     1694      !!             - the fluxes have been separated from the stress as 
     1695      !!               (a) they are updated at each ice time step compare to 
     1696      !!               an update at each coupled time step for the stress, and 
     1697      !!               (b) the conservative computation of the fluxes over the 
     1698      !!               sea-ice area requires the knowledge of the ice fraction 
     1699      !!               after the ice advection and before the ice thermodynamics, 
     1700      !!               so that the stress is updated before the ice dynamics 
     1701      !!               while the fluxes are updated after it. 
     1702      !! 
     1703      !! ** Details 
     1704      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1705      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1706      !! 
     1707      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1708      !! 
     1709      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1710      !!                                                                      river runoff (rnf) is provided but not included here 
    13621711      !! 
    13631712      !! ** Action  :   update at each nf_ice time step: 
    13641713      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13651714      !!                   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   
     1715      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1716      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1717      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1718      !!                   sprecip           solid precipitation over the ocean   
    13701719      !!---------------------------------------------------------------------- 
    13711720      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    … …  
    13761725      ! 
    13771726      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 
     1727      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1728      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
     1729      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1730      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13821731      !!---------------------------------------------------------------------- 
    13831732      ! 
    13841733      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13851734      ! 
    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 ) 
     1735      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1736      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1737      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1738      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13881739 
    13891740      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    13921743      ! 
    13931744      !                                                      ! ========================= ! 
    1394       !                                                      !    freshwater budget      !   (emp) 
     1745      !                                                      !    freshwater budget      !   (emp_tot) 
    13951746      !                                                      ! ========================= ! 
    13961747      ! 
    1397       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1398       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1399       !                                                           ! solid Precipitation                     (sprecip) 
    1400       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1748      !                                                           ! solid Precipitation                                (sprecip) 
     1749      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1750      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1751      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    14011752      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    14021753      CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    14031754         zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    14041755         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  
     1756         zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)          
     1757#if defined key_cice 
     1758         IF ( TRIM(sn_rcv_emp%clcat) == 'yes' ) THEN 
     1759            ! zemp_ice is the sum of frcv(jpr_ievp)%z3(:,:,1) over all layers - snow 
     1760            zemp_ice(:,:) = - frcv(jpr_snow)%z3(:,:,1) 
     1761            DO jl=1,jpl 
     1762               zemp_ice(:,:   ) = zemp_ice(:,:) + frcv(jpr_ievp)%z3(:,:,jl) 
     1763            ENDDO 
     1764            ! latent heat coupled for each category in CICE 
     1765            qla_ice(:,:,1:jpl) = - frcv(jpr_ievp)%z3(:,:,1:jpl) * lsub 
     1766         ELSE 
     1767            ! If CICE has multicategories it still expects coupling fields for 
     1768            ! each even if we treat as a single field 
     1769            ! The latent heat flux is split between the ice categories according 
     1770            ! to the fraction of the ice in each category 
     1771            zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
     1772            WHERE ( zicefr(:,:) /= 0._wp )  
     1773               ztmp(:,:) = 1./zicefr(:,:) 
     1774            ELSEWHERE  
     1775               ztmp(:,:) = 0.e0 
     1776            END WHERE   
     1777            DO jl=1,jpl 
     1778               qla_ice(:,:,jl) = - a_i(:,:,jl) * ztmp(:,:) * frcv(jpr_ievp)%z3(:,:,1) * lsub  
     1779            END DO 
     1780            WHERE ( zicefr(:,:) == 0._wp )  qla_ice(:,:,1) = -frcv(jpr_ievp)%z3(:,:,1) * lsub  
     1781         ENDIF 
     1782#else          
     1783         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1784#endif                   
     1785         CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1) * tmask(:,:,1)      )   ! liquid precipitation  
     1786         CALL iom_put( 'rain_ao_cea'  , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1)      )   ! liquid precipitation  
    14081787         IF( iom_use('hflx_rain_cea') )   & 
    1409             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from liq. precip.  
     1788            &  CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) * tmask(:,:,1))   ! heat flux from liq. precip.  
     1789         IF( iom_use('hflx_prec_cea') )   & 
     1790            & CALL iom_put( 'hflx_prec_cea', ztprecip * zcptn(:,:) * tmask(:,:,1) * p_frld(:,:) )   ! heat content flux from all precip  (cell avg) 
    14101791         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(:,:) 
     1792            & ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
    14121793         IF( iom_use('evap_ao_cea'  ) )   & 
    1413             CALL iom_put( 'evap_ao_cea'  , ztmp                   )   ! ice-free oce evap (cell average) 
     1794            &  CALL iom_put( 'evap_ao_cea'  , ztmp * tmask(:,:,1)                  )   ! ice-free oce evap (cell average) 
    14141795         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 
     1796            &  CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) * tmask(:,:,1) )   ! heat flux from from evap (cell average) 
     1797      CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14171798         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1418          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1799         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14191800         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14201801         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14211802      END SELECT 
    14221803 
    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) 
     1804#if defined key_lim3 
     1805      ! zsnw = snow fraction over ice after wind blowing 
     1806      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1807       
     1808      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1809      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1810      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1811 
     1812      ! --- evaporation over ocean (used later for qemp) --- ! 
     1813      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1814 
     1815      ! --- evaporation over ice (kg/m2/s) --- ! 
     1816      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1817      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1818      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1819      zdevap_ice(:,:) = 0._wp 
     1820       
     1821      ! --- runoffs (included in emp later on) --- ! 
    14271822      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1823 
     1824      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1825      IF( srcv(jpr_cal)%laction ) THEN  
     1826         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1827         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1828         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1829      ENDIF 
     1830 
     1831      IF( ln_mixcpl ) THEN 
     1832         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1833         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1834         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1835         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1836         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1837         DO jl=1,jpl 
     1838            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
     1839            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
     1840         ENDDO 
     1841      ELSE 
     1842         emp_tot(:,:) =         zemp_tot(:,:) 
     1843         emp_ice(:,:) =         zemp_ice(:,:) 
     1844         emp_oce(:,:) =         zemp_oce(:,:)      
     1845         sprecip(:,:) =         zsprecip(:,:) 
     1846         tprecip(:,:) =         ztprecip(:,:) 
     1847         DO jl=1,jpl 
     1848            evap_ice (:,:,jl) = zevap_ice (:,:) 
     1849            devap_ice(:,:,jl) = zdevap_ice(:,:) 
     1850         ENDDO 
     1851      ENDIF 
     1852 
     1853      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1854                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1855      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1856      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
     1857#else 
     1858      ! runoffs and calving (put in emp_tot) 
     1859      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1860      IF( iom_use('hflx_rnf_cea') )   & 
     1861         CALL iom_put( 'hflx_rnf_cea' , rnf(:,:) * zcptn(:,:) ) 
    14281862      IF( srcv(jpr_cal)%laction ) THEN  
    14291863         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    … …  
    14431877      ENDIF 
    14441878 
    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) 
     1879      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1880                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1881      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1882      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
     1883#endif 
    14501884 
    14511885      !                                                      ! ========================= ! 
    14521886      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    14531887      !                                                      ! ========================= ! 
    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) 
     1888      CASE( 'oce only' )         ! the required field is directly provided 
     1889         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1890      CASE( 'conservative' )     ! the required fields are directly provided 
     1891         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14581892         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14591893            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    14601894         ELSE 
    1461             ! Set all category values equal for the moment 
    14621895            DO jl=1,jpl 
    1463                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1896               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    14641897            ENDDO 
    14651898         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) 
     1899      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1900         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    14681901         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14691902            DO jl=1,jpl 
    … …  
    14721905            ENDDO 
    14731906         ELSE 
    1474             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1907            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    14751908            DO jl=1,jpl 
    14761909               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    … …  
    14781911            ENDDO 
    14791912         ENDIF 
    1480       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1913      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    14811914! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    14821915         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14831916         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    14841917            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1485             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1918            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    14861919      END SELECT 
    14871920!!gm 
    … …  
    14931926!! similar job should be done for snow and precipitation temperature 
    14941927      !                                      
    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  
     1928      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1929         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1930                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1931         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1932      ENDIF 
     1933 
     1934#if defined key_lim3       
    15201935      ! --- non solar flux over ocean --- ! 
    15211936      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    15231938      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15241939 
    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) --- ! 
     1940      ! --- heat flux associated with emp (W/m2) --- ! 
     1941      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1942         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1943         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1944!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1945!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1946      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1947                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
     1948       
     1949      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15351950      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15361951 
    1537       ! --- total non solar flux --- ! 
    1538       zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1952      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     1953      DO jl = 1, jpl 
     1954         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
     1955      END DO 
     1956 
     1957      ! --- total non solar flux (including evap/precip) --- ! 
     1958      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
    15391959 
    15401960      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15431963         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15441964         DO jl=1,jpl 
    1545             qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1965            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
     1966            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
    15461967         ENDDO 
    15471968         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15481969         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1549 !!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1970         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
    15501971      ELSE 
    15511972         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    15521973         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    15531974         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 )  
     1975         qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
     1976         qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
     1977         qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
     1978         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
     1979      ENDIF 
     1980 
     1981      !! clem: we should output qemp_oce and qemp_ice (at least) 
     1982      IF( iom_use('hflx_snow_cea') )   CALL iom_put( 'hflx_snow_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) )   ! heat flux from snow (cell average) 
     1983      !! these diags are not outputed yet 
     1984!!      IF( iom_use('hflx_rain_cea') )   CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )   ! heat flux from rain (cell average) 
     1985!!      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) 
     1986!!      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) ) ! heat flux from snow (cell average) 
     1987 
    15591988#else 
    1560  
    15611989      ! clem: this formulation is certainly wrong... but better than it was... 
     1990       
    15621991      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    1563          &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
     1992         &          - (p_frld(:,:) * zsprecip(:,:) * lfus)  &          ! remove the latent heat flux of solid precip. melting 
    15641993         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1565          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1994         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    15661995 
    15671996     IF( ln_mixcpl ) THEN 
    … …  
    15752004         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    15762005      ENDIF 
    1577  
    15782006#endif 
    15792007 
    … …  
    16262054 
    16272055#if defined key_lim3 
    1628       CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16292056      ! --- solar flux over ocean --- ! 
    16302057      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16342061      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16352062      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
    1636  
    1637       CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16382063#endif 
    16392064 
    … …  
    16862111      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    16872112 
    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 ) 
     2113      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     2114      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     2115      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     2116      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    16902117      ! 
    16912118      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17062133      ! 
    17072134      INTEGER ::   ji, jj, jl   ! dummy loop indices 
     2135      INTEGER ::   ikchoix 
    17082136      INTEGER ::   isec, info   ! local integer 
    17092137      REAL(wp) ::   zumax, zvmax 
    17102138      REAL(wp), POINTER, DIMENSION(:,:)   ::   zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 
     2139      REAL(wp), POINTER, DIMENSION(:,:)   ::   zotx1_in, zoty1_in 
    17112140      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztmp3, ztmp4    
    17122141      !!---------------------------------------------------------------------- 
    … …  
    17152144      ! 
    17162145      CALL wrk_alloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 
     2146      CALL wrk_alloc( jpi,jpj, zotx1_in, zoty1_in) 
    17172147      CALL wrk_alloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 
    17182148 
    … …  
    17432173                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    17442174                  ELSEWHERE 
    1745                      ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     2175                     ztmp3(:,:,1) = rt0 
    17462176                  END WHERE 
    17472177               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    … …  
    17582188               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    17592189               END SELECT 
     2190            CASE( 'oce and weighted ice' )   ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0  
     2191               SELECT CASE( sn_snd_temp%clcat ) 
     2192               CASE( 'yes' )    
     2193           ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     2194               CASE( 'no' ) 
     2195           ztmp3(:,:,:) = 0.0 
     2196           DO jl=1,jpl 
     2197                     ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     2198           ENDDO 
     2199               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     2200               END SELECT 
    17602201            CASE( 'mixed oce-ice'        )    
    17612202               ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)  
    … …  
    17742215      !                                                      ! ------------------------- ! 
    17752216      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' ) 
     2217          SELECT CASE( sn_snd_alb%cldes ) 
     2218          CASE( 'ice' ) 
     2219             SELECT CASE( sn_snd_alb%clcat ) 
     2220             CASE( 'yes' )    
     2221                ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     2222             CASE( 'no' ) 
     2223                WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     2224                   ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 
     2225                ELSEWHERE 
     2226                   ztmp1(:,:) = albedo_oce_mix(:,:) 
     2227                END WHERE 
     2228             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 
     2229             END SELECT 
     2230          CASE( 'weighted ice' )   ; 
     2231             SELECT CASE( sn_snd_alb%clcat ) 
     2232             CASE( 'yes' )    
     2233                ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     2234             CASE( 'no' ) 
     2235                WHERE( fr_i (:,:) > 0. ) 
     2236                   ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 
     2237                ELSEWHERE 
     2238                   ztmp1(:,:) = 0. 
     2239                END WHERE 
     2240             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 
     2241             END SELECT 
     2242          CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
    17802243         END SELECT 
    1781          CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    1782       ENDIF 
     2244 
     2245         SELECT CASE( sn_snd_alb%clcat ) 
     2246            CASE( 'yes' )    
     2247               CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode 
     2248            CASE( 'no'  )    
     2249               CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )  
     2250         END SELECT 
     2251      ENDIF 
     2252 
    17832253      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean 
    17842254         ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 
    … …  
    17992269         END SELECT 
    18002270         IF( ssnd(jps_fice)%laction )   CALL cpl_snd( jps_fice, isec, ztmp3, info ) 
     2271      ENDIF 
     2272       
     2273      ! Send ice fraction field (first order interpolation), for weighting UM fluxes to be passed to NEMO 
     2274      IF (ssnd(jps_fice1)%laction) THEN 
     2275         SELECT CASE (sn_snd_thick1%clcat) 
     2276         CASE( 'yes' )   ;   ztmp3(:,:,1:jpl) =  a_i(:,:,1:jpl) 
     2277         CASE( 'no' )    ;   ztmp3(:,:,1) = fr_i(:,:) 
     2278         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' ) 
     2279    END SELECT 
     2280         CALL cpl_snd (jps_fice1, isec, ztmp3, info) 
    18012281      ENDIF 
    18022282       
    … …  
    18452325      ENDIF 
    18462326      ! 
     2327#if defined key_cice && ! defined key_cice4 
     2328      ! Send meltpond fields  
     2329      IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 
     2330         SELECT CASE( sn_snd_mpnd%cldes)  
     2331         CASE( 'weighted ice' )  
     2332            SELECT CASE( sn_snd_mpnd%clcat )  
     2333            CASE( 'yes' )  
     2334               ztmp3(:,:,1:jpl) =  a_p(:,:,1:jpl) * a_i(:,:,1:jpl)  
     2335               ztmp4(:,:,1:jpl) =  ht_p(:,:,1:jpl) * a_i(:,:,1:jpl)  
     2336            CASE( 'no' )  
     2337               ztmp3(:,:,:) = 0.0  
     2338               ztmp4(:,:,:) = 0.0  
     2339               DO jl=1,jpl  
     2340                 ztmp3(:,:,1) = ztmp3(:,:,1) + a_p(:,:,jpl) * a_i(:,:,jpl)  
     2341                 ztmp4(:,:,1) = ztmp4(:,:,1) + ht_p(:,:,jpl) * a_i(:,:,jpl)  
     2342               ENDDO  
     2343            CASE default    ;   CALL ctl_stop( 'sbc_cpl_mpd: wrong definition of sn_snd_mpnd%clcat' )  
     2344            END SELECT  
     2345         CASE( 'ice only' )     
     2346            ztmp3(:,:,1:jpl) = a_p(:,:,1:jpl)  
     2347            ztmp4(:,:,1:jpl) = ht_p(:,:,1:jpl)  
     2348         END SELECT  
     2349         IF( ssnd(jps_a_p)%laction )   CALL cpl_snd( jps_a_p, isec, ztmp3, info )     
     2350         IF( ssnd(jps_ht_p)%laction )   CALL cpl_snd( jps_ht_p, isec, ztmp4, info )     
     2351         ! 
     2352         ! Send ice effective conductivity 
     2353         SELECT CASE( sn_snd_cond%cldes) 
     2354         CASE( 'weighted ice' )    
     2355            SELECT CASE( sn_snd_cond%clcat ) 
     2356            CASE( 'yes' )    
     2357               ztmp3(:,:,1:jpl) =  kn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     2358            CASE( 'no' ) 
     2359               ztmp3(:,:,:) = 0.0 
     2360               DO jl=1,jpl 
     2361                 ztmp3(:,:,1) = ztmp3(:,:,1) + kn_ice(:,:,jl) * a_i(:,:,jl) 
     2362               ENDDO 
     2363            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) 
     2364            END SELECT 
     2365         CASE( 'ice only' )    
     2366           ztmp3(:,:,1:jpl) = kn_ice(:,:,1:jpl) 
     2367         END SELECT 
     2368         IF( ssnd(jps_kice)%laction )   CALL cpl_snd( jps_kice, isec, ztmp3, info ) 
     2369      ENDIF 
     2370#endif 
     2371      ! 
     2372      ! 
    18472373#if defined key_cpl_carbon_cycle 
    18482374      !                                                      ! ------------------------- ! 
    … …  
    18522378      ! 
    18532379#endif 
     2380 
     2381 
     2382 
     2383      IF (ln_medusa) THEN 
     2384      !                                                      ! ---------------------------------------------- ! 
     2385      !                                                      !  CO2 flux, DMS and chlorophyll from MEDUSA     !  
     2386      !                                                      ! ---------------------------------------------- ! 
     2387         IF ( ssnd(jps_bio_co2)%laction ) THEN 
     2388            CALL cpl_snd( jps_bio_co2, isec, RESHAPE( CO2Flux_out_cpl, (/jpi,jpj,1/) ), info ) 
     2389         ENDIF 
     2390 
     2391         IF ( ssnd(jps_bio_dms)%laction )  THEN 
     2392            CALL cpl_snd( jps_bio_dms, isec, RESHAPE( DMS_out_cpl, (/jpi,jpj,1/) ), info ) 
     2393         ENDIF 
     2394 
     2395         IF ( ssnd(jps_bio_chloro)%laction )  THEN 
     2396            CALL cpl_snd( jps_bio_chloro, isec, RESHAPE( chloro_out_cpl, (/jpi,jpj,1/) ), info ) 
     2397         ENDIF 
     2398      ENDIF 
     2399 
    18542400      !                                                      ! ------------------------- ! 
    18552401      IF( ssnd(jps_ocx1)%laction ) THEN                      !      Surface current      ! 
    … …  
    18582404         !                                                  j+1   j     -----V---F 
    18592405         ! surface velocity always sent from T point                     !       | 
    1860          !                                                        j      |   T   U 
     2406         ! [except for HadGEM3]                                   j      |   T   U 
    18612407         !                                                               |       | 
    18622408         !                                                   j    j-1   -I-------| 
    … …  
    18672413            zotx1(:,:) = un(:,:,1)   
    18682414            zoty1(:,:) = vn(:,:,1)   
    1869          ELSE         
     2415         ELSE 
    18702416            SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
    18712417            CASE( 'oce only'             )      ! C-grid ==> T 
    1872                DO jj = 2, jpjm1 
    1873                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    1874                      zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
    1875                      zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
     2418               IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 
     2419                  DO jj = 2, jpjm1 
     2420                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     2421                        zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
     2422                        zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
     2423                     END DO 
    18762424                  END DO 
    1877                END DO 
     2425               ELSE 
     2426! Temporarily Changed for UKV 
     2427                  DO jj = 2, jpjm1 
     2428                     DO ji = 2, jpim1 
     2429                        zotx1(ji,jj) = un(ji,jj,1) 
     2430                        zoty1(ji,jj) = vn(ji,jj,1) 
     2431                     END DO 
     2432                  END DO 
     2433               ENDIF  
    18782434            CASE( 'weighted oce and ice' )    
    18792435               SELECT CASE ( cp_ice_msh ) 
    … …  
    19342490                  END DO 
    19352491               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
    1936                   DO jj = 2, jpjm1 
    1937                      DO ji = 2, jpim1   ! NO vector opt. 
    1938                         zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
    1939                            &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
    1940                            &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1941                         zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    1942                            &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
    1943                            &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     2492                  IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 
     2493                     DO jj = 2, jpjm1 
     2494                        DO ji = 2, jpim1   ! NO vector opt. 
     2495                           zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj,1) ) * zfr_l(ji,jj)   &    
     2496                                &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
     2497                                &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     2498                           zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji,jj-1,1) ) * zfr_l(ji,jj)   & 
     2499                                &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
     2500                                &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     2501                        END DO 
    19442502                     END DO 
    1945                   END DO 
     2503#if defined key_cice 
     2504                  ELSE 
     2505! Temporarily Changed for HadGEM3 
     2506                     DO jj = 2, jpjm1 
     2507                        DO ji = 2, jpim1   ! NO vector opt. 
     2508                           zotx1(ji,jj) = (1.0-fr_iu(ji,jj)) * un(ji,jj,1)             & 
     2509                                &              + fr_iu(ji,jj) * 0.5 * ( u_ice(ji,jj-1) + u_ice(ji,jj) )  
     2510                           zoty1(ji,jj) = (1.0-fr_iv(ji,jj)) * vn(ji,jj,1)             & 
     2511                                &              + fr_iv(ji,jj) * 0.5 * ( v_ice(ji-1,jj) + v_ice(ji,jj) )  
     2512                        END DO 
     2513                     END DO 
     2514#endif 
     2515                  ENDIF 
    19462516               END SELECT 
    19472517            END SELECT 
    … …  
    19532523         IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN             ! Rotation of the components 
    19542524            !                                                                     ! Ocean component 
    1955             CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 )       ! 1st component  
    1956             CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 )       ! 2nd component  
    1957             zotx1(:,:) = ztmp1(:,:)                                                   ! overwrite the components  
    1958             zoty1(:,:) = ztmp2(:,:) 
    1959             IF( ssnd(jps_ivx1)%laction ) THEN                                     ! Ice component 
    1960                CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 )    ! 1st component  
    1961                CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 )    ! 2nd component  
    1962                zitx1(:,:) = ztmp1(:,:)                                                ! overwrite the components  
    1963                zity1(:,:) = ztmp2(:,:) 
    1964             ENDIF 
     2525            IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 
     2526               CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 )       ! 1st component 
     2527               CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 )       ! 2nd component 
     2528               zotx1(:,:) = ztmp1(:,:)                                                   ! overwrite the components 
     2529               zoty1(:,:) = ztmp2(:,:) 
     2530               IF( ssnd(jps_ivx1)%laction ) THEN                                  ! Ice component 
     2531                  CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 )    ! 1st component 
     2532                  CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 )    ! 2nd component 
     2533                  zitx1(:,:) = ztmp1(:,:)                                                ! overwrite the components 
     2534                  zity1(:,:) = ztmp2(:,:) 
     2535               ENDIF 
     2536            ELSE 
     2537               ! Temporary code for HadGEM3 - will be removed eventually. 
     2538               ! Only applies when we want uvel on U grid and vvel on V grid 
     2539               ! Rotate U and V onto geographic grid before sending. 
     2540 
     2541               DO jj=2,jpjm1 
     2542                  DO ji=2,jpim1 
     2543                     ztmp1(ji,jj)=0.25*vmask(ji,jj,1)                  & 
     2544                          *(zotx1(ji,jj)+zotx1(ji-1,jj)    & 
     2545                          +zotx1(ji,jj+1)+zotx1(ji-1,jj+1)) 
     2546                     ztmp2(ji,jj)=0.25*umask(ji,jj,1)                  & 
     2547                          *(zoty1(ji,jj)+zoty1(ji+1,jj)    & 
     2548                          +zoty1(ji,jj-1)+zoty1(ji+1,jj-1)) 
     2549                  ENDDO 
     2550               ENDDO 
     2551 
     2552               ! Ensure any N fold and wrap columns are updated 
     2553               CALL lbc_lnk(ztmp1, 'V', -1.0) 
     2554               CALL lbc_lnk(ztmp2, 'U', -1.0) 
     2555                             
     2556               ikchoix = -1 
     2557               ! We need copies of zotx1 and zoty2 in order to avoid problems  
     2558               ! caused by INTENTs used in the following subroutine.  
     2559               zotx1_in(:,:) = zotx1(:,:) 
     2560               zoty1_in(:,:) = zoty1(:,:) 
     2561               CALL repcmo (zotx1_in,ztmp2,ztmp1,zoty1_in,zotx1,zoty1,ikchoix) 
     2562           ENDIF 
    19652563         ENDIF 
    19662564         ! 
    … …  
    20232621      IF( ssnd(jps_rnf   )%laction )  CALL cpl_snd( jps_rnf   , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) 
    20242622      IF( ssnd(jps_taum  )%laction )  CALL cpl_snd( jps_taum  , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) 
    2025  
     2623       
     2624#if defined key_cice 
     2625      ztmp1(:,:) = sstfrz(:,:) + rt0 
     2626      IF( ssnd(jps_sstfrz)%laction )  CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
     2627#endif 
     2628      ! 
    20262629      CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 
     2630      CALL wrk_dealloc( jpi,jpj, zotx1_in, zoty1_in ) 
    20272631      CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 
    20282632      ! 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    r7960 r9987  
    1515   USE dom_oce         ! ocean space and time domain 
    1616   USE domvvl 
    17    USE phycst, only : rcp, rau0, r1_rau0, rhosn, rhoic 
     17   USE eosbn2, only : eos_fzp ! Function to calculate freezing point of seawater 
     18   USE phycst, only : rcp, rau0, r1_rau0, rhosn, rhoic, rt0 
    1819   USE in_out_manager  ! I/O manager 
    1920   USE iom, ONLY : iom_put,iom_use              ! I/O manager library !!Joakim edit 
    … …  
    3738   USE ice_gather_scatter 
    3839   USE ice_calendar, only: dt 
     40# if defined key_cice4 
    3941   USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen 
    40 # if defined key_cice4 
    4142   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
    4243                strocnxT,strocnyT,                               &  
    … …  
    4546                flatn_f,fsurfn_f,fcondtopn_f,                    & 
    4647                uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl,   & 
    47                 swvdr,swvdf,swidr,swidf 
     48                swvdr,swvdf,swidr,swidf,Tf 
    4849   USE ice_therm_vertical, only: calc_Tsfc 
    4950#else 
     51   USE ice_state, only: aice,aicen,uvel,nt_hpnd,trcrn,vvel,vsno,& 
     52                vsnon,vice,vicen,nt_Tsfc 
    5053   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
    5154                strocnxT,strocnyT,                               &  
    52                 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,     & 
    53                 fresh_ai,fhocn_ai,fswthru_ai,frzmlt,          & 
     55                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,      & 
     56                fresh_ai,fhocn_ai,fswthru_ai,frzmlt,             & 
    5457                flatn_f,fsurfn_f,fcondtopn_f,                    & 
     58#ifdef key_asminc 
     59                daice_da,fresh_da,fsalt_da,                    & 
     60#endif 
    5561                uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl,   & 
    56                 swvdr,swvdf,swidr,swidf 
    57    USE ice_therm_shared, only: calc_Tsfc 
     62                swvdr,swvdf,swidr,swidf,Tf,                      & 
     63      !! When using NEMO with CICE, this change requires use of  
     64      !! one of the following two CICE branches: 
     65      !! - at CICE5.0,   hadax/r1015_GSI8_with_GSI7 
     66      !! - at CICE5.1.2, hadax/vn5.1.2_GSI8 
     67                keffn_top,Tn_top 
     68 
     69   USE ice_therm_shared, only: calc_Tsfc, heat_capacity 
     70   USE ice_shortwave, only: apeffn 
    5871#endif 
    5972   USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf 
    … …  
    161174      INTEGER, INTENT( in  ) ::   ksbc                ! surface forcing type 
    162175      REAL(wp), DIMENSION(:,:), POINTER :: ztmp1, ztmp2 
    163       REAL(wp) ::   zcoefu, zcoefv, zcoeff            ! local scalar 
     176      REAL(wp), DIMENSION(:,:,:), POINTER :: ztfrz3d 
    164177      INTEGER  ::   ji, jj, jl, jk                    ! dummy loop indices 
    165178      !!--------------------------------------------------------------------- 
    … …  
    174187      jj_off = INT ( (jpjglo - ny_global) / 2 ) 
    175188 
    176 #if defined key_nemocice_decomp 
    177       ! Pass initial SST from NEMO to CICE so ice is initialised correctly if 
    178       ! there is no restart file. 
    179       ! Values from a CICE restart file would overwrite this 
    180       IF ( .NOT. ln_rstart ) THEN     
    181          CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.)  
    182       ENDIF   
    183 #endif 
    184  
    185 ! Initialize CICE 
     189      ! Initialize CICE 
    186190      CALL CICE_Initialize 
    187191 
    188 ! Do some CICE consistency checks 
     192      ! Do some CICE consistency checks 
    189193      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 
    190194         IF ( calc_strair .OR. calc_Tsfc ) THEN 
    … …  
    198202 
    199203 
    200 ! allocate sbc_ice and sbc_cice arrays 
    201       IF( sbc_ice_alloc()      /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' ) 
     204      ! allocate sbc_ice and sbc_cice arrays 
     205      IF( sbc_ice_alloc()      /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_alloc : unable to allocate arrays' ) 
    202206      IF( sbc_ice_cice_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' ) 
    203207 
    204 ! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart 
     208      ! Ensure that no temperature points are below freezing if not a NEMO restart 
    205209      IF( .NOT. ln_rstart ) THEN 
    206          tsn(:,:,:,jp_tem) = MAX (tsn(:,:,:,jp_tem),Tocnfrz) 
     210 
     211         CALL wrk_alloc( jpi,jpj,jpk, ztfrz3d )  
     212         DO jk=1,jpk 
     213             CALL eos_fzp( tsn(:,:,jk,jp_sal), ztfrz3d(:,:,jk), fsdept_n(:,:,jk) ) 
     214         ENDDO 
     215         tsn(:,:,:,jp_tem) = MAX( tsn(:,:,:,jp_tem), ztfrz3d ) 
    207216         tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) 
    208       ENDIF 
    209  
    210       fr_iu(:,:)=0.0 
    211       fr_iv(:,:)=0.0 
     217         CALL wrk_dealloc( jpi,jpj,jpk, ztfrz3d )  
     218 
     219#if defined key_nemocice_decomp 
     220         ! Pass initial SST from NEMO to CICE so ice is initialised correctly if 
     221         ! there is no restart file. 
     222         ! Values from a CICE restart file would overwrite this 
     223         CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.)  
     224#endif 
     225 
     226      ENDIF   
     227 
     228      ! calculate surface freezing temperature and send to CICE 
     229      CALL  eos_fzp(sss_m(:,:), sstfrz(:,:), fsdept_n(:,:,1))  
     230      CALL nemo2cice(sstfrz,Tf, 'T', 1. ) 
    212231 
    213232      CALL cice2nemo(aice,fr_i, 'T', 1. ) 
    … …  
    220239! T point to U point 
    221240! T point to V point 
     241      fr_iu(:,:)=0.0 
     242      fr_iv(:,:)=0.0 
    222243      DO jj=1,jpjm1 
    223244         DO ji=1,jpim1 
    … …  
    283304  
    284305      CALL wrk_dealloc( jpi,jpj, ztmp1, ztmp2 ) 
    285       ! 
     306 
     307#if defined key_asminc 
     308      ! Initialize fresh water and salt fluxes from data assim    
     309      !  and data assimilation index to cice  
     310      nfresh_da(:,:) = 0.0    
     311      nfsalt_da(:,:) = 0.0    
     312      ndaice_da(:,:) = 0.0          
     313#endif 
     314      ! 
     315      ! In coupled mode get extra fields from CICE for passing back to atmosphere 
     316  
     317      IF ( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(nit000) 
     318      !  
    286319      IF( nn_timing == 1 )  CALL timing_stop('cice_sbc_init') 
    287320      ! 
    … …  
    343376         CALL nemo2cice(ztmp,stray,'F', -1. ) 
    344377 
     378 
     379! Alex West: From configuration GSI8 onwards, when NEMO is used with CICE in 
     380! HadGEM3 the 'time-travelling ice' coupling approach is used, whereby  
     381! atmosphere-ice fluxes are passed as pseudo-local values, formed by dividing 
     382! gridbox mean fluxes in the UM by future ice concentration obtained through   
     383! OASIS.  This allows for a much more realistic apportionment of energy through 
     384! the ice - and conserves energy. 
     385! Therefore the fluxes are now divided by ice concentration in the coupled 
     386! formulation (jp_purecpl) as well as for jp_flx.  This NEMO branch should only 
     387! be used at UM10.2 onwards (unless an explicit GSI8 UM branch is included), at 
     388! which point the GSI8 UM changes were committed. 
     389 
    345390! Surface downward latent heat flux (CI_5) 
    346391         IF (ksbc == jp_flx) THEN 
    … …  
    348393               ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl) 
    349394            ENDDO 
    350          ELSE 
    351 ! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow 
    352             qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * Lsub 
    353 ! End of temporary code 
    354             DO jj=1,jpj 
    355                DO ji=1,jpi 
    356                   IF (fr_i(ji,jj).eq.0.0) THEN 
    357                      DO jl=1,ncat 
    358                         ztmpn(ji,jj,jl)=0.0 
    359                      ENDDO 
    360                      ! This will then be conserved in CICE 
    361                      ztmpn(ji,jj,1)=qla_ice(ji,jj,1) 
    362                   ELSE 
    363                      DO jl=1,ncat 
    364                         ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj) 
    365                      ENDDO 
    366                   ENDIF 
    367                ENDDO 
     395         ELSE IF (ksbc == jp_purecpl) THEN 
     396            DO jl=1,ncat 
     397               ztmpn(:,:,jl)=qla_ice(:,:,jl)*a_i(:,:,jl) 
    368398            ENDDO 
     399    ELSE 
     400           !In coupled mode - qla_ice calculated in sbc_cpl for each category 
     401           ztmpn(:,:,1:ncat)=qla_ice(:,:,1:ncat) 
    369402         ENDIF 
     403 
    370404         DO jl=1,ncat 
    371405            CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. ) 
    … …  
    373407! GBM conductive flux through ice (CI_6) 
    374408!  Convert to GBM 
    375             IF (ksbc == jp_flx) THEN 
     409            IF (ksbc == jp_flx .OR. ksbc == jp_purecpl) THEN 
    376410               ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl) 
    377411            ELSE 
    … …  
    382416! GBM surface heat flux (CI_7) 
    383417!  Convert to GBM 
    384             IF (ksbc == jp_flx) THEN 
     418            IF (ksbc == jp_flx .OR. ksbc == jp_purecpl) THEN 
    385419               ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl)  
    386420            ELSE 
    … …  
    431465      ENDIF 
    432466 
     467#if defined key_asminc 
     468!Ice concentration change (from assimilation) 
     469      ztmp(:,:)=ndaice_da(:,:)*tmask(:,:,1) 
     470      Call nemo2cice(ztmp,daice_da,'T', 1. ) 
     471#endif  
     472 
    433473! Snowfall 
    434474! Ensure fsnow is positive (as in CICE routine prepare_forcing) 
    435475      IF( iom_use('snowpre') )   CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit   
    436       ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0)   
     476      IF( kt == nit000 .AND. lwp )  THEN 
     477         WRITE(numout,*) 'sprecip weight, rn_sfac=', rn_sfac 
     478      ENDIF 
     479      ztmp(:,:)=MAX(fr_i(:,:)*rn_sfac*sprecip(:,:),0.0)   
    437480      CALL nemo2cice(ztmp,fsnow,'T', 1. )  
    438481 
    … …  
    442485      CALL nemo2cice(ztmp,frain,'T', 1. )  
    443486 
     487! Recalculate freezing temperature and send to CICE  
     488      CALL eos_fzp(sss_m(:,:), sstfrz(:,:), fsdept_n(:,:,1))  
     489      CALL nemo2cice(sstfrz,Tf,'T', 1. ) 
     490 
    444491! Freezing/melting potential 
    445492! Calculated over NEMO leapfrog timestep (hence 2*dt) 
    446       nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,:)*(Tocnfrz-sst_m(:,:))/(2.0*dt) 
    447  
    448       ztmp(:,:) = nfrzmlt(:,:) 
    449       CALL nemo2cice(ztmp,frzmlt,'T', 1. ) 
     493      nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,:)*(sstfrz(:,:)-sst_m(:,:))/(2.0*dt)  
     494      CALL nemo2cice(nfrzmlt,frzmlt,'T', 1. ) 
    450495 
    451496! SST  and SSS 
    … …  
    453498      CALL nemo2cice(sst_m,sst,'T', 1. ) 
    454499      CALL nemo2cice(sss_m,sss,'T', 1. ) 
     500 
     501      IF( ksbc == jp_purecpl ) THEN 
     502! Sea ice surface skin temperature 
     503         DO jl=1,ncat 
     504           CALL nemo2cice(tsfc_ice(:,:,jl), trcrn(:,:,nt_tsfc,jl,:),'T',1.) 
     505         ENDDO  
     506      ENDIF 
    455507 
    456508! x comp and y comp of surface ocean current 
    … …  
    685737      ENDIF 
    686738 
     739#if defined key_asminc 
     740! Import fresh water and salt flux due to seaice da 
     741      CALL cice2nemo(fresh_da, nfresh_da,'T',1.0) 
     742      CALL cice2nemo(fsalt_da, nfsalt_da,'T',1.0) 
     743#endif 
     744 
    687745! Release work space 
    688746 
    … …  
    708766      IF( nn_timing == 1 )  CALL timing_start('cice_sbc_hadgam') 
    709767      ! 
    710       IF( kt == nit000 )  THEN 
    711          IF(lwp) WRITE(numout,*)'cice_sbc_hadgam' 
    712          IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 
    713       ENDIF 
    714  
    715768      !                                         ! =========================== ! 
    716769      !                                         !   Prepare Coupling fields   ! 
    … …  
    730783         CALL cice2nemo(vicen(:,:,jl,:),ht_i(:,:,jl),'T', 1. ) 
    731784      ENDDO 
     785 
     786#if ! defined key_cice4 
     787! Meltpond fraction and depth 
     788      DO jl = 1,ncat 
     789         CALL cice2nemo(apeffn(:,:,jl,:),a_p(:,:,jl),'T', 1. ) 
     790         CALL cice2nemo(trcrn(:,:,nt_hpnd,jl,:),ht_p(:,:,jl),'T', 1. ) 
     791      ENDDO 
     792#endif 
     793 
     794 
     795! If using multilayers thermodynamics in CICE then get top layer temperature 
     796! and effective conductivity        
     797!! When using NEMO with CICE, this change requires use of  
     798!! one of the following two CICE branches: 
     799!! - at CICE5.0,   hadax/r1015_GSI8_with_GSI7 
     800!! - at CICE5.1.2, hadax/vn5.1.2_GSI8 
     801      IF (heat_capacity) THEN 
     802         DO jl = 1,ncat 
     803            CALL cice2nemo(Tn_top(:,:,jl,:),tn_ice(:,:,jl),'T', 1. ) 
     804            CALL cice2nemo(keffn_top(:,:,jl,:),kn_ice(:,:,jl),'T', 1. ) 
     805         ENDDO 
     806! Convert surface temperature to Kelvin 
     807         tn_ice(:,:,:)=tn_ice(:,:,:)+rt0 
     808      ELSE 
     809         tn_ice(:,:,:) = 0.0 
     810         kn_ice(:,:,:) = 0.0 
     811      ENDIF        
     812 
    732813      ! 
    733814      IF( nn_timing == 1 )  CALL timing_stop('cice_sbc_hadgam') 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r7960 r9987  
    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         !----------------------------! 
    … …  
    264261      !!---------------------------------------------------------------------- 
    265262      INTEGER :: ierr 
     263      INTEGER :: ji, jj 
    266264      !!---------------------------------------------------------------------- 
    267265      IF(lwp) WRITE(numout,*) 
    … …  
    320318      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
    321319      ! 
     320      DO jj = 1, jpj 
     321         DO ji = 1, jpi 
     322            IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
     323            ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
     324            ENDIF 
     325        ENDDO 
     326      ENDDO  
     327      ! 
    322328      nstart = numit  + nn_fsbc       
    323329      nitrun = nitend - nit000 + 1  
    … …  
    342348      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    343349      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   
     350         &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    345351      !!------------------------------------------------------------------- 
    346352      !                     
    … …  
    363369         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    364370         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    365          WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     371         WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
     372         WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
    366373         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    367374         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    578585      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    579586      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    580       sfx_res(:,:) = 0._wp 
     587      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
    581588       
    582589      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    594601      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    595602      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    596       hfx_err_dif(:,:) = 0._wp   ; 
    597  
     603      hfx_err_dif(:,:) = 0._wp 
     604      wfx_err_sub(:,:) = 0._wp 
     605       
    598606      afx_tot(:,:) = 0._wp   ; 
    599607      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r7960 r9987  
    2626   USE zdfbfr 
    2727   USE fldread         ! read input field at current time step 
    28  
    29  
     28   USE lib_fortran, ONLY: glob_sum 
    3029 
    3130   IMPLICIT NONE 
    … …  
    5352   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5453   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 
    6054   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    61 #endif 
    6255 
    6356 
    … …  
    9083    INTEGER                      ::   ji, jj, jk, ijkmin, inum, ierror 
    9184    INTEGER                      ::   ikt, ikb   ! top and bottom level of the isf boundary layer 
     85    REAL(wp)                     ::   zgreenland_fwfisf_sum, zantarctica_fwfisf_sum 
    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 
    9792    INTEGER           ::   ios           ! Local integer output status for namelist read 
     93 
     94    REAL(wp), DIMENSION(:,:,:), POINTER :: zfwfisf3d, zqhcisf3d, zqlatisf3d 
     95    REAL(wp), DIMENSION(:,:  ), POINTER :: zqhcisf2d 
    9896      ! 
    9997      !!--------------------------------------------------------------------- 
    … …  
    176174              DO jj = 1, jpj 
    177175                  jk = 2 
    178                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     176                  DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    179177                  misfkt(ji,jj) = jk-1 
    180178               END DO 
    … …  
    194192         END IF 
    195193          
     194         ! save initial top boundary layer thickness          
    196195         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
     196 
     197      END IF 
     198 
     199      !                                            ! ---------------------------------------- ! 
     200      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
     201         !                                         ! ---------------------------------------- ! 
     202         fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
     203         risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
     204         ! 
     205      ENDIF 
     206 
     207      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    197208 
    198209         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    … …  
    205216 
    206217               ! determine the deepest level influenced by the boundary layer 
    207                ! test on tmask useless ????? 
    208218               DO jk = ikt, mbkt(ji,jj) 
    209219                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    … …  
    217227            END DO 
    218228         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  
    232229 
    233230         ! compute salf and heat flux 
    … …  
    256253            CALL fld_read ( kt, nn_fsbc, sf_rnfisf   ) 
    257254            fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fresh water flux from the isf (fwfisf <0 mean melting)  
     255 
     256            IF( lk_oasis) THEN 
     257            ! nn_coupled_iceshelf_fluxes uninitialised unless lk_oasis=true 
     258            IF( nn_coupled_iceshelf_fluxes .gt. 0 ) THEN 
     259 
     260              ! Adjust total iceshelf melt rates so that sum of iceberg calving and iceshelf melting in the northern 
     261              ! and southern hemispheres equals rate of increase of mass of greenland and antarctic ice sheets 
     262              ! to preserve total freshwater conservation in coupled models without an active ice sheet model. 
     263  
     264              ! All related global sums must be done bit reproducibly 
     265               zgreenland_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * greenland_icesheet_mask(:,:) ) 
     266 
     267               ! use ABS function because we need to preserve the sign of fwfisf 
     268               WHERE( greenland_icesheet_mask(:,:) == 1.0 )                                                                  & 
     269              &    fwfisf(:,:) = fwfisf(:,:)  * ABS( greenland_icesheet_mass_rate_of_change * (1.0-rn_greenland_calving_fraction) & 
     270              &                           / ( zgreenland_fwfisf_sum + 1.0e-10_wp ) ) 
     271 
     272               ! check 
     273               IF(lwp) WRITE(numout, *) 'Greenland iceshelf melting climatology (kg/s) : ',zgreenland_fwfisf_sum 
     274 
     275               zgreenland_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * greenland_icesheet_mask(:,:) ) 
     276 
     277               IF(lwp) WRITE(numout, *) 'Greenland iceshelf melting adjusted value (kg/s) : ',zgreenland_fwfisf_sum 
     278 
     279               zantarctica_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * antarctica_icesheet_mask(:,:) ) 
     280 
     281               ! use ABS function because we need to preserve the sign of fwfisf 
     282               WHERE( antarctica_icesheet_mask(:,:) == 1.0 ) & 
     283              &    fwfisf(:,:) = fwfisf(:,:)  * ABS( antarctica_icesheet_mass_rate_of_change * (1.0-rn_antarctica_calving_fraction) & 
     284              &                           / ( zantarctica_fwfisf_sum + 1.0e-10_wp ) ) 
     285       
     286               ! check 
     287               IF(lwp) WRITE(numout, *) 'Antarctica iceshelf melting climatology (kg/s) : ',zantarctica_fwfisf_sum 
     288 
     289               zantarctica_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * antarctica_icesheet_mask(:,:) ) 
     290 
     291               IF(lwp) WRITE(numout, *) 'Antarctica iceshelf melting adjusted value (kg/s) : ',zantarctica_fwfisf_sum 
     292 
     293            ENDIF 
     294            ENDIF 
     295 
    258296            qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
    259297            stbl(:,:)   = soce 
    … …  
    264302            !CALL fld_read ( kt, nn_fsbc, sf_qisf   ) 
    265303            fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1)            ! fwf 
     304 
     305            IF( lk_oasis) THEN 
     306            ! nn_coupled_iceshelf_fluxes uninitialised unless lk_oasis=true 
     307            IF( nn_coupled_iceshelf_fluxes .gt. 0 ) THEN 
     308 
     309              ! Adjust total iceshelf melt rates so that sum of iceberg calving and iceshelf melting in the northern 
     310              ! and southern hemispheres equals rate of increase of mass of greenland and antarctic ice sheets 
     311              ! to preserve total freshwater conservation in coupled models without an active ice sheet model. 
     312 
     313              ! All related global sums must be done bit reproducibly 
     314               zgreenland_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * greenland_icesheet_mask(:,:) ) 
     315 
     316               ! use ABS function because we need to preserve the sign of fwfisf 
     317               WHERE( greenland_icesheet_mask(:,:) == 1.0 )                                                                  & 
     318              &    fwfisf(:,:) = fwfisf(:,:)  * ABS( greenland_icesheet_mass_rate_of_change * (1.0-rn_greenland_calving_fraction) & 
     319              &                           / ( zgreenland_fwfisf_sum + 1.0e-10_wp ) ) 
     320 
     321               ! check 
     322               IF(lwp) WRITE(numout, *) 'Greenland iceshelf melting climatology (kg/s) : ',zgreenland_fwfisf_sum 
     323 
     324               zgreenland_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * greenland_icesheet_mask(:,:) ) 
     325 
     326               IF(lwp) WRITE(numout, *) 'Greenland iceshelf melting adjusted value (kg/s) : ',zgreenland_fwfisf_sum 
     327 
     328               zantarctica_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * antarctica_icesheet_mask(:,:) ) 
     329 
     330               ! use ABS function because we need to preserve the sign of fwfisf 
     331               WHERE( antarctica_icesheet_mask(:,:) == 1.0 ) & 
     332              &    fwfisf(:,:) = fwfisf(:,:)  * ABS( antarctica_icesheet_mass_rate_of_change * (1.0-rn_antarctica_calving_fraction) & 
     333              &                           / ( zantarctica_fwfisf_sum + 1.0e-10_wp ) ) 
     334       
     335               ! check 
     336               IF(lwp) WRITE(numout, *) 'Antarctica iceshelf melting climatology (kg/s) : ',zantarctica_fwfisf_sum 
     337 
     338               zantarctica_fwfisf_sum = glob_sum( fwfisf(:,:) * e1t(:,:) * e2t(:,:) * antarctica_icesheet_mask(:,:) ) 
     339 
     340               IF(lwp) WRITE(numout, *) 'Antarctica iceshelf melting adjusted value (kg/s) : ',zantarctica_fwfisf_sum 
     341 
     342            ENDIF 
     343            ENDIF 
     344 
    266345            qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
    267346            !qisf(:,:)   = sf_qisf(1)%fnow(:,:,1)              ! heat flux 
    … …  
    270349         END IF 
    271350         ! 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 ! 
     351         ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
     352!         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     353         zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
     354         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
    274355          
    275356         ! salt effect already take into account in vertical advection 
    276357         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    277            
     358 
     359         ! output 
     360         IF( iom_use('qlatisf' ) )   CALL iom_put('qlatisf', qisf) 
     361         IF( iom_use('fwfisf'  ) )   CALL iom_put('fwfisf' , fwfisf * stbl(:,:) / soce ) 
     362 
     363         ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
     364         fwfisf(:,:) = rdivisf * fwfisf(:,:)          
     365  
    278366         ! lbclnk 
    279367         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    … …  
    281369         CALL lbc_lnk(fwfisf(:,:)   ,'T',1.) 
    282370         CALL lbc_lnk(qisf(:,:)     ,'T',1.) 
     371 
     372!============================================================================================================================================= 
     373         IF ( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN 
     374            CALL wrk_alloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
     375            CALL wrk_alloc( jpi,jpj,     zqhcisf2d                        ) 
     376 
     377            zfwfisf3d(:,:,:) = 0.0_wp                         ! 3d ice shelf melting (kg/m2/s) 
     378            zqhcisf3d(:,:,:) = 0.0_wp                         ! 3d heat content flux (W/m2) 
     379            zqlatisf3d(:,:,:)= 0.0_wp                         ! 3d ice shelf melting latent heat flux (W/m2) 
     380            zqhcisf2d(:,:)   = fwfisf(:,:) * zt_frz * rcp     ! 2d heat content flux (W/m2) 
     381 
     382            DO jj = 1,jpj 
     383               DO ji = 1,jpi 
     384                  ikt = misfkt(ji,jj) 
     385                  ikb = misfkb(ji,jj) 
     386                  DO jk = ikt, ikb - 1 
     387                     zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf   (ji,jj) * r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 
     388                     zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 
     389                     zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf     (ji,jj) * r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 
     390                  END DO 
     391                  zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf   (ji,jj) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) * fse3t(ji,jj,jk) 
     392                  zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) * fse3t(ji,jj,jk) 
     393                  zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf     (ji,jj) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) * fse3t(ji,jj,jk) 
     394               END DO 
     395            END DO 
     396 
     397            CALL iom_put('fwfisf3d' , zfwfisf3d (:,:,:)) 
     398            CALL iom_put('qlatisf3d', zqlatisf3d(:,:,:)) 
     399            CALL iom_put('qhcisf3d' , zqhcisf3d (:,:,:)) 
     400            CALL iom_put('qhcisf'   , zqhcisf2d (:,:  )) 
     401 
     402            CALL wrk_dealloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
     403            CALL wrk_dealloc( jpi,jpj,     zqhcisf2d                        ) 
     404         END IF 
     405!============================================================================================================================================= 
    283406 
    284407         IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    … …  
    295418         ENDIF 
    296419         !  
    297          ! output 
    298          CALL iom_put('qisf'  , qisf) 
    299          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    300420      END IF 
    301421   
    … …  
    370490             ! Calculate freezing temperature 
    371491                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    372                 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
     492                CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    373493                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    374494             ENDDO 
    … …  
    452572      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    453573! Calculate freezing temperature 
    454       zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
     574      CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    455575 
    456576       
    … …  
    472592 
    473593                     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 
     594                     IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     595 
    479596! save gammat and compute zhtflx_b 
    480597                     zgammat2d(ji,jj)=zgammat 
    … …  
    794911               ! test on tmask useless ????? 
    795912               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 
     913                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    797914               END DO 
    798915               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 

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

    r7960 r9987  
    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 
    … …  
    265266      ENDIF 
    266267      ! 
    267       IF( lk_oasis )   CALL sbc_cpl_init (nn_ice)   ! OASIS initialisation. must be done before: (1) first time step 
    268       !                                                     !                                            (2) the use of nn_fsbc 
     268      IF( lk_oasis ) THEN 
     269         IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )          
     270         CALL sbc_cpl_init (nn_ice)   ! OASIS initialisation. must be done before: (1) first time step 
     271                                      !                                            (2) the use of nn_fsbc 
     272      ENDIF 
    269273 
    270274!     nn_fsbc initialization if OPA-SAS coupling via OASIS 
    … …  
    339343         emp_b(:,:) = emp(:,:) 
    340344         sfx_b(:,:) = sfx(:,:) 
     345         IF ( ln_rnf ) THEN 
     346            rnf_b    (:,:  ) = rnf    (:,:  ) 
     347            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     348         ENDIF 
    341349      ENDIF 
    342350      !                                            ! ---------------------------------------- ! 
    … …  
    455463      !                                                ! ---------------------------------------- ! 
    456464      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    457          CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
     465         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
     466         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    458467         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    459468                                                                ! (includes virtual salt flux beneath ice  

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

    r7960 r9987  
    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   ! 
    … …  
    126118      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    127119      ! 
    128       ! Runoff reduction only associated to the ORCA2_LIM configuration 
    129       ! when reading the NetCDF file runoff_1m_nomask.nc 
    130       IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
    131          WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    132             sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
    133          END WHERE 
    134       ENDIF 
    135       ! 
    136120      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
    137121         ! 
    138122         IF( .NOT. l_rnfcpl )   rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt 
     123         CALL lbc_lnk(rnf(:,:), 'T', 1._wp) 
    139124         ! 
    140125         !                                                     ! set temperature & salinity content of runoffs 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SOL/solpcg.F90

    r7960 r9987  
    9393      REAL(wp) ::   zgcad        ! temporary scalars 
    9494      REAL(wp), DIMENSION(2) ::   zsum 
    95       REAL(wp), POINTER, DIMENSION(:,:) ::   zgcr 
     95      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zgcr 
    9696      !!---------------------------------------------------------------------- 
    9797      ! 
    9898      IF( nn_timing == 1 )  CALL timing_start('sol_pcg') 
    9999      ! 
    100       CALL wrk_alloc( jpi, jpj, zgcr ) 
     100      ALLOCATE( zgcr(1:jpi,1:jpj) ) 
    101101      ! 
    102102      ! Initialization of the algorithm with standard PCG 
    … …  
    210210      CALL lbc_lnk( gcx, c_solver_pt, 1. )      ! Output in gcx with lateral b.c. applied 
    211211      !  
    212       CALL wrk_dealloc( jpi, jpj, zgcr ) 
     212      DEALLOCATE ( zgcr ) 
    213213      ! 
    214214      IF( nn_timing == 1 )  CALL timing_stop('sol_pcg') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r7959 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r7960 r9987  
    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 
    … …  
    311312      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celcius] 
    312313      !                                                                ! 2 : salinity               [psu] 
    313       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    314       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     314      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(inout) ::   prd    ! in situ density            [-] 
     315      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(inout) ::   prhop  ! potential density (surface referenced) 
    315316      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    316317      ! 
    … …  
    456457      END SELECT 
    457458      ! 
     459      CALL lbc_lnk( prd, 'T', 1.0_wp ) 
     460      ! 
    458461      IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 
    459462      ! 
    … …  
    901904      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celcius,psu] 
    902905      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celcius-1,psu-1] 
    903       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     906      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(inout) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    904907      ! 
    905908      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    991994 
    992995 
    993    FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     996   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
    994997      !!---------------------------------------------------------------------- 
    995998      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10051008      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10061009      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1007       REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1010      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
    10081011      ! 
    10091012      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    10171020         DO jj = 1, jpj 
    10181021            DO ji = 1, jpi 
    1019                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1022               zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp )           ! square root salinity 
    10201023               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10211024                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10381041         nstop = nstop + 1 
    10391042         ! 
    1040       END SELECT 
    1041       ! 
    1042    END FUNCTION eos_fzp_2d 
    1043  
    1044   FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1043      END SELECT       
     1044      ! 
     1045  END SUBROUTINE eos_fzp_2d 
     1046 
     1047  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    10451048      !!---------------------------------------------------------------------- 
    10461049      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10541057      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10551058      !!---------------------------------------------------------------------- 
    1056       REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
    1057       REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
    1058       REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1059      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
     1060      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
     1061      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
    10591062      ! 
    10601063      REAL(wp) :: zs   ! local scalars 
    … …  
    10651068      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    10661069         ! 
    1067          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1070         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity 
    10681071         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10691072                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10861089      END SELECT 
    10871090      ! 
    1088    END FUNCTION eos_fzp_0d 
     1091   END SUBROUTINE eos_fzp_0d 
    10891092 
    10901093 
    … …  
    12551258            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12561259         ENDIF 
     1260      ENDIF 
     1261      ! 
     1262      ! Consistency check on ln_useCT and nn_eos 
     1263      IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 
     1264         CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 
     1265      ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 
     1266         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)") 
    12571267      ENDIF 
    12581268      ! 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r7960 r9987  
    2626   USE cla             ! cross land advection      (cla_traadv     routine) 
    2727   USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     28   USE trd_oce         ! trends: ocean variables 
     29   USE trdtra          ! trends manager: tracers  
    2830   ! 
    2931   USE in_out_manager  ! I/O manager 
    … …  
    7880      ! 
    7981      INTEGER ::   jk   ! dummy loop index 
    80       REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 
     82      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zun, zvn, zwn 
     83      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds   ! 3D workspace 
    8184      !!---------------------------------------------------------------------- 
    8285      ! 
    8386      IF( nn_timing == 1 )  CALL timing_start('tra_adv') 
    8487      ! 
    85       CALL wrk_alloc( jpi, jpj, jpk, zun, zvn, zwn ) 
     88      ALLOCATE(zun(1:jpi, 1:jpj, 1:jpk)) 
     89      ALLOCATE(zvn(1:jpi, 1:jpj, 1:jpk)) 
     90      ALLOCATE(zwn(1:jpi, 1:jpj, 1:jpk)) 
    8691      !                                          ! set time step 
    8792      IF( neuler == 0 .AND. kt == nit000 ) THEN     ! at nit000 
    … …  
    120125      IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
    121126      ! 
    122     
     127      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     128         ALLOCATE(ztrdt( 1:jpi, 1:jpj, 1:jpk) ) 
     129         ALLOCATE(ztrds( 1:jpi, 1:jpj, 1:jpk) ) 
     130         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     131         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     132      ENDIF 
     133      ! 
    123134      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    124135      CASE ( 1 )   ;    CALL tra_adv_cen2   ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    … …  
    151162      END SELECT 
    152163      ! 
     164      IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics 
     165         DO jk = 1, jpkm1 
     166            ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) 
     167            ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) 
     168         END DO 
     169         CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 
     170         CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 
     171         DEALLOCATE (ztrdt) 
     172         DEALLOCATE (ztrds) 
     173      ENDIF 
    153174      !                                              ! print mean trends (used for debugging) 
    154175      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
    … …  
    157178      IF( nn_timing == 1 )  CALL timing_stop( 'tra_adv' ) 
    158179      ! 
    159       CALL wrk_dealloc( jpi, jpj, jpk, zun, zvn, zwn ) 
     180      DEALLOCATE(zun) 
     181      DEALLOCATE(zvn) 
     182      DEALLOCATE(zwn) 
    160183      !                                           
    161184   END SUBROUTINE tra_adv 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r7960 r9987  
    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 
    … …  
    279279         END IF 
    280280         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    281          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    282            IF( jn == jp_tem )   htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    283            IF( jn == jp_sal )   str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    284          ENDIF 
     281         IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 
    285282         ! 
    286283      END DO 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r7960 r9987  
    2828   USE wrk_nemo        ! Memory Allocation 
    2929   USE timing          ! Timing 
     30   USE diaptr         ! Heat/Salt transport diagnostics 
     31   USE trddyn 
     32   USE trd_oce 
    3033 
    3134   IMPLICIT NONE 
    … …  
    7881# endif   
    7982      REAL(wp), POINTER, DIMENSION(:,:) :: zu_eiv, zv_eiv, zw_eiv, z2d 
     83      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, z3d_T 
    8084      !!---------------------------------------------------------------------- 
    8185      ! 
    … …  
    8488# if defined key_diaeiv  
    8589      CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 
     90      CALL wrk_alloc( jpi, jpj, jpk, z3d, z3d_T ) 
    8691# else 
    8792      CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) 
    … …  
    160165         CALL iom_put( "voce_eiv", v_eiv )    ! j-eiv current 
    161166         CALL iom_put( "woce_eiv", w_eiv )    ! vert. eiv current 
    162          IF( iom_use('ueiv_heattr') ) THEN 
    163             zztmp = 0.5 * rau0 * rcp  
     167         IF( iom_use('weiv_masstr') ) THEN   ! vertical mass transport & its square value 
     168           z2d(:,:) = rau0 * e12t(:,:) 
     169           DO jk = 1, jpk 
     170              z3d(:,:,jk) = w_eiv(:,:,jk) * z2d(:,:) 
     171           END DO 
     172           CALL iom_put( "weiv_masstr" , z3d )   
     173         ENDIF 
     174         IF( iom_use("ueiv_masstr") .OR. iom_use("ueiv_heattr") .OR. iom_use('ueiv_heattr3d')        & 
     175                                    .OR. iom_use("ueiv_salttr") .OR. iom_use('ueiv_salttr3d') ) THEN 
     176            z3d(:,:,jpk) = 0.e0 
     177            z2d(:,:) = 0.e0 
     178            DO jk = 1, jpkm1 
     179               z3d(:,:,jk) = rau0 * u_eiv(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 
     180               z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 
     181            END DO 
     182            CALL iom_put( "ueiv_masstr", z3d )                  ! mass transport in i-direction 
     183         ENDIF 
     184 
     185         IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN 
     186            zztmp = 0.5 * rcp  
    164187            z2d(:,:) = 0.e0  
    165             DO jk = 1, jpkm1 
    166                DO jj = 2, jpjm1 
    167                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    168                      z2d(ji,jj) = z2d(ji,jj) + u_eiv(ji,jj,jk) & 
    169                        &         * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e2u(ji,jj) * fse3u(ji,jj,jk)  
    170                   END DO 
    171                END DO 
    172             END DO 
    173             CALL lbc_lnk( z2d, 'U', -1. ) 
    174             CALL iom_put( "ueiv_heattr", zztmp * z2d )                  ! heat transport in i-direction 
     188            z3d_T(:,:,:) = 0.e0  
     189            DO jk = 1, jpkm1 
     190               DO jj = 2, jpjm1 
     191                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     192                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
     193                     z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk)  
     194                  END DO 
     195               END DO 
     196            END DO 
     197            IF (iom_use('ueiv_heattr') ) THEN 
     198               CALL lbc_lnk( z2d, 'U', -1. ) 
     199               CALL iom_put( "ueiv_heattr", zztmp * z2d )                  ! 2D heat transport in i-direction 
     200            ENDIF 
     201            IF (iom_use('ueiv_heattr3d') ) THEN 
     202               CALL lbc_lnk( z3d_T, 'U', -1. ) 
     203               CALL iom_put( "ueiv_heattr3d", zztmp * z3d_T )              ! 3D heat transport in i-direction 
     204            ENDIF 
     205         ENDIF 
     206 
     207         IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d') ) THEN 
     208            zztmp = 0.5 * 0.001 
     209            z2d(:,:) = 0.e0  
     210            z3d_T(:,:,:) = 0.e0  
     211            DO jk = 1, jpkm1 
     212               DO jj = 2, jpjm1 
     213                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     214                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
     215                     z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk)  
     216                  END DO 
     217               END DO 
     218            END DO 
     219            IF (iom_use('ueiv_salttr') ) THEN 
     220               CALL lbc_lnk( z2d, 'U', -1. ) 
     221               CALL iom_put( "ueiv_salttr", zztmp * z2d )                  ! 2D salt transport in i-direction 
     222            ENDIF 
     223            IF (iom_use('ueiv_salttr3d') ) THEN 
     224               CALL lbc_lnk( z3d_T, 'U', -1. ) 
     225               CALL iom_put( "ueiv_salttr3d", zztmp * z3d_T )              ! 3D salt transport in i-direction 
     226            ENDIF 
     227         ENDIF 
     228 
     229         IF( iom_use("veiv_masstr") .OR. iom_use("veiv_heattr") .OR. iom_use('veiv_heattr3d')       & 
     230                                    .OR. iom_use("veiv_salttr") .OR. iom_use('veiv_salttr3d') ) THEN 
     231            z3d(:,:,jpk) = 0.e0 
     232            DO jk = 1, jpkm1 
     233               z3d(:,:,jk) = rau0 * v_eiv(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) 
     234            END DO 
     235            CALL iom_put( "veiv_masstr", z3d )                  ! mass transport in j-direction 
    175236         ENDIF 
    176237             
    177          IF( iom_use('veiv_heattr') ) THEN 
    178             zztmp = 0.5 * rau0 * rcp  
     238         IF( iom_use('veiv_heattr') .OR. iom_use('veiv_heattr3d') ) THEN 
     239            zztmp = 0.5 * rcp  
    179240            z2d(:,:) = 0.e0  
    180             DO jk = 1, jpkm1 
    181                DO jj = 2, jpjm1 
    182                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    183                      z2d(ji,jj) = z2d(ji,jj) + v_eiv(ji,jj,jk) & 
    184                      &           * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e1v(ji,jj) * fse3v(ji,jj,jk)  
    185                   END DO 
    186                END DO 
    187             END DO 
    188             CALL lbc_lnk( z2d, 'V', -1. ) 
    189             CALL iom_put( "veiv_heattr", zztmp * z2d )                  !  heat transport in i-direction 
    190          ENDIF 
     241            z3d_T(:,:,:) = 0.e0  
     242            DO jk = 1, jpkm1 
     243               DO jj = 2, jpjm1 
     244                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     245                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
     246                     z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk)  
     247                  END DO 
     248               END DO 
     249            END DO 
     250            IF (iom_use('veiv_heattr') ) THEN 
     251               CALL lbc_lnk( z2d, 'V', -1. ) 
     252               CALL iom_put( "veiv_heattr", zztmp * z2d )                  ! 2D heat transport in j-direction 
     253            ENDIF 
     254            IF (iom_use('veiv_heattr3d') ) THEN 
     255               CALL lbc_lnk( z3d_T, 'V', -1. ) 
     256               CALL iom_put( "veiv_heattr3d", zztmp * z3d_T )              ! 3D heat transport in j-direction 
     257            ENDIF 
     258         ENDIF 
     259 
     260         IF( iom_use('veiv_salttr') .OR. iom_use('veiv_salttr3d') ) THEN 
     261            zztmp = 0.5 * 0.001 
     262            z2d(:,:) = 0.e0  
     263            z3d_T(:,:,:) = 0.e0  
     264            DO jk = 1, jpkm1 
     265               DO jj = 2, jpjm1 
     266                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     267                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
     268                     z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 
     269                  END DO 
     270               END DO 
     271            END DO 
     272            IF (iom_use('veiv_salttr') ) THEN 
     273               CALL lbc_lnk( z2d, 'V', -1. ) 
     274               CALL iom_put( "veiv_salttr", zztmp * z2d )                  ! 2D salt transport in i-direction 
     275            ENDIF 
     276            IF (iom_use('veiv_salttr3d') ) THEN 
     277               CALL lbc_lnk( z3d_T, 'V', -1. ) 
     278               CALL iom_put( "veiv_salttr3d", zztmp * z3d_T )              ! 3D salt transport in i-direction 
     279            ENDIF 
     280         ENDIF 
     281 
     282         IF( iom_use('weiv_masstr') .OR. iom_use('weiv_heattr3d') .OR. iom_use('weiv_salttr3d')) THEN   ! vertical mass transport & its square value 
     283           z2d(:,:) = rau0 * e12t(:,:) 
     284           DO jk = 1, jpk 
     285              z3d(:,:,jk) = w_eiv(:,:,jk) * z2d(:,:) 
     286           END DO 
     287           CALL iom_put( "weiv_masstr" , z3d )                  ! mass transport in k-direction 
     288         ENDIF 
     289 
     290         IF( iom_use('weiv_heattr3d') ) THEN 
     291            zztmp = 0.5 * rcp  
     292            DO jk = 1, jpkm1 
     293               DO jj = 2, jpjm1 
     294                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     295                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj,jk+1,jp_tem) ) 
     296                  END DO 
     297               END DO 
     298            END DO 
     299            CALL lbc_lnk( z3d_T, 'T', 1. ) 
     300            CALL iom_put( "weiv_heattr3d", zztmp * z3d_T )                 ! 3D heat transport in k-direction 
     301         ENDIF 
     302 
     303         IF( iom_use('weiv_salttr3d') ) THEN 
     304            zztmp = 0.5 * 0.001  
     305            DO jk = 1, jpkm1 
     306               DO jj = 2, jpjm1 
     307                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     308                     z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj,jk+1,jp_sal) ) 
     309                  END DO 
     310               END DO 
     311            END DO 
     312            CALL lbc_lnk( z3d_T, 'T', 1. ) 
     313            CALL iom_put( "weiv_salttr3d", zztmp * z3d_T )                 ! 3D salt transport in k-direction 
     314         ENDIF 
     315 
    191316    END IF 
     317! 
     318    IF( ln_diaptr .AND. cdtype == 'TRA' ) THEN 
     319       z3d(:,:,:) = 0._wp 
     320       DO jk = 1, jpkm1 
     321          DO jj = 2, jpjm1 
     322             DO ji = fs_2, fs_jpim1   ! vector opt. 
     323                z3d(ji,jj,jk) = v_eiv(ji,jj,jk) * 0.5 * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) & 
     324                &             * e1v(ji,jj) * fse3v(ji,jj,jk) 
     325             END DO 
     326          END DO 
     327       END DO 
     328       CALL dia_ptr_ohst_components( jp_tem, 'eiv', z3d ) 
     329       z3d(:,:,:) = 0._wp 
     330       DO jk = 1, jpkm1 
     331          DO jj = 2, jpjm1 
     332             DO ji = fs_2, fs_jpim1   ! vector opt. 
     333                z3d(ji,jj,jk) = v_eiv(ji,jj,jk) * 0.5 * (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) & 
     334                &             * e1v(ji,jj) * fse3v(ji,jj,jk) 
     335             END DO 
     336          END DO 
     337       END DO 
     338       CALL dia_ptr_ohst_components( jp_sal, 'eiv', z3d ) 
     339    ENDIF 
     340 
     341    IF( ln_KE_trd ) CALL trd_dyn(u_eiv, v_eiv, jpdyn_eivke, kt ) 
    192342# endif   
    193       !  
     343 
    194344# if defined key_diaeiv  
    195345      CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 
     346      CALL wrk_dealloc( jpi, jpj, jpk, z3d, z3d_T ) 
    196347# else 
    197348      CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) 
    … …  
    212363      CHARACTER(len=3) ::   cdtype 
    213364      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) 
     365      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', & 
     366          &  kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
    215367   END SUBROUTINE tra_adv_eiv 
    216368#endif 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r7960 r9987  
    8282      REAL(wp) ::   zv, z0v, zzwy, z0w        !   -      - 
    8383      REAL(wp) ::   ztra, zbtr, zdt, zalpha   !   -      - 
    84       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zslpx, zslpy   ! 3D workspace 
    85       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwx  , zwy     ! -      -  
     84      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zslpx, zslpy   ! 3D workspace 
     85      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zwx  , zwy     ! -      -  
    8686      !!---------------------------------------------------------------------- 
    8787      ! 
    8888      IF( nn_timing == 1 )  CALL timing_start('tra_adv_muscl') 
    8989      ! 
    90       CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
     90      ALLOCATE( zslpx(1:jpi, 1:jpj, 1:jpk) ) 
     91      ALLOCATE( zslpy(1:jpi, 1:jpj, 1:jpk) ) 
     92      ALLOCATE( zwx  (1:jpi, 1:jpj, 1:jpk) ) 
     93      ALLOCATE( zwy  (1:jpi, 1:jpj, 1:jpk) ) 
    9194      ! 
    9295      IF( kt == kit000 )  THEN 
    … …  
    219222         END IF 
    220223         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    221          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    222             IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    223             IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    224          ENDIF 
     224         IF( cdtype == 'TRA' .AND. ln_diaptr )  CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:)  ) 
    225225 
    226226         ! II. Vertical advective fluxes 
    … …  
    291291      END DO 
    292292      ! 
    293       CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
     293      DEALLOCATE( zslpx ) 
     294      DEALLOCATE( zslpy ) 
     295      DEALLOCATE( zwx   ) 
     296      DEALLOCATE( zwy   ) 
    294297      ! 
    295298      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_muscl') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r7960 r9987  
    200200 
    201201         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    202          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    203             IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    204             IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    205          ENDIF 
     202         IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:)  ) 
    206203 
    207204         ! II. Vertical advective fluxes 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r7960 r9987  
    355355         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    356356         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    357          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    358            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    359            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    360          ENDIF 
     357         IF( cdtype == 'TRA' .AND. ln_diaptr )  CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 
    361358         ! 
    362359      END DO 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r7960 r9987  
    3434   USE timing         ! Timing 
    3535   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     36   USE iom 
    3637 
    3738   IMPLICIT NONE 
    … …  
    4243 
    4344   LOGICAL ::   l_trd   ! flag to compute trends 
     45   LOGICAL ::   l_trans   ! flag to output vertically integrated transports 
    4446 
    4547   !! * Substitutions 
    … …  
    8486      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk   !   -      - 
    8587      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk   !   -      - 
    86       REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
     88      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwi, zwz 
     89      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 
     90      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   :: z2d 
    8891      !!---------------------------------------------------------------------- 
    8992      ! 
    9093      IF( nn_timing == 1 )  CALL timing_start('tra_adv_tvd') 
    9194      ! 
    92       CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz ) 
     95      ALLOCATE(zwi(1:jpi, 1:jpj, 1:jpk)) 
     96      ALLOCATE(zwz(1:jpi, 1:jpj, 1:jpk)) 
     97 
    9398      ! 
    9499      IF( kt == kit000 )  THEN 
    … …  
    97102         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    98103         ! 
    99          l_trd = .FALSE. 
    100          IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    101104      ENDIF 
    102       ! 
    103       IF( l_trd )  THEN 
    104          CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     105      l_trd = .FALSE. 
     106      l_trans = .FALSE. 
     107      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
     108      IF( cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") ) ) l_trans = .TRUE. 
     109      ! 
     110      IF( l_trd .OR. l_trans )  THEN 
     111         ALLOCATE(ztrdx(1:jpi, 1:jpj, 1:jpk)) 
     112         ALLOCATE(ztrdy(1:jpi, 1:jpj, 1:jpk)) 
     113         ALLOCATE(ztrdz(1:jpi, 1:jpj, 1:jpk)) 
    105114         ztrdx(:,:,:) = 0.e0   ;    ztrdy(:,:,:) = 0.e0   ;   ztrdz(:,:,:) = 0.e0 
     115         ALLOCATE(z2d(1:jpi, 1:jpj)) 
     116      ENDIF 
     117      ! 
     118      IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     119         ALLOCATE(zptry(1:jpi, 1:jpj, 1:jpk)) 
     120         zptry(:,:,:) = 0._wp 
    106121      ENDIF 
    107122      ! 
    … …  
    173188            DO jj = 2, jpjm1 
    174189               DO ji = fs_2, fs_jpim1   ! vector opt. 
    175                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    176190                  ! 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) ) 
     191                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     192                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     193                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    180194                  ! 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) 
     195                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     196                  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) 
    183197               END DO 
    184198            END DO 
    … …  
    188202 
    189203         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    190          IF( l_trd )  THEN  
     204         IF( l_trd .OR. l_trans )  THEN  
    191205            ! store intermediate advective trends 
    192206            ztrdx(:,:,:) = zwx(:,:,:)   ;    ztrdy(:,:,:) = zwy(:,:,:)  ;   ztrdz(:,:,:) = zwz(:,:,:) 
    193207         END IF 
    194208         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    195          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    196            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    197            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    198          ENDIF 
     209         IF( cdtype == 'TRA' .AND. ln_diaptr )    zptry(:,:,:) = zwy(:,:,:)  
    199210 
    200211         ! 3. antidiffusive flux : high order minus low order 
    … …  
    254265 
    255266         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    256          IF( l_trd )  THEN  
     267         IF( l_trd .OR. l_trans )  THEN  
    257268            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< Add to previously computed 
    258269            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
    259270            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! <<< Add to previously computed 
    260              
    261             CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )    
    262             CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )   
    263             CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
     271         ENDIF 
     272          
     273         IF( l_trd ) THEN  
     274            CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 
     275            CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 
     276            CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 
    264277         END IF 
    265          !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     278 
     279         IF( l_trans .AND. jn==jp_tem ) THEN 
     280            z2d(:,:) = 0._wp  
     281            DO jk = 1, jpkm1 
     282               DO jj = 2, jpjm1 
     283                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     284                     z2d(ji,jj) = z2d(ji,jj) + ztrdx(ji,jj,jk)  
     285                  END DO 
     286               END DO 
     287            END DO 
     288            CALL lbc_lnk( z2d, 'U', -1. ) 
     289            CALL iom_put( "uadv_heattr", rau0_rcp * z2d )       ! heat transport in i-direction 
     290              ! 
     291            z2d(:,:) = 0._wp  
     292            DO jk = 1, jpkm1 
     293               DO jj = 2, jpjm1 
     294                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     295                     z2d(ji,jj) = z2d(ji,jj) + ztrdy(ji,jj,jk)  
     296                  END DO 
     297               END DO 
     298            END DO 
     299            CALL lbc_lnk( z2d, 'V', -1. ) 
     300            CALL iom_put( "vadv_heattr", rau0_rcp * z2d )       ! heat transport in j-direction 
     301         ENDIF 
     302         ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    266303         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    267            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
    268            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
     304            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
     305            CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 
    269306         ENDIF 
    270307         ! 
    271308      END DO 
    272309      ! 
    273                    CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 
    274       IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     310      DEALLOCATE( zwi ) 
     311      DEALLOCATE( zwz ) 
     312      IF( l_trd .OR. l_trans )  THEN  
     313         DEALLOCATE( ztrdx ) 
     314         DEALLOCATE( ztrdy ) 
     315         DEALLOCATE( ztrdz ) 
     316         DEALLOCATE( z2d ) 
     317      ENDIF 
     318      IF( cdtype == 'TRA' .AND. ln_diaptr ) DEALLOCATE( zptry ) 
    275319      ! 
    276320      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd') 
    … …  
    316360      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk   !   -      - 
    317361      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk   !   -      - 
    318       REAL(wp), POINTER, DIMENSION(:,:  ) :: zwx_sav , zwy_sav 
    319       REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 
    320       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
    321       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs 
     362      REAL(wp), ALLOCATABLE, DIMENSION(:,:  ) :: zwx_sav , zwy_sav 
     363      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 
     364      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
     365      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zptry 
     366      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrs 
    322367      !!---------------------------------------------------------------------- 
    323368      ! 
    324369      IF( nn_timing == 1 )  CALL timing_start('tra_adv_tvd_zts') 
    325370      ! 
    326       CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
    327       CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
    328       CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
     371      ALLOCATE(zwx_sav(1:jpi, 1:jpj)) 
     372      ALLOCATE(zwy_sav(1:jpi, 1:jpj)) 
     373      ALLOCATE(zwi(1:jpi, 1:jpj, 1:jpk)) 
     374      ALLOCATE(zwz(1:jpi, 1:jpj, 1:jpk))         
     375      ALLOCATE(zhdiv(1:jpi, 1:jpj, 1:jpk))        
     376      ALLOCATE(zwz_sav(1:jpi, 1:jpj, 1:jpk))        
     377      ALLOCATE(zwzts(1:jpi, 1:jpj, 1:jpk))  
     378      ALLOCATE(ztrs(1:jpi, 1:jpj, 1:jpk, 1:kjpt+1)) 
    329379      ! 
    330380      IF( kt == kit000 )  THEN 
    … …  
    338388      ! 
    339389      IF( l_trd )  THEN 
    340          CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     390         ALLOCATE(ztrdx(1:jpi, 1:jpj, 1:jpk))        
     391         ALLOCATE(ztrdy(1:jpi, 1:jpj, 1:jpk))        
     392         ALLOCATE(ztrdz(1:jpi, 1:jpj, 1:jpk))        
    341393         ztrdx(:,:,:) = 0._wp  ;    ztrdy(:,:,:) = 0._wp  ;   ztrdz(:,:,:) = 0._wp 
     394      ENDIF 
     395      ! 
     396      IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     397         ALLOCATE(zptry(1:jpi, 1:jpj, 1:jpk))        
     398         zptry(:,:,:) = 0._wp 
    342399      ENDIF 
    343400      ! 
    … …  
    410467            DO jj = 2, jpjm1 
    411468               DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                   zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    413469                  ! 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) ) 
     470                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     471                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     472                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    417473                  ! 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) 
     474                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     475                  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) 
    420476               END DO 
    421477            END DO 
    … …  
    430486         END IF 
    431487         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    432          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    433            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    434            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    435          ENDIF 
     488         IF( cdtype == 'TRA' .AND. ln_diaptr )  zptry(:,:,:) = zwy(:,:,:) 
    436489 
    437490         ! 3. antidiffusive flux : high order minus low order 
    438491         ! -------------------------------------------------- 
    439492         ! antidiffusive flux on i and j 
    440  
    441  
     493         ! 
    442494         DO jk = 1, jpkm1 
    443  
     495            ! 
    444496            DO jj = 1, jpjm1 
    445497               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    472524         ! 
    473525         ztrs(:,:,:,1) = ptb(:,:,:,jn) 
     526         ztrs(:,:,1,2) = ptb(:,:,1,jn) 
     527         ztrs(:,:,1,3) = ptb(:,:,1,jn) 
    474528         zwzts(:,:,:) = 0._wp 
    475529 
    … …  
    557611         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    558612         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    559            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
    560            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
     613            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  
     614            CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 
    561615         ENDIF 
    562616         ! 
    563617      END DO 
    564618      ! 
    565                    CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
    566                    CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
    567                    CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    568       IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     619      DEALLOCATE(zwi)  
     620      DEALLOCATE(zwz)  
     621      DEALLOCATE(zhdiv)  
     622      DEALLOCATE(zwz_sav)  
     623      DEALLOCATE(zwzts) 
     624      DEALLOCATE(ztrs ) 
     625      DEALLOCATE(zwx_sav)  
     626      DEALLOCATE(zwy_sav ) 
     627 
     628      IF( l_trd )  THEN 
     629          DEALLOCATE(ztrdx)  
     630          DEALLOCATE(ztrdy)  
     631          DEALLOCATE(ztrdz) 
     632      END IF 
     633 
     634      IF( cdtype == 'TRA' .AND. ln_diaptr ) DEALLOCATE(zptry ) 
    569635      ! 
    570636      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd_zts') 
    571637      ! 
    572638   END SUBROUTINE tra_adv_tvd_zts 
     639 
    573640 
    574641   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 
    … …  
    593660      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt   ! local scalars 
    594661      REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    595       REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo 
     662      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo 
    596663      !!---------------------------------------------------------------------- 
    597664      ! 
    598665      IF( nn_timing == 1 )  CALL timing_start('nonosc') 
    599666      ! 
    600       CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 
     667      ALLOCATE(zbetup(1:jpi, 1:jpj, 1:jpk)) 
     668      ALLOCATE(zbetdo(1:jpi, 1:jpj, 1:jpk)) 
     669      ALLOCATE(zbup(1:jpi, 1:jpj, 1:jpk)) 
     670      ALLOCATE(zbdo(1:jpi, 1:jpj, 1:jpk)) 
    601671      ! 
    602672      zbig  = 1.e+40_wp 
    … …  
    675745      CALL lbc_lnk( paa, 'U', -1. )   ;   CALL lbc_lnk( pbb, 'V', -1. )   ! lateral boundary condition (changed sign) 
    676746      ! 
    677       CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 
     747      DEALLOCATE(zbetup) 
     748      DEALLOCATE(zbetdo)  
     749      DEALLOCATE(zbup) 
     750      DEALLOCATE(zbdo) 
    678751      ! 
    679752      IF( nn_timing == 1 )  CALL timing_stop('nonosc') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r7960 r9987  
    177177         END IF 
    178178         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    179          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    180             IF( jn == jp_tem )  htr_adv(:) = ptr_sj( ztv(:,:,:) ) 
    181             IF( jn == jp_sal )  str_adv(:) = ptr_sj( ztv(:,:,:) ) 
    182          ENDIF 
     179         IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', ztv(:,:,:) ) 
    183180          
    184181         ! TVD scheme for the vertical direction   

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r7960 r9987  
    107107      INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
    108108      ! 
    109       REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
     109      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    110110      !!---------------------------------------------------------------------- 
    111111      ! 
    … …  
    113113      ! 
    114114      IF( l_trdtra )   THEN                         !* Save ta and sa trends 
    115          CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
     115         ALLOCATE( ztrdt (1:jpi, 1:jpj, 1:jpk)) 
     116         ALLOCATE( ztrds (1:jpi, 1:jpj, 1:jpk)) 
    116117         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    117118         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    … …  
    151152         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 
    152153         CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 
    153          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
     154         DEALLOCATE( ztrdt, ztrds ) 
    154155      ENDIF 
    155156      ! 
    … …  
    187188      INTEGER  ::   ik           ! local integers 
    188189      REAL(wp) ::   zbtr         ! local scalars 
    189       REAL(wp), POINTER, DIMENSION(:,:) :: zptb 
     190      REAL(wp), ALLOCATABLE , DIMENSION(:,:) :: zptb 
    190191      !!---------------------------------------------------------------------- 
    191192      ! 
    192193      IF( nn_timing == 1 )  CALL timing_start('tra_bbl_dif') 
    193194      ! 
    194       CALL wrk_alloc( jpi, jpj, zptb ) 
     195      ALLOCATE(zptb(1:jpi, 1:jpj)) 
    195196      ! 
    196197      DO jn = 1, kjpt                                     ! tracer loop 
    … …  
    217218      END DO                                                ! end tracer 
    218219      !                                                     ! =========== 
    219       CALL wrk_dealloc( jpi, jpj, zptb ) 
     220      DEALLOCATE( zptb ) 
    220221      ! 
    221222      IF( nn_timing == 1 )  CALL timing_stop('tra_bbl_dif') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r7960 r9987  
    173173         !                                                 
    174174         ! "zonal" mean lateral diffusive heat and salt transport 
    175          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    176            IF( jn == jp_tem )  htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    177            IF( jn == jp_sal )  str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    178          ENDIF 
     175         IF( cdtype == 'TRA' .AND. ln_diaptr )   CALL dia_ptr_ohst_components( jn, 'ldf', ztv(:,:,:) ) 
    179176         !                                                ! =========== 
    180177      END DO                                              ! tracer loop 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r7960 r9987  
    247247         !                                                ! =============== 
    248248         ! "Poleward" diffusive heat or salt transport 
    249          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 
    250             ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    251             IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    252             IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    253          ENDIF 
     249        ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     250         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) CALL dia_ptr_ohst_components( jn, 'ldf', -zftv(:,:,:) ) 
    254251 
    255252         !                             ! ************ !   ! =============== 
    … …  
    330327               END DO 
    331328            ELSE 
    332                IF(lwp) WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 
    333                IF(lwp) WRITE(numout,*) '         We stop' 
    334                STOP 'ldfght' 
     329               WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 
     330               WRITE(numout,*) '         We stop' 
     331               CALL ctl_stop( 'STOP', 'ldfght : unexpected kaht value') 
    335332            ENDIF 
    336333            !                                             ! =============== 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r7960 r9987  
    2626   USE ldfslp          ! iso-neutral slopes 
    2727   USE diaptr          ! poleward transport diagnostics 
     28   USE trd_oce         ! trends: ocean variables 
     29   USE trdtra          ! trends manager: tracers  
    2830   USE in_out_manager  ! I/O manager 
    2931   USE iom             ! I/O library 
    3032   USE phycst          ! physical constants 
    3133   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    32    USE wrk_nemo        ! Memory Allocation 
    3334   USE timing          ! Timing 
    3435 
    … …  
    105106      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    106107      INTEGER  ::  ikt 
    107       REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! local scalars 
    108       REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !   -      - 
    109       REAL(wp) ::  zcoef0, zbtr, ztra            !   -      - 
    110       REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
    111       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
     108      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3       ! local scalars 
     109      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4       !   -      - 
     110      REAL(wp) ::  zcoef0, zbtr                      !   -      - 
     111      REAL(wp), ALLOCATABLE, DIMENSION(:,:  ) ::  z2d 
     112      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
     113      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::  ztrax, ztray, ztraz  
     114      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::  ztrax_T, ztray_T, ztraz_T 
    112115      !!---------------------------------------------------------------------- 
    113116      ! 
    114117      IF( nn_timing == 1 )  CALL timing_start('tra_ldf_iso') 
    115118      ! 
    116       CALL wrk_alloc( jpi, jpj,      z2d )  
    117       CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
     119      ALLOCATE( z2d(1:jpi, 1:jpj))  
     120      ALLOCATE( zdit(1:jpi, 1:jpj, 1:jpk)) 
     121      ALLOCATE( zdjt(1:jpi, 1:jpj, 1:jpk))  
     122      ALLOCATE( ztfw(1:jpi, 1:jpj, 1:jpk))  
     123      ALLOCATE( zdkt(1:jpi, 1:jpj, 1:jpk))  
     124      ALLOCATE( zdk1t(1:jpi, 1:jpj, 1:jpk))  
     125      ALLOCATE( ztrax(1:jpi,1:jpj,1:jpk))  
     126      ALLOCATE( ztray(1:jpi,1:jpj,1:jpk)) 
     127      ALLOCATE( ztraz(1:jpi,1:jpj,1:jpk) )  
     128      IF( l_trdtra .and. cdtype == 'TRA' ) THEN 
     129         ALLOCATE( ztrax_T(1:jpi,1:jpj,1:jpk))  
     130         ALLOCATE( ztray_T(1:jpi,1:jpj,1:jpk))  
     131         ALLOCATE( ztraz_T(1:jpi,1:jpj,1:jpk))  
     132      ENDIF 
    118133      ! 
    119134 
    … …  
    127142      DO jn = 1, kjpt                                            ! tracer loop 
    128143         !                                                       ! =========== 
     144         ztrax(:,:,:) = 0._wp ; ztray(:,:,:) = 0._wp ; ztraz(:,:,:) = 0._wp ;  
    129145         !                                                
    130146         !!---------------------------------------------------------------------- 
    … …  
    226242               DO ji = fs_2, fs_jpim1   ! vector opt. 
    227243                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    228                   ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 
    229                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     244                  ztrax(ji,jj,jk) = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) ) 
     245                  ztray(ji,jj,jk) = zbtr * ( zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 
    230246               END DO 
    231247            END DO 
    … …  
    234250         !                                             ! =============== 
    235251         ! 
     252         pta(:,:,:,jn) = pta(:,:,:,jn) + ztrax(:,:,:) + ztray(:,:,:) 
     253         ! 
    236254         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    237          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    238255            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    239             IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    240             IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    241          ENDIF 
     256         IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', -zftv(:,:,:)  ) 
    242257  
    243258         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
    … …  
    314329               DO ji = fs_2, fs_jpim1   ! vector opt. 
    315330                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    316                   ztra = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    317                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     331                  ztraz(ji,jj,jk) = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    318332               END DO 
    319333            END DO 
    320334         END DO 
     335         pta(:,:,:,jn) = pta(:,:,:,jn) + ztraz(:,:,:) 
    321336         ! 
     337         IF( l_trdtra .AND. cdtype == "TRA" .AND. jn .eq. 1 )  THEN      ! save the temperature trends 
     338            ztrax_T(:,:,:) = ztrax(:,:,:) 
     339            ztray_T(:,:,:) = ztray(:,:,:) 
     340            ztraz_T(:,:,:) = ztraz(:,:,:) 
     341         ENDIF 
     342         IF( l_trdtrc .AND. cdtype == "TRC" )   THEN      ! save the horizontal component of diffusive trends for further diagnostics 
     343            CALL trd_tra( kt, cdtype, jn, jptra_iso_x, ztrax ) 
     344            CALL trd_tra( kt, cdtype, jn, jptra_iso_y, ztray )  
     345            CALL trd_tra( kt, cdtype, jn, jptra_iso_z1, ztraz )  ! This is the first part of the vertical component. 
     346         ENDIF 
    322347      END DO 
    323348      ! 
    324       CALL wrk_dealloc( jpi, jpj, z2d )  
    325       CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
     349      IF( l_trdtra .AND. cdtype == "TRA" )   THEN      ! save the horizontal component of diffusive trends for further diagnostics 
     350         CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_x, ztrax_T ) 
     351         CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_x, ztrax ) 
     352         CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_y, ztray_T ) 
     353         CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_y, ztray ) 
     354         CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_z1, ztraz_T )  ! This is the first part of the vertical component 
     355         CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_z1, ztraz )    ! 
     356      ENDIF 
     357      ! 
     358      DEALLOCATE( z2d )  
     359      DEALLOCATE( zdit)  
     360      DEALLOCATE( zdjt) 
     361      DEALLOCATE( ztfw)  
     362      DEALLOCATE( zdkt ) 
     363      DEALLOCATE( zdk1t )  
     364      DEALLOCATE( ztrax, ztray, ztraz )  
     365      IF( l_trdtra  .and. cdtype == 'TRA' ) DEALLOCATE( ztrax_T, ztray_T, ztraz_T )  
    326366      ! 
    327367      IF( nn_timing == 1 )  CALL timing_stop('tra_ldf_iso') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r7960 r9987  
    386386         ! 
    387387         !                             ! "Poleward" diffusive heat or salt transports (T-S case only) 
    388          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    389             IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( zftv(:,:,:) )        ! 3.3  names 
    390             IF( jn == jp_sal)   str_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    391          ENDIF 
     388         IF( cdtype == 'TRA' .AND. ln_diaptr )  CALL dia_ptr_ohst_components( jn, 'ldf', zftv(:,:,:) ) 
    392389 
    393390         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r7960 r9987  
    154154         ! 
    155155         ! "Poleward" diffusive heat or salt transports 
    156          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    157             IF( jn  == jp_tem)   htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    158             IF( jn  == jp_sal)   str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    159          ENDIF 
     156         IF( cdtype == 'TRA' .AND. ln_diaptr )    CALL dia_ptr_ohst_components( jn, 'ldf', ztv(:,:,:) ) 
    160157         !                                                  ! ================== 
    161158      END DO                                                ! end of tracer loop 

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

    r7960 r9987  
    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 
    … …  
    110110      ! Update after tracer on domain lateral boundaries 
    111111      !  
     112#if defined key_agrif 
     113      CALL Agrif_tra                     ! AGRIF zoom boundaries 
     114#endif 
     115      ! 
    112116      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    113117      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    … …  
    115119#if defined key_bdy  
    116120      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    117 #endif 
    118 #if defined key_agrif 
    119       CALL Agrif_tra                     ! AGRIF zoom boundaries 
    120121#endif 
    121122  
    … …  
    126127 
    127128      ! trends computation initialisation 
    128       IF( l_trdtra )   THEN                    ! store now fields before applying the Asselin filter 
     129      IF( l_trdtra )   THEN                     
    129130         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    130          ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
    131          ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
     131         ztrdt(:,:,jpk) = 0._wp 
     132         ztrds(:,:,jpk) = 0._wp 
    132133         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend  
    133134            CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 
    134135            CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 
    135136         ENDIF 
     137         ! total trend for the non-time-filtered variables. 
     138         ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from tsn terms 
     139         IF( lk_vvl ) THEN 
     140            DO jk = 1, jpkm1 
     141               zfact = 1.0 / rdttra(jk) 
     142               ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem)*fse3t_a(:,:,jk) / fse3t_n(:,:,jk) - tsn(:,:,jk,jp_tem)) * zfact 
     143               ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal)*fse3t_a(:,:,jk) / fse3t_n(:,:,jk) - tsn(:,:,jk,jp_sal)) * zfact 
     144            END DO 
     145         ELSE 
     146            DO jk = 1, jpkm1 
     147               zfact = 1.0 / rdttra(jk) 
     148               ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsn(:,:,jk,jp_tem) ) * zfact  
     149               ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsn(:,:,jk,jp_sal) ) * zfact  
     150            END DO 
     151         END IF 
     152         CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt ) 
     153         CALL trd_tra( kt, 'TRA', jp_sal, jptra_tot, ztrds ) 
     154         IF( .NOT.lk_vvl )  THEN 
     155            ! Store now fields before applying the Asselin filter  
     156            ! in order to calculate Asselin filter trend later. 
     157            ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
     158            ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
     159         END IF 
    136160      ENDIF 
    137161 
    … …  
    142166            END DO 
    143167         END DO 
     168         IF (l_trdtra.AND.lk_vvl) THEN      ! Zero Asselin filter contribution must be explicitly written out since for vvl 
     169                                            ! Asselin filter is output by tra_nxt_vvl that is not called on this time step 
     170            ztrdt(:,:,:) = 0._wp 
     171            ztrds(:,:,:) = 0._wp 
     172            CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 
     173            CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 
     174         END IF 
    144175      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    145176         ! 
    … …  
    148179         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    149180         ENDIF 
    150       ENDIF  
    151       ! 
    152 #if defined key_agrif 
    153       ! Update tracer at AGRIF zoom boundaries 
    154       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
    155 #endif       
    156       ! 
    157       ! trends computation 
    158       IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
     181      ENDIF      
     182      ! 
     183     ! trends computation 
     184      IF( l_trdtra.AND..NOT.lk_vvl) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    159185         DO jk = 1, jpkm1 
    160186            zfact = 1._wp / r2dtra(jk)              
    … …  
    164190         CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 
    165191         CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 
    166          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    167192      END IF 
     193      IF( l_trdtra) CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    168194      ! 
    169195      !                        ! control print 
    … …  
    279305 
    280306      !!      
    281       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     307      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf   ! local logical 
    282308      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    283       REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
     309      REAL(wp) ::   zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    284310      REAL(wp) ::   zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d   !   -      - 
     311      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrd_atf 
    285312      !!---------------------------------------------------------------------- 
    286313      ! 
    … …  
    295322         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    296323         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     324         IF (nn_isf .GE. 1) THEN  
     325            ll_isf = .TRUE.            ! active  tracers case  and  ice shelf melting/freezing 
     326         ELSE 
     327            ll_isf = .FALSE. 
     328         END IF 
    297329      ELSE                           
    298330         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    299331         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    300332         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
    301       ENDIF 
    302       ! 
     333         ll_isf     = .FALSE.          ! passive tracers or NO ice shelf melting/freezing 
     334      ENDIF 
     335      ! 
     336      IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) )   THEN 
     337         CALL wrk_alloc( jpi, jpj, jpk, kjpt, ztrd_atf ) 
     338         ztrd_atf(:,:,:,:) = 0.0_wp 
     339      ENDIF 
    303340      DO jn = 1, kjpt       
    304341         DO jk = 1, jpkm1 
     342            zfact = 1._wp / r2dtra(jk) 
    305343            zfact1 = atfp * p2dt(jk) 
    306344            zfact2 = zfact1 / rau0 
    … …  
    321359                  ztc_f  = ztc_n  + atfp * ztc_d 
    322360                  ! 
    323                   IF( jk == 1 ) THEN           ! first level  
    324                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     361                  IF( jk == mikt(ji,jj) ) THEN           ! first level  
     362                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
     363                            &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
     364                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
    325365                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    326366                  ENDIF 
    327367 
    328                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     368                  ! solar penetration (temperature only) 
     369                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    329370                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    330371 
    331                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     372                  ! river runoff 
     373                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    332374                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    333375                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     376 
     377                  ! ice shelf 
     378                  IF( ll_isf ) THEN 
     379                     ! level fully include in the Losch_2008 ice shelf boundary layer 
     380                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
     381                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     382                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
     383                     ! level partially include in Losch_2008 ice shelf boundary layer  
     384                     IF ( jk == misfkb(ji,jj) )                                                   & 
     385                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     386                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
     387                  END IF 
    334388 
    335389                  ze3t_f = 1.e0 / ze3t_f 
    … …  
    340394                     ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
    341395                     pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
     396                  ENDIF 
     397                  IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN 
     398                     ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n 
    342399                  ENDIF 
    343400               END DO 
    … …  
    347404      END DO 
    348405      ! 
     406      IF( l_trdtra .and. cdtype == 'TRA' ) THEN  
     407         CALL trd_tra( kt, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) 
     408         CALL trd_tra( kt, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) 
     409         CALL wrk_dealloc( jpi, jpj, jpk, kjpt, ztrd_atf ) 
     410      ENDIF 
     411      IF( l_trdtrc .and. cdtype == 'TRC' ) THEN 
     412         DO jn = 1, kjpt 
     413            CALL trd_tra( kt, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) 
     414         END DO 
     415         CALL wrk_dealloc( jpi, jpj, jpk, kjpt, ztrd_atf ) 
     416      ENDIF 
     417 
    349418   END SUBROUTINE tra_nxt_vvl 
    350419 

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

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r7960 r9987  
    3333   USE timing          ! Timing 
    3434   USE eosbn2 
     35#if defined key_asminc    
     36   USE asminc          ! Assimilation increment 
     37#endif 
    3538 
    3639   IMPLICIT NONE 
    … …  
    159162         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    160163            zfact = 1._wp 
     164            sbc_tsc(:,:,:) = 0._wp 
    161165            sbc_tsc_b(:,:,:) = 0._wp 
    162166         ENDIF 
    … …  
    232236               DO jk = ikt, ikb - 1 
    233237               ! 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 ) 
    236238               ! compute trend 
    237239                  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) 
     240                     &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
    241241                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    242242                     &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    … …  
    245245               ! level partially include in ice shelf boundary layer  
    246246               ! 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 ) 
    249247               ! compute trend 
    250248               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) 
     249                  &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    254250               tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    255251                  &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
    … …  
    287283         END DO   
    288284      ENDIF 
     285 
     286      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     287      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     288 
     289#if defined key_asminc 
     290! WARNING: THIS MAY WELL NOT BE REQUIRED - WE DON'T WANT TO CHANGE T&S BUT THIS MAY COMPENSATE ANOTHER TERM... 
     291! Rate of change in e3t for each level is ssh_iau*e3t_0/ht_0 
     292! Contribution to tsa should be rate of change in level / per m of ocean? (hence the division by fse3t_n) 
     293      IF( ln_sshinc ) THEN         ! input of heat and salt due to assimilation 
     294         DO jj = 2, jpj  
     295            DO ji = fs_2, fs_jpim1 
     296               zdep = ssh_iau(ji,jj) / ( ht_0(ji,jj) + 1.0 - ssmask(ji, jj) ) 
     297               DO jk = 1, jpkm1 
     298                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
     299                                        &            + tsn(ji,jj,jk,jp_tem) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) ) 
     300                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
     301                                        &            + tsn(ji,jj,jk,jp_sal) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) ) 
     302               END DO 
     303            END DO   
     304         END DO   
     305      ENDIF 
     306#endif 
    289307  
    290308      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 

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

    r7960 r9987  
    9494 
    9595      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    96          DO jk = 1, jpkm1 
    97             ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dtra(jk) ) - ztrdt(:,:,jk) 
    98             ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 
    99          END DO 
     96         ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn. 
     97         IF( lk_vvl ) THEN 
     98            DO jk = 1, jpkm1 
     99               ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem)*fse3t_a(:,:,jk) - tsb(:,:,jk,jp_tem)*fse3t_b(:,:,jk) ) & 
     100                    & / (fse3t_n(:,:,jk)*r2dtra(jk)) ) - ztrdt(:,:,jk) 
     101               ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal)*fse3t_a(:,:,jk) - tsb(:,:,jk,jp_sal)*fse3t_b(:,:,jk) ) & 
     102                    & / (fse3t_n(:,:,jk)*r2dtra(jk)) ) - ztrds(:,:,jk) 
     103            END DO 
     104         ELSE 
     105            DO jk = 1, jpkm1 
     106               ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dtra(jk) ) - ztrdt(:,:,jk) 
     107               ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 
     108            END DO 
     109         END IF 
    100110         CALL lbc_lnk( ztrdt, 'T', 1. ) 
    101111         CALL lbc_lnk( ztrds, 'T', 1. ) 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trd_oce.F90

    r7960 r9987  
    3333# endif 
    3434   !                                                  !!!* Active tracers trends indexes 
    35    INTEGER, PUBLIC, PARAMETER ::   jptot_tra  = 14     !: Total trend nb: change it when adding/removing one indice below 
     35   INTEGER, PUBLIC, PARAMETER ::   jptot_tra  = 20     !: Total trend nb: change it when adding/removing one indice below 
    3636   !                               ===============     !   
    3737   INTEGER, PUBLIC, PARAMETER ::   jptra_xad  =  1     !: x- horizontal advection 
    … …  
    3939   INTEGER, PUBLIC, PARAMETER ::   jptra_zad  =  3     !: z- vertical   advection 
    4040   INTEGER, PUBLIC, PARAMETER ::   jptra_sad  =  4     !: z- vertical   advection 
    41    INTEGER, PUBLIC, PARAMETER ::   jptra_ldf  =  5     !: lateral       diffusion 
    42    INTEGER, PUBLIC, PARAMETER ::   jptra_zdf  =  6     !: vertical      diffusion 
    43    INTEGER, PUBLIC, PARAMETER ::   jptra_zdfp =  7     !: "PURE" vert.  diffusion (ln_traldf_iso=T) 
    44    INTEGER, PUBLIC, PARAMETER ::   jptra_bbc  =  8     !: Bottom Boundary Condition (geoth. heating)  
    45    INTEGER, PUBLIC, PARAMETER ::   jptra_bbl  =  9     !: Bottom Boundary Layer (diffusive and/or advective) 
    46    INTEGER, PUBLIC, PARAMETER ::   jptra_npc  = 10     !: non-penetrative convection treatment 
    47    INTEGER, PUBLIC, PARAMETER ::   jptra_dmp  = 11     !: internal restoring (damping) 
    48    INTEGER, PUBLIC, PARAMETER ::   jptra_qsr  = 12     !: penetrative solar radiation 
    49    INTEGER, PUBLIC, PARAMETER ::   jptra_nsr  = 13     !: non solar radiation / C/D on salinity  (+runoff if ln_rnf=T) 
    50    INTEGER, PUBLIC, PARAMETER ::   jptra_atf  = 14     !: Asselin time filter 
     41   INTEGER, PUBLIC, PARAMETER ::   jptra_totad  =  5   !: total         advection 
     42   INTEGER, PUBLIC, PARAMETER ::   jptra_ldf  =  6     !: lateral       diffusion 
     43   INTEGER, PUBLIC, PARAMETER ::   jptra_iso_x  =  7   !: x-component of isopycnal diffusion 
     44   INTEGER, PUBLIC, PARAMETER ::   jptra_iso_y  =  8   !: y-component of isopycnal diffusion 
     45   INTEGER, PUBLIC, PARAMETER ::   jptra_iso_z1 =  9   !: z-component of isopycnal diffusion 
     46   INTEGER, PUBLIC, PARAMETER ::   jptra_zdf  = 10     !: vertical      diffusion 
     47   INTEGER, PUBLIC, PARAMETER ::   jptra_zdfp = 11     !: "PURE" vert.  diffusion (ln_traldf_iso=T) 
     48   INTEGER, PUBLIC, PARAMETER ::   jptra_evd  = 12     !: EVD term (convection) 
     49   INTEGER, PUBLIC, PARAMETER ::   jptra_bbc  = 13     !: Bottom Boundary Condition (geoth. heating)  
     50   INTEGER, PUBLIC, PARAMETER ::   jptra_bbl  = 14     !: Bottom Boundary Layer (diffusive and/or advective) 
     51   INTEGER, PUBLIC, PARAMETER ::   jptra_npc  = 15     !: non-penetrative convection treatment 
     52   INTEGER, PUBLIC, PARAMETER ::   jptra_dmp  = 16     !: internal restoring (damping) 
     53   INTEGER, PUBLIC, PARAMETER ::   jptra_qsr  = 17     !: penetrative solar radiation 
     54   INTEGER, PUBLIC, PARAMETER ::   jptra_nsr  = 18     !: non solar radiation / C/D on salinity  (+runoff if ln_rnf=T) 
     55   INTEGER, PUBLIC, PARAMETER ::   jptra_atf  = 19     !: Asselin time filter 
     56   INTEGER, PUBLIC, PARAMETER ::   jptra_tot  = 20     !: Model total trend 
    5157   ! 
    5258   !                                                  !!!* Passive tracers trends indices (use if "key_top" defined) 
    53    INTEGER, PUBLIC, PARAMETER ::   jptra_sms  = 15     !: sources m. sinks 
    54    INTEGER, PUBLIC, PARAMETER ::   jptra_radn = 16     !: corr. trn<0 in trcrad 
    55    INTEGER, PUBLIC, PARAMETER ::   jptra_radb = 17     !: corr. trb<0 in trcrad (like atf) 
     59   INTEGER, PUBLIC, PARAMETER ::   jptra_sms  = 19     !: sources m. sinks 
     60   INTEGER, PUBLIC, PARAMETER ::   jptra_radn = 20     !: corr. trn<0 in trcrad 
     61   INTEGER, PUBLIC, PARAMETER ::   jptra_radb = 21     !: corr. trb<0 in trcrad (like atf) 
    5662   ! 
    5763   !                                                  !!!* Momentum trends indices 
    58    INTEGER, PUBLIC, PARAMETER ::   jptot_dyn  = 15     !: Total trend nb: change it when adding/removing one indice below 
     64   INTEGER, PUBLIC, PARAMETER ::   jptot_dyn  = 16     !: Total trend nb: change it when adding/removing one indice below 
    5965   !                               ===============     !   
    6066   INTEGER, PUBLIC, PARAMETER ::   jpdyn_hpg  =  1     !: hydrostatic pressure gradient  
    … …  
    7379   INTEGER, PUBLIC, PARAMETER ::   jpdyn_spgflt  = 14  !: filter contribution to surface pressure gradient (spg_flt) 
    7480   INTEGER, PUBLIC, PARAMETER ::   jpdyn_spgexp  = 15  !: explicit contribution to surface pressure gradient (spg_flt) 
     81   INTEGER, PUBLIC, PARAMETER ::   jpdyn_eivke   = 16  !: K.E trend from Gent McWilliams scheme 
    7582   ! 
    7683   !!---------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdini.F90

    r7960 r9987  
    9191!!gm end 
    9292      ! 
    93       IF( lk_vvl .AND. ( l_trdtra .OR. l_trddyn ) )  CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) 
    9493       
    9594!!gm  : Potential BUG : 3D output only for vector invariant form!  add a ctl_stop or code the flux form case 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    r7960 r9987  
    2727   USE lib_mpp        ! MPP library 
    2828   USE wrk_nemo       ! Memory allocation 
     29   USE ldfslp         ! Isopycnal slopes 
    2930 
    3031   IMPLICIT NONE 
    … …  
    4243#  include "domzgr_substitute.h90" 
    4344#  include "vectopt_loop_substitute.h90" 
     45#  include "ldfeiv_substitute.h90" 
     46 
    4447   !!---------------------------------------------------------------------- 
    4548   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    117120      ! 
    118121      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  
     122        CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
     123        CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
     124        CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
     125        CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
     126        CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
     127        CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
     128        CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
     129        CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
     130        CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
     131        CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
    129132                                 !                                   ! 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)  
     133                                CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
     134                     z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
     135                     z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
     136                     zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
     137                     DO jj = 2, jpj 
     138                         DO ji = 2, jpi 
     139                           zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
     140                            &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
     141                         END DO 
     142                     END DO 
     143                                CALL iom_put( "ketrd_tau", zke2d ) 
     144                                CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
     145        CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
    143146!!gm TO BE DONE properly 
    144147!!gm only valid if ln_bfrimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... 
    … …  
    162165!         ENDIF 
    163166!!gm end 
    164          CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
     167        CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
    165168!! a faire !!!!  idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! 
    166169!! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf.... 
    … …  
    184187!                              CALL iom_put( "ketrd_bfri", zke2d ) 
    185188!         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 
     189        CASE( jpdyn_ken )   ;   ! kinetic energy 
     190                    ! called in dynnxt.F90 before asselin time filter 
     191                    ! with putrd=ua and pvtrd=va 
     192                    zke(:,:,:) = 0.5_wp * zke(:,:,:) 
     193                    CALL iom_put( "KE", zke ) 
     194                    ! 
     195                    CALL ken_p2k( kt , zke ) 
     196                      CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
     197        CASE( jpdyn_eivke ) 
     198            ! CMIP6 diagnostic tknebto = tendency of KE from 
     199            ! parameterized mesoscale eddy advection 
     200            ! = vertical_integral( k (N S)^2 ) rho dz 
     201            ! rho = reference density 
     202            ! S = isoneutral slope. 
     203            ! Most terms are on W grid so work on this grid 
     204            CALL wrk_alloc( jpi, jpj, zke2d ) 
     205            zke2d(:,:) = 0._wp 
     206            DO jk = 1,jpk 
     207               DO ji = 1,jpi 
     208                  DO jj = 1,jpj 
     209                     zke2d(ji,jj) = zke2d(ji,jj) +  rau0 * fsaeiw(ji, jj, jk)               & 
     210                          &                      * ( wslpi(ji, jj, jk) * wslpi(ji,jj,jk)    & 
     211                          &                      +   wslpj(ji, jj, jk) * wslpj(ji,jj,jk) )  & 
     212                          &                      *   rn2(ji,jj,jk) * fse3w(ji, jj, jk) 
     213                  ENDDO 
     214               ENDDO 
     215            ENDDO 
     216            CALL iom_put("ketrd_eiv", zke2d) 
     217            CALL wrk_dealloc( jpi, jpj, zke2d ) 
    194218         ! 
    195219      END SELECT 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

    r7960 r9987  
    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 ) 
    … …  
    150150      rab_pe(:,:,:,:) = 0._wp 
    151151      ! 
    152       IF ( lk_vvl               )   CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume') 
     152!      IF ( lk_vvl               )   CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume') 
    153153      ! 
    154154      nkstp     = nit000 - 1 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90

    r7960 r9987  
    3838   REAL(wp) ::   r2dt   ! time-step, = 2 rdttra except at nit000 (=rdttra) if neuler=0 
    3939 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   trdtx, trdty, trdt   ! use to store the temperature trends 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   trdtx, trdty, trdt  ! use to store the temperature trends 
     41   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_evd  ! store avt_evd to calculate EVD trend 
    4142 
    4243   !! * Substitutions 
    … …  
    5556      !!                  ***  FUNCTION trd_tra_alloc  *** 
    5657      !!--------------------------------------------------------------------- 
    57       ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , STAT= trd_tra_alloc ) 
     58      ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) 
    5859      ! 
    5960      IF( lk_mpp             )   CALL mpp_sum ( trd_tra_alloc ) 
    … …  
    104105                                 ztrds(:,:,:) = 0._wp 
    105106                                 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 
     107         CASE( jptra_evd )   ;   avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 
    106108         CASE DEFAULT                 ! other trends: masked trends 
    107109            trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)              ! mask & store 
    … …  
    128130            zwt(:,:,jpk) = 0._wp   ;   zws(:,:,jpk) = 0._wp 
    129131            DO jk = 2, jpk 
    130                zwt(:,:,jk) =   avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
     132               zwt(:,:,jk) = avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
    131133               zws(:,:,jk) = fsavs(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
    132134            END DO 
    … …  
    138140            END DO 
    139141            CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt )   
     142            ! 
     143            !                         ! Also calculate EVD trend at this point.  
     144            zwt(:,:,:) = 0._wp   ;   zws(:,:,:) = 0._wp            ! vertical diffusive fluxes 
     145            DO jk = 2, jpk 
     146               zwt(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
     147               zws(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
     148            END DO 
     149            ! 
     150            ztrdt(:,:,jpk) = 0._wp   ;   ztrds(:,:,jpk) = 0._wp 
     151            DO jk = 1, jpkm1 
     152               ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / fse3t(:,:,jk) 
     153               ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / fse3t(:,:,jk)  
     154            END DO 
     155            CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt )   
    140156            ! 
    141157            CALL wrk_dealloc( jpi, jpj, jpk, zwt, zws, ztrdt ) 
    … …  
    285301      !! ** Purpose :   output 3D tracer trends using IOM 
    286302      !!---------------------------------------------------------------------- 
    287       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend  
    288       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend 
    289       INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index 
    290       INTEGER                   , INTENT(in   ) ::   kt      ! time step 
    291       !! 
    292       INTEGER ::   ji, jj, jk   ! dummy loop indices 
    293       INTEGER ::   ikbu, ikbv   ! local integers 
    294       REAL(wp), POINTER, DIMENSION(:,:)   ::   z2dx, z2dy   ! 2D workspace  
    295       !!---------------------------------------------------------------------- 
    296       ! 
    297 !!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added 
    298       ! 
    299       SELECT CASE( ktrd ) 
    300       CASE( jptra_xad  )   ;   CALL iom_put( "ttrd_xad" , ptrdx )        ! x- horizontal advection 
    301                                CALL iom_put( "strd_xad" , ptrdy ) 
    302       CASE( jptra_yad  )   ;   CALL iom_put( "ttrd_yad" , ptrdx )        ! y- horizontal advection 
    303                                CALL iom_put( "strd_yad" , ptrdy ) 
    304       CASE( jptra_zad  )   ;   CALL iom_put( "ttrd_zad" , ptrdx )        ! z- vertical   advection 
    305                                CALL iom_put( "strd_zad" , ptrdy ) 
    306                                IF( .NOT. lk_vvl ) THEN                   ! cst volume : adv flux through z=0 surface 
    307                                   CALL wrk_alloc( jpi, jpj, z2dx, z2dy ) 
    308                                   z2dx(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / fse3t(:,:,1) 
    309                                   z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / fse3t(:,:,1) 
    310                                   CALL iom_put( "ttrd_sad", z2dx ) 
    311                                   CALL iom_put( "strd_sad", z2dy ) 
    312                                   CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 
    313                                ENDIF 
    314       CASE( jptra_ldf  )   ;   CALL iom_put( "ttrd_ldf" , ptrdx )        ! lateral diffusion 
    315                                CALL iom_put( "strd_ldf" , ptrdy ) 
    316       CASE( jptra_zdf  )   ;   CALL iom_put( "ttrd_zdf" , ptrdx )        ! vertical diffusion (including Kz contribution) 
    317                                CALL iom_put( "strd_zdf" , ptrdy ) 
    318       CASE( jptra_zdfp )   ;   CALL iom_put( "ttrd_zdfp", ptrdx )        ! PURE vertical diffusion (no isoneutral contribution) 
    319                                CALL iom_put( "strd_zdfp", ptrdy ) 
    320       CASE( jptra_dmp  )   ;   CALL iom_put( "ttrd_dmp" , ptrdx )        ! internal restoring (damping) 
    321                                CALL iom_put( "strd_dmp" , ptrdy ) 
    322       CASE( jptra_bbl  )   ;   CALL iom_put( "ttrd_bbl" , ptrdx )        ! bottom boundary layer 
    323                                CALL iom_put( "strd_bbl" , ptrdy ) 
    324       CASE( jptra_npc  )   ;   CALL iom_put( "ttrd_npc" , ptrdx )        ! static instability mixing 
    325                                CALL iom_put( "strd_npc" , ptrdy ) 
    326       CASE( jptra_nsr  )   ;   CALL iom_put( "ttrd_qns" , ptrdx )        ! surface forcing + runoff (ln_rnf=T) 
    327                                CALL iom_put( "strd_cdt" , ptrdy ) 
    328       CASE( jptra_qsr  )   ;   CALL iom_put( "ttrd_qsr" , ptrdx )        ! penetrative solar radiat. (only on temperature) 
    329       CASE( jptra_bbc  )   ;   CALL iom_put( "ttrd_bbc" , ptrdx )        ! geothermal heating   (only on temperature) 
    330       CASE( jptra_atf  )   ;   CALL iom_put( "ttrd_atf" , ptrdx )        ! asselin time Filter 
    331                                CALL iom_put( "strd_atf" , ptrdy ) 
    332       END SELECT 
    333       ! 
     303     REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend  
     304     REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend 
     305     INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index 
     306     INTEGER                   , INTENT(in   ) ::   kt      ! time step 
     307     !! 
     308     INTEGER ::   ji, jj, jk   ! dummy loop indices 
     309     INTEGER ::   ikbu, ikbv   ! local integers 
     310     REAL(wp), POINTER, DIMENSION(:,:)   ::   z2dx, z2dy   ! 2D workspace  
     311     !!---------------------------------------------------------------------- 
     312     ! 
     313     !!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added 
     314     ! 
     315     ! Trends evaluated every time step that could go to the standard T file and can be output every ts into a 1ts file if 1ts output is selected 
     316     SELECT CASE( ktrd ) 
     317     ! This total trend is done every time step 
     318     CASE( jptra_tot  )   ;   CALL iom_put( "ttrd_tot" , ptrdx )           ! model total trend 
     319        CALL iom_put( "strd_tot" , ptrdy ) 
     320     END SELECT 
     321 
     322     ! These trends are done every second time step. When 1ts output is selected must go different (2ts) file from standard T-file 
     323     IF( MOD( kt, 2 ) == 0 ) THEN 
     324        SELECT CASE( ktrd ) 
     325        CASE( jptra_xad  )   ;   CALL iom_put( "ttrd_xad" , ptrdx )        ! x- horizontal advection 
     326           CALL iom_put( "strd_xad" , ptrdy ) 
     327        CASE( jptra_yad  )   ;   CALL iom_put( "ttrd_yad" , ptrdx )        ! y- horizontal advection 
     328           CALL iom_put( "strd_yad" , ptrdy ) 
     329        CASE( jptra_zad  )   ;   CALL iom_put( "ttrd_zad" , ptrdx )        ! z- vertical   advection 
     330           CALL iom_put( "strd_zad" , ptrdy ) 
     331           IF( .NOT. lk_vvl ) THEN                   ! cst volume : adv flux through z=0 surface 
     332              CALL wrk_alloc( jpi, jpj, z2dx, z2dy ) 
     333              z2dx(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / fse3t(:,:,1) 
     334              z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / fse3t(:,:,1) 
     335              CALL iom_put( "ttrd_sad", z2dx ) 
     336              CALL iom_put( "strd_sad", z2dy ) 
     337              CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 
     338           ENDIF 
     339        CASE( jptra_totad  ) ;   CALL iom_put( "ttrd_totad" , ptrdx )      ! total   advection 
     340           CALL iom_put( "strd_totad" , ptrdy ) 
     341        CASE( jptra_ldf  )   ;   CALL iom_put( "ttrd_ldf" , ptrdx )        ! lateral diffusion 
     342           CALL iom_put( "strd_ldf" , ptrdy ) 
     343        CASE( jptra_zdf  )   ;   CALL iom_put( "ttrd_zdf" , ptrdx )        ! vertical diffusion (including Kz contribution) 
     344           CALL iom_put( "strd_zdf" , ptrdy ) 
     345        CASE( jptra_zdfp )   ;   CALL iom_put( "ttrd_zdfp", ptrdx )        ! PURE vertical diffusion (no isoneutral contribution) 
     346           CALL iom_put( "strd_zdfp", ptrdy ) 
     347        CASE( jptra_evd )    ;   CALL iom_put( "ttrd_evd", ptrdx )         ! EVD trend (convection) 
     348           CALL iom_put( "strd_evd", ptrdy ) 
     349        CASE( jptra_dmp  )   ;   CALL iom_put( "ttrd_dmp" , ptrdx )        ! internal restoring (damping) 
     350           CALL iom_put( "strd_dmp" , ptrdy ) 
     351        CASE( jptra_bbl  )   ;   CALL iom_put( "ttrd_bbl" , ptrdx )        ! bottom boundary layer 
     352           CALL iom_put( "strd_bbl" , ptrdy ) 
     353        CASE( jptra_npc  )   ;   CALL iom_put( "ttrd_npc" , ptrdx )        ! static instability mixing 
     354           CALL iom_put( "strd_npc" , ptrdy ) 
     355        CASE( jptra_bbc  )   ;   CALL iom_put( "ttrd_bbc" , ptrdx )        ! geothermal heating   (only on temperature) 
     356        CASE( jptra_nsr  )   ;   CALL iom_put( "ttrd_qns" , ptrdx(:,:,1) ) ! surface forcing + runoff (ln_rnf=T) 
     357           CALL iom_put( "strd_cdt" , ptrdy(:,:,1) )        ! output as 2D surface fields 
     358        CASE( jptra_qsr  )   ;   CALL iom_put( "ttrd_qsr" , ptrdx )        ! penetrative solar radiat. (only on temperature) 
     359        END SELECT 
     360        ! the Asselin filter trend  is also every other time step but needs to be lagged one time step 
     361        ! Even when 1ts output is selected can go to the same (2ts) file as the trends plotted every even time step. 
     362     ELSE IF( MOD( kt, 2 ) == 1 ) THEN 
     363        SELECT CASE( ktrd ) 
     364        CASE( jptra_atf  )   ;   CALL iom_put( "ttrd_atf" , ptrdx )        ! asselin time Filter 
     365           CALL iom_put( "strd_atf" , ptrdy ) 
     366        END SELECT 
     367     END IF 
     368     ! 
    334369   END SUBROUTINE trd_tra_iom 
    335370 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90

    r7960 r9987  
     1#if ! defined key_top 
    12MODULE trdtrc 
    23   !!====================================================================== 
    … …  
    2223   !!====================================================================== 
    2324END MODULE trdtrc 
     25#endif 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r7960 r9987  
    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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90

    r7960 r9987  
    1919   USE zdf_oce         ! ocean vertical physics variables 
    2020   USE zdfkpp          ! KPP vertical mixing 
     21   USE trd_oce         ! trends: ocean variables 
     22   USE trdtra          ! trends manager: tracers  
    2123   USE in_out_manager  ! I/O manager 
    2224   USE iom             ! for iom_put 
    … …  
    122124      zavt_evd(:,:,:) = avt(:,:,:) - zavt_evd(:,:,:)   ! change in avt due to evd 
    123125      CALL iom_put( "avt_evd", zavt_evd )              ! output this change 
     126      IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) 
    124127      ! 
    125128      IF( nn_timing == 1 )  CALL timing_stop('zdf_evd') 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r7960 r9987  
    1818   USE phycst          ! physical constants 
    1919   USE iom             ! I/O library 
     20   USE eosbn2          ! for zdf_mxl_zint 
    2021   USE lib_mpp         ! MPP library 
    2122   USE wrk_nemo        ! work arrays 
    … …  
    2728 
    2829   PUBLIC   zdf_mxl       ! called by step.F90 
     30   PUBLIC   zdf_mxl_alloc ! Used in zdf_tke_init 
    2931 
    3032   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
    … …  
    3234   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m] 
    3335   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: mixed layer depth at t-points        [m] 
     36   REAL(wp), PUBLIC, ALLOCATABLE,       DIMENSION(:,:) ::   hmld_zint  !: vertically-interpolated mixed layer depth   [m]  
     37   REAL(wp), PUBLIC, ALLOCATABLE,       DIMENSION(:,:) ::   htc_mld    ! Heat content of hmld_zint 
     38   LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)    :: ll_found   ! Is T_b to be found by interpolation ?  
     39   LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  :: ll_belowml ! Flag points below mixed layer when ll_found=F 
    3440 
    3541   REAL(wp), PUBLIC ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth 
    3642   REAL(wp)         ::   avt_c = 5.e-4_wp   ! Kz criterion for the turbocline depth 
     43 
     44   TYPE, PUBLIC :: MXL_ZINT   !: Structure for MLD defs 
     45      INTEGER   :: mld_type   ! mixed layer type      
     46      REAL(wp)  :: zref       ! depth of initial T_ref 
     47      REAL(wp)  :: dT_crit    ! Critical temp diff 
     48      REAL(wp)  :: iso_frac   ! Fraction of rn_dT_crit used 
     49   END TYPE MXL_ZINT 
    3750 
    3851   !! * Substitutions 
    … …  
    5164      zdf_mxl_alloc = 0      ! set to zero if no array to be allocated 
    5265      IF( .NOT. ALLOCATED( nmln ) ) THEN 
    53          ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) 
     66         ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), hmld_zint(jpi,jpj),       & 
     67        &          htc_mld(jpi,jpj),                                                                    & 
     68        &          ll_found(jpi,jpj), ll_belowml(jpi,jpj,jpk), STAT= zdf_mxl_alloc ) 
    5469         ! 
    5570         IF( lk_mpp             )   CALL mpp_sum ( zdf_mxl_alloc ) 
    … …  
    7994      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8095      ! 
    81       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    82       INTEGER  ::   iikn, iiki, ikt, imkt  ! local integer 
    83       REAL(wp) ::   zN2_c        ! local scalar 
     96      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     97      INTEGER  ::   iikn, iiki, ikt ! local integer 
     98      REAL(wp) ::   zN2_c           ! local scalar 
    8499      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    85100      !!---------------------------------------------------------------------- 
    … …  
    89104      CALL wrk_alloc( jpi,jpj, imld ) 
    90105 
    91       IF( kt == nit000 ) THEN 
     106      IF( kt <= nit000 ) THEN 
    92107         IF(lwp) WRITE(numout,*) 
    93108         IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth' 
    … …  
    116131         DO jj = 1, jpj 
    117132            DO ji = 1, jpi 
    118                imkt = mikt(ji,jj) 
    119                IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
     133               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    120134            END DO 
    121135         END DO 
    … …  
    126140            iiki = imld(ji,jj) 
    127141            iikn = nmln(ji,jj) 
    128             imkt = mikt(ji,jj) 
    129             hmld (ji,jj) = ( fsdepw(ji,jj,iiki  ) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! Turbocline depth  
    130             hmlp (ji,jj) = ( fsdepw(ji,jj,iikn  ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
    131             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 
     142            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
     143            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth 
     144            hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    132145         END DO 
    133146      END DO 
    134       IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    135          CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    136          CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
     147      ! no need to output in offline mode 
     148      IF( .NOT.lk_offline ) THEN    
     149         IF ( iom_use("mldr10_1") ) THEN 
     150            IF( ln_isfcav ) THEN 
     151               CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     152            ELSE 
     153               CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     154            END IF 
     155         END IF 
     156         IF ( iom_use("mldkz5") ) THEN 
     157            IF( ln_isfcav ) THEN 
     158               CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     159            ELSE 
     160               CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     161            END IF 
     162         END IF 
    137163      ENDIF 
    138164       
     165      ! Vertically-interpolated mixed-layer depth diagnostic 
     166      CALL zdf_mxl_zint( kt ) 
     167 
    139168      IF(ln_ctl)   CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ', ovlap=1 ) 
    140169      ! 
    … …  
    144173      ! 
    145174   END SUBROUTINE zdf_mxl 
     175 
     176   SUBROUTINE zdf_mxl_zint_mld( sf )  
     177      !!----------------------------------------------------------------------------------  
     178      !!                    ***  ROUTINE zdf_mxl_zint_mld  ***  
     179      !                                                                         
     180      !   Calculate vertically-interpolated mixed layer depth diagnostic.  
     181      !             
     182      !   This routine can calculate the mixed layer depth diagnostic suggested by 
     183      !   Kara et al, 2000, JGR, 105, 16803, but is more general and can calculate 
     184      !   vertically-interpolated mixed-layer depth diagnostics with other parameter 
     185      !   settings set in the namzdf_mldzint namelist.   
     186      !  
     187      !   If mld_type=1 the mixed layer depth is calculated as the depth at which the   
     188      !   density has increased by an amount equivalent to a temperature difference of   
     189      !   0.8C at the surface.  
     190      !  
     191      !   For other values of mld_type the mixed layer is calculated as the depth at   
     192      !   which the temperature differs by 0.8C from the surface temperature.   
     193      !                                                                         
     194      !   David Acreman, Daley Calvert                                       
     195      !  
     196      !!-----------------------------------------------------------------------------------  
     197 
     198      TYPE(MXL_ZINT), INTENT(in)  :: sf 
     199 
     200      ! Diagnostic criteria 
     201      INTEGER   :: nn_mld_type   ! mixed layer type      
     202      REAL(wp)  :: rn_zref       ! depth of initial T_ref 
     203      REAL(wp)  :: rn_dT_crit    ! Critical temp diff 
     204      REAL(wp)  :: rn_iso_frac   ! Fraction of rn_dT_crit used 
     205 
     206      ! Local variables 
     207      REAL(wp), PARAMETER :: zepsilon = 1.e-30          ! local small value 
     208      INTEGER, POINTER, DIMENSION(:,:) :: ikmt          ! number of active tracer levels  
     209      INTEGER, POINTER, DIMENSION(:,:) :: ik_ref        ! index of reference level  
     210      INTEGER, POINTER, DIMENSION(:,:) :: ik_iso        ! index of last uniform temp level  
     211      REAL, POINTER, DIMENSION(:,:,:)  :: zT            ! Temperature or density  
     212      REAL, POINTER, DIMENSION(:,:)    :: ppzdep        ! depth for use in calculating d(rho)  
     213      REAL, POINTER, DIMENSION(:,:)    :: zT_ref        ! reference temperature  
     214      REAL    :: zT_b                                   ! base temperature  
     215      REAL, POINTER, DIMENSION(:,:,:)  :: zdTdz         ! gradient of zT  
     216      REAL, POINTER, DIMENSION(:,:,:)  :: zmoddT        ! Absolute temperature difference  
     217      REAL    :: zdz                                    ! depth difference  
     218      REAL    :: zdT                                    ! temperature difference  
     219      REAL, POINTER, DIMENSION(:,:)    :: zdelta_T      ! difference critereon  
     220      REAL, POINTER, DIMENSION(:,:)    :: zRHO1, zRHO2  ! Densities  
     221      INTEGER :: ji, jj, jk                             ! loop counter  
     222 
     223      !!-------------------------------------------------------------------------------------  
     224      !   
     225      CALL wrk_alloc( jpi, jpj, ikmt, ik_ref, ik_iso)  
     226      CALL wrk_alloc( jpi, jpj, ppzdep, zT_ref, zdelta_T, zRHO1, zRHO2 )  
     227      CALL wrk_alloc( jpi, jpj, jpk, zT, zdTdz, zmoddT )  
     228 
     229      ! Unpack structure 
     230      nn_mld_type = sf%mld_type 
     231      rn_zref     = sf%zref 
     232      rn_dT_crit  = sf%dT_crit 
     233      rn_iso_frac = sf%iso_frac 
     234 
     235      ! Set the mixed layer depth criterion at each grid point  
     236      IF( nn_mld_type == 0 ) THEN 
     237         zdelta_T(:,:) = rn_dT_crit 
     238         zT(:,:,:) = rhop(:,:,:) 
     239      ELSE IF( nn_mld_type == 1 ) THEN 
     240         ppzdep(:,:)=0.0  
     241         call eos ( tsn(:,:,1,:), ppzdep(:,:), zRHO1(:,:) )  
     242! Use zT temporarily as a copy of tsn with rn_dT_crit added to SST  
     243! [assumes number of tracers less than number of vertical levels]  
     244         zT(:,:,1:jpts)=tsn(:,:,1,1:jpts)  
     245         zT(:,:,jp_tem)=zT(:,:,1)+rn_dT_crit  
     246         CALL eos( zT(:,:,1:jpts), ppzdep(:,:), zRHO2(:,:) )  
     247         zdelta_T(:,:) = abs( zRHO1(:,:) - zRHO2(:,:) ) * rau0  
     248         ! RHO from eos (2d version) doesn't calculate north or east halo:  
     249         CALL lbc_lnk( zdelta_T, 'T', 1. )  
     250         zT(:,:,:) = rhop(:,:,:)  
     251      ELSE  
     252         zdelta_T(:,:) = rn_dT_crit                       
     253         zT(:,:,:) = tsn(:,:,:,jp_tem)                            
     254      END IF  
     255 
     256      ! Calculate the gradient of zT and absolute difference for use later  
     257      DO jk = 1 ,jpk-2  
     258         zdTdz(:,:,jk)  =    ( zT(:,:,jk+1) - zT(:,:,jk) ) / fse3w(:,:,jk+1)  
     259         zmoddT(:,:,jk) = abs( zT(:,:,jk+1) - zT(:,:,jk) )  
     260      END DO  
     261 
     262      ! Find density/temperature at the reference level (Kara et al use 10m).           
     263      ! ik_ref is the index of the box centre immediately above or at the reference level  
     264      ! Find rn_zref in the array of model level depths and find the ref     
     265      ! density/temperature by linear interpolation.                                    
     266      DO jk = jpkm1, 2, -1  
     267         WHERE ( fsdept(:,:,jk) > rn_zref )  
     268           ik_ref(:,:) = jk - 1  
     269           zT_ref(:,:) = zT(:,:,jk-1) + zdTdz(:,:,jk-1) * ( rn_zref - fsdept(:,:,jk-1) )  
     270         END WHERE  
     271      END DO  
     272 
     273      ! If the first grid box centre is below the reference level then use the  
     274      ! top model level to get zT_ref  
     275      WHERE ( fsdept(:,:,1) > rn_zref )   
     276         zT_ref = zT(:,:,1)  
     277         ik_ref = 1  
     278      END WHERE  
     279 
     280      ! The number of active tracer levels is 1 less than the number of active w levels  
     281      ikmt(:,:) = mbathy(:,:) - 1  
     282 
     283      ! Initialize / reset 
     284      ll_found(:,:) = .false. 
     285 
     286      IF ( rn_iso_frac - zepsilon > 0. ) THEN 
     287         ! Search for a uniform density/temperature region where adjacent levels           
     288         ! differ by less than rn_iso_frac * deltaT.                                       
     289         ! ik_iso is the index of the last level in the uniform layer   
     290         ! ll_found indicates whether the mixed layer depth can be found by interpolation  
     291         ik_iso(:,:)   = ik_ref(:,:)  
     292         DO jj = 1, nlcj  
     293            DO ji = 1, nlci  
     294!CDIR NOVECTOR  
     295               DO jk = ik_ref(ji,jj), ikmt(ji,jj)-1  
     296                  IF ( zmoddT(ji,jj,jk) > ( rn_iso_frac * zdelta_T(ji,jj) ) ) THEN  
     297                     ik_iso(ji,jj)   = jk  
     298                     ll_found(ji,jj) = ( zmoddT(ji,jj,jk) > zdelta_T(ji,jj) )  
     299                     EXIT  
     300                  END IF  
     301               END DO  
     302            END DO  
     303         END DO  
     304 
     305         ! Use linear interpolation to find depth of mixed layer base where possible  
     306         hmld_zint(:,:) = rn_zref  
     307         DO jj = 1, jpj  
     308            DO ji = 1, jpi  
     309               IF (ll_found(ji,jj) .and. tmask(ji,jj,1) == 1.0) THEN  
     310                  zdz =  abs( zdelta_T(ji,jj) / zdTdz(ji,jj,ik_iso(ji,jj)) )  
     311                  hmld_zint(ji,jj) = fsdept(ji,jj,ik_iso(ji,jj)) + zdz  
     312               END IF  
     313            END DO  
     314         END DO  
     315      END IF 
     316 
     317      ! If ll_found = .false. then calculate MLD using difference of zdelta_T     
     318      ! from the reference density/temperature  
     319  
     320! Prevent this section from working on land points  
     321      WHERE ( tmask(:,:,1) /= 1.0 )  
     322         ll_found = .true.  
     323      END WHERE  
     324  
     325      DO jk=1, jpk  
     326         ll_belowml(:,:,jk) = abs( zT(:,:,jk) - zT_ref(:,:) ) >= zdelta_T(:,:)   
     327      END DO  
     328  
     329! Set default value where interpolation cannot be used (ll_found=false)   
     330      DO jj = 1, jpj  
     331         DO ji = 1, jpi  
     332            IF ( .not. ll_found(ji,jj) )  hmld_zint(ji,jj) = fsdept(ji,jj,ikmt(ji,jj))  
     333         END DO  
     334      END DO  
     335 
     336      DO jj = 1, jpj  
     337         DO ji = 1, jpi  
     338!CDIR NOVECTOR  
     339            DO jk = ik_ref(ji,jj)+1, ikmt(ji,jj)  
     340               IF ( ll_found(ji,jj) ) EXIT  
     341               IF ( ll_belowml(ji,jj,jk) ) THEN                 
     342                  zT_b = zT_ref(ji,jj) + zdelta_T(ji,jj) * SIGN(1.0, zdTdz(ji,jj,jk-1) )  
     343                  zdT  = zT_b - zT(ji,jj,jk-1)                                       
     344                  zdz  = zdT / zdTdz(ji,jj,jk-1)                                        
     345                  hmld_zint(ji,jj) = fsdept(ji,jj,jk-1) + zdz  
     346                  EXIT                                                    
     347               END IF  
     348            END DO  
     349         END DO  
     350      END DO  
     351 
     352      hmld_zint(:,:) = hmld_zint(:,:)*tmask(:,:,1)  
     353      !   
     354      CALL wrk_dealloc( jpi, jpj, ikmt, ik_ref, ik_iso)  
     355      CALL wrk_dealloc( jpi, jpj, ppzdep, zT_ref, zdelta_T, zRHO1, zRHO2 )  
     356      CALL wrk_dealloc( jpi,jpj, jpk, zT, zdTdz, zmoddT )  
     357      !  
     358   END SUBROUTINE zdf_mxl_zint_mld 
     359 
     360   SUBROUTINE zdf_mxl_zint_htc( kt ) 
     361      !!---------------------------------------------------------------------- 
     362      !!                  ***  ROUTINE zdf_mxl_zint_htc  *** 
     363      !!  
     364      !! ** Purpose :    
     365      !! 
     366      !! ** Method  :    
     367      !!---------------------------------------------------------------------- 
     368 
     369      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     370 
     371      INTEGER :: ji, jj, jk 
     372      INTEGER :: ikmax 
     373      REAL(wp) :: zc, zcoef 
     374      ! 
     375      INTEGER,  ALLOCATABLE, DIMENSION(:,:) ::   ilevel 
     376      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zthick_0, zthick 
     377 
     378      !!---------------------------------------------------------------------- 
     379 
     380      IF( .NOT. ALLOCATED(ilevel) ) THEN 
     381         ALLOCATE( ilevel(jpi,jpj), zthick_0(jpi,jpj), & 
     382         &         zthick(jpi,jpj), STAT=ji ) 
     383         IF( lk_mpp  )   CALL mpp_sum(ji) 
     384         IF( ji /= 0 )   CALL ctl_stop( 'STOP', 'zdf_mxl_zint_htc : unable to allocate arrays' ) 
     385      ENDIF 
     386 
     387      ! Find last whole model T level above the MLD 
     388      ilevel(:,:)   = 0 
     389      zthick_0(:,:) = 0._wp 
     390 
     391      DO jk = 1, jpkm1   
     392         DO jj = 1, jpj 
     393            DO ji = 1, jpi                     
     394               zthick_0(ji,jj) = zthick_0(ji,jj) + fse3t(ji,jj,jk) 
     395               IF( zthick_0(ji,jj) < hmld_zint(ji,jj) )   ilevel(ji,jj) = jk 
     396            END DO 
     397         END DO 
     398         WRITE(numout,*) 'zthick_0(jk =',jk,') =',zthick_0(2,2) 
     399         WRITE(numout,*) 'fsdepw(jk+1 =',jk+1,') =',fsdepw(2,2,jk+1) 
     400      END DO 
     401 
     402      ! Surface boundary condition 
     403      IF( lk_vvl ) THEN   ;   zthick(:,:) = 0._wp       ;   htc_mld(:,:) = 0._wp                                    
     404      ELSE                ;   zthick(:,:) = sshn(:,:)   ;   htc_mld(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1)    
     405      ENDIF 
     406 
     407      ! Deepest whole T level above the MLD 
     408      ikmax = MIN( MAXVAL( ilevel(:,:) ), jpkm1 ) 
     409 
     410      ! Integration down to last whole model T level 
     411      DO jk = 1, ikmax 
     412         DO jj = 1, jpj 
     413            DO ji = 1, jpi 
     414               zc = fse3t(ji,jj,jk) * REAL( MIN( MAX( 0, ilevel(ji,jj) - jk + 1 ) , 1  )  )    ! 0 below ilevel 
     415               zthick(ji,jj) = zthick(ji,jj) + zc 
     416               htc_mld(ji,jj) = htc_mld(ji,jj) + zc * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
     417            END DO 
     418         END DO 
     419      END DO 
     420 
     421      ! Subsequent partial T level 
     422      zthick(:,:) = hmld_zint(:,:) - zthick(:,:)   !   remaining thickness to reach MLD 
     423 
     424      DO jj = 1, jpj 
     425         DO ji = 1, jpi 
     426            htc_mld(ji,jj) = htc_mld(ji,jj) + tsn(ji,jj,ilevel(ji,jj)+1,jp_tem)  &  
     427      &                      * MIN( fse3t(ji,jj,ilevel(ji,jj)+1), zthick(ji,jj) ) * tmask(ji,jj,ilevel(ji,jj)+1) 
     428         END DO 
     429      END DO 
     430 
     431      WRITE(numout,*) 'htc_mld(after) =',htc_mld(2,2) 
     432 
     433      ! Convert to heat content 
     434      zcoef = rau0 * rcp 
     435      htc_mld(:,:) = zcoef * htc_mld(:,:) 
     436 
     437   END SUBROUTINE zdf_mxl_zint_htc 
     438 
     439   SUBROUTINE zdf_mxl_zint( kt ) 
     440      !!---------------------------------------------------------------------- 
     441      !!                  ***  ROUTINE zdf_mxl_zint  *** 
     442      !!  
     443      !! ** Purpose :    
     444      !! 
     445      !! ** Method  :    
     446      !!---------------------------------------------------------------------- 
     447 
     448      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     449 
     450      INTEGER :: ios 
     451      INTEGER :: jn 
     452 
     453      INTEGER :: nn_mld_diag = 0    ! number of diagnostics 
     454 
     455      CHARACTER(len=1) :: cmld 
     456 
     457      TYPE(MXL_ZINT) :: sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 
     458      TYPE(MXL_ZINT), SAVE, DIMENSION(5) ::   mld_diags 
     459 
     460      NAMELIST/namzdf_mldzint/ nn_mld_diag, sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 
     461 
     462      !!---------------------------------------------------------------------- 
     463       
     464      IF( kt == nit000 ) THEN 
     465         REWIND( numnam_ref )              ! Namelist namzdf_mldzint in reference namelist  
     466         READ  ( numnam_ref, namzdf_mldzint, IOSTAT = ios, ERR = 901) 
     467901      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_mldzint in reference namelist', lwp ) 
     468 
     469         REWIND( numnam_cfg )              ! Namelist namzdf_mldzint in configuration namelist  
     470         READ  ( numnam_cfg, namzdf_mldzint, IOSTAT = ios, ERR = 902 ) 
     471902      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_mldzint in configuration namelist', lwp ) 
     472         IF(lwm) WRITE ( numond, namzdf_mldzint ) 
     473 
     474         IF( nn_mld_diag > 5 )   CALL ctl_stop( 'STOP', 'zdf_mxl_ini: Specify no more than 5 MLD definitions' ) 
     475 
     476         mld_diags(1) = sn_mld1 
     477         mld_diags(2) = sn_mld2 
     478         mld_diags(3) = sn_mld3 
     479         mld_diags(4) = sn_mld4 
     480         mld_diags(5) = sn_mld5 
     481 
     482         IF( lwp .AND. (nn_mld_diag > 0) ) THEN 
     483            WRITE(numout,*) '=============== Vertically-interpolated mixed layer ================' 
     484            WRITE(numout,*) '(Diagnostic number, nn_mld_type, rn_zref, rn_dT_crit, rn_iso_frac)' 
     485            DO jn = 1, nn_mld_diag 
     486               WRITE(numout,*) 'MLD criterion',jn,':' 
     487               WRITE(numout,*) '    nn_mld_type =', mld_diags(jn)%mld_type 
     488               WRITE(numout,*) '    rn_zref ='    , mld_diags(jn)%zref 
     489               WRITE(numout,*) '    rn_dT_crit =' , mld_diags(jn)%dT_crit 
     490               WRITE(numout,*) '    rn_iso_frac =', mld_diags(jn)%iso_frac 
     491            END DO 
     492            WRITE(numout,*) '====================================================================' 
     493         ENDIF 
     494      ENDIF 
     495 
     496      IF( nn_mld_diag > 0 ) THEN 
     497         DO jn = 1, nn_mld_diag 
     498            WRITE(cmld,'(I1)') jn 
     499            IF( iom_use( "mldzint_"//cmld ) .OR. iom_use( "mldhtc_"//cmld ) ) THEN 
     500               CALL zdf_mxl_zint_mld( mld_diags(jn) ) 
     501 
     502               IF( iom_use( "mldzint_"//cmld ) ) THEN 
     503                  CALL iom_put( "mldzint_"//cmld, hmld_zint(:,:) ) 
     504               ENDIF 
     505 
     506               IF( iom_use( "mldhtc_"//cmld ) )  THEN 
     507                  CALL zdf_mxl_zint_htc( kt ) 
     508                  CALL iom_put( "mldhtc_"//cmld , htc_mld(:,:)   ) 
     509               ENDIF 
     510            ENDIF 
     511         END DO 
     512      ENDIF 
     513 
     514   END SUBROUTINE zdf_mxl_zint 
    146515 
    147516   !!====================================================================== 

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

    r9188 r9987  
    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 
    … …  
    7783   INTEGER  ::   nn_htau   ! type of tke profile of penetration (=0/1) 
    7884   REAL(wp) ::   rn_efr    ! fraction of TKE surface value which penetrates in the ocean 
     85   REAL(wp) ::   rn_c      ! fraction of TKE added within the mixed layer by nn_etau 
    7986   LOGICAL  ::   ln_lc     ! Langmuir cells (LC) as a source term of TKE or not 
    8087   REAL(wp) ::   rn_lc     ! coef to compute vertical velocity of Langmuir cells 
    … …  
    8289   REAL(wp) ::   ri_cri    ! critic Richardson number (deduced from rn_ediff and rn_ediss values) 
    8390   REAL(wp) ::   rmxl_min  ! minimum mixing length value (deduced from rn_ediff and rn_emin values)  [m] 
     91   REAL(wp) ::   rhtau                     ! coefficient to relate MLD to htau when nn_htau == 2 
    8492   REAL(wp) ::   rhftau_add = 1.e-3_wp     ! add offset   applied to HF part of taum  (nn_etau=3) 
    8593   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    8694 
    8795   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
     96   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_niw          !: TKE budget- near-inertial waves term 
     97   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   efr            ! surface boundary condition for nn_etau = 4 
    8898   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    8999#if defined key_c1d 
    … …  
    108118      !!---------------------------------------------------------------------- 
    109119      ALLOCATE(                                                                    & 
     120         &      efr  (jpi,jpj)     , e_niw(jpi,jpj,jpk) ,                         &       
    110121#if defined key_c1d 
    111122         &      e_dis(jpi,jpj,jpk) , e_mix(jpi,jpj,jpk) ,                          & 
    … …  
    184195      avmv_k(:,:,:) = avmv(:,:,:)  
    185196      ! 
     197#if defined key_agrif 
     198      ! Update child grid f => parent grid  
     199      IF( .NOT.Agrif_Root() )   CALL Agrif_Update_Tke( kt )      ! children only 
     200#endif       
     201     !  
    186202   END SUBROUTINE zdf_tke 
    187203 
    … …  
    312328                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    313329                  !                                           ! TKE Langmuir circulation source term 
    314                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     330                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
     331                     &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    315332               END DO 
    316333            END DO 
    … …  
    345362            DO ji = fs_2, fs_jpim1   ! vector opt. 
    346363               zcof   = zfact1 * tmask(ji,jj,jk) 
     364# if defined key_zdftmx_new 
     365               ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
     366               zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) )   &  ! upper diagonal 
     367                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
     368               zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) )   &  ! lower diagonal 
     369                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     370# else 
    347371               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    348372                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    349373               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    350374                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     375# endif 
    351376                  !                                                           ! shear prod. at w-point weightened by mask 
    352377               zesh2  =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 
    … …  
    408433      END DO 
    409434 
     435      !                                 ! Save TKE prior to nn_etau addition   
     436      e_niw(:,:,:) = en(:,:,:)   
     437      !   
    410438      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    411439      !                            !  TKE due to surface and internal wave breaking 
    412440      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     441      IF( nn_htau == 2 ) THEN           !* mixed-layer depth dependant length scale 
     442         DO jj = 2, jpjm1 
     443            DO ji = fs_2, fs_jpim1   ! vector opt. 
     444               htau(ji,jj) = rhtau * hmlp(ji,jj) 
     445            END DO 
     446         END DO 
     447      ENDIF 
     448#if defined key_iomput 
     449      ! 
     450      CALL iom_put( "htau", htau(:,:) )  ! Check htau (even if constant in time) 
     451#endif 
     452      ! 
    413453      IF( nn_etau == 1 ) THEN           !* penetration below the mixed layer (rn_efr fraction) 
    414454         DO jk = 2, jpkm1 
    … …  
    445485            END DO 
    446486         END DO 
     487      ELSEIF( nn_etau == 4 ) THEN       !* column integral independant of htau (rn_efr must be scaled up) 
     488         IF( nn_htau == 2 ) THEN        ! efr dependant on time-varying htau  
     489            DO jj = 2, jpjm1 
     490               DO ji = fs_2, fs_jpim1   ! vector opt. 
     491                  efr(ji,jj) = rn_efr / ( htau(ji,jj) * ( 1._wp - EXP( -bathy(ji,jj) / htau(ji,jj) ) ) ) 
     492               END DO 
     493            END DO 
     494         ENDIF 
     495         DO jk = 2, jpkm1 
     496            DO jj = 2, jpjm1 
     497               DO ji = fs_2, fs_jpim1   ! vector opt. 
     498                  en(ji,jj,jk) = en(ji,jj,jk) + efr(ji,jj) * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
     499                     &                                                   * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) 
     500               END DO 
     501            END DO 
     502         END DO 
    447503      ENDIF 
    448504      CALL lbc_lnk( en, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     505      ! 
     506      DO jk = 2, jpkm1                             ! TKE budget: near-inertial waves term   
     507         DO jj = 2, jpjm1   
     508            DO ji = fs_2, fs_jpim1   ! vector opt.   
     509               e_niw(ji,jj,jk) = en(ji,jj,jk) - e_niw(ji,jj,jk)   
     510            END DO   
     511         END DO   
     512      END DO   
     513      !   
     514      CALL lbc_lnk( e_niw, 'W', 1. )   
    449515      ! 
    450516      CALL wrk_dealloc( jpi,jpj, imlc )    ! integer 
    … …  
    705771      !!---------------------------------------------------------------------- 
    706772      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    707       INTEGER ::   ios 
     773      INTEGER ::   ios, ierr 
    708774      !! 
    709775      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,   & 
    710776         &                 rn_emin0, rn_bshear, nn_mxl , ln_mxl0  ,   & 
    711777         &                 rn_mxl0 , nn_pdl   , ln_lc  , rn_lc    ,   & 
    712          &                 nn_etau , nn_htau  , rn_efr    
     778         &                 nn_etau , nn_htau  , rn_efr , rn_c    
    713779      !!---------------------------------------------------------------------- 
    714       ! 
     780 
    715781      REWIND( numnam_ref )              ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy 
    716782      READ  ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) 
    … …  
    723789      ! 
    724790      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number 
     791# if defined key_zdftmx_new 
     792      ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 
     793      rn_emin  = 1.e-10_wp 
     794      rmxl_min = 1.e-03_wp 
     795      IF(lwp) THEN                  ! Control print 
     796         WRITE(numout,*) 
     797         WRITE(numout,*) 'zdf_tke_init :  New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 
     798         WRITE(numout,*) '~~~~~~~~~~~~' 
     799      ENDIF 
     800# else 
    725801      rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity 
     802# endif 
    726803      ! 
    727804      IF(lwp) THEN                    !* Control print 
    … …  
    745822         WRITE(numout,*) '      flag for computation of exp. tke profile    nn_htau   = ', nn_htau 
    746823         WRITE(numout,*) '      fraction of en which pene. the thermocline  rn_efr    = ', rn_efr 
     824         WRITE(numout,*) '      fraction of TKE added within the mixed layer by nn_etau rn_c    = ', rn_c 
    747825         WRITE(numout,*) 
    748826         WRITE(numout,*) '      critical Richardson nb with your parameters  ri_cri = ', ri_cri 
    … …  
    755833      IF( nn_mxl  < 0   .OR.  nn_mxl  > 3 )   CALL ctl_stop( 'bad flag: nn_mxl is  0, 1 or 2 ' ) 
    756834      IF( nn_pdl  < 0   .OR.  nn_pdl  > 1 )   CALL ctl_stop( 'bad flag: nn_pdl is  0 or 1    ' ) 
    757       IF( nn_htau < 0   .OR.  nn_htau > 1 )   CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 
     835      IF( nn_htau < 0  .OR.  nn_htau > 5 )   CALL ctl_stop( 'bad flag: nn_htau is 0 to 5    ' ) 
    758836      IF( nn_etau == 3 .AND. .NOT. ln_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 
    759837 
    … …  
    763841      ENDIF 
    764842       
    765       IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln  
     843      IF( nn_etau == 2  ) THEN 
     844          ierr = zdf_mxl_alloc() 
     845          nmln(:,:) = nlb10           ! Initialization of nmln 
     846      ENDIF 
     847 
     848      IF( nn_etau /= 0 .and. nn_htau == 2 ) THEN 
     849          ierr = zdf_mxl_alloc() 
     850          nmln(:,:) = nlb10           ! Initialization of nmln 
     851      ENDIF 
    766852 
    767853      !                               !* depth of penetration of surface tke 
    768854      IF( nn_etau /= 0 ) THEN       
     855         htau(:,:) = 0._wp 
    769856         SELECT CASE( nn_htau )             ! Choice of the depth of penetration 
    770857         CASE( 0 )                                 ! constant depth penetration (here 10 meters) 
    … …  
    772859         CASE( 1 )                                 ! F(latitude) : 0.5m to 30m poleward of 40 degrees 
    773860            htau(:,:) = MAX(  0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) )   )             
     861         CASE( 2 )                                 ! fraction of depth-integrated TKE within mixed-layer 
     862            rhtau = -1._wp / LOG( 1._wp - rn_c ) 
     863         CASE( 3 )                                 ! F(latitude) : 0.5m to 15m poleward of 20 degrees 
     864            htau(:,:) = MAX(  0.5_wp, MIN( 15._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) )   ) 
     865         CASE( 4 )                                 ! F(latitude) : 0.5m to 10m/30m poleward of 13/40 degrees north/south 
     866            DO jj = 2, jpjm1 
     867               DO ji = fs_2, fs_jpim1   ! vector opt. 
     868                  IF( gphit(ji,jj) <= 0._wp ) THEN 
     869                     htau(ji,jj) = MAX(  0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(ji,jj) ) ) )   ) 
     870                  ELSE 
     871                     htau(ji,jj) = MAX(  0.5_wp, MIN( 10._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(ji,jj) ) ) )   ) 
     872                  ENDIF 
     873               END DO 
     874            END DO 
     875         CASE ( 5 )                                ! F(latitude) : 0.5m to 10m poleward of 13 degrees north/south, 
     876            DO jj = 2, jpjm1                       !               10m to 30m between 30/45 degrees south 
     877               DO ji = fs_2, fs_jpim1   ! vector opt. 
     878                  IF( gphit(ji,jj) <= -30._wp ) THEN 
     879                     htau(ji,jj) = MAX(  10._wp, MIN( 30._wp, 55._wp* ABS( SIN( rpi/120._wp * ( gphit(ji,jj) + 23._wp ) ) ) )   ) 
     880                  ELSE 
     881                     htau(ji,jj) = MAX(  0.5_wp, MIN( 10._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(ji,jj) ) ) )   ) 
     882                  ENDIF 
     883               END DO 
     884            END DO 
    774885         END SELECT 
     886         ! 
     887         IF( nn_etau == 4 .AND. nn_htau /= 2 ) THEN            ! efr dependant on constant htau 
     888            DO jj = 2, jpjm1 
     889               DO ji = fs_2, fs_jpim1   ! vector opt. 
     890                  efr(ji,jj) = rn_efr / ( htau(ji,jj) * ( 1._wp - EXP( -bathy(ji,jj) / htau(ji,jj) ) ) ) 
     891               END DO 
     892            END DO 
     893         ENDIF 
    775894      ENDIF 
    776895      !                               !* set vertical eddy coef. to the background value 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r7960 r9987  
    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( "emix_tmx", emix_tmx ) 
     921       
     922      CALL wrk_dealloc( jpi,jpj,       zfact, zhdep ) 
     923      CALL wrk_dealloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     924 
     925      IF(ln_ctl)   CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 
     926      ! 
     927      IF( nn_timing == 1 )   CALL timing_stop('zdf_tmx') 
     928      ! 
     929   END SUBROUTINE zdf_tmx 
     930 
     931 
     932   SUBROUTINE zdf_tmx_init 
     933      !!---------------------------------------------------------------------- 
     934      !!                  ***  ROUTINE zdf_tmx_init  *** 
     935      !!                      
     936      !! ** Purpose :   Initialization of the wave-driven vertical mixing, reading 
     937      !!              of input power maps and decay length scales in netcdf files. 
     938      !! 
     939      !! ** Method  : - Read the namzdf_tmx namelist and check the parameters 
     940      !! 
     941      !!              - Read the input data in NetCDF files : 
     942      !!              power available from high-mode wave breaking (mixing_power_bot.nc) 
     943      !!              power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 
     944      !!              power available from critical slope wave-breaking (mixing_power_cri.nc) 
     945      !!              WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 
     946      !!              decay scale for critical slope wave-breaking (decay_scale_cri.nc) 
     947      !! 
     948      !! ** input   : - Namlist namzdf_tmx 
     949      !!              - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 
     950      !!              decay_scale_bot.nc decay_scale_cri.nc 
     951      !! 
     952      !! ** Action  : - Increase by 1 the nstop flag is setting problem encounter 
     953      !!              - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 
     954      !! 
     955      !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 
     956      !!          
     957      !!---------------------------------------------------------------------- 
     958      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     959      INTEGER  ::   inum         ! local integer 
     960      INTEGER  ::   ios 
     961      REAL(wp) ::   zbot, zpyc, zcri   ! local scalars 
     962      !! 
     963      NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 
     964      !!---------------------------------------------------------------------- 
     965      ! 
     966      IF( nn_timing == 1 )  CALL timing_start('zdf_tmx_init') 
     967      ! 
     968      REWIND( numnam_ref )              ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 
     969      READ  ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 
     970901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 
     971      ! 
     972      REWIND( numnam_cfg )              ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 
     973      READ  ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 
     974902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 
     975      IF(lwm) WRITE ( numond, namzdf_tmx_new ) 
     976      ! 
     977      IF(lwp) THEN                  ! Control print 
     978         WRITE(numout,*) 
     979         WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 
     980         WRITE(numout,*) '~~~~~~~~~~~~' 
     981         WRITE(numout,*) '   Namelist namzdf_tmx_new : set wave-driven mixing parameters' 
     982         WRITE(numout,*) '      Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 
     983         WRITE(numout,*) '      Variable (T) or constant (F) mixing efficiency            = ', ln_mevar 
     984         WRITE(numout,*) '      Differential internal wave-driven mixing (T) or not (F)   = ', ln_tsdiff 
     985      ENDIF 
     986       
     987      ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 
     988      ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should  
     989      ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 
     990      avmb(:) = 1.4e-6_wp        ! viscous molecular value 
     991      avtb(:) = 1.e-10_wp        ! very small diffusive minimum (background avt is specified in zdf_tmx)     
     992      avtb_2d(:,:) = 1.e0_wp     ! uniform  
     993      IF(lwp) THEN                  ! Control print 
     994         WRITE(numout,*) 
     995         WRITE(numout,*) '   Force the background value applied to avm & avt in TKE to be everywhere ',   & 
     996            &               'the viscous molecular value & a very small diffusive value, resp.' 
     997      ENDIF 
     998       
     999      IF( .NOT.lk_zdfddm )   CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 
     1000       
     1001      !                             ! allocate tmx arrays 
     1002      IF( zdf_tmx_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 
     1003      ! 
     1004      !                             ! read necessary fields 
     1005      CALL iom_open('mixing_power_bot',inum)       ! energy flux for high-mode wave breaking [W/m2] 
     1006      CALL iom_get  (inum, jpdom_data, 'field', ebot_tmx, 1 )  
     1007      CALL iom_close(inum) 
     1008      ! 
     1009      CALL iom_open('mixing_power_pyc',inum)       ! energy flux for pynocline-intensified wave breaking [W/m2] 
     1010      CALL iom_get  (inum, jpdom_data, 'field', epyc_tmx, 1 ) 
     1011      CALL iom_close(inum) 
     1012      ! 
     1013      CALL iom_open('mixing_power_cri',inum)       ! energy flux for critical slope wave breaking [W/m2] 
     1014      CALL iom_get  (inum, jpdom_data, 'field', ecri_tmx, 1 ) 
     1015      CALL iom_close(inum) 
     1016      ! 
     1017      CALL iom_open('decay_scale_bot',inum)        ! spatially variable decay scale for high-mode wave breaking [m] 
     1018      CALL iom_get  (inum, jpdom_data, 'field', hbot_tmx, 1 ) 
     1019      CALL iom_close(inum) 
     1020      ! 
     1021      CALL iom_open('decay_scale_cri',inum)        ! spatially variable decay scale for critical slope wave breaking [m] 
     1022      CALL iom_get  (inum, jpdom_data, 'field', hcri_tmx, 1 ) 
     1023      CALL iom_close(inum) 
     1024 
     1025      ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 
     1026      epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 
     1027      ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 
     1028 
     1029      ! Set once for all to zero the first and last vertical levels of appropriate variables 
     1030      emix_tmx (:,:, 1 ) = 0._wp 
     1031      emix_tmx (:,:,jpk) = 0._wp 
     1032      zav_ratio(:,:, 1 ) = 0._wp 
     1033      zav_ratio(:,:,jpk) = 0._wp 
     1034      zav_wave (:,:, 1 ) = 0._wp 
     1035      zav_wave (:,:,jpk) = 0._wp 
     1036 
     1037      zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 
     1038      zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 
     1039      zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 
     1040      IF(lwp) THEN 
     1041         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 
     1042         WRITE(numout,*) '      Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 
     1043         WRITE(numout,*) '      Critical slope wave-breaking energy:        ', zcri * 1.e-12_wp, 'TW' 
     1044      ENDIF 
     1045      ! 
     1046      IF( nn_timing == 1 )  CALL timing_stop('zdf_tmx_init') 
     1047      ! 
     1048   END SUBROUTINE zdf_tmx_init 
     1049 
    5631050#else 
    5641051   !!---------------------------------------------------------------------- 

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

    r7960 r9987  
    6868   USE icbini          ! handle bergs, initialisation 
    6969   USE icbstp          ! handle bergs, calving, themodynamics and transport 
     70   USE sbccpl  
    7071   USE cpl_oasis3      ! OASIS3 coupling 
    7172   USE c1d             ! 1D configuration 
    … …  
    7475#if defined key_top 
    7576   USE trcini          ! passive tracer initialisation 
     77   USE trc, ONLY: numstr  ! tracer stats unit number 
    7678#endif 
    7779   USE lib_mpp         ! distributed memory computing 
    … …  
    161163          ENDIF 
    162164 
     165#if defined key_agrif 
     166          CALL Agrif_Regrid() 
     167#endif 
     168 
    163169         DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    164170#if defined key_agrif 
    165             CALL Agrif_Step( stp )           ! AGRIF: time stepping 
     171            CALL stp                         ! AGRIF: time stepping 
    166172#else 
    167             CALL stp( istp )                 ! standard time stepping 
     173            IF (lk_oasis) CALL sbc_cpl_snd( istp )  ! Coupling to atmos 
     174       CALL stp( istp ) 
     175            ! We don't couple on the final timestep because 
     176            ! our restart file has already been written 
     177            ! and contains all the necessary data for a 
     178            ! restart. sbc_cpl_snd could be called here 
     179            ! but it would require 
     180            ! a) A test to ensure it was not performed 
     181            !    on the very last time-step 
     182            ! b) the presence of another call to 
     183            !    sbc_cpl_snd call prior to the main DO loop 
     184            ! This solution produces identical results 
     185            ! with fewer lines of code.  
    168186#endif 
    169187            istp = istp + 1 
    … …  
    187205      ! 
    188206#if defined key_agrif 
    189       CALL Agrif_ParentGrid_To_ChildGrid() 
    190       IF( lk_diaobs ) CALL dia_obs_wri 
    191       IF( nn_timing == 1 )   CALL timing_finalize 
    192       CALL Agrif_ChildGrid_To_ParentGrid() 
     207      IF( .NOT. Agrif_Root() ) THEN 
     208         CALL Agrif_ParentGrid_To_ChildGrid() 
     209         IF( lk_diaobs ) CALL dia_obs_wri 
     210         IF( nn_timing == 1 )   CALL timing_finalize 
     211         CALL Agrif_ChildGrid_To_ParentGrid() 
     212      ENDIF 
    193213#endif 
    194214      IF( nn_timing == 1 )   CALL timing_finalize 
    … …  
    206226      ENDIF 
    207227#endif 
     228      ! 
     229      ! Met Office addition: if failed, return non-zero exit code 
     230      IF( nstop /= 0 )  CALL exit( 9 )  
    208231      ! 
    209232   END SUBROUTINE nemo_gcm 
    … …  
    277300      IF( Agrif_Root() ) THEN 
    278301         IF( lk_oasis ) THEN 
    279             CALL cpl_init( "oceanx", ilocal_comm )                     ! nemo local communicator given by oasis 
     302            CALL cpl_init( "toyoce", ilocal_comm )                     ! nemo local communicator given by oasis 
    280303            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios 
    281304         ELSE 
    … …  
    288311      IF( lk_oasis ) THEN 
    289312         IF( Agrif_Root() ) THEN 
    290             CALL cpl_init( "oceanx", ilocal_comm )                      ! nemo local communicator given by oasis 
     313            CALL cpl_init( "toyoce", ilocal_comm )                      ! nemo local communicator given by oasis 
    291314         ENDIF 
    292315         ! Nodes selection (control print return in cltxt) 
    … …  
    334357         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    335358#endif 
    336       ENDIF 
     359      ENDIF          
    337360         jpk = jpkdta                                             ! third dim 
     361#if defined key_agrif 
     362         ! simple trick to use same vertical grid as parent 
     363         ! but different number of levels:  
     364         ! Save maximum number of levels in jpkdta, then define all vertical grids 
     365         ! with this number. 
     366         ! Suppress once vertical online interpolation is ok 
     367         IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 
     368#endif 
    338369         jpim1 = jpi-1                                            ! inner domain indices 
    339370         jpjm1 = jpj-1                                            !   "           " 
    … …  
    448479      !                                     ! Diagnostics 
    449480      IF( lk_floats     )   CALL     flo_init   ! drifting Floats 
    450       IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag 
    451481                            CALL dia_ptr_init   ! Poleward TRansports initialization 
    452482      IF( lk_diadct     )   CALL dia_dct_init   ! Sections tranports 
    453483                            CALL dia_hsb_init   ! heat content, salt content and volume budgets 
    454484                            CALL     trd_init   ! Mixed-layer/Vorticity/Integral constraints trends 
     485                            CALL     bias_init  ! Pressure correction bias 
    455486      IF( lk_diaobs     ) THEN                  ! Observation & model comparison 
    456487                            CALL dia_obs_init            ! Initialize observational data 
    … …  
    461492      IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments 
    462493      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 
     494       
     495      IF (nstop > 0) THEN 
     496        CALL CTL_STOP('STOP','Critical errors in NEMO initialisation') 
     497      END IF 
     498 
    463499      ! 
    464500   END SUBROUTINE nemo_init 
    … …  
    596632      IF( numdct_heat     /= -1 )   CLOSE( numdct_heat     )   ! heat transports 
    597633      IF( numdct_salt     /= -1 )   CLOSE( numdct_salt     )   ! salt transports 
    598  
     634#if defined key_top 
     635      IF( numstr          /= -1 )   CLOSE( numstr          )   ! tracer statistics  
     636#endif 
    599637      ! 
    600638      numout = 6                                     ! redefine numout in case it is used after this point... 
    … …  
    612650      !!---------------------------------------------------------------------- 
    613651      USE diawri    , ONLY: dia_wri_alloc 
     652      USE insitu_tem, ONLY: insitu_tem_alloc 
    614653      USE dom_oce   , ONLY: dom_oce_alloc 
    615654      USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc 
    … …  
    628667      ierr =        oce_alloc       ()          ! ocean 
    629668      ierr = ierr + dia_wri_alloc   () 
     669      ierr = ierr + insitu_tem_alloc() 
    630670      ierr = ierr + dom_oce_alloc   ()          ! ocean domain 
    631671      ierr = ierr + ldfdyn_oce_alloc()          ! ocean lateral  physics : dynamics 
    … …  
    710750      INTEGER :: ifac, jl, inu 
    711751      INTEGER, PARAMETER :: ntest = 14 
    712       INTEGER :: ilfax(ntest) 
    713       ! 
    714       ! lfax contains the set of allowed factors. 
    715       data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    716          &                            128,   64,   32,   16,    8,   4,   2  / 
    717       !!---------------------------------------------------------------------- 
     752      INTEGER, DIMENSION(ntest) :: ilfax 
     753      ! 
     754      ! ilfax contains the set of allowed factors. 
     755      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
     756      !!---------------------------------------------------------------------- 
     757      ! ilfax contains the set of allowed factors. 
     758      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    718759 
    719760      ! Clear the error flag and initialise output vars 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r7960 r9987  
    7171   !! Energy budget of the leads (open water embedded in sea ice) 
    7272   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fraqsr_1lev        !: fraction of solar net radiation absorbed in the first ocean level [-] 
     73  
     74   !! Arrays used in coupling when MEDUSA is present. These arrays need to be declared 
     75   !! even if MEDUSA is not active, to allow compilation, in which case they will not be allocated.  
     76   !! --------------------- 
     77   REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: CO2Flux_out_cpl(:,:)  ! Output coupling CO2 flux   
     78   REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: DMS_out_cpl(:,:)      ! Output coupling DMS   
     79   REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: chloro_out_cpl(:,:)   ! Output coupling chlorophyll  
     80                                                                ! (expected in Kg/M3)   
    7381 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: PCO2a_in_cpl(:,:)     ! Input coupling CO2 partial pressure  
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: Dust_in_cpl(:,:)      ! Input coupling dust  
     84 
     85#if defined key_medusa 
     86   LOGICAL, PUBLIC, PARAMETER :: ln_medusa=.TRUE. ! Medusa switched on or off.  
     87#else 
     88   LOGICAL, PUBLIC, PARAMETER :: ln_medusa=.FALSE. ! Medusa switched on or off.  
     89#endif 
    7490   !!---------------------------------------------------------------------- 
    7591   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    … …  
    8399      !!                   ***  FUNCTION oce_alloc  *** 
    84100      !!---------------------------------------------------------------------- 
    85       INTEGER :: ierr(4) 
     101      INTEGER :: ierr(5) 
    86102      !!---------------------------------------------------------------------- 
    87103      ! 
    … …  
    119135      ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(4) ) 
    120136         ! 
     137#if defined key_oasis3 
     138      IF (ln_medusa) THEN 
     139         ! We only actually need these arrays to be allocated if coupling and MEDUSA  
     140         ! are enabled 
     141         ALLOCATE( CO2Flux_out_cpl(jpi,jpj), DMS_out_cpl(jpi,jpj),               & 
     142                   chloro_out_cpl(jpi,jpj),                                      & 
     143                   PCO2a_in_cpl(jpi,jpj), Dust_in_cpl(jpi,jpj),     STAT=ierr(5) ) 
     144 
     145      ENDIF 
     146#endif 
     147 
    121148      oce_alloc = MAXVAL( ierr ) 
    122149      IF( oce_alloc /= 0 )   CALL ctl_warn('oce_alloc: failed to allocate arrays') 

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

    r7960 r9987  
    3333   USE step_oce         ! time stepping definition modules 
    3434   USE iom 
     35   USE lbclnk 
    3536 
    3637   IMPLICIT NONE 
    … …  
    5051 
    5152#if defined key_agrif 
    52    SUBROUTINE stp( ) 
     53   RECURSIVE SUBROUTINE stp( ) 
    5354      INTEGER             ::   kstp   ! ocean time-step index 
    5455#else 
    … …  
    7374      !!---------------------------------------------------------------------- 
    7475      INTEGER ::   jk       ! dummy loop indice 
     76      INTEGER ::   tind     ! tracer loop index 
    7577      INTEGER ::   indic    ! error indicator if < 0 
    7678      INTEGER ::   kcall    ! optional integer argument (dom_vvl_sf_nxt) 
    … …  
    7981#if defined key_agrif 
    8082      kstp = nit000 + Agrif_Nb_Step() 
    81 !      IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
    82 !      IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 
     83      IF ( lk_agrif_debug ) THEN 
     84         IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
     85         IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 
     86      ENDIF 
     87 
    8388      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
     89 
    8490# if defined key_iomput 
    8591      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    … …  
    97103      IF( ln_crs     )       CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" )   ! tell iom we are at time step kstp 
    98104 
     105      IF( ln_bias )          CALL bias_opn( kstp ) 
     106 
    99107      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    100108      ! Update data, open boundaries, surface boundary condition (including sea-ice) 
    … …  
    105113                         CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
    106114      ENDIF 
     115 
     116      ! We must ensure that tsb halos are up to date on EVERY timestep. 
     117      DO tind = 1, jpts 
     118         CALL lbc_lnk( tsb(:,:,:,tind), 'T', 1. ) 
     119      END DO 
     120 
    107121                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    108122                                                      ! clem: moved here for bdy ice purpose 
    … …  
    110124      ! Update stochastic parameters and random T/S fluctuations 
    111125      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    112                         CALL sto_par( kstp )          ! Stochastic parameters 
     126       IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters 
     127       IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations 
    113128 
    114129      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    152167      ! 
    153168      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    154          IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    155                          CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
     169         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    156170         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    157171            &            CALL zps_hde    ( kstp, jpts, tsb, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
    … …  
    188202          ! Note that the computation of vertical velocity above, hence "after" sea level 
    189203          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
    190             IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    191                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
     204            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    192205            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    193206               &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
    … …  
    200213                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    201214                                  va(:,:,:) = 0.e0 
    202           IF(  ln_asmiau .AND. & 
     215          IF(  lk_asminc .AND. ln_asmiau .AND. & 
    203216             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
    204217          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
    … …  
    231244      IF( lk_diaar5  )      CALL dia_ar5( kstp )         ! ar5 diag 
    232245      IF( lk_diaharm )      CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     246                            CALL dia_prod( kstp )        ! ocean model: product diagnostics 
    233247                            CALL dia_wri( kstp )         ! ocean model: outputs 
    234248      ! 
    … …  
    248262                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    249263 
    250       IF(  ln_asmiau .AND. & 
     264      IF(  lk_asminc .AND. ln_asmiau .AND. & 
    251265         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    252266                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    … …  
    255269      IF( lk_trabbl      )   CALL tra_bbl    ( kstp )       ! advective (and/or diffusive) bottom boundary layer scheme 
    256270      IF( ln_tradmp      )   CALL tra_dmp    ( kstp )       ! internal damping trends 
     271      IF( ln_bias        )   CALL tra_bias   ( kstp ) 
    257272      IF( lk_bdy         )   CALL bdy_tra_dmp( kstp )       ! bdy damping trends 
    258273                             CALL tra_adv    ( kstp )       ! horizontal & vertical advection 
    … …  
    270285         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    271286                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    272             IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    273287                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    274288            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
    … …  
    279293               &                                           rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
    280294               &                                    gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
     295            IF( ln_bias )    CALL dyn_bias( kstp ) 
    281296      ELSE                                                  ! centered hpg  (eos then time stepping) 
    282297         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    283             IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    284298                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    285299         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
    … …  
    293307         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    294308                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
     309         IF( ln_bias )       CALL dyn_bias( kstp ) 
    295310      ENDIF 
    296311 
    … …  
    314329                               va(:,:,:) = 0.e0 
    315330 
    316         IF(  ln_asmiau .AND. & 
     331        IF(  lk_asminc .AND. ln_asmiau .AND. & 
    317332           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    318333        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
    … …  
    335350                               CALL ssh_swp( kstp )         ! swap of sea surface height 
    336351      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    337  
     352      ! 
     353      IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
     354      IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
     355 
     356#if defined key_agrif 
     357      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     358      ! AGRIF 
     359      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     360                               CALL Agrif_Integrate_ChildGrids( stp )   
     361 
     362      IF ( Agrif_NbStepint().EQ.0 ) THEN 
     363                               CALL Agrif_Update_Tra()      ! Update active tracers 
     364                               CALL Agrif_Update_Dyn()      ! Update momentum 
     365      ENDIF 
     366#endif 
    338367      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    339368      IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    340369 
    341370      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    342       ! Control and restarts 
     371      ! Control 
    343372      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    344373                               CALL stp_ctl( kstp, indic ) 
    … …  
    352381         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    353382      ENDIF 
    354       IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
     383 
     384 
     385      IF( lrst_bias )          CALL bias_wrt     ( kstp ) 
    355386 
    356387      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    357388      ! Coupled mode 
    358389      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    359       IF( lk_oasis         )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
     390      !IF( lk_oasis         )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
    360391      ! 
    361392#if defined key_iomput 
    … …  
    367398      ! 
    368399      IF( nn_timing == 1 .AND.  kstp == nit000  )   CALL timing_reset 
     400      !      
    369401      ! 
    370402   END SUBROUTINE stp 

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

    r7960 r9987  
    8888 
    8989   USE diawri           ! Standard run outputs             (dia_wri routine) 
     90   USE diaprod          ! Product diagnostics              (dia_prod routine) 
    9091   USE diaptr           ! poleward transports              (dia_ptr routine) 
    9192   USE diadct           ! sections transports              (dia_dct routine) 
    … …  
    99100 
    100101   USE crsfld           ! Standard output on coarse grid   (crs_fld routine) 
    101  
     102   USE biaspar          ! bias param 
     103   USE bias             ! bias routines                    (tra_bias routine 
     104                        !                                   dyn_bias routine) 
    102105   USE asminc           ! assimilation increments      (tra_asm_inc routine) 
    103106   !                                                   (dyn_asm_inc routine) 
    … …  
    112115#if defined key_agrif 
    113116   USE agrif_opa_sponge ! Momemtum and tracers sponges 
     117   USE agrif_opa_update ! Update (2-way nesting) 
    114118#endif 
    115119#if defined key_top 

  • branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r7960 r9987  
    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 

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

    r7960 r9987  
    453453   SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt ,   & 
    454454      &                      kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d    ) 
     455   USE in_out_manager, ONLY: numout 
    455456      INTEGER                              , INTENT(in   )           :: kidim, kjdim, kkdim, kldim 
    456457      INTEGER                              , INTENT(in   )           :: kisrt, kjsrt, kksrt, klsrt 
    … …  
    483484         &      .AND. SUM( tree(ii)%ishape ) /= 0 ) 
    484485         ii = ii + 1 
    485          IF (ii > jparray) STOP   ! increase the value of jparray (should not be needed as already very big!) 
     486         IF (ii > jparray) THEN 
     487            WRITE(numout,*) "E R R O R: NEMO aborted wrk_allocbase" 
     488            FLUSH(numout) 
     489            STOP 'Increase the value of jparray' 
     490                           ! increase the value of jparray (should not be needed as already very big!) 
     491         END IF 
    486492      END DO 
    487493       
Note: See TracChangeset for help on using the changeset viewer.