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 7806 – NEMO

Changeset 7806


Ignore:
Timestamp:
2017-03-17T08:46:30+01:00 (7 years ago)
Author:
cbricaud
Message:

phaze dev_r5003_MERCATOR6_CRS branch with rev7805 of 3.6_stable branch

Location:
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
Files:
75 edited
2 copied

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r7256 r7806  
    212212   REAL(wp), PUBLIC ::   rn_betas         !: coef. for partitioning of snowfall between leads and sea ice 
    213213   REAL(wp), PUBLIC ::   rn_kappa_i       !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 
     214   REAL(wp), PUBLIC ::   rn_cdsn          !: thermal conductivity of the snow [W/m/K] 
    214215   REAL(wp), PUBLIC ::   nn_conv_dif      !: maximal number of iterations for heat diffusion 
    215216   REAL(wp), PUBLIC ::   rn_terr_dif      !: maximal tolerated error (C) for heat diffusion 
    … …  
    320321   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   o_i     !: Sea-Ice Age (days) 
    321322   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   oa_i    !: Sea-Ice Age times ice area (days) 
     323 
    322324   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bv_i    !: brine volume 
    323325 
    … …  
    406408   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_vice     !: ice volume variation   [m/s]  
    407409   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_vsnw     !: snw volume variation   [m/s]  
     410 
    408411   ! 
    409412   !!---------------------------------------------------------------------- 
    … …  
    463466         &      et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i (jpi,jpj) , bvm_i(jpi,jpj) ,     & 
    464467         &      smt_i(jpi,jpj) , tm_su(jpi,jpj) , htm_i(jpi,jpj) , htm_s(jpi,jpj) ,     & 
    465          &      om_i (jpi,jpj)                              , STAT=ierr(ii) ) 
     468         &      om_i (jpi,jpj) , STAT=ierr(ii) ) 
    466469      ii = ii + 1 
    467470      ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limdyn.F90

    r5602 r7806  
    244244      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    245245      NAMELIST/namicedyn/ nn_icestr, ln_icestr_bvf, rn_pe_rdg, rn_pstar, rn_crhg, rn_cio,  rn_creepl, rn_ecc, & 
    246          &                nn_nevp, rn_relast, nn_ahi0, rn_ahi0_ref 
    247       INTEGER  ::   ji, jj 
    248       REAL(wp) ::   za00, zd_max 
     246         &                nn_nevp, rn_relast 
    249247      !!------------------------------------------------------------------- 
    250248 
    … …  
    272270         WRITE(numout,*) '   number of iterations for subcycling                  nn_nevp       = ', nn_nevp 
    273271         WRITE(numout,*) '   ratio of elastic timescale over ice time step        rn_relast     = ', rn_relast 
    274          WRITE(numout,*) '   horizontal diffusivity calculation                   nn_ahi0       = ', nn_ahi0 
    275          WRITE(numout,*) '   horizontal diffusivity coeff. (orca2 grid)           rn_ahi0_ref   = ', rn_ahi0_ref 
    276272      ENDIF 
    277273      ! 
    … …  
    279275      rhoco  = rau0  * rn_cio 
    280276      ! 
    281       !  Diffusion coefficients 
    282       SELECT CASE( nn_ahi0 ) 
    283  
    284       CASE( 0 ) 
    285          ahiu(:,:) = rn_ahi0_ref 
    286          ahiv(:,:) = rn_ahi0_ref 
    287  
    288          IF(lwp) WRITE(numout,*) '' 
    289          IF(lwp) WRITE(numout,*) '   laplacian operator: ahim constant = rn_ahi0_ref' 
    290  
    291       CASE( 1 )  
    292  
    293          zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
    294          IF( lk_mpp )   CALL mpp_max( zd_max )          ! max over the global domain 
    295           
    296          ahiu(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp   ! 1.e05 = 100km = max grid space at 60° latitude in orca2 
    297                                                         !                    (60° = min latitude for ice cover)   
    298          ahiv(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp 
    299  
    300          IF(lwp) WRITE(numout,*) '' 
    301          IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to max of e1 e2 over the domain (', zd_max, ')' 
    302          IF(lwp) WRITE(numout,*) '   value for ahim = ', rn_ahi0_ref * zd_max * 1.e-05_wp  
    303           
    304       CASE( 2 )  
    305  
    306          zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
    307          IF( lk_mpp )   CALL mpp_max( zd_max )   ! max over the global domain 
    308           
    309          za00 = rn_ahi0_ref * 1.e-05_wp          ! 1.e05 = 100km = max grid space at 60° latitude in orca2 
    310                                                  !                    (60° = min latitude for ice cover)   
    311          DO jj = 1, jpj 
    312             DO ji = 1, jpi 
    313                ahiu(ji,jj) = za00 * MAX( e1t(ji,jj), e2t(ji,jj) ) * umask(ji,jj,1) 
    314                ahiv(ji,jj) = za00 * MAX( e1f(ji,jj), e2f(ji,jj) ) * vmask(ji,jj,1) 
    315             END DO 
    316          END DO 
    317          ! 
    318          IF(lwp) WRITE(numout,*) '' 
    319          IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to e1' 
    320          IF(lwp) WRITE(numout,*) '   maximum grid-spacing = ', zd_max, ' maximum value for ahim = ', za00*zd_max 
    321           
    322       END SELECT 
    323  
    324277   END SUBROUTINE lim_dyn_init 
    325278 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r7256 r7806  
    202202      ! ----------------------- 
    203203 
    204       IF(ln_ctl)   THEN 
    205          DO jk = 1 , isize 
    206             zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
    207             WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
    208             CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
    209          END DO 
    210       ENDIF 
     204 !     IF(ln_ctl)   THEN 
     205 !        DO jk = 1 , isize 
     206 !           zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     207 !           WRITE(charout,FMT="('lim_hdf  : zconv =',D23.16, ' iter =',I4)") zconv, iter 
     208 !           CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     209 !        END DO 
     210  !    ENDIF 
    211211      ! 
    212212      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
    … …  
    233233      !!------------------------------------------------------------------- 
    234234      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    235       NAMELIST/namicehdf/ nn_convfrq  
    236       !!------------------------------------------------------------------- 
    237       ! 
    238       IF(lwp) THEN 
    239          WRITE(numout,*) 
    240          WRITE(numout,*) 'lim_hdf : Ice horizontal diffusion' 
    241          WRITE(numout,*) '~~~~~~~' 
    242       ENDIF 
     235      NAMELIST/namicehdf/  nn_ahi0, rn_ahi0_ref, nn_convfrq  
     236      INTEGER  ::   ji, jj 
     237      REAL(wp) ::   za00, zd_max 
     238      !!------------------------------------------------------------------- 
    243239      ! 
    244240      REWIND( numnam_ice_ref )              ! Namelist namicehdf in reference namelist : Ice horizontal diffusion 
    … …  
    253249      IF(lwp) THEN                          ! control print 
    254250         WRITE(numout,*) 
    255          WRITE(numout,*)'   Namelist of ice parameters for ice horizontal diffusion computation ' 
    256          WRITE(numout,*)'      convergence check frequency of the Crant-Nicholson scheme   nn_convfrq   = ', nn_convfrq 
     251         WRITE(numout,*) 'lim_hdf_init : Ice horizontal diffusion' 
     252         WRITE(numout,*) '~~~~~~~~~~~' 
     253         WRITE(numout,*) '   horizontal diffusivity calculation                          nn_ahi0      = ', nn_ahi0 
     254         WRITE(numout,*) '   horizontal diffusivity coeff. (orca2 grid)                  rn_ahi0_ref  = ', rn_ahi0_ref 
     255         WRITE(numout,*) '   convergence check frequency of the Crant-Nicholson scheme   nn_convfrq   = ', nn_convfrq 
    257256      ENDIF 
     257      ! 
     258      !  Diffusion coefficients 
     259      SELECT CASE( nn_ahi0 ) 
     260 
     261      CASE( -1 ) 
     262         ahiu(:,:) = 0._wp 
     263         ahiv(:,:) = 0._wp 
     264 
     265         IF(lwp) WRITE(numout,*) '' 
     266         IF(lwp) WRITE(numout,*) '   No sea-ice diffusion applied' 
     267 
     268      CASE( 0 ) 
     269         ahiu(:,:) = rn_ahi0_ref 
     270         ahiv(:,:) = rn_ahi0_ref 
     271 
     272         IF(lwp) WRITE(numout,*) '' 
     273         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim constant = rn_ahi0_ref' 
     274 
     275      CASE( 1 )  
     276 
     277         zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
     278         IF( lk_mpp )   CALL mpp_max( zd_max )          ! max over the global domain 
     279          
     280         ahiu(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp   ! 1.e05 = 100km = max grid space at 60deg latitude in orca2 
     281                                                        !                    (60deg = min latitude for ice cover)   
     282         ahiv(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp 
     283 
     284         IF(lwp) WRITE(numout,*) '' 
     285         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to max of e1 e2 over the domain (', zd_max, ')' 
     286         IF(lwp) WRITE(numout,*) '   value for ahim = ', rn_ahi0_ref * zd_max * 1.e-05_wp  
     287          
     288      CASE( 2 )  
     289 
     290         zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
     291         IF( lk_mpp )   CALL mpp_max( zd_max )   ! max over the global domain 
     292          
     293         za00 = rn_ahi0_ref * 1.e-05_wp          ! 1.e05 = 100km = max grid space at 60deg latitude in orca2 
     294                                                 !                    (60deg = min latitude for ice cover)   
     295         DO jj = 1, jpj 
     296            DO ji = 1, jpi 
     297               ahiu(ji,jj) = za00 * MAX( e1t(ji,jj), e2t(ji,jj) ) * umask(ji,jj,1) 
     298               ahiv(ji,jj) = za00 * MAX( e1f(ji,jj), e2f(ji,jj) ) * vmask(ji,jj,1) 
     299            END DO 
     300         END DO 
     301         ! 
     302         IF(lwp) WRITE(numout,*) '' 
     303         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to e1' 
     304         IF(lwp) WRITE(numout,*) '   maximum grid-spacing = ', zd_max, ' maximum value for ahim = ', za00*zd_max 
     305          
     306      END SELECT 
    258307      ! 
    259308   END SUBROUTINE lim_hdf_init 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limrst.F90

    r5602 r7806  
    108108      INTEGER ::   iter 
    109109      CHARACTER(len=15) ::   znam 
    110       CHARACTER(len=1)  ::   zchar, zchar1 
     110      CHARACTER(len=2)  ::   zchar, zchar1 
    111111      REAL(wp), POINTER, DIMENSION(:,:) :: z2d 
    112112      !!---------------------------------------------------------------------- 
    … …  
    130130      ! Prognostic variables  
    131131      DO jl = 1, jpl  
    132          WRITE(zchar,'(I1)') jl 
    133          znam = 'v_i'//'_htc'//zchar 
     132         WRITE(zchar,'(I2)') jl 
     133         znam = 'v_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    134134         z2d(:,:) = v_i(:,:,jl) 
    135135         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    136          znam = 'v_s'//'_htc'//zchar 
     136         znam = 'v_s'//'_htc'//TRIM(ADJUSTL(zchar)) 
    137137         z2d(:,:) = v_s(:,:,jl) 
    138138         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    139          znam = 'smv_i'//'_htc'//zchar 
     139         znam = 'smv_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    140140         z2d(:,:) = smv_i(:,:,jl) 
    141141         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    142          znam = 'oa_i'//'_htc'//zchar 
     142         znam = 'oa_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    143143         z2d(:,:) = oa_i(:,:,jl) 
    144144         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    145          znam = 'a_i'//'_htc'//zchar 
     145         znam = 'a_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    146146         z2d(:,:) = a_i(:,:,jl) 
    147147         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    148          znam = 't_su'//'_htc'//zchar 
     148         znam = 't_su'//'_htc'//TRIM(ADJUSTL(zchar)) 
    149149         z2d(:,:) = t_su(:,:,jl) 
    150150         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    151       END DO 
    152  
    153       DO jl = 1, jpl  
    154          WRITE(zchar,'(I1)') jl 
    155          znam = 'tempt_sl1'//'_htc'//zchar 
     151         znam = 'tempt_sl1'//'_htc'//TRIM(ADJUSTL(zchar)) 
    156152         z2d(:,:) = e_s(:,:,1,jl) 
    157153         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    158       END DO 
    159  
    160       DO jl = 1, jpl  
    161          WRITE(zchar,'(I1)') jl 
    162154         DO jk = 1, nlay_i  
    163             WRITE(zchar1,'(I1)') jk 
    164             znam = 'tempt'//'_il'//zchar1//'_htc'//zchar 
     155            WRITE(zchar1,'(I2)') jk 
     156            znam = 'tempt'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    165157            z2d(:,:) = e_i(:,:,jk,jl) 
    166158            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    … …  
    177169 
    178170      DO jl = 1, jpl  
    179          WRITE(zchar,'(I1)') jl 
    180          znam = 'sxice'//'_htc'//zchar 
     171         WRITE(zchar,'(I2)') jl 
     172         znam = 'sxice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    181173         z2d(:,:) = sxice(:,:,jl) 
    182174         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    183          znam = 'syice'//'_htc'//zchar 
     175         znam = 'syice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    184176         z2d(:,:) = syice(:,:,jl) 
    185177         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    186          znam = 'sxxice'//'_htc'//zchar 
     178         znam = 'sxxice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    187179         z2d(:,:) = sxxice(:,:,jl) 
    188180         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    189          znam = 'syyice'//'_htc'//zchar 
     181         znam = 'syyice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    190182         z2d(:,:) = syyice(:,:,jl) 
    191183         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    192          znam = 'sxyice'//'_htc'//zchar 
     184         znam = 'sxyice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    193185         z2d(:,:) = sxyice(:,:,jl) 
    194186         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    195          znam = 'sxsn'//'_htc'//zchar 
     187         znam = 'sxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    196188         z2d(:,:) = sxsn(:,:,jl) 
    197189         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    198          znam = 'sysn'//'_htc'//zchar 
     190         znam = 'sysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    199191         z2d(:,:) = sysn(:,:,jl) 
    200192         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    201          znam = 'sxxsn'//'_htc'//zchar 
     193         znam = 'sxxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    202194         z2d(:,:) = sxxsn(:,:,jl) 
    203195         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    204          znam = 'syysn'//'_htc'//zchar 
     196         znam = 'syysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    205197         z2d(:,:) = syysn(:,:,jl) 
    206198         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    207          znam = 'sxysn'//'_htc'//zchar 
     199         znam = 'sxysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    208200         z2d(:,:) = sxysn(:,:,jl) 
    209201         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    210          znam = 'sxa'//'_htc'//zchar 
     202         znam = 'sxa'//'_htc'//TRIM(ADJUSTL(zchar)) 
    211203         z2d(:,:) = sxa(:,:,jl) 
    212204         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    213          znam = 'sya'//'_htc'//zchar 
     205         znam = 'sya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    214206         z2d(:,:) = sya(:,:,jl) 
    215207         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    216          znam = 'sxxa'//'_htc'//zchar 
     208         znam = 'sxxa'//'_htc'//TRIM(ADJUSTL(zchar)) 
    217209         z2d(:,:) = sxxa(:,:,jl) 
    218210         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    219          znam = 'syya'//'_htc'//zchar 
     211         znam = 'syya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    220212         z2d(:,:) = syya(:,:,jl) 
    221213         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    222          znam = 'sxya'//'_htc'//zchar 
     214         znam = 'sxya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    223215         z2d(:,:) = sxya(:,:,jl) 
    224216         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    225          znam = 'sxc0'//'_htc'//zchar 
     217         znam = 'sxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    226218         z2d(:,:) = sxc0(:,:,jl) 
    227219         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    228          znam = 'syc0'//'_htc'//zchar 
     220         znam = 'syc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    229221         z2d(:,:) = syc0(:,:,jl) 
    230222         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    231          znam = 'sxxc0'//'_htc'//zchar 
     223         znam = 'sxxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    232224         z2d(:,:) = sxxc0(:,:,jl) 
    233225         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    234          znam = 'syyc0'//'_htc'//zchar 
     226         znam = 'syyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    235227         z2d(:,:) = syyc0(:,:,jl) 
    236228         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    237          znam = 'sxyc0'//'_htc'//zchar 
     229         znam = 'sxyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    238230         z2d(:,:) = sxyc0(:,:,jl) 
    239231         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    240          znam = 'sxsal'//'_htc'//zchar 
     232         znam = 'sxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    241233         z2d(:,:) = sxsal(:,:,jl) 
    242234         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    243          znam = 'sysal'//'_htc'//zchar 
     235         znam = 'sysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    244236         z2d(:,:) = sysal(:,:,jl) 
    245237         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    246          znam = 'sxxsal'//'_htc'//zchar 
     238         znam = 'sxxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    247239         z2d(:,:) = sxxsal(:,:,jl) 
    248240         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    249          znam = 'syysal'//'_htc'//zchar 
     241         znam = 'syysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    250242         z2d(:,:) = syysal(:,:,jl) 
    251243         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    252          znam = 'sxysal'//'_htc'//zchar 
     244         znam = 'sxysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    253245         z2d(:,:) = sxysal(:,:,jl) 
    254246         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    255          znam = 'sxage'//'_htc'//zchar 
     247         znam = 'sxage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    256248         z2d(:,:) = sxage(:,:,jl) 
    257249         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    258          znam = 'syage'//'_htc'//zchar 
     250         znam = 'syage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    259251         z2d(:,:) = syage(:,:,jl) 
    260252         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    261          znam = 'sxxage'//'_htc'//zchar 
     253         znam = 'sxxage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    262254         z2d(:,:) = sxxage(:,:,jl) 
    263255         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    264          znam = 'syyage'//'_htc'//zchar 
     256         znam = 'syyage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    265257         z2d(:,:) = syyage(:,:,jl) 
    266258         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    267          znam = 'sxyage'//'_htc'//zchar 
     259         znam = 'sxyage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    268260         z2d(:,:) = sxyage(:,:,jl) 
    269261         CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    … …  
    277269 
    278270      DO jl = 1, jpl  
    279          WRITE(zchar,'(I1)') jl 
     271         WRITE(zchar,'(I2)') jl 
    280272         DO jk = 1, nlay_i  
    281             WRITE(zchar1,'(I1)') jk 
    282             znam = 'sxe'//'_il'//zchar1//'_htc'//zchar 
     273            WRITE(zchar1,'(I2)') jk 
     274            znam = 'sxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    283275            z2d(:,:) = sxe(:,:,jk,jl) 
    284276            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    285             znam = 'sye'//'_il'//zchar1//'_htc'//zchar 
     277            znam = 'sye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    286278            z2d(:,:) = sye(:,:,jk,jl) 
    287279            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    288             znam = 'sxxe'//'_il'//zchar1//'_htc'//zchar 
     280            znam = 'sxxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    289281            z2d(:,:) = sxxe(:,:,jk,jl) 
    290282            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    291             znam = 'syye'//'_il'//zchar1//'_htc'//zchar 
     283            znam = 'syye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    292284            z2d(:,:) = syye(:,:,jk,jl) 
    293285            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    294             znam = 'sxye'//'_il'//zchar1//'_htc'//zchar 
     286            znam = 'sxye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    295287            z2d(:,:) = sxye(:,:,jk,jl) 
    296288            CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 
    … …  
    318310      REAL(wp), POINTER, DIMENSION(:,:) ::   z2d 
    319311      CHARACTER(len=15) ::   znam 
    320       CHARACTER(len=1)  ::   zchar, zchar1 
     312      CHARACTER(len=2)  ::   zchar, zchar1 
    321313      INTEGER           ::   jlibalt = jprstlib 
    322314      LOGICAL           ::   llok 
    … …  
    357349 
    358350      DO jl = 1, jpl  
    359          WRITE(zchar,'(I1)') jl 
    360          znam = 'v_i'//'_htc'//zchar 
     351         WRITE(zchar,'(I2)') jl 
     352         znam = 'v_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    361353         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    362354         v_i(:,:,jl) = z2d(:,:) 
    363          znam = 'v_s'//'_htc'//zchar 
     355         znam = 'v_s'//'_htc'//TRIM(ADJUSTL(zchar)) 
    364356         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    365357         v_s(:,:,jl) = z2d(:,:)  
    366          znam = 'smv_i'//'_htc'//zchar 
     358         znam = 'smv_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    367359         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    368360         smv_i(:,:,jl) = z2d(:,:) 
    369          znam = 'oa_i'//'_htc'//zchar 
     361         znam = 'oa_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    370362         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    371363         oa_i(:,:,jl) = z2d(:,:) 
    372          znam = 'a_i'//'_htc'//zchar 
     364         znam = 'a_i'//'_htc'//TRIM(ADJUSTL(zchar)) 
    373365         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    374366         a_i(:,:,jl) = z2d(:,:) 
    375          znam = 't_su'//'_htc'//zchar 
     367         znam = 't_su'//'_htc'//TRIM(ADJUSTL(zchar)) 
    376368         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    377369         t_su(:,:,jl) = z2d(:,:) 
    378       END DO 
    379  
    380       DO jl = 1, jpl  
    381          WRITE(zchar,'(I1)') jl 
    382          znam = 'tempt_sl1'//'_htc'//zchar 
     370         znam = 'tempt_sl1'//'_htc'//TRIM(ADJUSTL(zchar)) 
    383371         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    384372         e_s(:,:,1,jl) = z2d(:,:) 
    385       END DO 
    386  
    387       DO jl = 1, jpl  
    388          WRITE(zchar,'(I1)') jl 
    389373         DO jk = 1, nlay_i  
    390             WRITE(zchar1,'(I1)') jk 
    391             znam = 'tempt'//'_il'//zchar1//'_htc'//zchar 
     374            WRITE(zchar1,'(I2)') jk 
     375            znam = 'tempt'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    392376            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    393377            e_i(:,:,jk,jl) = z2d(:,:) 
    … …  
    404388 
    405389      DO jl = 1, jpl  
    406          WRITE(zchar,'(I1)') jl 
    407          znam = 'sxice'//'_htc'//zchar 
     390         WRITE(zchar,'(I2)') jl 
     391         znam = 'sxice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    408392         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    409393         sxice(:,:,jl) = z2d(:,:) 
    410          znam = 'syice'//'_htc'//zchar 
     394         znam = 'syice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    411395         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    412396         syice(:,:,jl) = z2d(:,:) 
    413          znam = 'sxxice'//'_htc'//zchar 
     397         znam = 'sxxice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    414398         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    415399         sxxice(:,:,jl) = z2d(:,:) 
    416          znam = 'syyice'//'_htc'//zchar 
     400         znam = 'syyice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    417401         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    418402         syyice(:,:,jl) = z2d(:,:) 
    419          znam = 'sxyice'//'_htc'//zchar 
     403         znam = 'sxyice'//'_htc'//TRIM(ADJUSTL(zchar)) 
    420404         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    421405         sxyice(:,:,jl) = z2d(:,:) 
    422          znam = 'sxsn'//'_htc'//zchar 
     406         znam = 'sxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    423407         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    424408         sxsn(:,:,jl) = z2d(:,:) 
    425          znam = 'sysn'//'_htc'//zchar 
     409         znam = 'sysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    426410         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    427411         sysn(:,:,jl) = z2d(:,:) 
    428          znam = 'sxxsn'//'_htc'//zchar 
     412         znam = 'sxxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    429413         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    430414         sxxsn(:,:,jl) = z2d(:,:) 
    431          znam = 'syysn'//'_htc'//zchar 
     415         znam = 'syysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    432416         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    433417         syysn(:,:,jl) = z2d(:,:) 
    434          znam = 'sxysn'//'_htc'//zchar 
     418         znam = 'sxysn'//'_htc'//TRIM(ADJUSTL(zchar)) 
    435419         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    436420         sxysn(:,:,jl) = z2d(:,:) 
    437          znam = 'sxa'//'_htc'//zchar 
     421         znam = 'sxa'//'_htc'//TRIM(ADJUSTL(zchar)) 
    438422         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    439423         sxa(:,:,jl) = z2d(:,:) 
    440          znam = 'sya'//'_htc'//zchar 
     424         znam = 'sya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    441425         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    442426         sya(:,:,jl) = z2d(:,:) 
    443          znam = 'sxxa'//'_htc'//zchar 
     427         znam = 'sxxa'//'_htc'//TRIM(ADJUSTL(zchar)) 
    444428         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    445429         sxxa(:,:,jl) = z2d(:,:) 
    446          znam = 'syya'//'_htc'//zchar 
     430         znam = 'syya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    447431         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    448432         syya(:,:,jl) = z2d(:,:) 
    449          znam = 'sxya'//'_htc'//zchar 
     433         znam = 'sxya'//'_htc'//TRIM(ADJUSTL(zchar)) 
    450434         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    451435         sxya(:,:,jl) = z2d(:,:) 
    452          znam = 'sxc0'//'_htc'//zchar 
     436         znam = 'sxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    453437         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    454438         sxc0(:,:,jl) = z2d(:,:) 
    455          znam = 'syc0'//'_htc'//zchar 
     439         znam = 'syc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    456440         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    457441         syc0(:,:,jl) = z2d(:,:) 
    458          znam = 'sxxc0'//'_htc'//zchar 
     442         znam = 'sxxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    459443         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    460444         sxxc0(:,:,jl) = z2d(:,:) 
    461          znam = 'syyc0'//'_htc'//zchar 
     445         znam = 'syyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    462446         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    463447         syyc0(:,:,jl) = z2d(:,:) 
    464          znam = 'sxyc0'//'_htc'//zchar 
     448         znam = 'sxyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 
    465449         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    466450         sxyc0(:,:,jl) = z2d(:,:) 
    467          znam = 'sxsal'//'_htc'//zchar 
     451         znam = 'sxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    468452         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    469453         sxsal(:,:,jl) = z2d(:,:) 
    470          znam = 'sysal'//'_htc'//zchar 
     454         znam = 'sysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    471455         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    472456         sysal(:,:,jl) = z2d(:,:) 
    473          znam = 'sxxsal'//'_htc'//zchar 
     457         znam = 'sxxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    474458         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    475459         sxxsal(:,:,jl) = z2d(:,:) 
    476          znam = 'syysal'//'_htc'//zchar 
     460         znam = 'syysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    477461         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    478462         syysal(:,:,jl) = z2d(:,:) 
    479          znam = 'sxysal'//'_htc'//zchar 
     463         znam = 'sxysal'//'_htc'//TRIM(ADJUSTL(zchar)) 
    480464         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    481465         sxysal(:,:,jl) = z2d(:,:) 
    482          znam = 'sxage'//'_htc'//zchar 
     466         znam = 'sxage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    483467         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    484468         sxage(:,:,jl) = z2d(:,:) 
    485          znam = 'syage'//'_htc'//zchar 
     469         znam = 'syage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    486470         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    487471         syage(:,:,jl) = z2d(:,:) 
    488          znam = 'sxxage'//'_htc'//zchar 
     472         znam = 'sxxage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    489473         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    490474         sxxage(:,:,jl) = z2d(:,:) 
    491          znam = 'syyage'//'_htc'//zchar 
     475         znam = 'syyage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    492476         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    493477         syyage(:,:,jl) = z2d(:,:) 
    494          znam = 'sxyage'//'_htc'//zchar 
     478         znam = 'sxyage'//'_htc'//TRIM(ADJUSTL(zchar)) 
    495479         CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    496480         sxyage(:,:,jl)= z2d(:,:) 
    … …  
    504488 
    505489      DO jl = 1, jpl  
    506          WRITE(zchar,'(I1)') jl 
     490         WRITE(zchar,'(I2)') jl 
    507491         DO jk = 1, nlay_i  
    508             WRITE(zchar1,'(I1)') jk 
    509             znam = 'sxe'//'_il'//zchar1//'_htc'//zchar 
     492            WRITE(zchar1,'(I2)') jk 
     493            znam = 'sxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    510494            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    511495            sxe(:,:,jk,jl) = z2d(:,:) 
    512             znam = 'sye'//'_il'//zchar1//'_htc'//zchar 
     496            znam = 'sye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    513497            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    514498            sye(:,:,jk,jl) = z2d(:,:) 
    515             znam = 'sxxe'//'_il'//zchar1//'_htc'//zchar 
     499            znam = 'sxxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    516500            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    517501            sxxe(:,:,jk,jl) = z2d(:,:) 
    518             znam = 'syye'//'_il'//zchar1//'_htc'//zchar 
     502            znam = 'syye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    519503            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    520504            syye(:,:,jk,jl) = z2d(:,:) 
    521             znam = 'sxye'//'_il'//zchar1//'_htc'//zchar 
     505            znam = 'sxye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 
    522506            CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 
    523507            sxye(:,:,jk,jl) = z2d(:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r7256 r7806  
    613613         CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 
    614614         CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 
    615          !          
    616615      END SELECT 
    617616 
    … …  
    633632      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    634633      NAMELIST/namicethd/ rn_hnewice, ln_frazil, rn_maxfrazb, rn_vfrazb, rn_Cfrazb,                       & 
    635          &                rn_himin, rn_betas, rn_kappa_i, nn_conv_dif, rn_terr_dif, nn_ice_thcon, & 
    636          &                nn_monocat, ln_it_qnsice 
     634         &                rn_himin, rn_betas, rn_kappa_i, nn_conv_dif, rn_terr_dif, nn_ice_thcon,         & 
     635         &                rn_cdsn, nn_monocat, ln_it_qnsice 
    637636      !!------------------------------------------------------------------- 
    638637      ! 
    … …  
    673672         WRITE(numout,*)'      maximal err. on T for heat diffusion computation        rn_terr_dif  = ', rn_terr_dif 
    674673         WRITE(numout,*)'      switch for comp. of thermal conductivity in the ice     nn_ice_thcon = ', nn_ice_thcon 
     674         WRITE(numout,*)'      thermal conductivity of the snow                        rn_cdsn      = ', rn_cdsn 
    675675         WRITE(numout,*)'      check heat conservation in the ice/snow                 con_i        = ', con_i 
    676676         WRITE(numout,*)'      virtual ITD mono-category parameterizations (1) or not  nn_monocat   = ', nn_monocat 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90

    r5602 r7806  
    376376 
    377377               ! Effective thickness he (zhe) 
    378                zfac     = 1._wp / ( rcdsn + zkimean ) 
    379                zratio_s = rcdsn   * zfac 
     378               zfac     = 1._wp / ( rn_cdsn + zkimean ) 
     379               zratio_s = rn_cdsn   * zfac 
    380380               zratio_i = zkimean * zfac 
    381381               zhe      = zratio_s * ht_i_1d(ji) + zratio_i * ht_s_1d(ji) 
    … …  
    400400         DO ji = kideb, kiut 
    401401            zfac                  =  1. / MAX( epsi10 , zh_s(ji) ) 
    402             zkappa_s(ji,0)        = zghe(ji) * rcdsn * zfac 
    403             zkappa_s(ji,nlay_s)   = zghe(ji) * rcdsn * zfac 
     402            zkappa_s(ji,0)        = zghe(ji) * rn_cdsn * zfac 
     403            zkappa_s(ji,nlay_s)   = zghe(ji) * rn_cdsn * zfac 
    404404         END DO 
    405405 
    406406         DO jk = 1, nlay_s-1 
    407407            DO ji = kideb , kiut 
    408                zkappa_s(ji,jk)    = zghe(ji) * 2.0 * rcdsn / MAX( epsi10, 2.0 * zh_s(ji) ) 
     408               zkappa_s(ji,jk)    = zghe(ji) * 2.0 * rn_cdsn / MAX( epsi10, 2.0 * zh_s(ji) ) 
    409409            END DO 
    410410         END DO 
    … …  
    422422            zkappa_i(ji,0)        = zghe(ji) * ztcond_i(ji,0) * zfac 
    423423            zkappa_i(ji,nlay_i)   = zghe(ji) * ztcond_i(ji,nlay_i) * zfac 
    424             zkappa_s(ji,nlay_s)   = zghe(ji) * zghe(ji) * 2.0 * rcdsn * ztcond_i(ji,0) / &  
    425            &                        MAX( epsi10, ( zghe(ji) * ztcond_i(ji,0) * zh_s(ji) + zghe(ji) * rcdsn * zh_i(ji) ) ) 
     424            zkappa_s(ji,nlay_s)   = zghe(ji) * zghe(ji) * 2.0 * rn_cdsn * ztcond_i(ji,0) / &  
     425           &                        MAX( epsi10, ( zghe(ji) * ztcond_i(ji,0) * zh_s(ji) + zghe(ji) * rn_cdsn * zh_i(ji) ) ) 
    426426            zkappa_i(ji,0)        = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) ) 
    427427         END DO 
    … …  
    697697               &             ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,numeqmin(ji))   
    698698         END DO 
     699 
    699700         ! 
    700701         !-------------------------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r7256 r7806  
    531531         DO jj=MAX(j1,2),j2 
    532532            DO ji=MAX(i1,2),i2 
    533                uice_agr(ji,jj) = tabres(ji,jj) 
     533               u_ice_nst(ji,jj) = tabres(ji,jj) 
    534534            END DO 
    535535         END DO 
    … …  
    582582         DO jj=MAX(j1,2),j2 
    583583            DO ji=MAX(i1,2),i2 
    584                vice_agr(ji,jj) = tabres(ji,jj) 
     584               v_ice_nst(ji,jj) = tabres(ji,jj) 
    585585            END DO 
    586586         END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r7256 r7806  
    177177         tabres = zrhox * tabres 
    178178      ELSE 
    179          DO jj=j1,j2 
    180             DO ji=i1,i2 
     179         DO jj=MAX(j1,2),j2 
     180            DO ji=MAX(i1,2),i2 
    181181               v_ice(ji,jj) = tabres(ji,jj) / (e1f(ji-1,jj-1)) 
    182182               v_ice(ji,jj) = v_ice(ji,jj) * tmu(ji,jj) 
    … …  
    202202      IF( before ) THEN 
    203203         zrhoy = Agrif_Rhoy() 
    204          DO jj=MAX(j1,2),j2 
    205             DO ji=MAX(i1,2),i2 
     204         DO jj=j1,j2 
     205            DO ji=i1,i2 
    206206               tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
    207207            END DO 
    … …  
    209209         tabres = zrhoy * tabres 
    210210      ELSE 
    211          DO jj=MAX(j1,2),j2 
    212             DO ji=MAX(i1,2),i2 
     211         DO jj=j1,j2 
     212            DO ji=i1,i2 
    213213               u_ice(ji,jj) = tabres(ji,jj) / (e2u(ji,jj)) 
    214214               u_ice(ji,jj) = u_ice(ji,jj) * tmu(ji,jj) 
    … …  
    235235      IF( before ) THEN 
    236236         zrhox = Agrif_Rhox() 
    237          DO jj=MAX(j1,2),j2 
    238             DO ji=MAX(i1,2),i2 
     237         DO jj=j1,j2 
     238            DO ji=i1,i2 
    239239               tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
    240240            END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r7217 r7806  
    1717   USE lib_mpp         ! distributed memory computing library 
    1818 
     19   USE iom 
    1920   USE domstp          ! domain: set the time-step 
    2021 
    … …  
    7374 
    7475      CALL dom_nam      ! read namelist ( namrun, namdom, namcla ) 
     76      CALL dom_msk      ! Masks 
     77      CALL dom_hgr      ! Horizontal grid 
    7578      CALL dom_zgr      ! Vertical mesh and bathymetry option 
    76       CALL dom_grd      ! Create a domain file 
    77  
    78      ! 
    79       ! - ML - Used in dom_vvl_sf_nxt and lateral diffusion routines 
    80       !        but could be usefull in many other routines 
     79      ! 
    8180      e12t    (:,:) = e1t(:,:) * e2t(:,:) 
    8281      e1e2t   (:,:) = e1t(:,:) * e2t(:,:) 
    … …  
    9190      re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 
    9291      ! 
    93       hu(:,:) = 0._wp                          ! Ocean depth at U- and V-points 
    94       hv(:,:) = 0._wp 
    95       DO jk = 1, jpk 
    96          hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
    97          hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
    98       END DO 
    99       !                                        ! Inverse of the local depth 
    100       hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask(:,:,1) ) * umask(:,:,1) 
    101       hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask(:,:,1) ) * vmask(:,:,1) 
    102  
    10392      CALL dom_stp      ! Time step 
    104       CALL dom_msk      ! Masks 
    10593      CALL dom_ctl      ! Domain control 
    10694 
    … …  
    178166      nstocklist = nn_stocklist 
    179167      nwrite = nn_write 
    180  
    181  
    182168      !                             ! control of output frequency 
    183169      IF ( nstock == 0 .OR. nstock > nitend ) THEN 
    … …  
    222208904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 
    223209      IF(lwm) WRITE ( numond, namdom ) 
     210 
    224211 
    225212      IF(lwp) THEN 
    … …  
    321308   END SUBROUTINE dom_nam 
    322309 
     310   SUBROUTINE dom_msk 
     311      !!--------------------------------------------------------------------- 
     312      !!                 ***  ROUTINE dom_msk  *** 
     313      !! ** Purpose :  Read the NetCDF file(s) which contain(s) all the 
     314      !!      ocean mask informations and defines the interior domain T-mask. 
     315      !! 
     316      !! ** Method  :  Read in a file all the arrays generated in routines 
     317      !!               dommsk:   'mask.nc' file 
     318      !!              The interior ocean/land mask is computed from tmask 
     319      !!              setting to zero the duplicated row and lines due to 
     320      !!              MPP exchange halos, est-west cyclic and north fold 
     321      !!              boundary conditions. 
     322      !! 
     323      !! ** Action :   tmask_i  : interiorland/ocean mask at t-point 
     324      !!               tpol     : ??? 
     325      !!---------------------------------------------------------------------- 
     326      ! 
     327      INTEGER  ::  inum   ! local integers 
     328      INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
     329      INTEGER  ::   iif, iil, ijf, ijl       ! local integers 
     330      REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 
     331      ! 
     332      !!--------------------------------------------------------------------- 
     333       
     334 
     335 
     336      IF(lwp) WRITE(numout,*) 
     337      IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)' 
     338      IF(lwp) WRITE(numout,*) '~~~~~~~' 
     339 
     340      CALL wrk_alloc( jpi, jpj, zmbk ) 
     341      zmbk(:,:) = 0._wp 
     342 
     343      IF(lwp) WRITE(numout,*) '          one file in "mesh_mask.nc" ' 
     344      CALL iom_open( 'mask', inum ) 
     345 
     346         !                                                         ! masks (inum2)  
     347      CALL iom_get( inum, jpdom_data, 'tmask', tmask ) 
     348      CALL iom_get( inum, jpdom_data, 'umask', umask ) 
     349      CALL iom_get( inum, jpdom_data, 'vmask', vmask ) 
     350      CALL iom_get( inum, jpdom_data, 'fmask', fmask ) 
     351 
     352      CALL lbc_lnk( tmask, 'T', 1._wp )    ! Lateral boundary conditions 
     353      CALL lbc_lnk( umask, 'U', 1._wp )       
     354      CALL lbc_lnk( vmask, 'V', 1._wp ) 
     355      CALL lbc_lnk( fmask, 'F', 1._wp ) 
     356 
     357#if defined key_c1d 
     358      ! set umask and vmask equal tmask in 1D configuration 
     359      IF(lwp) WRITE(numout,*) 
     360      IF(lwp) WRITE(numout,*) '**********  1D configuration : set umask and vmask equal tmask ********' 
     361      IF(lwp) WRITE(numout,*) '**********                                                     ********' 
     362 
     363      umask(:,:,:) = tmask(:,:,:) 
     364      vmask(:,:,:) = tmask(:,:,:) 
     365#endif 
     366 
     367#if defined key_degrad 
     368      CALL iom_get( inum, jpdom_data, 'facvolt', facvol ) 
     369#endif 
     370 
     371      CALL iom_get( inum, jpdom_data, 'mbathy', zmbk )              ! number of ocean t-points 
     372      mbathy (:,:) = INT( zmbk(:,:) ) 
     373      misfdep(:,:) = 1                                               ! ice shelf case not yet done 
     374       
     375      CALL zgr_bot_level                                             ! mbk. arrays (deepest ocean t-, u- & v-points 
     376 
     377      !                                     ! ============================ 
     378      !                                     !        close the files  
     379      !                                     ! ============================ 
     380 
     381      ! 
     382      ! Interior domain mask (used for global sum) 
     383      ! -------------------- 
     384      ssmask(:,:)  = tmask(:,:,1) 
     385      tmask_i(:,:) = tmask(:,:,1) 
     386      iif = jpreci                        ! thickness of exchange halos in i-axis 
     387      iil = nlci - jpreci + 1 
     388      ijf = jprecj                        ! thickness of exchange halos in j-axis 
     389      ijl = nlcj - jprecj + 1 
     390      ! 
     391      tmask_i( 1 :iif,   :   ) = 0._wp    ! first columns 
     392      tmask_i(iil:jpi,   :   ) = 0._wp    ! last  columns (including mpp extra columns) 
     393      tmask_i(   :   , 1 :ijf) = 0._wp    ! first rows 
     394      tmask_i(   :   ,ijl:jpj) = 0._wp    ! last  rows (including mpp extra rows) 
     395      ! 
     396      !                                   ! north fold mask 
     397      tpol(1:jpiglo) = 1._wp 
     398      !                                 
     399      IF( jperio == 3 .OR. jperio == 4 )   tpol(jpiglo/2+1:jpiglo) = 0._wp    ! T-point pivot 
     400      IF( jperio == 5 .OR. jperio == 6 )   tpol(     1    :jpiglo) = 0._wp    ! F-point pivot 
     401      IF( jperio == 3 .OR. jperio == 4 ) THEN      ! T-point pivot: only half of the nlcj-1 row 
     402         IF( mjg(ijl-1) == jpjglo-1 ) THEN 
     403            DO ji = iif+1, iil-1 
     404               tmask_i(ji,ijl-1) = tmask_i(ji,ijl-1) * tpol(mig(ji)) 
     405            END DO 
     406         ENDIF 
     407      ENDIF  
     408      ! 
     409      ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 
     410      ! least 1 wet u point 
     411      DO jj = 1, jpjm1 
     412         DO ji = 1, fs_jpim1   ! vector loop 
     413            umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
     414            vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
     415         END DO 
     416         DO ji = 1, jpim1      ! NO vector opt. 
     417            fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
     418               &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
     419         END DO 
     420      END DO 
     421      CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
     422      CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
     423      CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
     424 
     425      ! 3. Ocean/land mask at wu-, wv- and w points  
     426      !---------------------------------------------- 
     427      wmask (:,:,1) = tmask(:,:,1) ! ???????? 
     428      wumask(:,:,1) = umask(:,:,1) ! ???????? 
     429      wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
     430      DO jk = 2, jpk 
     431         wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 
     432         wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1)    
     433         wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 
     434      END DO 
     435      ! 
     436      CALL wrk_dealloc( jpi, jpj, zmbk ) 
     437      ! 
     438      CALL iom_close( inum ) 
     439      ! 
     440   END SUBROUTINE dom_msk 
     441 
     442   SUBROUTINE zgr_bot_level 
     443      !!---------------------------------------------------------------------- 
     444      !!                    ***  ROUTINE zgr_bot_level  *** 
     445      !! 
     446      !! ** Purpose :   defines the vertical index of ocean bottom (mbk. arrays) 
     447      !! 
     448      !! ** Method  :   computes from mbathy with a minimum value of 1 over land 
     449      !! 
     450      !! ** Action  :   mbkt, mbku, mbkv :   vertical indices of the deeptest 
     451      !!                                     ocean level at t-, u- & v-points 
     452      !!                                     (min value = 1 over land) 
     453      !!---------------------------------------------------------------------- 
     454      ! 
     455      INTEGER ::   ji, jj   ! dummy loop indices 
     456      REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 
     457      !!---------------------------------------------------------------------- 
     458 
     459      ! 
     460      IF(lwp) WRITE(numout,*) 
     461      IF(lwp) WRITE(numout,*) '    zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 
     462      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~' 
     463      ! 
     464      CALL wrk_alloc( jpi, jpj, zmbk ) 
     465      ! 
     466      mbkt(:,:) = MAX( mbathy(:,:) , 1 )    ! bottom k-index of T-level (=1 over land) 
     467      mikt(:,:) = 1 ; miku(:,:) = 1; mikv(:,:) = 1; ! top k-index of T-level (=1 over open ocean; >1 beneath ice shelf) 
     468      !                                     ! bottom k-index of W-level = mbkt+1 
     469      DO jj = 1, jpjm1                      ! bottom k-index of u- (v-) level 
     470         DO ji = 1, jpim1 
     471            mbku(ji,jj) = MIN(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  ) 
     472            mbkv(ji,jj) = MIN(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
     473         END DO 
     474      END DO 
     475      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk  
     476      zmbk(:,:) = REAL( mbku(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     477      zmbk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     478      ! 
     479      CALL wrk_dealloc( jpi, jpj, zmbk ) 
     480      ! 
     481   END SUBROUTINE zgr_bot_level 
     482 
     483   SUBROUTINE dom_hgr 
     484      !!---------------------------------------------------------------------- 
     485      !!                  ***  ROUTINE dom_hgr  *** 
     486      !!                    
     487      !! ** Purpose :  Read the NetCDF file(s) which contain(s) all the 
     488      !!      ocean horizontal mesh informations  
     489      !! 
     490      !! ** Method  :   Read in a file all the arrays generated in routines 
     491      !!                domhgr:   'mesh_hgr.nc' file 
     492      !!---------------------------------------------------------------------- 
     493      !! 
     494      INTEGER ::   ji, jj   ! dummy loop indices 
     495      INTEGER  ::  inum    ! local integers 
     496      !!---------------------------------------------------------------------- 
     497 
     498      IF(lwp) WRITE(numout,*) 
     499      IF(lwp) WRITE(numout,*) 'dom_grd_hgr : read NetCDF mesh and mask information file(s)' 
     500      IF(lwp) WRITE(numout,*) '~~~~~~~' 
     501 
     502      IF(lwp) WRITE(numout,*) '          one file in "mesh_mask.nc" ' 
     503      CALL iom_open( 'mesh_hgr', inum ) 
     504 
     505      !                                                         ! horizontal mesh (inum3) 
     506      CALL iom_get( inum, jpdom_data, 'glamt', glamt ) 
     507      CALL iom_get( inum, jpdom_data, 'glamu', glamu ) 
     508      CALL iom_get( inum, jpdom_data, 'glamv', glamv ) 
     509      CALL iom_get( inum, jpdom_data, 'glamf', glamf ) 
     510 
     511      CALL iom_get( inum, jpdom_data, 'gphit', gphit ) 
     512      CALL iom_get( inum, jpdom_data, 'gphiu', gphiu ) 
     513      CALL iom_get( inum, jpdom_data, 'gphiv', gphiv ) 
     514      CALL iom_get( inum, jpdom_data, 'gphif', gphif ) 
     515 
     516      CALL iom_get( inum, jpdom_data, 'e1t', e1t ) 
     517      CALL iom_get( inum, jpdom_data, 'e1u', e1u ) 
     518      CALL iom_get( inum, jpdom_data, 'e1v', e1v ) 
     519       
     520      CALL iom_get( inum, jpdom_data, 'e2t', e2t ) 
     521      CALL iom_get( inum, jpdom_data, 'e2u', e2u ) 
     522      CALL iom_get( inum, jpdom_data, 'e2v', e2v ) 
     523 
     524      CALL iom_get( inum, jpdom_data, 'ff', ff ) 
     525 
     526 
     527      ! Control printing : Grid informations (if not restart) 
     528      ! ---------------- 
     529 
     530      IF(lwp .AND. .NOT.ln_rstart ) THEN 
     531         WRITE(numout,*) 
     532         WRITE(numout,*) '          longitude and e1 scale factors' 
     533         WRITE(numout,*) '          ------------------------------' 
     534         WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1),   & 
     535            glamv(ji,1), glamf(ji,1),   & 
     536            e1t(ji,1), e1u(ji,1),   & 
     537            e1v(ji,1), ji = 1, jpi,10) 
     538 
     539         WRITE(numout,*) 
     540         WRITE(numout,*) '          latitude and e2 scale factors' 
     541         WRITE(numout,*) '          -----------------------------' 
     542         WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj),   & 
     543            &                     gphiv(1,jj), gphif(1,jj),   & 
     544            &                     e2t  (1,jj), e2u  (1,jj),   & 
     545            &                     e2v  (1,jj), jj = 1, jpj, 10 ) 
     546      ENDIF 
     547 
     548      !                                     ! ============================ 
     549      !                                     !        close the files  
     550      !                                     ! ============================ 
     551      CALL iom_close( inum ) 
     552      ! 
     5539300     FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x,    & 
     554            f19.10, 1x, f19.10, 1x, f19.10 ) 
     555   END SUBROUTINE dom_hgr 
     556 
     557 
    323558   SUBROUTINE dom_zgr 
    324559      !!---------------------------------------------------------------------- 
    325560      !!                ***  ROUTINE dom_zgr  *** 
    326561      !!                    
    327       !! ** Purpose :  set the depth of model levels and the resulting  
    328       !!      vertical scale factors. 
     562      !! ** Purpose :  Read the NetCDF file(s) which contain(s) all the 
     563      !!      ocean horizontal mesh informations and/or set the depth of model levels  
     564      !!      and the resulting vertical scale factors. 
    329565      !! 
    330566      !! ** Method  : - reference 1D vertical coordinate (gdep._1d, e3._1d) 
    … …  
    338574      !! ** Action  :   define gdep., e3., mbathy and bathy 
    339575      !!---------------------------------------------------------------------- 
    340       INTEGER ::   ioptio = 0   ! temporary integer 
    341       INTEGER ::   ios 
     576      INTEGER  ::  ioptio = 0   ! temporary integer 
     577      INTEGER  ::  inum, ios 
     578      INTEGER  ::  ji, jj, jk, ik 
     579      REAL(wp) ::  zrefdep 
    342580      !! 
    343581      NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 
     582      REAL(wp), POINTER, DIMENSION(:,:) :: zprt, zprw 
    344583      !!---------------------------------------------------------------------- 
    345584 
    … …  
    372611      IF ( ioptio == 33 )   CALL ctl_stop( ' isf cavity with off line module not yet done    ' ) 
    373612 
    374    END SUBROUTINE dom_zgr 
    375  
    376    SUBROUTINE dom_ctl 
    377       !!---------------------------------------------------------------------- 
    378       !!                     ***  ROUTINE dom_ctl  *** 
    379       !! 
    380       !! ** Purpose :   Domain control. 
    381       !! 
    382       !! ** Method  :   compute and print extrema of masked scale factors 
    383       !! 
    384       !! History : 
    385       !!   8.5  !  02-08  (G. Madec)    Original code 
    386       !!---------------------------------------------------------------------- 
    387       !! * Local declarations 
    388       INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 
    389       INTEGER, DIMENSION(2) ::   iloc      !  
    390       REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
    391       !!---------------------------------------------------------------------- 
    392  
    393       ! Extrema of the scale factors 
    394  
    395       IF(lwp)WRITE(numout,*) 
    396       IF(lwp)WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 
    397       IF(lwp)WRITE(numout,*) '~~~~~~~' 
    398  
    399       IF (lk_mpp) THEN 
    400          CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 
    401          CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 
    402          CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 
    403          CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 
     613      IF(lwp) WRITE(numout,*) '          one file in "mesh_mask.nc" ' 
     614      CALL iom_open( 'mesh_zgr', inum ) 
     615 
     616      CALL iom_get( inum, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 
     617      CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
     618      IF( ln_zco .OR. ln_zps ) THEN 
     619         CALL iom_get( inum, jpdom_unknown, 'e3t_1d'  , e3t_1d   )    ! reference scale factors 
     620         CALL iom_get( inum, jpdom_unknown, 'e3w_1d'  , e3w_1d   ) 
     621      ENDIF 
     622 
     623!!gm BUG in s-coordinate this does not work! 
     624      ! deepest/shallowest W level Above/Below ~10m 
     625      zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) )                 ! ref. depth with tolerance (10% of minimum layer thickness) 
     626      nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 
     627      nla10 = nlb10 - 1                                              ! deepest    W level Above ~10m 
     628!!gm end bug 
     629 
     630      IF(lwp) THEN 
     631         WRITE(numout,*) 
     632         WRITE(numout,*) '              Reference z-coordinate depth and scale factors:' 
     633         WRITE(numout, "(9x,' level   gdept    gdepw     e3t      e3w  ')" ) 
     634         WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 
     635      ENDIF 
     636 
     637      DO jk = 1, jpk 
     638         IF( e3w_1d  (jk) <= 0._wp .OR. e3t_1d  (jk) <= 0._wp )   CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 
     639         IF( gdepw_1d(jk) <  0._wp .OR. gdept_1d(jk) <  0._wp )   CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 
     640      END DO 
     641 
     642      IF( lk_vvl ) THEN 
     643          CALL iom_get( inum, jpdom_data, 'e3t_0', e3t_0(:,:,:) ) 
     644          CALL iom_get( inum, jpdom_data, 'e3u_0', e3u_0(:,:,:) ) 
     645          CALL iom_get( inum, jpdom_data, 'e3v_0', e3v_0(:,:,:) ) 
     646          CALL iom_get( inum, jpdom_data, 'e3w_0', e3w_0(:,:,:) ) 
     647          CALL iom_get( inum, jpdom_data, 'gdept_0', gdept_0(:,:,:) ) 
     648          CALL iom_get( inum, jpdom_data, 'gdepw_0', gdepw_0(:,:,:) ) 
     649          ht_0(:,:) = 0.0_wp                       ! Reference ocean depth at  T-points 
     650          DO jk = 1, jpk 
     651             ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 
     652          END DO 
    404653      ELSE 
    405          ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
    406          ze2min = MINVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
    407          ze1max = MAXVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
    408          ze2max = MAXVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
    409  
    410          iloc  = MINLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
    411          iimi1 = iloc(1) + nimpp - 1 
    412          ijmi1 = iloc(2) + njmpp - 1 
    413          iloc  = MINLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
    414          iimi2 = iloc(1) + nimpp - 1 
    415          ijmi2 = iloc(2) + njmpp - 1 
    416          iloc  = MAXLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
    417          iima1 = iloc(1) + nimpp - 1 
    418          ijma1 = iloc(2) + njmpp - 1 
    419          iloc  = MAXLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
    420          iima2 = iloc(1) + nimpp - 1 
    421          ijma2 = iloc(2) + njmpp - 1 
    422       ENDIF 
    423  
    424       IF(lwp) THEN 
    425          WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1 
    426          WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 
    427          WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 
    428          WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 
    429       ENDIF 
    430  
    431    END SUBROUTINE dom_ctl 
    432  
    433    SUBROUTINE dom_grd 
    434       !!---------------------------------------------------------------------- 
    435       !!                  ***  ROUTINE dom_grd  *** 
    436       !!                    
    437       !! ** Purpose :  Read the NetCDF file(s) which contain(s) all the 
    438       !!      ocean domain informations (mesh and mask arrays). This (these) 
    439       !!      file(s) is (are) used for visualisation (SAXO software) and 
    440       !!      diagnostic computation. 
    441       !! 
    442       !! ** Method  :   Read in a file all the arrays generated in routines 
    443       !!      domhgr, domzgr, and dommsk. Note: the file contain depends on 
    444       !!      the vertical coord. used (z-coord, partial steps, s-coord) 
    445       !!                    nmsh = 1  :   'mesh_mask.nc' file 
    446       !!                         = 2  :   'mesh.nc' and mask.nc' files 
    447       !!                         = 3  :   'mesh_hgr.nc', 'mesh_zgr.nc' and 
    448       !!                                  'mask.nc' files 
    449       !!      For huge size domain, use option 2 or 3 depending on your  
    450       !!      vertical coordinate. 
    451       !! 
    452       !! ** input file :  
    453       !!      meshmask.nc  : domain size, horizontal grid-point position, 
    454       !!                     masks, depth and vertical scale factors 
    455       !!---------------------------------------------------------------------- 
    456       USE iom 
    457       !! 
    458       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    459       INTEGER  ::   ik, inum0 , inum1 , inum2 , inum3 , inum4   ! local integers 
    460       REAL(wp) ::   zrefdep         ! local real 
    461       REAL(wp), POINTER, DIMENSION(:,:) :: zmbk, zprt, zprw 
    462       !!---------------------------------------------------------------------- 
    463  
    464       IF(lwp) WRITE(numout,*) 
    465       IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)' 
    466       IF(lwp) WRITE(numout,*) '~~~~~~~' 
    467  
    468       CALL wrk_alloc( jpi, jpj, zmbk, zprt, zprw ) 
    469  
    470       zmbk(:,:) = 0._wp 
    471  
    472       SELECT CASE (nmsh) 
    473          !                                     ! ============================ 
    474          CASE ( 1 )                            !  create 'mesh_mask.nc' file 
    475             !                                  ! ============================ 
    476  
    477             IF(lwp) WRITE(numout,*) '          one file in "mesh_mask.nc" ' 
    478             CALL iom_open( 'mesh_mask', inum0 ) 
    479  
    480             inum2 = inum0                                            ! put all the informations 
    481             inum3 = inum0                                            ! in unit inum0 
    482             inum4 = inum0 
    483  
    484             !                                  ! ============================ 
    485          CASE ( 2 )                            !  create 'mesh.nc' and  
    486             !                                  !         'mask.nc' files 
    487             !                                  ! ============================ 
    488  
    489             IF(lwp) WRITE(numout,*) '          two files in "mesh.nc" and "mask.nc" ' 
    490             CALL iom_open( 'mesh', inum1 ) 
    491             CALL iom_open( 'mask', inum2 ) 
    492  
    493             inum3 = inum1                                            ! put mesh informations  
    494             inum4 = inum1                                            ! in unit inum1  
    495  
    496             !                                  ! ============================ 
    497          CASE ( 3 )                            !  create 'mesh_hgr.nc' 
    498             !                                  !         'mesh_zgr.nc' and 
    499             !                                  !         'mask.nc'     files 
    500             !                                  ! ============================ 
    501  
    502             IF(lwp) WRITE(numout,*) '          three files in "mesh_hgr.nc" , "mesh_zgr.nc" and "mask.nc" ' 
    503             CALL iom_open( 'mesh_hgr', inum3 ) ! create 'mesh_hgr.nc' 
    504             CALL iom_open( 'mesh_zgr', inum4 ) ! create 'mesh_zgr.nc' 
    505             CALL iom_open( 'mask'    , inum2 ) ! create 'mask.nc' 
    506  
    507             !                                  ! =========================== 
    508          CASE DEFAULT                          ! return error  
    509             !                                  ! mesh has to be provided 
    510             !                                  ! =========================== 
    511             CALL ctl_stop( ' OFFLINE mode requires the input mesh mask(s). ',   & 
    512             &                                 ' Invalid nn_msh value in the namelist (0 is not allowed)' ) 
    513  
    514          END SELECT 
    515  
    516          !                                                         ! masks (inum2)  
    517          CALL iom_get( inum2, jpdom_data, 'tmask', tmask ) 
    518          CALL iom_get( inum2, jpdom_data, 'umask', umask ) 
    519          CALL iom_get( inum2, jpdom_data, 'vmask', vmask ) 
    520          CALL iom_get( inum2, jpdom_data, 'fmask', fmask ) 
    521  
    522          CALL lbc_lnk( tmask, 'T', 1._wp )    ! Lateral boundary conditions 
    523          CALL lbc_lnk( umask, 'U', 1._wp )       
    524          CALL lbc_lnk( vmask, 'V', 1._wp ) 
    525          CALL lbc_lnk( fmask, 'F', 1._wp ) 
    526  
    527 #if defined key_c1d 
    528          ! set umask and vmask equal tmask in 1D configuration 
    529          IF(lwp) WRITE(numout,*) 
    530          IF(lwp) WRITE(numout,*) '**********  1D configuration : set umask and vmask equal tmask ********' 
    531          IF(lwp) WRITE(numout,*) '**********                                                     ********' 
    532  
    533          umask(:,:,:) = tmask(:,:,:) 
    534          vmask(:,:,:) = tmask(:,:,:) 
    535 #endif 
    536  
    537 #if defined key_degrad 
    538          CALL iom_get( inum2, jpdom_data, 'facvolt', facvol ) 
    539 #endif 
    540  
    541          !                                                         ! horizontal mesh (inum3) 
    542          CALL iom_get( inum3, jpdom_data, 'glamt', glamt ) 
    543          CALL iom_get( inum3, jpdom_data, 'glamu', glamu ) 
    544          CALL iom_get( inum3, jpdom_data, 'glamv', glamv ) 
    545          CALL iom_get( inum3, jpdom_data, 'glamf', glamf ) 
    546  
    547          CALL iom_get( inum3, jpdom_data, 'gphit', gphit ) 
    548          CALL iom_get( inum3, jpdom_data, 'gphiu', gphiu ) 
    549          CALL iom_get( inum3, jpdom_data, 'gphiv', gphiv ) 
    550          CALL iom_get( inum3, jpdom_data, 'gphif', gphif ) 
    551  
    552          CALL iom_get( inum3, jpdom_data, 'e1t', e1t ) 
    553          CALL iom_get( inum3, jpdom_data, 'e1u', e1u ) 
    554          CALL iom_get( inum3, jpdom_data, 'e1v', e1v ) 
    555           
    556          CALL iom_get( inum3, jpdom_data, 'e2t', e2t ) 
    557          CALL iom_get( inum3, jpdom_data, 'e2u', e2u ) 
    558          CALL iom_get( inum3, jpdom_data, 'e2v', e2v ) 
    559  
    560          CALL iom_get( inum3, jpdom_data, 'ff', ff ) 
    561  
    562          CALL iom_get( inum4, jpdom_data, 'mbathy', zmbk )              ! number of ocean t-points 
    563          mbathy (:,:) = INT( zmbk(:,:) ) 
    564          misfdep(:,:) = 1                                               ! ice shelf case not yet done 
    565           
    566          CALL zgr_bot_level                                             ! mbk. arrays (deepest ocean t-, u- & v-points 
    567          ! 
    568654         IF( ln_sco ) THEN                                         ! s-coordinate 
    569             CALL iom_get( inum4, jpdom_data, 'hbatt', hbatt ) 
    570             CALL iom_get( inum4, jpdom_data, 'hbatu', hbatu ) 
    571             CALL iom_get( inum4, jpdom_data, 'hbatv', hbatv ) 
    572             CALL iom_get( inum4, jpdom_data, 'hbatf', hbatf ) 
     655            CALL iom_get( inum, jpdom_data, 'hbatt', hbatt ) 
     656            CALL iom_get( inum, jpdom_data, 'hbatu', hbatu ) 
     657            CALL iom_get( inum, jpdom_data, 'hbatv', hbatv ) 
     658            CALL iom_get( inum, jpdom_data, 'hbatf', hbatf ) 
    573659             
    574             CALL iom_get( inum4, jpdom_unknown, 'gsigt', gsigt ) ! scaling coef. 
    575             CALL iom_get( inum4, jpdom_unknown, 'gsigw', gsigw ) 
    576             CALL iom_get( inum4, jpdom_unknown, 'gsi3w', gsi3w )  
    577             CALL iom_get( inum4, jpdom_unknown, 'esigt', esigt ) 
    578             CALL iom_get( inum4, jpdom_unknown, 'esigw', esigw ) 
    579  
    580             CALL iom_get( inum4, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) ! scale factors 
    581             CALL iom_get( inum4, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 
    582             CALL iom_get( inum4, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 
    583             CALL iom_get( inum4, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 
    584  
    585             CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 
    586             CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
     660            CALL iom_get( inum, jpdom_unknown, 'gsigt', gsigt ) ! scaling coef. 
     661            CALL iom_get( inum, jpdom_unknown, 'gsigw', gsigw ) 
     662            CALL iom_get( inum, jpdom_unknown, 'gsi3w', gsi3w )  
     663            CALL iom_get( inum, jpdom_unknown, 'esigt', esigt ) 
     664            CALL iom_get( inum, jpdom_unknown, 'esigw', esigw ) 
     665 
     666            CALL iom_get( inum, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) ! scale factors 
     667            CALL iom_get( inum, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 
     668            CALL iom_get( inum, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 
     669            CALL iom_get( inum, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 
    587670         ENDIF 
    588671 
    589672  
    590673         IF( ln_zps ) THEN                                           ! z-coordinate - partial steps 
    591             CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d )  ! reference depth 
    592             CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
    593             CALL iom_get( inum4, jpdom_unknown, 'e3t_1d'  , e3t_1d   )    ! reference scale factors 
    594             CALL iom_get( inum4, jpdom_unknown, 'e3w_1d'  , e3w_1d   ) 
    595674            ! 
    596             IF( nmsh <= 6 ) THEN                                        ! 3D vertical scale factors 
    597                CALL iom_get( inum4, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) 
    598                CALL iom_get( inum4, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 
    599                CALL iom_get( inum4, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 
    600                CALL iom_get( inum4, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 
     675            IF( iom_varid( inum, 'e3t_0', ldstop = .FALSE. ) > 0 ) THEN 
     676               CALL iom_get( inum, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) 
     677               CALL iom_get( inum, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 
     678               CALL iom_get( inum, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 
     679               CALL iom_get( inum, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 
    601680            ELSE                                                        ! 2D bottom scale factors 
    602                CALL iom_get( inum4, jpdom_data, 'e3t_ps', e3tp ) 
    603                CALL iom_get( inum4, jpdom_data, 'e3w_ps', e3wp ) 
     681               CALL iom_get( inum, jpdom_data, 'e3t_ps', e3tp ) 
     682               CALL iom_get( inum, jpdom_data, 'e3w_ps', e3wp ) 
    604683               !                                                        ! deduces the 3D scale factors 
    605684               DO jk = 1, jpk 
    … …  
    633712            END IF 
    634713 
    635             IF( iom_varid( inum4, 'gdept_0', ldstop = .FALSE. ) > 0 ) THEN   ! 3D depth of t- and w-level 
    636                CALL iom_get( inum4, jpdom_data, 'gdept_0', fsdept_n(:,:,:) ) 
    637                CALL iom_get( inum4, jpdom_data, 'gdepw_0', fsdepw_n(:,:,:) ) 
     714            IF( iom_varid( inum, 'gdept_0', ldstop = .FALSE. ) > 0 ) THEN   ! 3D depth of t- and w-level 
     715               CALL iom_get( inum, jpdom_data, 'gdept_0', fsdept_n(:,:,:) ) 
     716               CALL iom_get( inum, jpdom_data, 'gdepw_0', fsdepw_n(:,:,:) ) 
    638717            ELSE                                                           ! 2D bottom depth 
    639                CALL iom_get( inum4, jpdom_data, 'hdept', zprt ) 
    640                CALL iom_get( inum4, jpdom_data, 'hdepw', zprw ) 
     718               CALL wrk_alloc( jpi, jpj, zprt, zprw ) 
     719               ! 
     720               CALL iom_get( inum, jpdom_data, 'hdept', zprt ) 
     721               CALL iom_get( inum, jpdom_data, 'hdepw', zprw ) 
    641722               ! 
    642723               DO jk = 1, jpk                                              ! deduces the 3D depth 
    … …  
    654735                  END DO 
    655736               END DO 
     737               CALL wrk_dealloc( jpi, jpj, zprt, zprw ) 
    656738            ENDIF 
    657739            ! 
    … …  
    659741 
    660742         IF( ln_zco ) THEN           ! Vertical coordinates and scales factors 
    661             CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 
    662             CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
    663             CALL iom_get( inum4, jpdom_unknown, 'e3t_1d'  , e3t_1d   ) 
    664             CALL iom_get( inum4, jpdom_unknown, 'e3w_1d'  , e3w_1d   ) 
    665743            DO jk = 1, jpk 
    666744               fse3t_n(:,:,jk) = e3t_1d(jk)                              ! set to the ref. factors 
    … …  
    672750            END DO 
    673751         ENDIF 
    674  
    675 !!gm BUG in s-coordinate this does not work! 
    676       ! deepest/shallowest W level Above/Below ~10m 
    677       zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) )                 ! ref. depth with tolerance (10% of minimum layer thickness) 
    678       nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 
    679       nla10 = nlb10 - 1                                              ! deepest    W level Above ~10m 
    680 !!gm end bug 
    681  
    682       ! Control printing : Grid informations (if not restart) 
    683       ! ---------------- 
    684  
    685       IF(lwp .AND. .NOT.ln_rstart ) THEN 
    686          WRITE(numout,*) 
    687          WRITE(numout,*) '          longitude and e1 scale factors' 
    688          WRITE(numout,*) '          ------------------------------' 
    689          WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1),   & 
    690             glamv(ji,1), glamf(ji,1),   & 
    691             e1t(ji,1), e1u(ji,1),   & 
    692             e1v(ji,1), ji = 1, jpi,10) 
    693 9300     FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x,    & 
    694             f19.10, 1x, f19.10, 1x, f19.10 ) 
    695  
    696          WRITE(numout,*) 
    697          WRITE(numout,*) '          latitude and e2 scale factors' 
    698          WRITE(numout,*) '          -----------------------------' 
    699          WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj),   & 
    700             &                     gphiv(1,jj), gphif(1,jj),   & 
    701             &                     e2t  (1,jj), e2u  (1,jj),   & 
    702             &                     e2v  (1,jj), jj = 1, jpj, 10 ) 
    703       ENDIF 
    704  
    705  
    706       IF( nprint == 1 .AND. lwp ) THEN 
    707          WRITE(numout,*) '          e1u e2u ' 
    708          CALL prihre( e1u,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 
    709          CALL prihre( e2u,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 
    710          WRITE(numout,*) '          e1v e2v  ' 
    711          CALL prihre( e1v,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 
    712          CALL prihre( e2v,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 
    713       ENDIF 
    714  
    715       IF(lwp) THEN 
    716          WRITE(numout,*) 
    717          WRITE(numout,*) '              Reference z-coordinate depth and scale factors:' 
    718          WRITE(numout, "(9x,' level   gdept    gdepw     e3t      e3w  ')" ) 
    719          WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 
    720       ENDIF 
    721  
    722       DO jk = 1, jpk 
    723          IF( e3w_1d  (jk) <= 0._wp .OR. e3t_1d  (jk) <= 0._wp )   CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 
    724          IF( gdepw_1d(jk) <  0._wp .OR. gdept_1d(jk) <  0._wp )   CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 
    725       END DO 
     752         ! 
     753      ENDIF 
    726754      !                                     ! ============================ 
    727755      !                                     !        close the files  
    728756      !                                     ! ============================ 
    729       SELECT CASE ( nmsh ) 
    730          CASE ( 1 )                 
    731             CALL iom_close( inum0 ) 
    732          CASE ( 2 ) 
    733             CALL iom_close( inum1 ) 
    734             CALL iom_close( inum2 ) 
    735          CASE ( 3 ) 
    736             CALL iom_close( inum2 ) 
    737             CALL iom_close( inum3 ) 
    738             CALL iom_close( inum4 ) 
    739       END SELECT 
    740       ! 
    741       CALL wrk_dealloc( jpi, jpj, zmbk, zprt, zprw ) 
    742       ! 
    743    END SUBROUTINE dom_grd 
    744  
    745  
    746    SUBROUTINE zgr_bot_level 
    747       !!---------------------------------------------------------------------- 
    748       !!                    ***  ROUTINE zgr_bot_level  *** 
    749       !! 
    750       !! ** Purpose :   defines the vertical index of ocean bottom (mbk. arrays) 
    751       !! 
    752       !! ** Method  :   computes from mbathy with a minimum value of 1 over land 
    753       !! 
    754       !! ** Action  :   mbkt, mbku, mbkv :   vertical indices of the deeptest 
    755       !!                                     ocean level at t-, u- & v-points 
    756       !!                                     (min value = 1 over land) 
    757       !!---------------------------------------------------------------------- 
    758       ! 
    759       INTEGER ::   ji, jj   ! dummy loop indices 
    760       REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 
    761       !!---------------------------------------------------------------------- 
    762  
    763       ! 
    764       IF(lwp) WRITE(numout,*) 
    765       IF(lwp) WRITE(numout,*) '    zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 
    766       IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~' 
    767       ! 
    768       CALL wrk_alloc( jpi, jpj, zmbk ) 
    769       ! 
    770       mbkt(:,:) = MAX( mbathy(:,:) , 1 )    ! bottom k-index of T-level (=1 over land) 
    771       mikt(:,:) = 1 ; miku(:,:) = 1; mikv(:,:) = 1; ! top k-index of T-level (=1 over open ocean; >1 beneath ice shelf) 
    772       !                                     ! bottom k-index of W-level = mbkt+1 
    773       DO jj = 1, jpjm1                      ! bottom k-index of u- (v-) level 
    774          DO ji = 1, jpim1 
    775             mbku(ji,jj) = MIN(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  ) 
    776             mbkv(ji,jj) = MIN(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
    777          END DO 
    778       END DO 
    779       ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk  
    780       zmbk(:,:) = REAL( mbku(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    781       zmbk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    782       ! 
    783       CALL wrk_dealloc( jpi, jpj, zmbk ) 
    784       ! 
    785    END SUBROUTINE zgr_bot_level 
    786  
    787    SUBROUTINE dom_msk 
    788       !!--------------------------------------------------------------------- 
    789       !!                 ***  ROUTINE dom_msk  *** 
    790       !! 
    791       !! ** Purpose :   Off-line case: defines the interior domain T-mask. 
    792       !! 
    793       !! ** Method  :   The interior ocean/land mask is computed from tmask 
    794       !!              setting to zero the duplicated row and lines due to 
    795       !!              MPP exchange halos, est-west cyclic and north fold 
    796       !!              boundary conditions. 
    797       !! 
    798       !! ** Action :   tmask_i  : interiorland/ocean mask at t-point 
    799       !!               tpol     : ??? 
    800       !!---------------------------------------------------------------------- 
    801       ! 
    802       INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
    803       INTEGER  ::   iif, iil, ijf, ijl       ! local integers 
    804       INTEGER, POINTER, DIMENSION(:,:) ::  imsk  
    805       ! 
    806       !!--------------------------------------------------------------------- 
    807        
    808       CALL wrk_alloc( jpi, jpj, imsk ) 
    809       ! 
    810       ! Interior domain mask (used for global sum) 
    811       ! -------------------- 
    812       ssmask(:,:)  = tmask(:,:,1) 
    813       tmask_i(:,:) = tmask(:,:,1) 
    814       iif = jpreci                        ! thickness of exchange halos in i-axis 
    815       iil = nlci - jpreci + 1 
    816       ijf = jprecj                        ! thickness of exchange halos in j-axis 
    817       ijl = nlcj - jprecj + 1 
    818       ! 
    819       tmask_i( 1 :iif,   :   ) = 0._wp    ! first columns 
    820       tmask_i(iil:jpi,   :   ) = 0._wp    ! last  columns (including mpp extra columns) 
    821       tmask_i(   :   , 1 :ijf) = 0._wp    ! first rows 
    822       tmask_i(   :   ,ijl:jpj) = 0._wp    ! last  rows (including mpp extra rows) 
    823       ! 
    824       !                                   ! north fold mask 
    825       tpol(1:jpiglo) = 1._wp 
    826       !                                 
    827       IF( jperio == 3 .OR. jperio == 4 )   tpol(jpiglo/2+1:jpiglo) = 0._wp    ! T-point pivot 
    828       IF( jperio == 5 .OR. jperio == 6 )   tpol(     1    :jpiglo) = 0._wp    ! F-point pivot 
    829       IF( jperio == 3 .OR. jperio == 4 ) THEN      ! T-point pivot: only half of the nlcj-1 row 
    830          IF( mjg(ijl-1) == jpjglo-1 ) THEN 
    831             DO ji = iif+1, iil-1 
    832                tmask_i(ji,ijl-1) = tmask_i(ji,ijl-1) * tpol(mig(ji)) 
    833             END DO 
    834          ENDIF 
    835       ENDIF  
    836       ! 
    837       ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 
    838       ! least 1 wet u point 
    839       DO jj = 1, jpjm1 
    840          DO ji = 1, fs_jpim1   ! vector loop 
    841             umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
    842             vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
    843          END DO 
    844          DO ji = 1, jpim1      ! NO vector opt. 
    845             fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
    846                &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
    847          END DO 
    848       END DO 
    849       CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
    850       CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
    851       CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
    852  
    853       ! 3. Ocean/land mask at wu-, wv- and w points  
    854       !---------------------------------------------- 
    855       wmask (:,:,1) = tmask(:,:,1) ! ???????? 
    856       wumask(:,:,1) = umask(:,:,1) ! ???????? 
    857       wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
    858       DO jk=2,jpk 
    859          wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 
    860          wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1)    
    861          wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 
    862       END DO 
    863       ! 
    864       IF( nprint == 1 .AND. lwp ) THEN    ! Control print 
    865          imsk(:,:) = INT( tmask_i(:,:) ) 
    866          WRITE(numout,*) ' tmask_i : ' 
    867          CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 
    868          WRITE (numout,*) 
    869          WRITE (numout,*) ' dommsk: tmask for each level' 
    870          WRITE (numout,*) ' ----------------------------' 
    871          DO jk = 1, jpk 
    872             imsk(:,:) = INT( tmask(:,:,jk) ) 
    873             WRITE(numout,*) 
    874             WRITE(numout,*) ' level = ',jk 
    875             CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 
    876          END DO 
    877       ENDIF 
    878       ! 
    879       CALL wrk_dealloc( jpi, jpj, imsk ) 
    880       ! 
    881    END SUBROUTINE dom_msk 
     757      CALL iom_close( inum ) 
     758      ! 
     759      ! 
     760   END SUBROUTINE dom_zgr 
     761 
     762   SUBROUTINE dom_ctl 
     763      !!---------------------------------------------------------------------- 
     764      !!                     ***  ROUTINE dom_ctl  *** 
     765      !! 
     766      !! ** Purpose :   Domain control. 
     767      !! 
     768      !! ** Method  :   compute and print extrema of masked scale factors 
     769      !! 
     770      !! History : 
     771      !!   8.5  !  02-08  (G. Madec)    Original code 
     772      !!---------------------------------------------------------------------- 
     773      !! * Local declarations 
     774      INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 
     775      INTEGER, DIMENSION(2) ::   iloc      !  
     776      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
     777      !!---------------------------------------------------------------------- 
     778 
     779      ! Extrema of the scale factors 
     780 
     781      IF(lwp)WRITE(numout,*) 
     782      IF(lwp)WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 
     783      IF(lwp)WRITE(numout,*) '~~~~~~~' 
     784 
     785      IF (lk_mpp) THEN 
     786         CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 
     787         CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 
     788         CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 
     789         CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 
     790      ELSE 
     791         ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     792         ze2min = MINVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     793         ze1max = MAXVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     794         ze2max = MAXVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )     
     795 
     796         iloc  = MINLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     797         iimi1 = iloc(1) + nimpp - 1 
     798         ijmi1 = iloc(2) + njmpp - 1 
     799         iloc  = MINLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     800         iimi2 = iloc(1) + nimpp - 1 
     801         ijmi2 = iloc(2) + njmpp - 1 
     802         iloc  = MAXLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     803         iima1 = iloc(1) + nimpp - 1 
     804         ijma1 = iloc(2) + njmpp - 1 
     805         iloc  = MAXLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 
     806         iima2 = iloc(1) + nimpp - 1 
     807         ijma2 = iloc(2) + njmpp - 1 
     808      ENDIF 
     809 
     810      IF(lwp) THEN 
     811         WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1 
     812         WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 
     813         WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 
     814         WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 
     815      ENDIF 
     816 
     817   END SUBROUTINE dom_ctl 
    882818 
    883819   !!====================================================================== 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r7256 r7806  
    2222   USE c1d             ! 1D configuration: lk_c1d 
    2323   USE dom_oce         ! ocean domain: variables 
     24   USE domvvl          ! variable volume 
    2425   USE zdf_oce         ! ocean vertical physics: variables 
    2526   USE sbc_oce         ! surface module: variables 
    … …  
    2829   USE trabbl          ! active tracer: bottom boundary layer 
    2930   USE ldfslp          ! lateral diffusion: iso-neutral slopes 
     31   USE sbcrnf          ! river runoffs 
    3032   USE ldfeiv          ! eddy induced velocity coef.  
    3133   USE ldftra_oce      ! ocean tracer   lateral physics 
    … …  
    3941   USE prtctl          ! print control 
    4042   USE fldread         ! read input fields  
     43   USE wrk_nemo        ! Memory allocation  
    4144   USE timing          ! Timing 
     45   USE trc, ONLY : ln_rsttr, numrtr, numrtw, lrst_trc 
    4246 
    4347   IMPLICIT NONE 
    … …  
    4650   PUBLIC   dta_dyn_init   ! called by opa.F90 
    4751   PUBLIC   dta_dyn        ! called by step.F90 
    48  
    49    CHARACTER(len=100) ::   cn_dir       !: Root directory for location of ssr files 
    50    LOGICAL            ::   ln_dynwzv    !: vertical velocity read in a file (T) or computed from u/v (F) 
    51    LOGICAL            ::   ln_dynbbl    !: bbl coef read in a file (T) or computed (F) 
    52    LOGICAL            ::   ln_degrad    !: degradation option enabled or not 
    53    LOGICAL            ::   ln_dynrnf    !: read runoff data in file (T) or set to zero (F) 
    54  
    55    INTEGER  , PARAMETER ::   jpfld = 21     ! maximum number of fields to read 
     52   PUBLIC   dta_dyn_swp   ! called by step.F90 
     53 
     54   CHARACTER(len=100) ::   cn_dir           !: Root directory for location of ssr files 
     55   LOGICAL            ::   ln_ssh_ini       !: initial ssh from dyn file (T) or not (F) - ssh is then read from passive tracer restart 
     56   LOGICAL            ::   ln_dynrnf        !: read runoff data in file (T) or set to zero (F) 
     57   LOGICAL            ::   ln_dynrnf_depth  !: read runoff data in file (T) or set to zero (F) 
     58   REAL(wp)           ::   fwbcorr 
     59 
     60 
     61   INTEGER  , PARAMETER ::   jpfld = 20     ! maximum number of fields to read 
    5662   INTEGER  , SAVE      ::   jf_tem         ! index of temperature 
    5763   INTEGER  , SAVE      ::   jf_sal         ! index of salinity 
    58    INTEGER  , SAVE      ::   jf_uwd         ! index of u-wind 
    59    INTEGER  , SAVE      ::   jf_vwd         ! index of v-wind 
    60    INTEGER  , SAVE      ::   jf_wwd         ! index of w-wind 
     64   INTEGER  , SAVE      ::   jf_uwd         ! index of u-transport 
     65   INTEGER  , SAVE      ::   jf_vwd         ! index of v-transport 
     66   INTEGER  , SAVE      ::   jf_wwd         ! index of v-transport 
    6167   INTEGER  , SAVE      ::   jf_avt         ! index of Kz 
    6268   INTEGER  , SAVE      ::   jf_mld         ! index of mixed layer deptht 
    6369   INTEGER  , SAVE      ::   jf_emp         ! index of water flux 
     70   INTEGER  , SAVE      ::   jf_empb        ! index of water flux 
    6471   INTEGER  , SAVE      ::   jf_qsr         ! index of solar radiation 
    6572   INTEGER  , SAVE      ::   jf_wnd         ! index of wind speed 
    6673   INTEGER  , SAVE      ::   jf_ice         ! index of sea ice cover 
    6774   INTEGER  , SAVE      ::   jf_rnf         ! index of river runoff 
     75   INTEGER  , SAVE      ::   jf_fmf         ! index of downward salt flux 
    6876   INTEGER  , SAVE      ::   jf_ubl         ! index of u-bbl coef 
    6977   INTEGER  , SAVE      ::   jf_vbl         ! index of v-bbl coef 
    70    INTEGER  , SAVE      ::   jf_ahu         ! index of u-diffusivity coef 
    71    INTEGER  , SAVE      ::   jf_ahv         ! index of v-diffusivity coef  
    72    INTEGER  , SAVE      ::   jf_ahw         ! index of w-diffusivity coef 
    73    INTEGER  , SAVE      ::   jf_eiu         ! index of u-eiv 
    74    INTEGER  , SAVE      ::   jf_eiv         ! index of v-eiv 
    75    INTEGER  , SAVE      ::   jf_eiw         ! index of w-eiv 
    76    INTEGER  , SAVE      ::   jf_fmf         ! index of downward salt flux 
    77  
    78    TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_dyn  ! structure of input fields (file informations, fields read) 
     78   INTEGER  , SAVE      ::   jf_div         ! index of e3t 
     79 
     80 
     81   TYPE(FLD), ALLOCATABLE, SAVE, DIMENSION(:) :: sf_dyn  ! structure of input fields (file informations, fields read) 
    7982   !                                               !  
    80    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wdta       ! vertical velocity at 2 time step 
    81    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:  ) :: wnow       ! vertical velocity at 2 time step 
    8283   REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uslpdta    ! zonal isopycnal slopes 
    8384   REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: vslpdta    ! meridional isopycnal slopes 
    8485   REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpidta   ! zonal diapycnal slopes 
    8586   REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpjdta   ! meridional diapycnal slopes 
    86    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: uslpnow    ! zonal isopycnal slopes 
    87    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: vslpnow    ! meridional isopycnal slopes 
    88    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: wslpinow   ! zonal diapycnal slopes 
    89    REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: wslpjnow   ! meridional diapycnal slopes 
    90  
    91    INTEGER :: nrecprev_tem , nrecprev_uwd 
     87 
     88   INTEGER, SAVE  :: nprevrec, nsecdyn 
    9289 
    9390   !! * Substitutions 
    … …  
    113110      !!---------------------------------------------------------------------- 
    114111      ! 
    115       USE oce, ONLY:  zts    => tsa  
    116       USE oce, ONLY:  zuslp  => ua   , zvslp  => va 
    117       USE oce, ONLY:  zwslpi => rotb , zwslpj => rotn 
    118       USE oce, ONLY:  zu     => ub   , zv     => vb,  zw => hdivb 
    119       ! 
     112      USE oce, ONLY:  zhdivtr => ua 
    120113      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    121       ! 
    122       INTEGER  ::   ji, jj     ! dummy loop indices 
    123       INTEGER  ::   isecsbc    ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
    124       REAL(wp) ::   ztinta     ! ratio applied to after  records when doing time interpolation 
    125       REAL(wp) ::   ztintb     ! ratio applied to before records when doing time interpolation 
    126       INTEGER  ::   iswap_tem, iswap_uwd    !  
     114      INTEGER             ::   ji, jj, jk 
     115      REAL(wp), POINTER, DIMENSION(:,:)   :: zemp 
     116      ! 
    127117      !!---------------------------------------------------------------------- 
    128118       
    … …  
    130120      IF( nn_timing == 1 )  CALL timing_start( 'dta_dyn') 
    131121      ! 
    132       isecsbc = nsec_year + nsec1jan000  
    133       ! 
    134       IF( kt == nit000 ) THEN 
    135          nrecprev_tem = 0 
    136          nrecprev_uwd = 0 
    137          ! 
    138          CALL fld_read( kt, 1, sf_dyn )      !==   read data at kt time step   ==! 
    139          ! 
    140          IF( lk_ldfslp .AND. .NOT.lk_c1d .AND. sf_dyn(jf_tem)%ln_tint ) THEN    ! Computes slopes (here avt is used as workspace)                        
    141             zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:)   ! temperature 
    142             zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:)   ! salinity  
    143             avt(:,:,:)        = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:)   ! vertical diffusive coef. 
    144             CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
    145             uslpdta (:,:,:,1) = zuslp (:,:,:)  
    146             vslpdta (:,:,:,1) = zvslp (:,:,:)  
    147             wslpidta(:,:,:,1) = zwslpi(:,:,:)  
    148             wslpjdta(:,:,:,1) = zwslpj(:,:,:)  
    149          ENDIF 
    150          IF( ln_dynwzv .AND. sf_dyn(jf_uwd)%ln_tint )  THEN    ! compute vertical velocity from u/v 
    151             zu(:,:,:) = sf_dyn(jf_uwd)%fdta(:,:,:,1) 
    152             zv(:,:,:) = sf_dyn(jf_vwd)%fdta(:,:,:,1) 
    153             CALL dta_dyn_wzv( zu, zv, zw ) 
    154             wdta(:,:,:,1) = zw(:,:,:) * tmask(:,:,:) 
    155          ENDIF 
    156       ELSE 
    157          nrecprev_tem = sf_dyn(jf_tem)%nrec_a(2) 
    158          nrecprev_uwd = sf_dyn(jf_uwd)%nrec_a(2) 
    159          ! 
    160          CALL fld_read( kt, 1, sf_dyn )      !==   read data at kt time step   ==! 
    161          ! 
    162       ENDIF 
    163       !  
    164       IF( lk_ldfslp .AND. .NOT.lk_c1d ) THEN    ! Computes slopes (here avt is used as workspace)                        
    165          iswap_tem = 0 
    166          IF(  kt /= nit000 .AND. ( sf_dyn(jf_tem)%nrec_a(2) - nrecprev_tem ) /= 0 )  iswap_tem = 1 
    167          IF( ( isecsbc > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap_tem == 1 ) .OR. kt == nit000 )  THEN    ! read/update the after data 
    168             IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 
    169             IF( sf_dyn(jf_tem)%ln_tint ) THEN                 ! time interpolation of data 
    170                IF( kt /= nit000 ) THEN 
    171                   uslpdta (:,:,:,1) =  uslpdta (:,:,:,2)         ! swap the data 
    172                   vslpdta (:,:,:,1) =  vslpdta (:,:,:,2)   
    173                   wslpidta(:,:,:,1) =  wslpidta(:,:,:,2)  
    174                   wslpjdta(:,:,:,1) =  wslpjdta(:,:,:,2)  
    175                ENDIF 
    176                ! 
    177                zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:)   ! temperature 
    178                zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:)   ! salinity  
    179                avt(:,:,:)        = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:)   ! vertical diffusive coef. 
    180                CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
    181                ! 
    182                uslpdta (:,:,:,2) = zuslp (:,:,:)  
    183                vslpdta (:,:,:,2) = zvslp (:,:,:)  
    184                wslpidta(:,:,:,2) = zwslpi(:,:,:)  
    185                wslpjdta(:,:,:,2) = zwslpj(:,:,:)  
    186             ELSE 
    187                zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) 
    188                zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) 
    189                avt(:,:,:)        = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) 
    190                CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
    191                uslpnow (:,:,:)   = zuslp (:,:,:)  
    192                vslpnow (:,:,:)   = zvslp (:,:,:)  
    193                wslpinow(:,:,:)   = zwslpi(:,:,:)  
    194                wslpjnow(:,:,:)   = zwslpj(:,:,:)  
    195             ENDIF 
    196          ENDIF 
    197          IF( sf_dyn(jf_tem)%ln_tint )  THEN 
    198             ztinta =  REAL( isecsbc - sf_dyn(jf_tem)%nrec_b(2), wp )  & 
    199                &    / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp ) 
    200             ztintb =  1. - ztinta 
    201             uslp (:,:,:) = ztintb * uslpdta (:,:,:,1)  + ztinta * uslpdta (:,:,:,2)   
    202             vslp (:,:,:) = ztintb * vslpdta (:,:,:,1)  + ztinta * vslpdta (:,:,:,2)   
    203             wslpi(:,:,:) = ztintb * wslpidta(:,:,:,1)  + ztinta * wslpidta(:,:,:,2)   
    204             wslpj(:,:,:) = ztintb * wslpjdta(:,:,:,1)  + ztinta * wslpjdta(:,:,:,2)   
    205          ELSE 
    206             uslp (:,:,:) = uslpnow (:,:,:) 
    207             vslp (:,:,:) = vslpnow (:,:,:) 
    208             wslpi(:,:,:) = wslpinow(:,:,:) 
    209             wslpj(:,:,:) = wslpjnow(:,:,:) 
    210          ENDIF 
    211       ENDIF 
    212       ! 
    213       IF( ln_dynwzv )  THEN    ! compute vertical velocity from u/v 
    214          iswap_uwd = 0 
    215          IF(  kt /= nit000 .AND. ( sf_dyn(jf_uwd)%nrec_a(2) - nrecprev_uwd ) /= 0 )  iswap_uwd = 1 
    216          IF( ( isecsbc > sf_dyn(jf_uwd)%nrec_b(2) .AND. iswap_uwd == 1 ) .OR. kt == nit000 )  THEN    ! read/update the after data 
    217             IF(lwp) WRITE(numout,*) ' Compute new vertical velocity at kt = ', kt 
    218             IF(lwp) WRITE(numout,*) 
    219             IF( sf_dyn(jf_uwd)%ln_tint ) THEN                 ! time interpolation of data 
    220                IF( kt /= nit000 )  THEN 
    221                   wdta(:,:,:,1) =  wdta(:,:,:,2)     ! swap the data for initialisation 
    222                ENDIF 
    223                zu(:,:,:) = sf_dyn(jf_uwd)%fdta(:,:,:,2) 
    224                zv(:,:,:) = sf_dyn(jf_vwd)%fdta(:,:,:,2) 
    225                CALL dta_dyn_wzv( zu, zv, zw ) 
    226                wdta(:,:,:,2) = zw(:,:,:) * tmask(:,:,:) 
    227             ELSE 
    228                zu(:,:,:) = sf_dyn(jf_uwd)%fnow(:,:,:)  
    229                zv(:,:,:) = sf_dyn(jf_vwd)%fnow(:,:,:) 
    230                CALL dta_dyn_wzv( zu, zv, zw ) 
    231                wnow(:,:,:)  = zw(:,:,:) * tmask(:,:,:) 
    232             ENDIF 
    233          ENDIF 
    234          IF( sf_dyn(jf_uwd)%ln_tint )  THEN 
    235             ztinta =  REAL( isecsbc - sf_dyn(jf_uwd)%nrec_b(2), wp )  & 
    236                &    / REAL( sf_dyn(jf_uwd)%nrec_a(2) - sf_dyn(jf_uwd)%nrec_b(2), wp ) 
    237             ztintb =  1. - ztinta 
    238             wn(:,:,:) = ztintb * wdta(:,:,:,1)  + ztinta * wdta(:,:,:,2)   
    239          ELSE 
    240             wn(:,:,:) = wnow(:,:,:) 
    241          ENDIF 
    242       ENDIF 
     122      ! 
     123      nsecdyn = nsec_year + nsec1jan000   ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
     124      ! 
     125      IF( kt == nit000 ) THEN    ;    nprevrec = 0 
     126      ELSE                       ;    nprevrec = sf_dyn(jf_tem)%nrec_a(2) 
     127      ENDIF 
     128      ! 
     129      CALL fld_read( kt, 1, sf_dyn )      !=  read data at kt time step   ==! 
     130      ! 
     131      IF( lk_ldfslp .AND. .NOT.lk_c1d )   CALL  dta_dyn_slp( kt )    ! Computation of slopes 
    243132      ! 
    244133      tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:)  * tmask(:,:,:)    ! temperature 
    245134      tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:)  * tmask(:,:,:)    ! salinity 
    246       ! 
     135      wndm(:,:)         = sf_dyn(jf_wnd)%fnow(:,:,1)  * tmask(:,:,1)    ! wind speed - needed for gas exchange 
     136      fmmflx(:,:)       = sf_dyn(jf_fmf)%fnow(:,:,1)  * tmask(:,:,1)    ! downward salt flux (v3.5+) 
     137      fr_i(:,:)         = sf_dyn(jf_ice)%fnow(:,:,1)  * tmask(:,:,1)    ! Sea-ice fraction 
     138      qsr (:,:)         = sf_dyn(jf_qsr)%fnow(:,:,1)  * tmask(:,:,1)    ! solar radiation 
     139      emp (:,:)         = sf_dyn(jf_emp)%fnow(:,:,1)  * tmask(:,:,1)    ! E-P 
     140      IF( ln_dynrnf ) THEN  
     141         rnf (:,:)      = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
     142         IF( ln_dynrnf_depth .AND. lk_vvl )    CALL  dta_dyn_hrnf 
     143      ENDIF 
     144      ! 
     145      un(:,:,:)        = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:)    ! effective u-transport 
     146      vn(:,:,:)        = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:)    ! effective v-transport 
     147      wn(:,:,:)        = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:)    ! effective v-transport 
     148      ! 
     149      IF( lk_vvl ) THEN 
     150         CALL wrk_alloc(jpi, jpj, zemp ) 
     151         zhdivtr(:,:,:)    = sf_dyn(jf_div)%fnow(:,:,:)  * tmask(:,:,:)    ! effective u-transport 
     152         emp_b (:,:)       = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
     153         zemp(:,:) = 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr * tmask(:,:,1) 
     154         CALL dta_dyn_ssh( kt, zhdivtr, sshb, zemp, ssha, fse3t_a(:,:,:) )  !=  ssh, vertical scale factor & vertical transport 
     155         CALL wrk_dealloc(jpi, jpj, zemp ) 
     156         !                                           Write in the tracer restart file 
     157         !                                          ******************************* 
     158         IF( lrst_trc ) THEN 
     159            IF(lwp) WRITE(numout,*) 
     160            IF(lwp) WRITE(numout,*) 'dta_dyn_ssh : ssh field written in tracer restart file ',   & 
     161               &                    'at it= ', kt,' date= ', ndastp 
     162            IF(lwp) WRITE(numout,*) '~~~~' 
     163            CALL iom_rstput( kt, nitrst, numrtw, 'sshn', ssha ) 
     164            CALL iom_rstput( kt, nitrst, numrtw, 'sshb', sshn ) 
     165         ENDIF 
     166      ENDIF 
    247167      ! 
    248168      CALL eos    ( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop 
    … …  
    251171 
    252172      rn2b(:,:,:) = rn2(:,:,:)         ! need for zdfmxl 
    253       CALL zdf_mxl( kt )                                                   ! In any case, we need mxl  
    254       ! 
    255       avt(:,:,:)       = sf_dyn(jf_avt)%fnow(:,:,:)  * tmask(:,:,:)    ! vertical diffusive coefficient  
    256       un (:,:,:)       = sf_dyn(jf_uwd)%fnow(:,:,:)  * umask(:,:,:)    ! u-velocity 
    257       vn (:,:,:)       = sf_dyn(jf_vwd)%fnow(:,:,:)  * vmask(:,:,:)    ! v-velocity  
    258       IF( .NOT.ln_dynwzv ) &                                          ! w-velocity read in file  
    259          wn (:,:,:)    = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:)     
    260       hmld(:,:)        = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1)    ! mixed layer depht 
    261       wndm(:,:)        = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1)    ! wind speed - needed for gas exchange 
    262       emp (:,:)        = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
    263       fmmflx(:,:)      = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1)    ! downward salt flux (v3.5+) 
    264       fr_i(:,:)        = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1)    ! Sea-ice fraction 
    265       qsr (:,:)        = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1)    ! solar radiation 
    266       IF( ln_dynrnf ) & 
    267       rnf (:,:)        = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1)    ! river runoffs  
    268  
    269       !                                                      ! bbl diffusive coef 
     173      CALL zdf_mxl( kt )                                                   ! In any case, we need mxl 
     174      ! 
     175      hmld(:,:)         = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1)    ! mixed layer depht 
     176      avt(:,:,:)        = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:)    ! vertical diffusive coefficient  
     177      ! 
    270178#if defined key_trabbl && ! defined key_c1d 
    271       IF( ln_dynbbl ) THEN                                        ! read in a file 
    272          ahu_bbl(:,:)  = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1) 
    273          ahv_bbl(:,:)  = sf_dyn(jf_vbl)%fnow(:,:,1) * vmask(:,:,1) 
    274       ELSE                                                        ! Compute bbl coefficients if needed 
    275          tsb(:,:,:,:) = tsn(:,:,:,:) 
    276          CALL bbl( kt, nit000, 'TRC') 
    277       END IF 
     179      ahu_bbl(:,:)      = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1)    ! bbl diffusive coef 
     180      ahv_bbl(:,:)      = sf_dyn(jf_vbl)%fnow(:,:,1) * vmask(:,:,1) 
    278181#endif 
    279 #if ( ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv ) && ! defined key_c1d  
    280       aeiw(:,:)        = sf_dyn(jf_eiw)%fnow(:,:,1) * tmask(:,:,1)    ! w-eiv 
    281       !                                                           ! Computes the horizontal values from the vertical value 
    282       DO jj = 2, jpjm1 
    283          DO ji = fs_2, fs_jpim1   ! vector opt. 
    284             aeiu(ji,jj) = .5 * ( aeiw(ji,jj) + aeiw(ji+1,jj  ) )  ! Average the diffusive coefficient at u- v- points 
    285             aeiv(ji,jj) = .5 * ( aeiw(ji,jj) + aeiw(ji  ,jj+1) )  ! at u- v- points 
    286          END DO 
    287       END DO 
    288       CALL lbc_lnk( aeiu, 'U', 1. )   ;   CALL lbc_lnk( aeiv, 'V', 1. )    ! lateral boundary condition 
    289 #endif 
    290        
    291 #if defined key_degrad && ! defined key_c1d  
    292       !                                          ! degrad option : diffusive and eiv coef are 3D 
    293       ahtu(:,:,:) = sf_dyn(jf_ahu)%fnow(:,:,:) * umask(:,:,:) 
    294       ahtv(:,:,:) = sf_dyn(jf_ahv)%fnow(:,:,:) * vmask(:,:,:) 
    295       ahtw(:,:,:) = sf_dyn(jf_ahw)%fnow(:,:,:) * tmask(:,:,:) 
    296 #  if defined key_traldf_eiv  
    297       aeiu(:,:,:) = sf_dyn(jf_eiu)%fnow(:,:,:) * umask(:,:,:) 
    298       aeiv(:,:,:) = sf_dyn(jf_eiv)%fnow(:,:,:) * vmask(:,:,:) 
    299       aeiw(:,:,:) = sf_dyn(jf_eiw)%fnow(:,:,:) * tmask(:,:,:) 
    300 #  endif 
    301 #endif 
     182      ! 
     183      ! 
     184      CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop 
    302185      ! 
    303186      IF(ln_ctl) THEN                  ! print control 
    … …  
    308191         CALL prt_ctl(tab3d_1=wn               , clinfo1=' wn      - : ', mask1=tmask, ovlap=1, kdim=jpk   ) 
    309192         CALL prt_ctl(tab3d_1=avt              , clinfo1=' kz      - : ', mask1=tmask, ovlap=1, kdim=jpk   ) 
    310          CALL prt_ctl(tab2d_1=fr_i             , clinfo1=' fr_i    - : ', mask1=tmask, ovlap=1 ) 
    311          CALL prt_ctl(tab2d_1=hmld             , clinfo1=' hmld    - : ', mask1=tmask, ovlap=1 ) 
    312          CALL prt_ctl(tab2d_1=fmmflx           , clinfo1=' fmmflx  - : ', mask1=tmask, ovlap=1 ) 
    313          CALL prt_ctl(tab2d_1=emp              , clinfo1=' emp     - : ', mask1=tmask, ovlap=1 ) 
    314          CALL prt_ctl(tab2d_1=wndm             , clinfo1=' wspd    - : ', mask1=tmask, ovlap=1 ) 
    315          CALL prt_ctl(tab2d_1=qsr              , clinfo1=' qsr     - : ', mask1=tmask, ovlap=1 ) 
     193!         CALL prt_ctl(tab2d_1=fr_i             , clinfo1=' fr_i    - : ', mask1=tmask, ovlap=1 ) 
     194!         CALL prt_ctl(tab2d_1=hmld             , clinfo1=' hmld    - : ', mask1=tmask, ovlap=1 ) 
     195!         CALL prt_ctl(tab2d_1=fmmflx           , clinfo1=' fmmflx  - : ', mask1=tmask, ovlap=1 ) 
     196!         CALL prt_ctl(tab2d_1=emp              , clinfo1=' emp     - : ', mask1=tmask, ovlap=1 ) 
     197!         CALL prt_ctl(tab2d_1=wndm             , clinfo1=' wspd    - : ', mask1=tmask, ovlap=1 ) 
     198!         CALL prt_ctl(tab2d_1=qsr              , clinfo1=' qsr     - : ', mask1=tmask, ovlap=1 ) 
    316199      ENDIF 
    317200      ! 
    … …  
    335218      INTEGER  :: inum, idv, idimv                   ! local integer 
    336219      INTEGER  :: ios                                ! Local integer output status for namelist read 
    337       !! 
    338       CHARACTER(len=100)            ::  cn_dir   !   Root directory for location of core files 
    339       TYPE(FLD_N), DIMENSION(jpfld) ::  slf_d    ! array of namelist informations on the fields to read 
    340       TYPE(FLD_N) :: sn_tem, sn_sal, sn_mld, sn_emp, sn_ice, sn_qsr, sn_wnd, sn_rnf  ! informations about the fields to be read 
    341       TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_avt, sn_ubl, sn_vbl          !   "                                 " 
    342       TYPE(FLD_N) :: sn_ahu, sn_ahv, sn_ahw, sn_eiu, sn_eiv, sn_eiw, sn_fmf  !   "                                 " 
    343       !!---------------------------------------------------------------------- 
    344       ! 
    345       NAMELIST/namdta_dyn/cn_dir, ln_dynwzv, ln_dynbbl, ln_degrad, ln_dynrnf,    & 
    346          &                sn_tem, sn_sal, sn_mld, sn_emp, sn_ice, sn_qsr, sn_wnd, sn_rnf,  & 
    347          &                sn_uwd, sn_vwd, sn_wwd, sn_avt, sn_ubl, sn_vbl,          & 
    348          &                sn_ahu, sn_ahv, sn_ahw, sn_eiu, sn_eiv, sn_eiw, sn_fmf 
     220      INTEGER  :: ji, jj, jk 
     221      REAL(wp) :: zcoef 
     222      INTEGER  :: nkrnf_max 
     223      REAL(wp) :: hrnf_max 
     224      !! 
     225      CHARACTER(len=100)            ::  cn_dir        !   Root directory for location of core files 
     226      TYPE(FLD_N), DIMENSION(jpfld) ::  slf_d         ! array of namelist informations on the fields to read 
     227      TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_empb, sn_emp  ! informations about the fields to be read 
     228      TYPE(FLD_N) :: sn_tem , sn_sal , sn_avt   !   "                 " 
     229      TYPE(FLD_N) :: sn_mld, sn_qsr, sn_wnd , sn_ice , sn_fmf   !   "               " 
     230      TYPE(FLD_N) :: sn_ubl, sn_vbl, sn_rnf    !   "              " 
     231      TYPE(FLD_N) :: sn_div  ! informations about the fields to be read 
     232      !!---------------------------------------------------------------------- 
     233 
     234      NAMELIST/namdta_dyn/cn_dir, ln_dynrnf, ln_dynrnf_depth,  ln_ssh_ini, fwbcorr, & 
     235         &                sn_uwd, sn_vwd, sn_wwd, sn_emp,    & 
     236         &                sn_avt, sn_tem, sn_sal, sn_mld , sn_qsr ,   & 
     237         &                sn_wnd, sn_ice, sn_fmf,                    & 
     238         &                sn_ubl, sn_vbl, sn_rnf,                   & 
     239         &                sn_empb, sn_div  
    349240      ! 
    350241      REWIND( numnam_ref )              ! Namelist namdta_dyn in reference namelist : Offline: init. of dynamical data 
    … …  
    363254         WRITE(numout,*) '~~~~~~~ ' 
    364255         WRITE(numout,*) '   Namelist namdta_dyn' 
    365          WRITE(numout,*) '      vertical velocity read from file (T) or computed (F) ln_dynwzv  = ', ln_dynwzv 
    366          WRITE(numout,*) '      bbl coef read from file (T) or computed (F)          ln_dynbbl  = ', ln_dynbbl 
    367          WRITE(numout,*) '      degradation option enabled (T) or not (F)            ln_degrad  = ', ln_degrad 
    368          WRITE(numout,*) '      river runoff option enabled (T) or not (F)           ln_dynrnf  = ', ln_dynrnf 
     256         WRITE(numout,*) '      ssh initialised from dyn file (T) or not (F)     ln_ssh_ini       = ', ln_ssh_ini 
     257         WRITE(numout,*) '      runoffs option enabled (T) or not (F)            ln_dynrnf        = ', ln_dynrnf 
     258         WRITE(numout,*) '      runoffs is spread in vertical                    ln_dynrnf_depth  = ', ln_dynrnf_depth 
     259         WRITE(numout,*) '      annual global mean of empmr for ssh correction   fwbcorr          = ', fwbcorr 
    369260         WRITE(numout,*) 
    370261      ENDIF 
    371262      !  
    372       IF( ln_degrad .AND. .NOT.lk_degrad ) THEN 
    373          CALL ctl_warn( 'dta_dyn_init: degradation option requires key_degrad activated ; force ln_degrad to false' ) 
    374          ln_degrad = .FALSE. 
    375       ENDIF 
    376       IF( ln_dynbbl .AND. ( .NOT.lk_trabbl .OR. lk_c1d ) ) THEN 
    377          CALL ctl_warn( 'dta_dyn_init: bbl option requires key_trabbl activated ; force ln_dynbbl to false' ) 
    378          ln_dynbbl = .FALSE. 
    379       ENDIF 
    380  
    381       jf_tem = 1   ;   jf_sal = 2   ;  jf_mld = 3   ;  jf_emp = 4   ;   jf_fmf  = 5   ;  jf_ice = 6   ;   jf_qsr = 7 
    382       jf_wnd = 8   ;   jf_uwd = 9   ;  jf_vwd = 10  ;  jf_wwd = 11  ;   jf_avt  = 12  ;  jfld  = jf_avt 
    383       ! 
    384       slf_d(jf_tem) = sn_tem   ;   slf_d(jf_sal)  = sn_sal   ;   slf_d(jf_mld) = sn_mld 
    385       slf_d(jf_emp) = sn_emp   ;   slf_d(jf_fmf ) = sn_fmf   ;   slf_d(jf_ice) = sn_ice  
    386       slf_d(jf_qsr) = sn_qsr   ;   slf_d(jf_wnd)  = sn_wnd   ;   slf_d(jf_avt) = sn_avt  
    387       slf_d(jf_uwd) = sn_uwd   ;   slf_d(jf_vwd)  = sn_vwd   ;   slf_d(jf_wwd) = sn_wwd 
    388  
     263 
     264      jf_uwd  = 1     ;   jf_vwd  = 2    ;   jf_wwd = 3    ;   jf_emp = 4    ;   jf_avt = 5 
     265      jf_tem  = 6     ;   jf_sal  = 7    ;   jf_mld = 8    ;   jf_qsr = 9 
     266      jf_wnd  = 10    ;   jf_ice  = 11   ;   jf_fmf = 12   ;   jfld   = jf_fmf 
     267 
     268      ! 
     269      slf_d(jf_uwd)  = sn_uwd    ;   slf_d(jf_vwd)  = sn_vwd   ;   slf_d(jf_wwd) = sn_wwd 
     270      slf_d(jf_emp)  = sn_emp    ;   slf_d(jf_avt)  = sn_avt 
     271      slf_d(jf_tem)  = sn_tem    ;   slf_d(jf_sal)  = sn_sal   ;   slf_d(jf_mld) = sn_mld 
     272      slf_d(jf_qsr)  = sn_qsr    ;   slf_d(jf_wnd)  = sn_wnd   ;   slf_d(jf_ice) = sn_ice 
     273      slf_d(jf_fmf)  = sn_fmf 
     274 
     275 
     276      ! 
     277      IF( lk_vvl ) THEN 
     278                 jf_div  = jfld + 1    ;         jf_empb  = jfld + 2      ;      jfld = jf_empb 
     279           slf_d(jf_div) = sn_div      ;   slf_d(jf_empb) = sn_empb 
     280      ENDIF 
     281      ! 
     282      IF( lk_trabbl ) THEN 
     283                 jf_ubl  = jfld + 1    ;         jf_vbl  = jfld + 2       ;      jfld = jf_vbl 
     284           slf_d(jf_ubl) = sn_ubl      ;   slf_d(jf_vbl) = sn_vbl 
     285      ENDIF 
    389286      ! 
    390287      IF( ln_dynrnf ) THEN 
    391                 jf_rnf = jfld + 1  ;  jfld  = jf_rnf 
    392          slf_d(jf_rnf) = sn_rnf 
     288                jf_rnf  = jfld + 1     ;     jfld  = jf_rnf 
     289          slf_d(jf_rnf) = sn_rnf     
    393290      ELSE 
    394          rnf (:,:) = 0._wp 
    395       ENDIF 
    396  
    397       ! 
    398       IF( .NOT.ln_degrad ) THEN     ! no degrad option 
    399          IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN        ! eiv & bbl 
    400                  jf_ubl  = jfld + 1 ;        jf_vbl  = jfld + 2 ;        jf_eiw  = jfld + 3   ;   jfld = jf_eiw 
    401            slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl  ;   slf_d(jf_eiw) = sn_eiw 
    402          ENDIF 
    403          IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN   ! no eiv & bbl 
    404                  jf_ubl  = jfld + 1 ;        jf_vbl  = jfld + 2 ;  jfld = jf_vbl 
    405            slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl 
    406          ENDIF 
    407          IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN   ! eiv & no bbl 
    408            jf_eiw = jfld + 1 ; jfld = jf_eiw ; slf_d(jf_eiw) = sn_eiw 
    409          ENDIF 
    410       ELSE 
    411               jf_ahu  = jfld + 1 ;        jf_ahv  = jfld + 2 ;        jf_ahw  = jfld + 3  ;  jfld = jf_ahw 
    412         slf_d(jf_ahu) = sn_ahu  ;   slf_d(jf_ahv) = sn_ahv  ;   slf_d(jf_ahw) = sn_ahw 
    413         IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN         ! eiv & bbl 
    414                  jf_ubl  = jfld + 1 ;        jf_vbl  = jfld + 2 ; 
    415            slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl 
    416                  jf_eiu  = jfld + 3 ;        jf_eiv  = jfld + 4 ;    jf_eiw  = jfld + 5   ;  jfld = jf_eiw  
    417            slf_d(jf_eiu) = sn_eiu  ;   slf_d(jf_eiv) = sn_eiv  ;    slf_d(jf_eiw) = sn_eiw 
    418         ENDIF 
    419         IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN    ! no eiv & bbl 
    420                  jf_ubl  = jfld + 1 ;        jf_vbl  = jfld + 2 ;  jfld = jf_vbl 
    421            slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl 
    422         ENDIF 
    423         IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN    ! eiv & no bbl 
    424                  jf_eiu  = jfld + 1 ;         jf_eiv  = jfld + 2 ;    jf_eiw  = jfld + 3   ; jfld = jf_eiw  
    425            slf_d(jf_eiu) = sn_eiu  ;   slf_d(jf_eiv) = sn_eiv  ;   slf_d(jf_eiw) = sn_eiw 
    426         ENDIF 
    427       ENDIF 
     291         rnf(:,:) = 0._wp 
     292      ENDIF 
     293 
    428294   
    429295      ALLOCATE( sf_dyn(jfld), STAT=ierr )         ! set sf structure 
    430       IF( ierr > 0 ) THEN 
     296      IF( ierr > 0 )  THEN 
    431297         CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' )   ;   RETURN 
    432298      ENDIF 
    433299      !                                         ! fill sf with slf_i and control print 
    434300      CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 
     301      ! 
    435302      ! Open file for each variable to get his number of dimension 
    436303      DO ifpr = 1, jfld 
    … …  
    456323            ALLOCATE( uslpdta (jpi,jpj,jpk,2), vslpdta (jpi,jpj,jpk,2),    & 
    457324            &         wslpidta(jpi,jpj,jpk,2), wslpjdta(jpi,jpj,jpk,2), STAT=ierr2 ) 
    458          ELSE 
    459             ALLOCATE( uslpnow (jpi,jpj,jpk)  , vslpnow (jpi,jpj,jpk)  ,    & 
    460             &         wslpinow(jpi,jpj,jpk)  , wslpjnow(jpi,jpj,jpk)  , STAT=ierr2 ) 
    461          ENDIF  
    462          IF( ierr2 > 0 ) THEN 
    463             CALL ctl_stop( 'dta_dyn_init : unable to allocate slope arrays' )   ;   RETURN 
     325            ! 
     326            IF( ierr2 > 0 )  THEN 
     327               CALL ctl_stop( 'dta_dyn_init : unable to allocate slope arrays' )   ;   RETURN 
     328            ENDIF 
    464329         ENDIF 
    465330      ENDIF 
    466       IF( ln_dynwzv ) THEN                  ! slopes  
    467          IF( sf_dyn(jf_uwd)%ln_tint ) THEN      ! time interpolation 
    468             ALLOCATE( wdta(jpi,jpj,jpk,2), STAT=ierr3 ) 
    469          ELSE 
    470             ALLOCATE( wnow(jpi,jpj,jpk)  , STAT=ierr3 ) 
    471          ENDIF  
    472          IF( ierr3 > 0 ) THEN 
    473             CALL ctl_stop( 'dta_dyn_init : unable to allocate wdta arrays' )   ;   RETURN 
    474          ENDIF 
    475       ENDIF 
    476       ! 
    477       CALL dta_dyn( nit000 ) 
    478       ! 
    479    END SUBROUTINE dta_dyn_init 
    480  
    481    SUBROUTINE dta_dyn_wzv( pu, pv, pw ) 
    482       !!---------------------------------------------------------------------- 
    483       !!                    ***  ROUTINE wzv  *** 
    484       !! 
    485       !! ** Purpose :   Compute the now vertical velocity after the array swap 
    486       !! 
    487       !! ** Method  : - compute the now divergence given by : 
    488       !!         * z-coordinate ONLY !!!! 
    489       !!         hdiv = 1/(e1t*e2t) [ di(e2u  u) + dj(e1v  v) ] 
    490       !!     - Using the incompressibility hypothesis, the vertical 
    491       !!      velocity is computed by integrating the horizontal divergence 
    492       !!      from the bottom to the surface. 
    493       !!        The boundary conditions are w=0 at the bottom (no flux). 
    494       !!---------------------------------------------------------------------- 
    495       USE oce, ONLY:  zhdiv => hdivn 
    496       ! 
    497       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) :: pu, pv    !:  horizontal velocities 
    498       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(  out) :: pw        !:  vertical velocity 
    499       !! 
    500       INTEGER  ::  ji, jj, jk 
    501       REAL(wp) ::  zu, zu1, zv, zv1, zet 
    502       !!---------------------------------------------------------------------- 
    503       ! 
    504       ! Computation of vertical velocity using horizontal divergence 
    505       zhdiv(:,:,:) = 0._wp 
    506       DO jk = 1, jpkm1 
    507          DO jj = 2, jpjm1 
    508             DO ji = fs_2, fs_jpim1   ! vector opt. 
    509                zu  = pu(ji  ,jj  ,jk) * umask(ji  ,jj  ,jk) * e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) 
    510                zu1 = pu(ji-1,jj  ,jk) * umask(ji-1,jj  ,jk) * e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) 
    511                zv  = pv(ji  ,jj  ,jk) * vmask(ji  ,jj  ,jk) * e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) 
    512                zv1 = pv(ji  ,jj-1,jk) * vmask(ji  ,jj-1,jk) * e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) 
    513                zet = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    514                zhdiv(ji,jj,jk) = ( zu - zu1 + zv - zv1 ) * zet  
     331      ! 
     332      IF( lk_vvl ) THEN 
     333        IF( ln_ssh_ini ) THEN                     ! Restart: read in restart file 
     334           IF(lwp) WRITE(numout,*) ' sshn forcing fields read in the dynamics restart file for initialisation' 
     335           CALL iom_open( 'restart', inum ) 
     336           CALL iom_get( inum, jpdom_autoglo, 'sshn', sshn(:,:)   ) 
     337           CALL iom_get( inum, jpdom_autoglo, 'sshb', sshb(:,:)   ) 
     338           CALL iom_close( inum )                                        ! close file 
     339        ELSE 
     340           IF(lwp) WRITE(numout,*) ' sshn forcing fields read in passive tracers restart file for initialisation' 
     341           CALL iom_get( numrtr, jpdom_autoglo, 'sshn', sshn(:,:)   ) 
     342           CALL iom_get( numrtr, jpdom_autoglo, 'sshb', sshb(:,:)   ) 
     343        ENDIF 
     344        ! 
     345        DO jk = 1, jpkm1 
     346           fse3t_n(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + sshn(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 
     347        ENDDO 
     348        fse3t_a(:,:,jpk) = e3t_0(:,:,jpk) 
     349 
     350        ! Horizontal scale factor interpolations 
     351        ! -------------------------------------- 
     352        CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 
     353        CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 
     354 
     355        ! Vertical scale factor interpolations 
     356        ! ------------------------------------ 
     357        CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n(:,:,:), 'W' ) 
     358   
     359        fse3t_b(:,:,:)  = fse3t_n(:,:,:) 
     360        fse3u_b(:,:,:)  = fse3u_n(:,:,:) 
     361        fse3v_b(:,:,:)  = fse3v_n(:,:,:) 
     362 
     363        ! t- and w- points depth 
     364        ! ---------------------- 
     365        fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
     366        fsdepw_n(:,:,1) = 0.0_wp 
     367 
     368        DO jk = 2, jpk 
     369           DO jj = 1,jpj 
     370              DO ji = 1,jpi 
     371                !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere 
     372                !    tmask = wmask, ie everywhere expect at jk = mikt 
     373                                                                   ! 1 for jk = 
     374                                                                   ! mikt 
     375                 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
     376                 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
     377                 fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     378                     &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 
     379              END DO 
     380           END DO 
     381        END DO 
     382 
     383        fsdept_b(:,:,:) = fsdept_n(:,:,:) 
     384        fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 
     385        ! 
     386      ENDIF 
     387      ! 
     388      IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN       ! read depht over which runoffs are distributed 
     389         IF(lwp) WRITE(numout,*)  
     390         IF(lwp) WRITE(numout,*) ' read in the file depht over which runoffs are distributed' 
     391         CALL iom_open ( "runoffs", inum )                           ! open file 
     392         CALL iom_get  ( inum, jpdom_data, 'rodepth', h_rnf )   ! read the river mouth array 
     393         CALL iom_close( inum )                                        ! close file 
     394         ! 
     395         nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
     396         DO jj = 1, jpj 
     397            DO ji = 1, jpi 
     398               IF( h_rnf(ji,jj) > 0._wp ) THEN 
     399                  jk = 2 
     400                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 
     401                  END DO 
     402                  nk_rnf(ji,jj) = jk 
     403               ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1 
     404               ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
     405               ELSE 
     406                  CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
     407                  WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 
     408               ENDIF 
    515409            END DO 
    516410         END DO 
     411         DO jj = 1, jpj                                ! set the associated depth 
     412            DO ji = 1, jpi 
     413               h_rnf(ji,jj) = 0._wp 
     414               DO jk = 1, nk_rnf(ji,jj) 
     415                  h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
     416               END DO 
     417            END DO 
     418         END DO 
     419      ELSE                                       ! runoffs applied at the surface 
     420         nk_rnf(:,:) = 1 
     421         h_rnf (:,:) = fse3t(:,:,1) 
     422      ENDIF 
     423      nkrnf_max = MAXVAL( nk_rnf(:,:) ) 
     424      hrnf_max = MAXVAL( h_rnf(:,:) ) 
     425      IF( lk_mpp )  THEN 
     426         CALL mpp_max( nkrnf_max )                 ! max over the  global domain 
     427         CALL mpp_max( hrnf_max )                 ! max over the  global domain 
     428      ENDIF 
     429      IF(lwp) WRITE(numout,*) ' ' 
     430      IF(lwp) WRITE(numout,*) ' max depht of runoff : ', hrnf_max,'    max level  : ', nkrnf_max 
     431      IF(lwp) WRITE(numout,*) ' ' 
     432      ! 
     433      CALL dta_dyn( nit000 ) 
     434      ! 
     435   END SUBROUTINE dta_dyn_init 
     436 
     437   SUBROUTINE dta_dyn_swp( kt ) 
     438     !!--------------------------------------------------------------------- 
     439      !!                    ***  ROUTINE dta_dyn_swp  *** 
     440      !! 
     441      !! ** Purpose : Swap and the data and compute the vertical scale factor at U/V/W point 
     442      !!              and the depht 
     443      !! 
     444      !!--------------------------------------------------------------------- 
     445      INTEGER, INTENT(in) :: kt       ! time step 
     446      INTEGER             :: ji, jj, jk 
     447      REAL(wp)            :: zcoef 
     448      ! 
     449      !!--------------------------------------------------------------------- 
     450 
     451      IF( kt == nit000 ) THEN 
     452         IF(lwp) WRITE(numout,*) 
     453         IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' 
     454         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     455      ENDIF 
     456 
     457      sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:))  ! before <-- now filtered 
     458      sshn(:,:) = ssha(:,:) 
     459 
     460      fse3t_n(:,:,:) = fse3t_a(:,:,:) 
     461 
     462      ! Reconstruction of all vertical scale factors at now and before time steps 
     463      ! ============================================================================= 
     464 
     465      ! Horizontal scale factor interpolations 
     466      ! -------------------------------------- 
     467      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 
     468      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 
     469 
     470      ! Vertical scale factor interpolations 
     471      ! ------------------------------------ 
     472      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 
     473 
     474      fse3t_b(:,:,:)  = fse3t_n(:,:,:) 
     475      fse3u_b(:,:,:)  = fse3u_n(:,:,:) 
     476      fse3v_b(:,:,:)  = fse3v_n(:,:,:) 
     477 
     478      ! t- and w- points depth 
     479      ! ---------------------- 
     480      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
     481      fsdepw_n(:,:,1) = 0.0_wp 
     482 
     483      DO jk = 2, jpk 
     484         DO jj = 1,jpj 
     485            DO ji = 1,jpi 
     486                 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
     487                 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
     488                 fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     489                     &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 
     490              END DO 
     491           END DO 
     492        END DO 
     493 
     494      fsdept_b(:,:,:) = fsdept_n(:,:,:) 
     495      fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 
     496 
     497      ! 
     498   END SUBROUTINE dta_dyn_swp 
     499 
     500   SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb,  pemp, pssha, pe3ta ) 
     501      !!---------------------------------------------------------------------- 
     502      !!                ***  ROUTINE dta_dyn_wzv  *** 
     503      !!                    
     504      !! ** Purpose :   compute the after ssh (ssha) and the now vertical velocity 
     505      !! 
     506      !! ** Method  : Using the incompressibility hypothesis,  
     507      !!        - the ssh increment is computed by integrating the horizontal divergence  
     508      !!          and multiply by the time step. 
     509      !! 
     510      !!        - compute the after scale factor : repartition of ssh INCREMENT proportionnaly 
     511      !!                                           to the level thickness ( z-star case ) 
     512      !! 
     513      !!        - the vertical velocity is computed by integrating the horizontal divergence   
     514      !!          from the bottom to the surface minus the scale factor evolution. 
     515      !!          The boundary conditions are w=0 at the bottom (no flux) 
     516      !! 
     517      !! ** action  :   ssha / e3t_a / wn 
     518      !! 
     519      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
     520      !!---------------------------------------------------------------------- 
     521      !! * Arguments 
     522      INTEGER,                                   INTENT(in )    :: kt        !  time-step 
     523      REAL(wp), DIMENSION(jpi,jpj,jpk)          , INTENT(in )   :: phdivtr   ! horizontal divergence transport 
     524      REAL(wp), DIMENSION(jpi,jpj)    , OPTIONAL, INTENT(in )   :: psshb     ! now ssh 
     525      REAL(wp), DIMENSION(jpi,jpj)    , OPTIONAL, INTENT(in )   :: pemp      ! evaporation minus precipitation 
     526      REAL(wp), DIMENSION(jpi,jpj)    , OPTIONAL, INTENT(inout) :: pssha     ! after ssh 
     527      REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(out)   :: pe3ta     ! after vertical scale factor 
     528      !! * Local declarations 
     529      INTEGER                       :: jk 
     530      REAL(wp), DIMENSION(jpi,jpj)  :: zhdiv   
     531      REAL(wp)  :: z2dt   
     532      !!---------------------------------------------------------------------- 
     533       
     534      ! 
     535      z2dt = 2._wp * rdt 
     536      ! 
     537      zhdiv(:,:) = 0._wp 
     538      DO jk = 1, jpkm1 
     539         zhdiv(:,:) = zhdiv(:,:) +  phdivtr(:,:,jk) * tmask(:,:,jk) 
    517540      END DO 
    518       CALL lbc_lnk( zhdiv, 'T', 1. )      ! Lateral boundary conditions on zhdiv 
    519       ! 
    520       ! computation of vertical velocity from the bottom 
    521       pw(:,:,jpk) = 0._wp 
    522       DO jk = jpkm1, 1, -1 
    523          pw(:,:,jk) = pw(:,:,jk+1) - fse3t(:,:,jk) * zhdiv(:,:,jk) 
     541      !                                                ! Sea surface  elevation time-stepping 
     542      pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rau0 * pemp(:,:)  + zhdiv(:,:) ) ) * ssmask(:,:) 
     543      !                                                 !  
     544      !                                                 ! After acale factors at t-points ( z_star coordinate ) 
     545      DO jk = 1, jpkm1 
     546        pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 
    524547      END DO 
    525548      ! 
    526    END SUBROUTINE dta_dyn_wzv 
    527  
    528    SUBROUTINE dta_dyn_slp( kt, pts, puslp, pvslp, pwslpi, pwslpj ) 
     549   END SUBROUTINE dta_dyn_ssh 
     550 
     551 
     552   SUBROUTINE dta_dyn_hrnf 
     553      !!---------------------------------------------------------------------- 
     554      !!                  ***  ROUTINE sbc_rnf  *** 
     555      !! 
     556      !! ** Purpose :   update the horizontal divergence with the runoff inflow 
     557      !! 
     558      !! ** Method  : 
     559      !!                CAUTION : rnf is positive (inflow) decreasing the 
     560      !!                          divergence and expressed in m/s 
     561      !! 
     562      !! ** Action  :   phdivn   decreased by the runoff inflow 
     563      !!---------------------------------------------------------------------- 
     564      !! 
     565      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     566      !!---------------------------------------------------------------------- 
     567      ! 
     568      DO jj = 1, jpj                   ! update the depth over which runoffs are distributed 
     569         DO ji = 1, jpi 
     570            h_rnf(ji,jj) = 0._wp 
     571            DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres 
     572                h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk)   ! to the bottom of the relevant grid box 
     573            END DO 
     574        END DO 
     575      END DO 
     576      ! 
     577   END SUBROUTINE dta_dyn_hrnf 
     578 
     579 
     580 
     581   SUBROUTINE dta_dyn_slp( kt ) 
     582      !!--------------------------------------------------------------------- 
     583      !!                    ***  ROUTINE dta_dyn_slp  *** 
     584      !! 
     585      !! ** Purpose : Computation of slope 
     586      !! 
     587      !!--------------------------------------------------------------------- 
     588      USE oce, ONLY:  zts => tsa  
     589      ! 
     590      INTEGER,  INTENT(in) :: kt       ! time step 
     591      ! 
     592      INTEGER  ::   ji, jj     ! dummy loop indices 
     593      REAL(wp) ::   ztinta     ! ratio applied to after  records when doing time interpolation 
     594      REAL(wp) ::   ztintb     ! ratio applied to before records when doing time interpolation 
     595      INTEGER  ::   iswap 
     596      REAL(wp), POINTER, DIMENSION(:,:,:) :: zuslp, zvslp, zwslpi, zwslpj 
     597      !!--------------------------------------------------------------------- 
     598      ! 
     599      CALL wrk_alloc(jpi, jpj, jpk, zuslp, zvslp, zwslpi, zwslpj ) 
     600      ! 
     601      IF( sf_dyn(jf_tem)%ln_tint ) THEN    ! Computes slopes (here avt is used as workspace)                        
     602         IF( kt == nit000 ) THEN 
     603            zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:)   ! temperature 
     604            zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:)   ! salinity  
     605            avt(:,:,:)        = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:)   ! vertical diffusive coef. 
     606            CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
     607            uslpdta (:,:,:,1) = zuslp (:,:,:)  
     608            vslpdta (:,:,:,1) = zvslp (:,:,:)  
     609            wslpidta(:,:,:,1) = zwslpi(:,:,:)  
     610            wslpjdta(:,:,:,1) = zwslpj(:,:,:)  
     611            ! 
     612            zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:)   ! temperature 
     613            zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:)   ! salinity  
     614            avt(:,:,:)        = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:)   ! vertical diffusive coef. 
     615            CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
     616            uslpdta (:,:,:,2) = zuslp (:,:,:)  
     617            vslpdta (:,:,:,2) = zvslp (:,:,:)  
     618            wslpidta(:,:,:,2) = zwslpi(:,:,:)  
     619            wslpjdta(:,:,:,2) = zwslpj(:,:,:)  
     620         ELSE 
     621           !  
     622           iswap = 0 
     623           IF( sf_dyn(jf_tem)%nrec_a(2) - nprevrec /= 0 )  iswap = 1 
     624           IF( nsecdyn > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap == 1 )  THEN    ! read/update the after data 
     625              IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 
     626              uslpdta (:,:,:,1) =  uslpdta (:,:,:,2)         ! swap the data 
     627              vslpdta (:,:,:,1) =  vslpdta (:,:,:,2)   
     628              wslpidta(:,:,:,1) =  wslpidta(:,:,:,2)  
     629              wslpjdta(:,:,:,1) =  wslpjdta(:,:,:,2)  
     630              ! 
     631              zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:)   ! temperature 
     632              zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:)   ! salinity  
     633              avt(:,:,:)        = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:)   ! vertical diffusive coef. 
     634              CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
     635              ! 
     636              uslpdta (:,:,:,2) = zuslp (:,:,:)  
     637              vslpdta (:,:,:,2) = zvslp (:,:,:)  
     638              wslpidta(:,:,:,2) = zwslpi(:,:,:)  
     639              wslpjdta(:,:,:,2) = zwslpj(:,:,:)  
     640            ENDIF 
     641         ENDIF 
     642      ENDIF 
     643      ! 
     644      IF( sf_dyn(jf_tem)%ln_tint )  THEN 
     645         ztinta =  REAL( nsecdyn - sf_dyn(jf_tem)%nrec_b(2), wp )  & 
     646            &    / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp ) 
     647         ztintb =  1. - ztinta 
     648#if defined key_ldfslp && ! defined key_c1d 
     649         uslp (:,:,:) = ztintb * uslpdta (:,:,:,1)  + ztinta * uslpdta (:,:,:,2)   
     650         vslp (:,:,:) = ztintb * vslpdta (:,:,:,1)  + ztinta * vslpdta (:,:,:,2)   
     651         wslpi(:,:,:) = ztintb * wslpidta(:,:,:,1)  + ztinta * wslpidta(:,:,:,2)   
     652         wslpj(:,:,:) = ztintb * wslpjdta(:,:,:,1)  + ztinta * wslpjdta(:,:,:,2)   
     653#endif 
     654      ELSE 
     655         zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:)   ! temperature 
     656         zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:)   ! salinity  
     657         avt(:,:,:)        = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:)   ! vertical diffusive coef. 
     658         CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 
     659         ! 
     660#if defined key_ldfslp && ! defined key_c1d 
     661         uslp (:,:,:) = zuslp (:,:,:) 
     662         vslp (:,:,:) = zvslp (:,:,:) 
     663         wslpi(:,:,:) = zwslpi(:,:,:) 
     664         wslpj(:,:,:) = zwslpj(:,:,:) 
     665#endif 
     666      ENDIF 
     667      ! 
     668      CALL wrk_dealloc(jpi, jpj, jpk, zuslp, zvslp, zwslpi, zwslpj ) 
     669      ! 
     670   END SUBROUTINE dta_dyn_slp 
     671 
     672   SUBROUTINE compute_slopes( kt, pts, puslp, pvslp, pwslpi, pwslpj ) 
    529673      !!--------------------------------------------------------------------- 
    530674      !!                    ***  ROUTINE dta_dyn_slp  *** 
    … …  
    568712#endif 
    569713      ! 
    570    END SUBROUTINE dta_dyn_slp 
     714   END SUBROUTINE compute_slopes 
     715 
    571716   !!====================================================================== 
    572717END MODULE dtadyn 

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

    r5602 r7806  
    3434   USE trcstp          ! passive tracer time-stepping      (trc_stp routine) 
    3535   USE dtadyn          ! Lecture and interpolation of the dynamical fields 
    36    !              ! I/O & MPP 
     36   !                   ! I/O & MPP 
    3737   USE iom             ! I/O library 
    3838   USE in_out_manager  ! I/O manager 
    … …  
    5050   USE trcnam 
    5151   USE trcrst 
    52    USE diaptr         ! Need to initialise this as some variables are used in if statements later 
    5352 
    5453   IMPLICIT NONE 
    … …  
    9493      istp = nit000 
    9594      !  
    96       CALL iom_init( cxios_context )            ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    97       !  
    9895      DO WHILE ( istp <= nitend .AND. nstop == 0 )    ! time stepping 
    9996         ! 
    100          IF( istp /= nit000 )   CALL day      ( istp )         ! Calendar (day was already called at nit000 in day_init) 
    101                                 CALL iom_setkt( istp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp 
    102                                 CALL dta_dyn  ( istp )         ! Interpolation of the dynamical fields 
    103                                 CALL trc_stp  ( istp )         ! time-stepping 
    104                                 CALL stp_ctl  ( istp, indic )  ! Time loop: control and print 
     97         IF( istp == nit000 )  CALL iom_init( cxios_context )            ! iom_put initialization 
     98         IF( istp /= nit000 )   CALL day        ( istp )         ! Calendar (day was already called at nit000 in day_init) 
     99                                CALL iom_setkt  ( istp - nit000 + 1, cxios_context )   ! say to iom that we are at time step kstp 
     100                                CALL trc_rst_opn( istp )         ! Open tracer                                !   restart file 
     101                                CALL dta_dyn    ( istp )         ! Interpolation of the dynamical fields 
     102                                CALL trc_stp    ( istp )         ! time-stepping 
     103         IF( lk_vvl )           CALL dta_dyn_swp( istp )         ! swap of sea surface height and vertical scale factors 
     104                                CALL stp_ctl    ( istp, indic )  ! Time loop: control and print 
    105105         istp = istp + 1 
    106106         IF( lk_mpp )   CALL mpp_max( nstop ) 
    … …  
    265265      IF( nn_timing == 1 )  CALL timing_start( 'nemo_init') 
    266266      ! 
    267                             CALL     phy_cst    ! Physical constants 
    268                             CALL     eos_init   ! Equation of state 
    269       IF( lk_c1d        )   CALL     c1d_init   ! 1D column configuration 
    270                             CALL     dom_cfg    ! Domain configuration 
     267                            CALL  phy_cst    ! Physical constants 
     268                            CALL  eos_init   ! Equation of state 
     269      IF( lk_c1d        )   CALL  c1d_init   ! 1D column configuration 
     270                            CALL  dom_cfg    ! Domain configuration 
     271      ! 
    271272      ! 
    272273      INQUIRE( FILE='coordinates.nc', EXIST = llexist )   ! Check if coordinate file exist 
    273274      ! 
    274       IF( llexist )  THEN  ;  CALL  dom_init   !  compute the grid from coordinates and bathymetry 
    275       ELSE                 ;  CALL  dom_rea    !  read grid from the meskmask 
     275      IF( llexist )  THEN ;  CALL  dom_init   !  compute the grid from coordinates and bathymetry 
     276      ELSE                ;  CALL  dom_rea    !  read grid from the meskmask 
    276277      ENDIF 
    277278                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
    278279 
    279       IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined) 
    280  
    281       IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
     280      IF( ln_nnogather )    CALL  nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined) 
     281 
     282      IF( ln_ctl       )    CALL prt_ctl_init   ! Print control 
    282283 
    283284                            CALL     sbc_init   ! Forcings : surface module 
    … …  
    289290 
    290291                            CALL tra_qsr_init   ! penetrative solar radiation qsr 
    291       IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme 
     292      IF( lk_trabbl   )     CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme 
    292293 
    293294                            CALL trc_nam_run    ! Needed to get restart parameters for passive tracers 
    294295                            CALL trc_rst_cal( nit000, 'READ' )   ! calendar 
    295296                            CALL dta_dyn_init   ! Initialization for the dynamics 
    296  
    297297                            CALL     trc_init   ! Passive tracers initialization 
    298                             CALL dia_ptr_init   ! Initialise diaptr as some variables are used  
    299298      !                                         ! in various advection and diffusion routines 
    300299      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA 

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

    r7256 r7806  
    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 ) 
    123        
     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 
    124135      !                                         ! steric sea surface height 
    125136      CALL eos( tsn, zrhd, zrhop, fsdept_n(:,:,:) )                 ! now in situ and potential density 
    … …  
    190201      CALL iom_put( 'temptot', ztemp ) 
    191202      CALL iom_put( 'saltot' , zsal  ) 
    192       ! 
    193       CALL wrk_dealloc( jpi , jpj              , zarea_ssh , zbotpres ) 
     203 
     204      IF( iom_use( 'tnpeo' )) THEN     
     205      ! Work done against stratification by vertical mixing 
     206      ! Exclude points where rn2 is negative as convection kicks in here and 
     207      ! work is not being done against stratification 
     208          pe(:,:) = 0._wp 
     209          IF( lk_zdfddm ) THEN 
     210             DO ji=1,jpi 
     211                DO jj=1,jpj 
     212                   DO jk=1,jpk 
     213                      zrw =   ( fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk) )   & 
     214                         &  / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 
     215                      ! 
     216                      zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw 
     217                      zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw 
     218                      ! 
     219                      pe(ji, jj) = pe(ji, jj) - MIN(0._wp, rn2(ji,jj,jk)) * & 
     220                           &       grav * (avt(ji,jj,jk) * zaw * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) )  & 
     221                           &       - fsavs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) ) 
     222 
     223                   ENDDO 
     224                ENDDO 
     225             ENDDO 
     226          ELSE 
     227             DO ji=1,jpi 
     228                DO jj=1,jpj 
     229                   DO jk=1,jpk 
     230                       pe(ji,jj) = pe(ji,jj) + avt(ji, jj, jk) * MIN(0._wp,rn2(ji, jj, jk)) * rau0 * fse3w(ji, jj, jk) 
     231                   ENDDO 
     232                ENDDO 
     233             ENDDO 
     234          ENDIF 
     235          CALL lbc_lnk(pe, 'T', 1._wp)          
     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                 ) 
    … …  
    232278      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    233279 
    234       CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
    235       CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
    236       CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    237       CALL iom_close( inum ) 
    238  
    239       sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    240       sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    241       IF( ln_zps ) THEN               ! z-coord. partial steps 
    242          DO jj = 1, jpj               ! interpolation of salinity at the last ocean level (i.e. the partial step) 
    243             DO ji = 1, jpi 
    244                ik = mbkt(ji,jj) 
    245                IF( ik > 1 ) THEN 
    246                   zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    247                   sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 
    248                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 
    249297            END DO 
    250          END DO 
     298         ENDIF 
    251299      ENDIF 
    252300      ! 

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

    r5602 r7806  
    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 
    … …  
    6569   !!---------------------------------------------------------------------- 
    6670   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    67    !! $Id$  
     71   !! $Id$ 
    6872   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6973   !!---------------------------------------------------------------------- 
    … …  
    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      ! 
    … …  
    111125            END DO 
    112126         ENDIF 
     127         IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 
     128            ! define fields multiplied by scalar 
     129            zmask(:,:,:) = 0._wp 
     130            zts(:,:,:,:) = 0._wp 
     131            zvn(:,:,:) = 0._wp 
     132            DO jk = 1, jpkm1 
     133               DO jj = 1, jpjm1 
     134                  DO ji = 1, jpi 
     135                     zvfc = e1v(ji,jj) * fse3v(ji,jj,jk) 
     136                     zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc 
     137                     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 
     138                     zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 
     139                     zvn(ji,jj,jk)        = vn(ji,jj,jk)         * zvfc 
     140                  ENDDO 
     141               ENDDO 
     142             ENDDO 
     143         ENDIF 
     144         IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 
     145             sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 
     146             r1_sjk(:,:,1) = 0._wp 
     147             WHERE( sjk(:,:,1) /= 0._wp )   r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 
     148 
     149             ! i-mean T and S, j-Stream-Function, global 
     150             tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 
     151             sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 
     152             v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 
     153 
     154             htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 
     155             str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 
     156 
     157             z2d(1,:) = htr_ove(:,1) * rc_pwatt        !  (conversion in PW) 
     158             DO ji = 1, jpi 
     159               z2d(ji,:) = z2d(1,:) 
     160             ENDDO 
     161             cl1 = 'sophtove' 
     162             CALL iom_put( TRIM(cl1), z2d ) 
     163             z2d(1,:) = str_ove(:,1) * rc_ggram        !  (conversion in Gg) 
     164             DO ji = 1, jpi 
     165               z2d(ji,:) = z2d(1,:) 
     166             ENDDO 
     167             cl1 = 'sopstove' 
     168             CALL iom_put( TRIM(cl1), z2d ) 
     169             IF( ln_subbas ) THEN 
     170                DO jn = 2, nptr 
     171                    sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
     172                    r1_sjk(:,:,jn) = 0._wp 
     173                    WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
     174 
     175                    ! i-mean T and S, j-Stream-Function, basin 
     176                    tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
     177                    sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
     178                    v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) )  
     179                    htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 
     180                    str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 
     181 
     182                    z2d(1,:) = htr_ove(:,jn) * rc_pwatt !  (conversion in PW) 
     183                    DO ji = 1, jpi 
     184                        z2d(ji,:) = z2d(1,:) 
     185                    ENDDO 
     186                    cl1 = TRIM('sophtove_'//clsubb(jn)) 
     187                    CALL iom_put( cl1, z2d ) 
     188                    z2d(1,:) = str_ove(:,jn) * rc_ggram        ! (conversion in Gg) 
     189                    DO ji = 1, jpi 
     190                        z2d(ji,:) = z2d(1,:) 
     191                    ENDDO 
     192                    cl1 = TRIM('sopstove_'//clsubb(jn)) 
     193                    CALL iom_put( cl1, z2d ) 
     194                END DO 
     195             ENDIF 
     196         ENDIF 
     197         IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 
     198         ! Calculate barotropic heat and salt transport here  
     199             sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 
     200             r1_sjk(:,1,1) = 0._wp 
     201             WHERE( sjk(:,1,1) /= 0._wp )   r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 
     202             
     203            vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 
     204            tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 
     205            tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 
     206            htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 
     207            str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 
     208            z2d(1,:) = htr_btr(:,1) * rc_pwatt        !  (conversion in PW) 
     209            DO ji = 2, jpi 
     210               z2d(ji,:) = z2d(1,:) 
     211            ENDDO 
     212            cl1 = 'sophtbtr' 
     213            CALL iom_put( TRIM(cl1), z2d ) 
     214            z2d(1,:) = str_btr(:,1) * rc_ggram        !  (conversion in Gg) 
     215            DO ji = 2, jpi 
     216              z2d(ji,:) = z2d(1,:) 
     217            ENDDO 
     218            cl1 = 'sopstbtr' 
     219            CALL iom_put( TRIM(cl1), z2d ) 
     220            IF( ln_subbas ) THEN 
     221                DO jn = 2, nptr 
     222                    sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 
     223                    r1_sjk(:,1,jn) = 0._wp 
     224                    WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 
     225                    vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 
     226                    tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 
     227                    tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 
     228                    htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 
     229                    str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 
     230                    z2d(1,:) = htr_btr(:,jn) * rc_pwatt !  (conversion in PW) 
     231                    DO ji = 1, jpi 
     232                        z2d(ji,:) = z2d(1,:) 
     233                    ENDDO 
     234                    cl1 = TRIM('sophtbtr_'//clsubb(jn)) 
     235                    CALL iom_put( cl1, z2d ) 
     236                    z2d(1,:) = str_btr(:,jn) * rc_ggram        ! (conversion in Gg) 
     237                    DO ji = 1, jpi 
     238                        z2d(ji,:) = z2d(1,:) 
     239                    ENDDO 
     240                    cl1 = TRIM('sopstbtr_'//clsubb(jn)) 
     241                    CALL iom_put( cl1, z2d ) 
     242               ENDDO 
     243            ENDIF !ln_subbas 
     244         ENDIF !iom_use("sopstbtr....) 
    113245         ! 
    114246      ELSE 
    … …  
    150282         !                                ! Advective and diffusive heat and salt transport 
    151283         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN    
    152             z2d(1,:) = htr_adv(:) * rc_pwatt        !  (conversion in PW) 
     284            z2d(1,:) = htr_adv(:,1) * rc_pwatt        !  (conversion in PW) 
    153285            DO ji = 1, jpi 
    154286               z2d(ji,:) = z2d(1,:) 
    … …  
    156288            cl1 = 'sophtadv'                  
    157289            CALL iom_put( TRIM(cl1), z2d ) 
    158             z2d(1,:) = str_adv(:) * rc_ggram        ! (conversion in Gg) 
     290            z2d(1,:) = str_adv(:,1) * rc_ggram        ! (conversion in Gg) 
    159291            DO ji = 1, jpi 
    160292               z2d(ji,:) = z2d(1,:) 
    … …  
    162294            cl1 = 'sopstadv' 
    163295            CALL iom_put( TRIM(cl1), z2d ) 
     296            IF( ln_subbas ) THEN 
     297              DO jn=2,nptr 
     298               z2d(1,:) = htr_adv(:,jn) * rc_pwatt        !  (conversion in PW) 
     299               DO ji = 1, jpi 
     300                 z2d(ji,:) = z2d(1,:) 
     301               ENDDO 
     302               cl1 = TRIM('sophtadv_'//clsubb(jn))                  
     303               CALL iom_put( cl1, z2d ) 
     304               z2d(1,:) = str_adv(:,jn) * rc_ggram        ! (conversion in Gg) 
     305               DO ji = 1, jpi 
     306                  z2d(ji,:) = z2d(1,:) 
     307               ENDDO 
     308               cl1 = TRIM('sopstadv_'//clsubb(jn))                  
     309               CALL iom_put( cl1, z2d )               
     310              ENDDO 
     311            ENDIF 
    164312         ENDIF 
    165313         ! 
    166314         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN    
    167             z2d(1,:) = htr_ldf(:) * rc_pwatt        !  (conversion in PW)  
     315            z2d(1,:) = htr_ldf(:,1) * rc_pwatt        !  (conversion in PW)  
    168316            DO ji = 1, jpi 
    169317               z2d(ji,:) = z2d(1,:) 
    … …  
    171319            cl1 = 'sophtldf' 
    172320            CALL iom_put( TRIM(cl1), z2d ) 
    173             z2d(1,:) = str_ldf(:) * rc_ggram        !  (conversion in Gg) 
     321            z2d(1,:) = str_ldf(:,1) * rc_ggram        !  (conversion in Gg) 
    174322            DO ji = 1, jpi 
    175323               z2d(ji,:) = z2d(1,:) 
    … …  
    177325            cl1 = 'sopstldf' 
    178326            CALL iom_put( TRIM(cl1), z2d ) 
    179          ENDIF 
     327            IF( ln_subbas ) THEN 
     328              DO jn=2,nptr 
     329               z2d(1,:) = htr_ldf(:,jn) * rc_pwatt        !  (conversion in PW) 
     330               DO ji = 1, jpi 
     331                 z2d(ji,:) = z2d(1,:) 
     332               ENDDO 
     333               cl1 = TRIM('sophtldf_'//clsubb(jn))                  
     334               CALL iom_put( cl1, z2d ) 
     335               z2d(1,:) = str_ldf(:,jn) * rc_ggram        ! (conversion in Gg) 
     336               DO ji = 1, jpi 
     337                  z2d(ji,:) = z2d(1,:) 
     338               ENDDO 
     339               cl1 = TRIM('sopstldf_'//clsubb(jn))                  
     340               CALL iom_put( cl1, z2d )               
     341              ENDDO 
     342            ENDIF 
     343         ENDIF 
     344 
     345         IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN    
     346            z2d(1,:) = htr_vt(:,1) * rc_pwatt        !  (conversion in PW)  
     347            DO ji = 1, jpi 
     348               z2d(ji,:) = z2d(1,:) 
     349            ENDDO 
     350            cl1 = 'sopht_vt' 
     351            CALL iom_put( TRIM(cl1), z2d ) 
     352            z2d(1,:) = str_vs(:,1) * rc_ggram        !  (conversion in Gg) 
     353            DO ji = 1, jpi 
     354               z2d(ji,:) = z2d(1,:) 
     355            ENDDO 
     356            cl1 = 'sopst_vs' 
     357            CALL iom_put( TRIM(cl1), z2d ) 
     358            IF( ln_subbas ) THEN 
     359              DO jn=2,nptr 
     360               z2d(1,:) = htr_vt(:,jn) * rc_pwatt        !  (conversion in PW) 
     361               DO ji = 1, jpi 
     362                 z2d(ji,:) = z2d(1,:) 
     363               ENDDO 
     364               cl1 = TRIM('sopht_vt_'//clsubb(jn))                  
     365               CALL iom_put( cl1, z2d ) 
     366               z2d(1,:) = str_vs(:,jn) * rc_ggram        ! (conversion in Gg) 
     367               DO ji = 1, jpi 
     368                  z2d(ji,:) = z2d(1,:) 
     369               ENDDO 
     370               cl1 = TRIM('sopst_vs_'//clsubb(jn))                  
     371               CALL iom_put( cl1, z2d )               
     372              ENDDO 
     373            ENDIF 
     374         ENDIF 
     375 
     376#ifdef key_diaeiv 
     377         IF(lk_traldf_eiv) THEN 
     378            IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN  
     379               z2d(1,:) = htr_eiv(:,1) * rc_pwatt        !  (conversion in PW)  
     380               DO ji = 1, jpi 
     381                  z2d(ji,:) = z2d(1,:) 
     382               ENDDO 
     383               cl1 = 'sophteiv' 
     384               CALL iom_put( TRIM(cl1), z2d ) 
     385               z2d(1,:) = str_eiv(:,1) * rc_ggram        !  (conversion in Gg) 
     386               DO ji = 1, jpi 
     387                  z2d(ji,:) = z2d(1,:) 
     388               ENDDO 
     389               cl1 = 'sopsteiv' 
     390               CALL iom_put( TRIM(cl1), z2d ) 
     391               IF( ln_subbas ) THEN 
     392                  DO jn=2,nptr 
     393                     z2d(1,:) = htr_eiv(:,jn) * rc_pwatt        !  (conversion in PW) 
     394                     DO ji = 1, jpi 
     395                        z2d(ji,:) = z2d(1,:) 
     396                     ENDDO 
     397                     cl1 = TRIM('sophteiv_'//clsubb(jn))                  
     398                     CALL iom_put( cl1, z2d ) 
     399                     z2d(1,:) = str_eiv(:,jn) * rc_ggram        ! (conversion in Gg) 
     400                     DO ji = 1, jpi 
     401                        z2d(ji,:) = z2d(1,:) 
     402                     ENDDO 
     403                     cl1 = TRIM('sopsteiv_'//clsubb(jn))  
     404                     CALL iom_put( cl1, z2d )               
     405                  ENDDO 
     406               ENDIF 
     407            ENDIF 
     408         ENDIF 
     409#endif 
    180410         ! 
    181411      ENDIF 
    … …  
    256486         ! Initialise arrays to zero because diatpr is called before they are first calculated 
    257487         ! 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  
     488         htr_adv(:,:) = 0._wp  ;  str_adv(:,:) =  0._wp  
     489         htr_ldf(:,:) = 0._wp  ;  str_ldf(:,:) =  0._wp  
     490         htr_eiv(:,:) = 0._wp  ;  str_eiv(:,:) =  0._wp  
     491         htr_vt(:,:) = 0._wp  ;   str_vs(:,:) =  0._wp 
     492         htr_ove(:,:) = 0._wp  ;   str_ove(:,:) =  0._wp 
     493         htr_btr(:,:) = 0._wp  ;   str_btr(:,:) =  0._wp 
    260494         ! 
    261495      ENDIF  
    … …  
    263497   END SUBROUTINE dia_ptr_init 
    264498 
     499   SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva )  
     500      !!---------------------------------------------------------------------- 
     501      !!                    ***  ROUTINE dia_ptr_ohst_components  *** 
     502      !!---------------------------------------------------------------------- 
     503      !! Wrapper for heat and salt transport calculations to calculate them for each basin 
     504      !! Called from all advection and/or diffusion routines 
     505      !!---------------------------------------------------------------------- 
     506      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
     507      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv' 
     508      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion 
     509      INTEGER                                        :: jn    ! 
     510 
     511      IF( cptr == 'adv' ) THEN 
     512         IF( ktra == jp_tem )  htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 
     513         IF( ktra == jp_sal )  str_adv(:,1) = ptr_sj( pva(:,:,:) ) 
     514      ENDIF 
     515      IF( cptr == 'ldf' ) THEN 
     516         IF( ktra == jp_tem )  htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 
     517         IF( ktra == jp_sal )  str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 
     518      ENDIF 
     519      IF( cptr == 'eiv' ) THEN 
     520         IF( ktra == jp_tem )  htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 
     521         IF( ktra == jp_sal )  str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 
     522      ENDIF 
     523      IF( cptr == 'vts' ) THEN 
     524         IF( ktra == jp_tem )  htr_vt(:,1) = ptr_sj( pva(:,:,:) ) 
     525         IF( ktra == jp_sal )  str_vs(:,1) = ptr_sj( pva(:,:,:) ) 
     526      ENDIF 
     527      ! 
     528      IF( ln_subbas ) THEN 
     529         ! 
     530         IF( cptr == 'adv' ) THEN 
     531             IF( ktra == jp_tem ) THEN  
     532                DO jn = 2, nptr 
     533                   htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     534                END DO 
     535             ENDIF 
     536             IF( ktra == jp_sal ) THEN  
     537                DO jn = 2, nptr 
     538                   str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     539                END DO 
     540             ENDIF 
     541         ENDIF 
     542         IF( cptr == 'ldf' ) THEN 
     543             IF( ktra == jp_tem ) THEN  
     544                DO jn = 2, nptr 
     545                    htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     546                 END DO 
     547             ENDIF 
     548             IF( ktra == jp_sal ) THEN  
     549                DO jn = 2, nptr 
     550                   str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     551                END DO 
     552             ENDIF 
     553         ENDIF 
     554         IF( cptr == 'eiv' ) THEN 
     555             IF( ktra == jp_tem ) THEN  
     556                DO jn = 2, nptr 
     557                    htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     558                 END DO 
     559             ENDIF 
     560             IF( ktra == jp_sal ) THEN  
     561                DO jn = 2, nptr 
     562                   str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     563                END DO 
     564             ENDIF 
     565         ENDIF 
     566         IF( cptr == 'vts' ) THEN 
     567             IF( ktra == jp_tem ) THEN  
     568                DO jn = 2, nptr 
     569                    htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     570                 END DO 
     571             ENDIF 
     572             IF( ktra == jp_sal ) THEN  
     573                DO jn = 2, nptr 
     574                   str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 
     575                END DO 
     576             ENDIF 
     577         ENDIF 
     578         ! 
     579      ENDIF 
     580   END SUBROUTINE dia_ptr_ohst_components 
     581 
    265582 
    266583   FUNCTION dia_ptr_alloc() 
    … …  
    273590      ierr(:) = 0 
    274591      ! 
    275       ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
    276          &      htr_adv(jpj) , str_adv(jpj) ,   & 
    277          &      htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1)  ) 
     592      ALLOCATE( btmsk(jpi,jpj,nptr) ,              & 
     593         &      htr_adv(jpj,nptr) , str_adv(jpj,nptr) ,   & 
     594         &      htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) ,   & 
     595         &      htr_vt(jpj,nptr)  , str_vs(jpj,nptr)  ,   & 
     596         &      htr_ove(jpj,nptr) , str_ove(jpj,nptr) ,   & 
     597         &      htr_btr(jpj,nptr) , str_btr(jpj,nptr) ,   & 
     598         &      htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1)  ) 
    278599         ! 
    279600      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 
    … …  
    402723#endif 
    403724      !!-------------------------------------------------------------------- 
    404       ! 
     725     ! 
    405726      p_fval => p_fval2d 
    406727 
    … …  
    434755#endif 
    435756      ! 
     757 
    436758   END FUNCTION ptr_sjk 
    437759 

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

    r7256 r7806  
    156156      IF( iom_use("e3tdef") )   & 
    157157         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
     158      CALL iom_put("tpt_dep", fsdept_n(:,:,:) ) 
     159 
    158160 
    159161 
    … …  
    318320      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
    319321      ! 
    320       IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
     322      IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    321323         z3d(:,:,jpk) = 0.e0 
     324         z2d(:,:) = 0.e0 
    322325         DO jk = 1, jpkm1 
    323326            z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 
     327            z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 
    324328         END DO 
    325329         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
     330         CALL iom_put( "u_masstr_vint", z2d )             ! mass transport in i-direction vertical sum 
    326331      ENDIF 
    327332       
    … …  
    386391         CALL iom_put( "v_salttr", 0.5 * z2d )            !  heat transport in j-direction 
    387392      ENDIF 
     393 
     394      ! Vertical integral of temperature 
     395      IF( iom_use("tosmint") ) THEN 
     396         z2d(:,:)=0._wp 
     397         DO jk = 1, jpkm1 
     398            DO jj = 2, jpjm1 
     399               DO ji = fs_2, fs_jpim1   ! vector opt. 
     400                  z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) *  tsn(ji,jj,jk,jp_tem) 
     401               END DO 
     402            END DO 
     403         END DO 
     404         CALL lbc_lnk( z2d, 'T', -1. ) 
     405         CALL iom_put( "tosmint", z2d )  
     406      ENDIF 
     407 
     408      ! Vertical integral of salinity 
     409      IF( iom_use("somint") ) THEN 
     410         z2d(:,:)=0._wp 
     411         DO jk = 1, jpkm1 
     412            DO jj = 2, jpjm1 
     413               DO ji = fs_2, fs_jpim1   ! vector opt. 
     414                  z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 
     415               END DO 
     416            END DO 
     417         END DO 
     418         CALL lbc_lnk( z2d, 'T', -1. ) 
     419         CALL iom_put( "somint", z2d )  
     420      ENDIF 
     421 
     422      CALL iom_put( "bn2", rn2 )  !Brunt-Vaisala buoyancy frequency (N^2) 
    388423      ! 
    389424      CALL wrk_dealloc( jpi , jpj      , z2d ) 

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

    r7217 r7806  
    2323   USE dom_oce         ! domain: ocean 
    2424   USE sbc_oce         ! surface boundary condition: ocean 
     25   USE trc_oce         ! shared ocean-passive tracers variables 
    2526   USE phycst          ! physical constants 
    2627   USE closea          ! closed seas 
    … …  
    9798      END DO 
    9899      ! 
    99       IF( lk_vvl )           CALL dom_vvl_init ! Vertical variable mesh 
    100       ! 
    101       IF( lk_c1d         )   CALL cor_c1d      ! 1D configuration: Coriolis set at T-point 
    102       ! 
    103       ! 
    104       hu(:,:) = 0._wp                          ! Ocean depth at U-points 
    105       hv(:,:) = 0._wp                          ! Ocean depth at V-points 
    106       ht(:,:) = 0._wp                          ! Ocean depth at T-points 
    107       DO jk = 1, jpkm1 
    108          hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
    109          hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
    110          ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
    111       END DO 
    112       !                                        ! Inverse of the local depth 
    113       hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:) 
    114       hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:) 
     100      IF( lk_c1d )           CALL cor_c1d      ! 1D configuration: Coriolis set at T-point 
     101      ! 
     102      IF( .NOT.lk_offline ) THEN 
     103        ! 
     104        IF( lk_vvl )         CALL dom_vvl_init ! Vertical variable mesh 
     105        ! 
     106        hu(:,:) = 0._wp                          ! Ocean depth at U-points 
     107        hv(:,:) = 0._wp                          ! Ocean depth at V-points 
     108        ht(:,:) = 0._wp                          ! Ocean depth at T-points 
     109        DO jk = 1, jpkm1 
     110           hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
     111           hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
     112           ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
     113        END DO 
     114        !                                        ! Inverse of the local depth 
     115        hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:) 
     116        hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:) 
     117        ! 
     118      ENDIF 
    115119 
    116120                             CALL dom_stp      ! time step 

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

    r7256 r7806  
    395395      IF(lwp) WRITE(numout,*) '    zgr_bat : defines level and meter bathymetry' 
    396396      IF(lwp) WRITE(numout,*) '    ~~~~~~~' 
     397      ! 
     398      ! (ISF) initialisation ice shelf draft and top level 
     399      risfdep(:,:)=0._wp 
     400      misfdep(:,:)=1 
    397401      !                                               ! ================== !  
    398402      IF( ntopo == 0 .OR. ntopo == -1 ) THEN          !   defined by hand  ! 
    … …  
    484488            END DO 
    485489         END DO 
    486          risfdep(:,:)=0.e0 
    487          misfdep(:,:)=1 
    488490         ! 
    489491         DEALLOCATE( idta, zdta ) 
    … …  
    535537            CALL iom_close( inum ) 
    536538            !                                                 
    537             risfdep(:,:)=0._wp          
    538             misfdep(:,:)=1              
    539539            IF ( ln_isfcav ) THEN 
    540540               CALL iom_open ( 'isf_draft_meter.nc', inum )  

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

    r5602 r7806  
    6565#if defined key_lim3 || defined key_cice 
    6666   REAL(wp), PUBLIC ::   rhoic    =  917._wp         !: volumic mass of sea ice                               [kg/m3] 
    67    REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: thermal conductivity of fresh ice 
    68    REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow 
    69    REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat for ice  
     67   REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: thermal conductivity of fresh ice                     [W/m/K] 
     68   REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat of fresh ice                            [J/kg/K] 
    7069   REAL(wp), PUBLIC ::   lsub     =    2.834e+6_wp   !: pure ice latent heat of sublimation                   [J/kg] 
    7170   REAL(wp), PUBLIC ::   lfus     =    0.334e+6_wp   !: latent heat of fusion of fresh ice                    [J/kg] 
    … …  
    8382   REAL(wp), PUBLIC ::   xlic     =  300.33e+6_wp    !: volumetric latent heat fusion of ice                  [J/m3] 
    8483   REAL(wp), PUBLIC ::   xsn      =    2.8e+6_wp     !: volumetric latent heat of sublimation of snow         [J/m3] 
     84#endif 
     85#if defined key_cice 
     86   REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow                          [W/m/K], now namelist parameter for LIM3 
    8587#endif 
    8688#if defined key_lim3 
    … …  
    177179      IF(lwp) THEN 
    178180         WRITE(numout,*) 
     181#if defined key_cice 
    179182         WRITE(numout,*) '          thermal conductivity of the snow          = ', rcdsn   , ' J/s/m/K' 
    180          WRITE(numout,*) '          thermal conductivity of the ice           = ', rcdic   , ' J/s/m/K' 
     183#endif 
     184         WRITE(numout,*) '          thermal conductivity of pure ice          = ', rcdic   , ' J/s/m/K' 
    181185         WRITE(numout,*) '          fresh ice specific heat                   = ', cpic    , ' J/kg/K' 
    182186         WRITE(numout,*) '          latent heat of fusion of fresh ice / snow = ', lfus    , ' J/kg' 

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

    r4990 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r5602 r7806  
    601601            DO jk = 1, jpk 
    602602               DO jj = 1, jpjm1 
    603                   DO ji = 1, jpim1 
     603                  DO ji = 1, fs_jpim1 
    604604                     ze3  = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    605605                        &   + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) 
    606                      IF( ze3 /= 0._wp )   ze3f(ji,jj,jk) = 4.0_wp / ze3 
     606                     IF   ( ze3 /= 0._wp ) THEN ;   ze3f(ji,jj,jk) = 4.0_wp / ze3 
     607                     ELSE                       ;   ze3f(ji,jj,jk) = 0.0_wp 
     608                     ENDIF 
    607609                  END DO 
    608610               END DO 
    … …  
    611613            DO jk = 1, jpk 
    612614               DO jj = 1, jpjm1 
    613                   DO ji = 1, jpim1 
     615                  DO ji = 1, fs_jpim1 
    614616                     ze3  = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    615617                        &   + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) 
    616618                     zmsk = (                   tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
    617619                        &                     + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk) ) 
    618                      IF( ze3 /= 0._wp )   ze3f(ji,jj,jk) = zmsk / ze3 
     620                     IF   ( ze3 /= 0._wp ) THEN ;   ze3f(ji,jj,jk) = zmsk / ze3 
     621                     ELSE                       ;   ze3f(ji,jj,jk) = 0.0_wp 
     622                     ENDIF 
    619623                  END DO 
    620624               END DO 

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

    r7398 r7806  
    235235      ! automatic definitions of some of the xml attributs 
    236236      CALL set_xmlatt 
     237 
     238      CALL set_1point 
    237239 
    238240      ! end file definition 
    … …  
    15861588      zz=REAL(narea,wp) 
    15871589      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1588        
     1590 
    15891591   END SUBROUTINE set_scalar 
     1592 
     1593   SUBROUTINE set_1point 
     1594      !!---------------------------------------------------------------------- 
     1595      !!                     ***  ROUTINE set_1point  *** 
     1596      !! 
     1597      !! ** Purpose :   define zoom grid for scalar fields 
     1598      !! 
     1599      !!---------------------------------------------------------------------- 
     1600      REAL(wp), DIMENSION(1)   ::   zz = 1. 
     1601      INTEGER  :: ix, iy 
     1602      !!---------------------------------------------------------------------- 
     1603      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  Nearest point to north pole should be ocean 
     1604      CALL iom_set_domain_attr('1point', zoom_ibegin=ix, zoom_jbegin=iy) 
     1605 
     1606   END SUBROUTINE set_1point 
    15901607 
    15911608 

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

    r5601 r7806  
    804804            ELSE 
    805805               startloop = 3 
    806                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     806               pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    807807            ENDIF 
    808808            DO ji = startloop, nlci 
    … …  
    816816            ELSE 
    817817               startloop = 3 
    818                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     818               pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    819819            ENDIF 
    820820            DO ji = startloop, nlci 
    … …  
    910910               DO ji = startloop , endloop 
    911911                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    912                   pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
     912                  pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    913913               END DO 
    914914 
    … …  
    926926               DO ji = startloop , endloop 
    927927                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    928                   pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 
     928                  pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 
    929929               END DO 
    930930 

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

    r7256 r7806  
    40264026      INTEGER          , INTENT(inout) ::   kios      ! IO status after reading the namelist 
    40274027      CHARACTER(len=*) , INTENT(in   ) ::   cdnam     ! group name of namelist for which error occurs 
    4028       CHARACTER(len=4)                 ::   clios     ! string to convert iostat in character for print 
     4028      CHARACTER(len=5)                 ::   clios     ! string to convert iostat in character for print 
    40294029      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print 
    40304030      !!---------------------------------------------------------------------- 
    … …  
    40324032      !  
    40334033      ! ---------------- 
    4034       WRITE (clios, '(I4.0)') kios 
     4034      WRITE (clios, '(I5.0)') kios 
    40354035      IF( kios < 0 ) THEN          
    40364036         CALL ctl_warn( 'W A R N I N G:  end of record or file while reading namelist ' & 

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

    r7256 r7806  
    3939   !                             !!* namelist namsbc_alb 
    4040   INTEGER  ::   nn_ice_alb 
    41    REAL(wp) ::   rn_albice 
     41   REAL(wp) ::   rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt 
    4242 
    4343   !!---------------------------------------------------------------------- 
    … …  
    101101      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    102102 
     103      ralb_sf = rn_alb_sdry ! dry snow 
     104      ralb_sm = rn_alb_smlt ! melting snow 
     105      ralb_if = rn_alb_idry ! bare frozen ice 
     106      ralb_im = rn_alb_imlt ! bare puddled ice  
    103107       
    104108      SELECT CASE ( nn_ice_alb ) 
    … …  
    109113      CASE( 0 ) 
    110114        
    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           
     115         !ralb_sf = 0.80       ! dry snow 
     116         !ralb_sm = 0.65       ! melting snow 
     117         !ralb_if = 0.72       ! bare frozen ice 
     118         !ralb_im = ...        ! bare puddled ice  
     119 
    116120         !  Computation of ice albedo (free of snow) 
    117121         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb(:,:,:) = ralb_im 
    … …  
    163167      CASE( 1 )  
    164168 
    165          ralb_im = rn_albice  ! bare puddled ice 
     169!        ralb_im = ...        ! bare puddled ice 
    166170! 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 
     171!        ralb_sf = 0.85      ! dry snow 
     172!        ralb_sm = 0.75      ! melting snow 
     173!        ralb_if = 0.60      ! bare frozen ice 
    170174! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 
    171175!         ralb_sf = 0.85       ! dry snow 
    … …  
    248252      !!---------------------------------------------------------------------- 
    249253      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    250       NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice  
     254      NAMELIST/namsbc_alb/ nn_ice_alb, rn_alb_sdry, rn_alb_smlt, rn_alb_idry , rn_alb_imlt 
    251255      !!---------------------------------------------------------------------- 
    252256      ! 
    … …  
    268272         WRITE(numout,*) '   Namelist namsbc_alb : albedo ' 
    269273         WRITE(numout,*) '      choose the albedo parameterization                  nn_ice_alb = ', nn_ice_alb 
    270          WRITE(numout,*) '      albedo of bare puddled ice                          rn_albice  = ', rn_albice 
     274         WRITE(numout,*) '      albedo of dry snow                                  rn_alb_sdry = ', rn_alb_sdry 
     275         WRITE(numout,*) '      albedo of melting snow                              rn_alb_smlt = ', rn_alb_smlt 
     276         WRITE(numout,*) '      albedo of dry ice                                   rn_alb_idry = ', rn_alb_idry 
     277         WRITE(numout,*) '      albedo of bare puddled ice                          rn_alb_imlt = ', rn_alb_imlt 
    271278      ENDIF 
    272279      ! 

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

    r5602 r7806  
    113113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff        [Kg/m2/s]   
    114114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwfisf , fwfisf_b !: ice shelf melting   [Kg/m2/s]   
     115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwficb , fwficb_b !: iceberg melting [Kg/m2/s]   
    115116   !! 
    116117   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend                      [K.m/s] jpi,jpj,jpts 
    … …  
    164165         ! 
    165166      ALLOCATE( fwfisf  (jpi,jpj), rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
    166          &      fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
     167         &      fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) ,     & 
     168         &      fwficb  (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) ) 
    167169         ! 
    168170      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 

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

    r7256 r7806  
    4343   USE eosbn2 
    4444   USE sbcrnf   , ONLY : l_rnfcpl 
     45   USE sbcisf   , ONLY : l_isfcpl 
    4546#if defined key_cpl_carbon_cycle 
    4647   USE p4zflx, ONLY : oce_co2 
    … …  
    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_isf    = 43 
     109   INTEGER, PARAMETER ::   jpr_icb    = 44 
     110   INTEGER, PARAMETER ::   jprcv      = 44            ! total number of fields received 
    108111 
    109112   INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction sent to the atmosphere 
    … …  
    149152   ! Received from the atmosphere                     ! 
    150153   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                         
     154   TYPE(FLD_C) ::   sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_icb, sn_rcv_isf                                
    152155   ! Other namelist parameters                        ! 
    153156   INTEGER     ::   nn_cplmodel            ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
    … …  
    219222         &                  sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr,      & 
    220223         &                  sn_rcv_qns , sn_rcv_emp   , sn_rcv_rnf  , sn_rcv_cal   , sn_rcv_iceflx,   & 
    221          &                  sn_rcv_co2 , nn_cplmodel  , ln_usecplmask 
     224         &                  sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf, nn_cplmodel  , ln_usecplmask 
    222225      !!--------------------------------------------------------------------- 
    223226      ! 
    … …  
    258261         WRITE(numout,*)'      runoffs                         = ', TRIM(sn_rcv_rnf%cldes   ), ' (', TRIM(sn_rcv_rnf%clcat   ), ')' 
    259262         WRITE(numout,*)'      calving                         = ', TRIM(sn_rcv_cal%cldes   ), ' (', TRIM(sn_rcv_cal%clcat   ), ')' 
     263         WRITE(numout,*)'      iceberg                         = ', TRIM(sn_rcv_icb%cldes   ), ' (', TRIM(sn_rcv_icb%clcat   ), ')' 
     264         WRITE(numout,*)'      ice shelf                       = ', TRIM(sn_rcv_isf%cldes   ), ' (', TRIM(sn_rcv_isf%clcat   ), ')' 
    260265         WRITE(numout,*)'      sea ice heat fluxes             = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 
    261266         WRITE(numout,*)'      atm co2                         = ', TRIM(sn_rcv_co2%cldes   ), ' (', TRIM(sn_rcv_co2%clcat   ), ')' 
    … …  
    397402      END SELECT 
    398403 
    399       !                                                      ! ------------------------- ! 
    400       !                                                      !     Runoffs & Calving     !    
    401       !                                                      ! ------------------------- ! 
     404 
     405      !                                                      ! ---------------------------------------------------- ! 
     406      !                                                      !     Runoffs, Calving, Iceberg, Iceshelf cavities     !    
     407      !                                                      ! ---------------------------------------------------- ! 
    402408      srcv(jpr_rnf   )%clname = 'O_Runoff' 
    403409      IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN 
    … …  
    409415      ENDIF 
    410416      ! 
    411       srcv(jpr_cal   )%clname = 'OCalving'   ;   IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE. 
     417      srcv(jpr_cal)%clname = 'OCalving'   ;  IF( TRIM( sn_rcv_cal%cldes) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE. 
     418      srcv(jpr_isf)%clname = 'OIcshelf'   ;  IF( TRIM( sn_rcv_isf%cldes) == 'coupled' )   srcv(jpr_isf)%laction = .TRUE. 
     419      srcv(jpr_icb)%clname = 'OIceberg'   ;  IF( TRIM( sn_rcv_icb%cldes) == 'coupled' )   srcv(jpr_icb)%laction = .TRUE. 
     420 
     421      IF( srcv(jpr_isf)%laction .AND. nn_isf > 0 ) THEN 
     422         l_isfcpl             = .TRUE.                      ! -> no need to read isf in sbcisf 
     423         IF(lwp) WRITE(numout,*) 
     424         IF(lwp) WRITE(numout,*) '   iceshelf received from oasis ' 
     425      ENDIF 
    412426 
    413427      !                                                      ! ------------------------- ! 
    … …  
    10711085         ENDIF 
    10721086         ! 
     1087         !    
    10731088         !                                                        ! runoffs and calving (added in emp) 
    1074          IF( srcv(jpr_rnf)%laction )     rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1089         IF( srcv(jpr_rnf)%laction )     rnf(:,:)  = frcv(jpr_rnf)%z3(:,:,1) 
    10751090         IF( srcv(jpr_cal)%laction )     zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1091 
     1092         IF( srcv(jpr_icb)%laction )  THEN  
     1093             fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 
     1094             rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runfofs 
     1095         ENDIF 
     1096         IF( srcv(jpr_isf)%laction )  fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)   
    10761097          
    10771098         IF( ln_mixcpl ) THEN   ;   emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) 
    … …  
    10911112            ENDIF 
    10921113         ENDIF 
     1114         ! 
     1115         IF( srcv(jpr_icb)%laction )  zqns(:,:) = zqns(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting 
     1116         ! 
    10931117         IF( ln_mixcpl ) THEN   ;   qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) 
    10941118         ELSE                   ;   qns(:,:) =                              zqns(:,:) 
    … …  
    13871411      ! 
    13881412      INTEGER ::   jl         ! dummy loop index 
    1389       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1413      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw 
    13901414      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
    13911415      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
    … …  
    13951419      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13961420      ! 
    1397       CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1421      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 
    13981422      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    13991423      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    … …  
    14181442         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    14191443         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
    1420                CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
     1444         IF( iom_use('precip') )          & 
     1445            &  CALL iom_put( 'precip'       ,   frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1)                              )  ! total  precipitation 
     1446         IF( iom_use('rain') )            & 
     1447            &  CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
     1448         IF( iom_use('rain_ao_cea') )   & 
     1449            &  CALL iom_put( 'rain_ao_cea'  , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1)      )   ! liquid precipitation  
    14211450         IF( iom_use('hflx_rain_cea') )   & 
    1422             &  CALL iom_put( 'hflx_rain_cea',   frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:)                                            )  ! heat flux from liq. precip.  
     1451            CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) * tmask(:,:,1))   ! heat flux from liq. precip.  
     1452         IF( iom_use('hflx_prec_cea') )   & 
     1453            CALL iom_put( 'hflx_prec_cea', ztprecip * zcptn(:,:) * tmask(:,:,1) * p_frld(:,:) )   ! heat content flux from all precip  (cell avg) 
     1454         IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
     1455            ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
    14231456         IF( iom_use('evap_ao_cea'  ) )   & 
    1424             &  CALL iom_put( 'evap_ao_cea'  ,   frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)                )  ! ice-free oce evap (cell average) 
     1457            CALL iom_put( 'evap_ao_cea'  , ztmp * tmask(:,:,1)                  )   ! ice-free oce evap (cell average) 
    14251458         IF( iom_use('hflx_evap_cea') )   & 
    1426             &  CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) )  ! heat flux from from evap (cell average) 
    1427       CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
     1459            CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) * tmask(:,:,1) )   ! heat flux from from evap (cell average) 
     1460      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14281461         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    14291462         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    … …  
    14581491         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    14591492      ENDIF 
     1493 
     1494      IF( srcv(jpr_icb)%laction )  THEN  
     1495         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 
     1496         rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runoffs 
     1497         CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 
     1498      ENDIF 
     1499      IF( srcv(jpr_isf)%laction )  THEN 
     1500        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)   
     1501        CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 
     1502      ENDIF 
     1503 
    14601504 
    14611505      IF( ln_mixcpl ) THEN 
    … …  
    14881532      ! runoffs and calving (put in emp_tot) 
    14891533      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1534      IF( iom_use('hflx_rnf_cea') )   & 
     1535         CALL iom_put( 'hflx_rnf_cea' , rnf(:,:) * zcptn(:,:) ) 
    14901536      IF( srcv(jpr_cal)%laction ) THEN  
    14911537         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    14921538         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    14931539      ENDIF 
     1540 
     1541 
     1542      IF( srcv(jpr_icb)%laction )  THEN  
     1543         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 
     1544         rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runoffs 
     1545         CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 
     1546      ENDIF 
     1547      IF( srcv(jpr_isf)%laction )  THEN 
     1548        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)   
     1549        CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 
     1550      ENDIF 
     1551 
    14941552 
    14951553      IF( ln_mixcpl ) THEN 
    … …  
    15601618      ENDIF 
    15611619 
     1620!!chris      
     1621!!    The heat content associated to the ice shelf in removed in the routine sbcisf.F90 
     1622      ! 
     1623      IF( srcv(jpr_icb)%laction )  zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting 
     1624      ! 
     1625!!      ! 
     1626 
    15621627#if defined key_lim3       
    15631628      ! --- non solar flux over ocean --- ! 
    … …  
    15661631      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15671632 
     1633      ! Heat content per unit mass of snow (J/kg) 
     1634      WHERE( SUM( a_i, dim=3 ) > 1.e-10 )   ;   zcptsnw(:,:) = cpic * SUM( (tn_ice -rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1635      ELSEWHERE                             ;   zcptsnw(:,:) = zcptn(:,:) 
     1636      ENDWHERE 
     1637      ! Heat content per unit mass of rain (J/kg) 
     1638      zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) -rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * p_frld(:,:) )  
     1639 
    15681640      ! --- heat flux associated with emp (W/m2) --- ! 
    15691641      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
    1570          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
    1571          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1642         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptrain(:,:)   &       ! liquid precip 
     1643         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptsnw(:,:) - lfus )  ! solid precip over ocean + snow melting 
    15721644!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    15731645!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1574       zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1646      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptsnw(:,:) - lfus ) ! solid precip over ice (only) 
    15751647                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
    15761648       
    15771649      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    1578       zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
     1650      zqprec_ice(:,:) = rhosn * ( zcptsnw(:,:) - lfus ) 
     1651      !zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
     1652       
    15791653 
    15801654      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
    … …  
    17371811      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    17381812 
    1739       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1813      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 
    17401814      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    17411815      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 

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

    r7256 r7806  
    650650CONTAINS 
    651651   SUBROUTINE sbc_ice_lim ( kt, kblk )     ! Dummy routine 
     652      INTEGER, INTENT(in) ::   kt, kblk 
    652653      WRITE(*,*) 'sbc_ice_lim: You should not have seen this print! error?', kt, kblk 
    653654   END SUBROUTINE sbc_ice_lim 

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

    r7256 r7806  
    3232   PRIVATE 
    3333 
    34    PUBLIC   sbc_isf, sbc_isf_div, sbc_isf_alloc  ! routine called in sbcmod and divcur 
     34   PUBLIC   sbc_isf, sbc_isf_init, sbc_isf_div, sbc_isf_alloc  ! routine called in sbcmod and divcur 
    3535 
    3636   ! public in order to be able to output then  
    … …  
    5454   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    5555   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
     56 
     57   LOGICAL, PUBLIC ::   l_isfcpl = .false.       ! isf recieved from oasis 
    5658 
    5759 
    … …  
    8183  
    8284  SUBROUTINE sbc_isf(kt) 
     85 
    8386    INTEGER, INTENT(in)          ::   kt         ! ocean time step 
     87    INTEGER                      ::   ji, jj, jk 
     88    INTEGER                      ::   ikt, ikb   ! top and bottom level of the isf boundary layer 
     89    REAL(wp)                     ::   zhk 
     90    REAL(wp)                     ::   zt_frz, zpress 
     91    REAL(wp), DIMENSION(:,:,:), POINTER :: zfwfisf3d, zqhcisf3d, zqlatisf3d 
     92    REAL(wp), DIMENSION(:,:  ), POINTER :: zqhcisf2d 
     93    REAL(wp)                            :: zhisf 
     94 
     95 
     96      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
     97 
     98         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
     99         DO jj = 1,jpj 
     100            DO ji = 1,jpi 
     101               ikt = misfkt(ji,jj) 
     102               ikb = misfkt(ji,jj) 
     103               ! thickness of boundary layer at least the top level thickness 
     104               rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 
     105 
     106               ! determine the deepest level influenced by the boundary layer 
     107               DO jk = ikt, mbkt(ji,jj) 
     108                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     109               END DO 
     110               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
     111               misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl 
     112               r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
     113 
     114               zhk           = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1 
     115               ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
     116            END DO 
     117         END DO 
     118 
     119         ! compute salf and heat flux 
     120         IF (nn_isf == 1) THEN 
     121            ! realistic ice shelf formulation 
     122            ! compute T/S/U/V for the top boundary layer 
     123            CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T') 
     124            CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T') 
     125            CALL sbc_isf_tbl(un(:,:,:),utbl(:,:),'U') 
     126            CALL sbc_isf_tbl(vn(:,:,:),vtbl(:,:),'V') 
     127            ! iom print 
     128            CALL iom_put('ttbl',ttbl(:,:)) 
     129            CALL iom_put('stbl',stbl(:,:)) 
     130            CALL iom_put('utbl',utbl(:,:)) 
     131            CALL iom_put('vtbl',vtbl(:,:)) 
     132            ! compute fwf and heat flux 
     133            IF( .NOT.l_isfcpl ) THEN    ;   CALL sbc_isf_cav (kt) 
     134            ELSE                        ;   qisf(:,:)  = fwfisf(:,:) * lfusisf              ! heat        flux 
     135            ENDIF 
     136 
     137         ELSE IF (nn_isf == 2) THEN 
     138            ! Beckmann and Goosse parametrisation  
     139            stbl(:,:)   = soce 
     140            CALL sbc_isf_bg03(kt) 
     141 
     142         ELSE IF (nn_isf == 3) THEN 
     143            ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
     144            IF( .NOT.l_isfcpl ) THEN 
     145               CALL fld_read ( kt, nn_fsbc, sf_rnfisf   ) 
     146               fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fresh water flux from the isf (fwfisf <0 mean melting)  
     147            ENDIF 
     148            qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
     149            stbl(:,:)   = soce 
     150 
     151         ELSE IF (nn_isf == 4) THEN 
     152            ! specified fwf and heat flux forcing beneath the ice shelf 
     153            IF( .NOT.l_isfcpl ) THEN 
     154               CALL fld_read ( kt, nn_fsbc, sf_fwfisf   ) 
     155               !CALL fld_read ( kt, nn_fsbc, sf_qisf   ) 
     156               fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1)            ! fwf 
     157            ENDIF 
     158            qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
     159            !qisf(:,:)   = sf_qisf(1)%fnow(:,:,1)              ! heat flux 
     160            stbl(:,:)   = soce 
     161 
     162         END IF 
     163         ! compute tsc due to isf 
     164         ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
     165!         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     166         zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
     167         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
     168          
     169         ! salt effect already take into account in vertical advection 
     170         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
     171 
     172         ! output 
     173         IF( iom_use('qlatisf' ) )   CALL iom_put('qlatisf', qisf) 
     174         IF( iom_use('fwfisf'  ) )   CALL iom_put('fwfisf' , fwfisf * stbl(:,:) / soce ) 
     175 
     176         ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
     177         fwfisf(:,:) = rdivisf * fwfisf(:,:)          
     178  
     179         ! lbclnk 
     180         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
     181         CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.) 
     182         CALL lbc_lnk(fwfisf(:,:)   ,'T',1.) 
     183         CALL lbc_lnk(qisf(:,:)     ,'T',1.) 
     184 
     185         ! Diagnostics 
     186         IF( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN 
     187            ! 
     188            CALL wrk_alloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
     189            CALL wrk_alloc( jpi,jpj,     zqhcisf2d                        ) 
     190            ! 
     191            zfwfisf3d(:,:,:) = 0.0_wp                         ! 3d ice shelf melting (kg/m2/s) 
     192            zqhcisf3d(:,:,:) = 0.0_wp                         ! 3d heat content flux (W/m2) 
     193            zqlatisf3d(:,:,:)= 0.0_wp                         ! 3d ice shelf melting latent heat flux (W/m2) 
     194            zqhcisf2d(:,:)   = fwfisf(:,:) * zt_frz * rcp     ! 2d heat content flux (W/m2) 
     195            ! 
     196            DO jj = 1,jpj 
     197               DO ji = 1,jpi 
     198                  ikt = misfkt(ji,jj) 
     199                  ikb = misfkb(ji,jj) 
     200                  DO jk = ikt, ikb - 1 
     201                     zhisf = r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 
     202                     zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf(ji,jj)    * zhisf 
     203                     zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * zhisf 
     204                     zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf(ji,jj)      * zhisf 
     205                  END DO 
     206                  jk = ikb 
     207                  zhisf = r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 
     208                  zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf   (ji,jj) * zhisf * ralpha(ji,jj)  
     209                  zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * zhisf * ralpha(ji,jj) 
     210                  zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf     (ji,jj) * zhisf * ralpha(ji,jj) 
     211               END DO 
     212            END DO 
     213            ! 
     214            CALL iom_put( 'fwfisf3d' , zfwfisf3d (:,:,:) ) 
     215            CALL iom_put( 'qlatisf3d', zqlatisf3d(:,:,:) ) 
     216            CALL iom_put( 'qhcisf3d' , zqhcisf3d (:,:,:) ) 
     217            CALL iom_put( 'qhcisf'   , zqhcisf2d (:,:  ) ) 
     218            ! 
     219            CALL wrk_dealloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
     220            CALL wrk_dealloc( jpi,jpj,     zqhcisf2d                        ) 
     221            ! 
     222         END IF 
     223         !  
     224      END IF 
     225      ! 
     226      ! 
     227      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
     228         IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
     229              & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 
     230            IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
     231            CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) ) ! before salt content isf_tsc trend 
     232            CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) )   ! before salt content isf_tsc trend 
     233            CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) )   ! before salt content isf_tsc trend 
     234         ELSE 
     235            fwfisf_b(:,:)    = fwfisf(:,:) 
     236            risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 
     237         END IF 
     238      ENDIF 
     239      ! 
     240      IF( lrst_oce ) THEN 
     241         IF(lwp) WRITE(numout,*) 
     242         IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   & 
     243            &                    'at it= ', kt,' date= ', ndastp 
     244         IF(lwp) WRITE(numout,*) '~~~~' 
     245         CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 
     246         CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
     247         CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
     248      ENDIF 
     249       ! 
     250  END SUBROUTINE sbc_isf 
     251 
     252  SUBROUTINE sbc_isf_init 
     253 
    84254    INTEGER                      ::   ji, jj, jk, ijkmin, inum, ierror 
    85255    INTEGER                      ::   ikt, ikb   ! top and bottom level of the isf boundary layer 
    86     REAL(wp)                     ::   rmin 
    87256    REAL(wp)                     ::   zhk 
    88     REAL(wp)                     ::   zt_frz, zpress 
    89257    CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
    90258    CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    91259    CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    92260    INTEGER           ::   ios           ! Local integer output status for namelist read 
     261 
    93262      ! 
    94263      !!--------------------------------------------------------------------- 
    … …  
    97266      ! 
    98267      ! 
    99       !                                         ! ====================== ! 
    100       IF( kt == nit000 ) THEN                   !  First call kt=nit000  ! 
    101          !                                      ! ====================== ! 
    102268         REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    103269         READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 
    … …  
    139305            misfkt(:,:)    = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv 
    140306         ELSE IF ((nn_isf == 3) .OR. (nn_isf == 2)) THEN 
    141             ALLOCATE( sf_rnfisf(1), STAT=ierror ) 
    142             ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 
    143             CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
     307            IF( .NOT.l_isfcpl ) THEN 
     308               ALLOCATE( sf_rnfisf(1), STAT=ierror ) 
     309               ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 
     310               CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
     311             ENDIF 
    144312 
    145313            !: read effective lenght (BG03) 
    … …  
    182350             
    183351            ! load variable used in fldread (use for temporal interpolation of isf fwf forcing) 
    184             ALLOCATE( sf_fwfisf(1), sf_qisf(1), STAT=ierror ) 
    185             ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 
    186             ALLOCATE( sf_qisf(1)%fnow(jpi,jpj,1), sf_qisf(1)%fdta(jpi,jpj,1,2) ) 
    187             CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
    188             !CALL fld_fill( sf_qisf  , (/ sn_qisf   /), cn_dirisf, 'sbc_isf_init', 'read heat flux isf data'       , 'namsbc_isf' ) 
     352            IF( .NOT.l_isfcpl ) THEN 
     353               ALLOCATE( sf_fwfisf(1), sf_qisf(1), STAT=ierror ) 
     354               ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 
     355               ALLOCATE( sf_qisf(1)%fnow(jpi,jpj,1), sf_qisf(1)%fdta(jpi,jpj,1,2) ) 
     356               CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
     357               !CALL fld_fill( sf_qisf  , (/ sn_qisf   /), cn_dirisf, 'sbc_isf_init', 'read heat flux isf data'       , 'namsbc_isf' ) 
     358            ENDIF 
    189359         END IF 
    190           
    191360         ! save initial top boundary layer thickness          
    192361         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
    193  
    194       END IF 
    195  
    196       !                                            ! ---------------------------------------- ! 
    197       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    198          !                                         ! ---------------------------------------- ! 
    199          fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
    200          risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    201          ! 
    202       ENDIF 
    203  
    204       IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    205  
    206          ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    207          DO jj = 1,jpj 
    208             DO ji = 1,jpi 
    209                ikt = misfkt(ji,jj) 
    210                ikb = misfkt(ji,jj) 
    211                ! thickness of boundary layer at least the top level thickness 
    212                rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 
    213  
    214                ! determine the deepest level influenced by the boundary layer 
    215                DO jk = ikt, mbkt(ji,jj) 
    216                   IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    217                END DO 
    218                rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
    219                misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl 
    220                r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
    221  
    222                zhk           = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1 
    223                ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
    224             END DO 
    225          END DO 
    226  
    227          ! compute salf and heat flux 
    228          IF (nn_isf == 1) THEN 
    229             ! realistic ice shelf formulation 
    230             ! compute T/S/U/V for the top boundary layer 
    231             CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T') 
    232             CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T') 
    233             CALL sbc_isf_tbl(un(:,:,:),utbl(:,:),'U') 
    234             CALL sbc_isf_tbl(vn(:,:,:),vtbl(:,:),'V') 
    235             ! iom print 
    236             CALL iom_put('ttbl',ttbl(:,:)) 
    237             CALL iom_put('stbl',stbl(:,:)) 
    238             CALL iom_put('utbl',utbl(:,:)) 
    239             CALL iom_put('vtbl',vtbl(:,:)) 
    240             ! compute fwf and heat flux 
    241             CALL sbc_isf_cav (kt) 
    242  
    243          ELSE IF (nn_isf == 2) THEN 
    244             ! Beckmann and Goosse parametrisation  
    245             stbl(:,:)   = soce 
    246             CALL sbc_isf_bg03(kt) 
    247  
    248          ELSE IF (nn_isf == 3) THEN 
    249             ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
    250             CALL fld_read ( kt, nn_fsbc, sf_rnfisf   ) 
    251             fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fresh water flux from the isf (fwfisf <0 mean melting)  
    252             qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
    253             stbl(:,:)   = soce 
    254  
    255          ELSE IF (nn_isf == 4) THEN 
    256             ! specified fwf and heat flux forcing beneath the ice shelf 
    257             CALL fld_read ( kt, nn_fsbc, sf_fwfisf   ) 
    258             !CALL fld_read ( kt, nn_fsbc, sf_qisf   ) 
    259             fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1)            ! fwf 
    260             qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
    261             !qisf(:,:)   = sf_qisf(1)%fnow(:,:,1)              ! heat flux 
    262             stbl(:,:)   = soce 
    263  
    264          END IF 
    265          ! compute tsc due to isf 
    266          ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
    267 !         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    268          zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    269          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
    270           
    271          ! salt effect already take into account in vertical advection 
    272          risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    273  
    274          ! output 
    275          IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
    276          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    277  
    278          ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
    279          fwfisf(:,:) = rdivisf * fwfisf(:,:)          
    280   
    281          ! lbclnk 
    282          CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    283          CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.) 
    284          CALL lbc_lnk(fwfisf(:,:)   ,'T',1.) 
    285          CALL lbc_lnk(qisf(:,:)     ,'T',1.) 
    286  
    287          IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    288             IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
    289                  & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 
    290                IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
    291                CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) )   ! before salt content isf_tsc trend 
    292                CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) )   ! before salt content isf_tsc trend 
    293                CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) )   ! before salt content isf_tsc trend 
    294             ELSE 
    295                fwfisf_b(:,:)    = fwfisf(:,:) 
    296                risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 
    297             END IF 
    298          ENDIF 
    299362         !  
    300       END IF 
    301    
    302   END SUBROUTINE sbc_isf 
     363   END SUBROUTINE sbc_isf_init 
     364       
     365 
    303366 
    304367  INTEGER FUNCTION sbc_isf_alloc() 

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

    r7256 r7806  
    300300      IF( ln_ssr           )   CALL sbc_ssr_init               ! Sea-Surface Restoring initialisation 
    301301      ! 
     302      IF( nn_isf   /= 0    )   CALL sbc_isf_init               ! Compute iceshelves 
     303 
    302304                               CALL sbc_rnf_init               ! Runof initialisation 
    303305      ! 
    … …  
    343345            rnf_b    (:,:  ) = rnf    (:,:  ) 
    344346            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     347         ENDIF 
     348         IF( nn_isf /= 0  )  THEN 
     349            fwfisf_b  (:,:  ) = fwfisf  (:,:  )                
     350            risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               
    345351         ENDIF 
    346352      ENDIF 

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

    r5602 r7806  
    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 
    … …  
    7981      INTEGER ::   jk   ! dummy loop index 
    8082      REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 
     83      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztrdt, ztrds   ! 3D workspace 
    8184      !!---------------------------------------------------------------------- 
    8285      ! 
    … …  
    120123      IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
    121124      ! 
    122     
     125      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     126         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
     127         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     128         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     129      ENDIF 
     130      ! 
    123131      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    124132      CASE ( 1 )   ;    CALL tra_adv_cen2   ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    … …  
    151159      END SELECT 
    152160      ! 
     161      IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics 
     162         DO jk = 1, jpkm1 
     163            ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) 
     164            ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) 
     165         END DO 
     166         CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 
     167         CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 
     168         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
     169      ENDIF 
    153170      !                                              ! print mean trends (used for debugging) 
    154171      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               & 

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

    r7256 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r7256 r7806  
    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 ) 

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

    r5602 r7806  
    4545   !!---------------------------------------------------------------------- 
    4646   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    47    !! $Id$  
     47   !! $Id$ 
    4848   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4949   !!---------------------------------------------------------------------- 
    … …  
    219219         END IF 
    220220         !                                 ! "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 
     221         IF( cdtype == 'TRA' .AND. ln_diaptr )  CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:)  ) 
    225222 
    226223         ! II. Vertical advective fluxes 

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

    r5602 r7806  
    3737   !!---------------------------------------------------------------------- 
    3838   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    39    !! $Id$  
     39   !! $Id$ 
    4040   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4141   !!---------------------------------------------------------------------- 
    … …  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r5602 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r7256 r7806  
    2727   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    2828   USE diaptr         ! poleward transport diagnostics 
     29   USE phycst 
    2930   ! 
    3031   USE lib_mpp        ! MPP library 
    … …  
    3435   USE timing         ! Timing 
    3536   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     37   USE iom 
    3638 
    3739   IMPLICIT NONE 
    … …  
    4244 
    4345   LOGICAL ::   l_trd   ! flag to compute trends 
     46   LOGICAL ::   l_trans   ! flag to output vertically integrated transports 
    4447 
    4548   !! * Substitutions 
    … …  
    8588      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk   !   -      - 
    8689      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
     90      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 
     91      REAL(wp), POINTER, DIMENSION(:,:)   :: z2d 
    8892      !!---------------------------------------------------------------------- 
    8993      ! 
    … …  
    97101         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    98102         ! 
    99          l_trd = .FALSE. 
    100          IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    101103      ENDIF 
    102       ! 
    103       IF( l_trd )  THEN 
     104 
     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 
    104111         CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    105112         ztrdx(:,:,:) = 0.e0   ;    ztrdy(:,:,:) = 0.e0   ;   ztrdz(:,:,:) = 0.e0 
     113         CALL wrk_alloc( jpi, jpj, z2d ) 
     114      ENDIF 
     115      ! 
     116      IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     117         CALL wrk_alloc( jpi, jpj, jpk, zptry ) 
     118         zptry(:,:,:) = 0._wp 
    106119      ENDIF 
    107120      ! 
    … …  
    187200 
    188201         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    189          IF( l_trd )  THEN  
     202         IF( l_trd .OR. l_trans )  THEN  
    190203            ! store intermediate advective trends 
    191204            ztrdx(:,:,:) = zwx(:,:,:)   ;    ztrdy(:,:,:) = zwy(:,:,:)  ;   ztrdz(:,:,:) = zwz(:,:,:) 
    192205         END IF 
    193206         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    194          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    195            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    196            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    197          ENDIF 
     207         IF( cdtype == 'TRA' .AND. ln_diaptr )    zptry(:,:,:) = zwy(:,:,:)  
    198208 
    199209         ! 3. antidiffusive flux : high order minus low order 
    … …  
    253263 
    254264         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    255          IF( l_trd )  THEN  
     265         IF( l_trd .OR. l_trans )  THEN  
    256266            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< Add to previously computed 
    257267            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
    258268            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! <<< Add to previously computed 
    259              
    260             CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )    
    261             CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )   
    262             CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
     269         ENDIF 
     270          
     271         IF( l_trd ) THEN  
     272            CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 
     273            CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 
     274            CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 
    263275         END IF 
    264          !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     276 
     277         IF( l_trans .AND. jn==jp_tem ) THEN 
     278            z2d(:,:) = 0._wp  
     279            DO jk = 1, jpkm1 
     280               DO jj = 2, jpjm1 
     281                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     282                     z2d(ji,jj) = z2d(ji,jj) + ztrdx(ji,jj,jk)  
     283                  END DO 
     284               END DO 
     285            END DO 
     286            CALL lbc_lnk( z2d, 'U', -1. ) 
     287            CALL iom_put( "uadv_heattr", rau0_rcp * z2d )       ! heat transport in i-direction 
     288              ! 
     289            z2d(:,:) = 0._wp  
     290            DO jk = 1, jpkm1 
     291               DO jj = 2, jpjm1 
     292                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     293                     z2d(ji,jj) = z2d(ji,jj) + ztrdy(ji,jj,jk)  
     294                  END DO 
     295               END DO 
     296            END DO 
     297            CALL lbc_lnk( z2d, 'V', -1. ) 
     298            CALL iom_put( "vadv_heattr", rau0_rcp * z2d )       ! heat transport in j-direction 
     299         ENDIF 
     300         ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    265301         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    266            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
    267            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
     302            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
     303            CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 
    268304         ENDIF 
    269305         ! 
    270306      END DO 
    271307      ! 
    272                    CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 
    273       IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     308      CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 
     309      IF( l_trd .OR. l_trans )  THEN  
     310         CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     311         CALL wrk_dealloc( jpi, jpj, z2d ) 
     312      ENDIF 
     313      IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 
    274314      ! 
    275315      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd') 
    … …  
    318358      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 
    319359      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
     360      REAL(wp), POINTER, DIMENSION(:,:,:) :: zptry 
    320361      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs 
    321362      !!---------------------------------------------------------------------- 
    … …  
    339380         CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    340381         ztrdx(:,:,:) = 0._wp  ;    ztrdy(:,:,:) = 0._wp  ;   ztrdz(:,:,:) = 0._wp 
     382      ENDIF 
     383      ! 
     384      IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     385         CALL wrk_alloc( jpi, jpj,jpk, zptry ) 
     386         zptry(:,:,:) = 0._wp 
    341387      ENDIF 
    342388      ! 
    … …  
    428474         END IF 
    429475         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    430          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    431            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    432            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    433          ENDIF 
     476         IF( cdtype == 'TRA' .AND. ln_diaptr )  zptry(:,:,:) = zwy(:,:,:) 
    434477 
    435478         ! 3. antidiffusive flux : high order minus low order 
    … …  
    556599         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    557600         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    558            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
    559            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
     601            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  
     602            CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 
    560603         ENDIF 
    561604         ! 
    … …  
    566609                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    567610      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     611      IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 
    568612      ! 
    569613      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd_zts') 

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

    r7795 r7806  
    183183            ztrdx(:,:,:) = zwx(:,:,:)   ;    ztrdy(:,:,:) = zwy(:,:,:)  ;   ztrdz(:,:,:) = zwz(:,:,:) 
    184184         END IF 
    185          !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    186          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    187            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
    188            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    189          ENDIF 
    190185 
    191186         ! 3. antidiffusive flux : high order minus low order 
    … …  
    245240            CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
    246241         END IF 
    247          !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    248          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
    249            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
    250            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    251          ENDIF 
    252242         ! 
    253243      END DO 

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

    r5602 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r5602 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r5602 r7806  
    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         !                             ! ************ !   ! =============== 

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

    r5602 r7806  
    235235         ! 
    236236         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    237          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    238237            ! 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 
     238         IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', -zftv(:,:,:)  ) 
    242239  
    243240         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 

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

    r7311 r7806  
    210210         !                                             ! =============== 
    211211         ! 
    212          ! "Poleward" diffusive heat or salt transports (T-S case only) 
    213          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    214             IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    215             IF( jn == jp_sal)   str_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    216          ENDIF 
    217212  
    218213#if defined key_diaar5 

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

    r5602 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r5602 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_crs.F90

    r6772 r7806  
    149149         END DO                                             !  End of slab   
    150150         ! 
    151          ! "Poleward" diffusive heat or salt transports 
    152          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    153             IF( jn  == jp_tem)   htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    154             IF( jn  == jp_sal)   str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    155          ENDIF 
    156151         !                                                  ! ================== 
    157152      END DO                                                ! end of tracer loop 

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

    r7256 r7806  
    129129 
    130130      ! trends computation initialisation 
    131       IF( l_trdtra )   THEN                    ! store now fields before applying the Asselin filter 
     131      IF( l_trdtra )   THEN                     
    132132         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    133          ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
    134          ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
     133         ztrdt(:,:,jk) = 0._wp 
     134         ztrds(:,:,jk) = 0._wp 
    135135         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend  
    136136            CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 
    137137            CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 
    138138         ENDIF 
     139         ! total trend for the non-time-filtered variables.  
     140         DO jk = 1, jpkm1 
     141            zfact = 1.0 / rdttra(jk) 
     142            ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsn(:,:,jk,jp_tem) ) * zfact  
     143            ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsn(:,:,jk,jp_sal) ) * zfact  
     144         END DO 
     145         CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt ) 
     146         CALL trd_tra( kt, 'TRA', jp_sal, jptra_tot, ztrds ) 
     147         ! Store now fields before applying the Asselin filter  
     148         ! in order to calculate Asselin filter trend later. 
     149         ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
     150         ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
    139151      ENDIF 
    140152 

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

    r7256 r7806  
    248248            END DO 
    249249         END DO 
    250          IF( lrst_oce ) THEN 
    251             IF(lwp) WRITE(numout,*) 
    252             IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   & 
    253                &                    'at it= ', kt,' date= ', ndastp 
    254             IF(lwp) WRITE(numout,*) '~~~~' 
    255             CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:)          ) 
    256             CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
    257             CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
    258          ENDIF 
    259250      END IF 
    260251      ! 

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

    r5602 r7806  
    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_zdf  =  7     !: vertical      diffusion 
     44   INTEGER, PUBLIC, PARAMETER ::   jptra_zdfp =  8     !: "PURE" vert.  diffusion (ln_traldf_iso=T) 
     45   INTEGER, PUBLIC, PARAMETER ::   jptra_evd  =  9     !: EVD term (convection) 
     46   INTEGER, PUBLIC, PARAMETER ::   jptra_bbc  = 10     !: Bottom Boundary Condition (geoth. heating)  
     47   INTEGER, PUBLIC, PARAMETER ::   jptra_bbl  = 11     !: Bottom Boundary Layer (diffusive and/or advective) 
     48   INTEGER, PUBLIC, PARAMETER ::   jptra_npc  = 12     !: non-penetrative convection treatment 
     49   INTEGER, PUBLIC, PARAMETER ::   jptra_dmp  = 13     !: internal restoring (damping) 
     50   INTEGER, PUBLIC, PARAMETER ::   jptra_qsr  = 14     !: penetrative solar radiation 
     51   INTEGER, PUBLIC, PARAMETER ::   jptra_nsr  = 15     !: non solar radiation / C/D on salinity  (+runoff if ln_rnf=T) 
     52   INTEGER, PUBLIC, PARAMETER ::   jptra_atf  = 16     !: Asselin time filter 
     53   INTEGER, PUBLIC, PARAMETER ::   jptra_tot  = 17     !: Model total trend 
    5154   ! 
    5255   !                                                  !!!* 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) 
     56   INTEGER, PUBLIC, PARAMETER ::   jptra_sms  = 18     !: sources m. sinks 
     57   INTEGER, PUBLIC, PARAMETER ::   jptra_radn = 19     !: corr. trn<0 in trcrad 
     58   INTEGER, PUBLIC, PARAMETER ::   jptra_radb = 20     !: corr. trb<0 in trcrad (like atf) 
    5659   ! 
    5760   !                                                  !!!* Momentum trends indices 
    58    INTEGER, PUBLIC, PARAMETER ::   jptot_dyn  = 15     !: Total trend nb: change it when adding/removing one indice below 
     61   INTEGER, PUBLIC, PARAMETER ::   jptot_dyn  = 16     !: Total trend nb: change it when adding/removing one indice below 
    5962   !                               ===============     !   
    6063   INTEGER, PUBLIC, PARAMETER ::   jpdyn_hpg  =  1     !: hydrostatic pressure gradient  
    … …  
    7376   INTEGER, PUBLIC, PARAMETER ::   jpdyn_spgflt  = 14  !: filter contribution to surface pressure gradient (spg_flt) 
    7477   INTEGER, PUBLIC, PARAMETER ::   jpdyn_spgexp  = 15  !: explicit contribution to surface pressure gradient (spg_flt) 
     78   INTEGER, PUBLIC, PARAMETER ::   jpdyn_eivke   = 16  !: K.E trend from Gent McWilliams scheme 
    7579   ! 
    7680   !!---------------------------------------------------------------------- 

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

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

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

    r7256 r7806  
    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) 
    … …  
    192195                    CALL ken_p2k( kt , zke ) 
    193196                      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#ifdef key_traldf_eiv 
     205            CALL wrk_alloc( jpi, jpj, zke2d ) 
     206            zke2d(:,:) = 0._wp 
     207            DO jk = 1,jpk 
     208               DO ji = 1,jpi 
     209                  DO jj = 1,jpj 
     210                     zke2d(ji,jj) = zke2d(ji,jj) +  rau0 * fsaeiw(ji, jj, jk)               & 
     211                          &                      * ( wslpi(ji, jj, jk) * wslpi(ji,jj,jk)    & 
     212                          &                      +   wslpj(ji, jj, jk) * wslpj(ji,jj,jk) )  & 
     213                          &                      *   rn2(ji,jj,jk) * fse3w(ji, jj, jk) 
     214                  ENDDO 
     215               ENDDO 
     216            ENDDO 
     217            CALL iom_put("ketrd_eiv", zke2d) 
     218            CALL wrk_dealloc( jpi, jpj, zke2d ) 
     219#endif 
    194220         ! 
    195221      END SELECT 

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

    r7256 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90

    r4990 r7806  
    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 ) 
    … …  
    312328                                  CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 
    313329                               ENDIF 
     330      CASE( jptra_totad  ) ;   CALL iom_put( "ttrd_totad" , ptrdx )        ! total   advection 
     331                               CALL iom_put( "strd_totad" , ptrdy ) 
    314332      CASE( jptra_ldf  )   ;   CALL iom_put( "ttrd_ldf" , ptrdx )        ! lateral diffusion 
    315333                               CALL iom_put( "strd_ldf" , ptrdy ) 
    … …  
    318336      CASE( jptra_zdfp )   ;   CALL iom_put( "ttrd_zdfp", ptrdx )        ! PURE vertical diffusion (no isoneutral contribution) 
    319337                               CALL iom_put( "strd_zdfp", ptrdy ) 
     338      CASE( jptra_evd )    ;   CALL iom_put( "ttrd_evd", ptrdx )         ! EVD trend (convection) 
     339                               CALL iom_put( "strd_evd", ptrdy ) 
    320340      CASE( jptra_dmp  )   ;   CALL iom_put( "ttrd_dmp" , ptrdx )        ! internal restoring (damping) 
    321341                               CALL iom_put( "strd_dmp" , ptrdy ) 
    … …  
    324344      CASE( jptra_npc  )   ;   CALL iom_put( "ttrd_npc" , ptrdx )        ! static instability mixing 
    325345                               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 ) 
     346      CASE( jptra_nsr  )   ;   CALL iom_put( "ttrd_qns" , ptrdx(:,:,1) )        ! surface forcing + runoff (ln_rnf=T) 
     347                               CALL iom_put( "strd_cdt" , ptrdy(:,:,1) )        ! output as 2D surface fields 
    328348      CASE( jptra_qsr  )   ;   CALL iom_put( "ttrd_qsr" , ptrdx )        ! penetrative solar radiat. (only on temperature) 
    329349      CASE( jptra_bbc  )   ;   CALL iom_put( "ttrd_bbc" , ptrdx )        ! geothermal heating   (only on temperature) 
    330350      CASE( jptra_atf  )   ;   CALL iom_put( "ttrd_atf" , ptrdx )        ! asselin time Filter 
    331351                               CALL iom_put( "strd_atf" , ptrdy ) 
     352      CASE( jptra_tot  )   ;   CALL iom_put( "ttrd_tot" , ptrdx )        ! model total trend 
     353                               CALL iom_put( "strd_tot" , ptrdy ) 
    332354      END SELECT 
    333355      ! 

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

    r4990 r7806  
    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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r7256 r7806  
    323323                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    324324                  !                                           ! TKE Langmuir circulation source term 
    325                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
     325                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
    326326                     &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    327327               END DO 
    … …  
    436436               DO ji = fs_2, fs_jpim1   ! vector opt. 
    437437                  en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    438                      &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     438                     &                                 * MAX(0.,1._wp - 2.*fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    439439               END DO 
    440440            END DO 
    … …  
    445445               jk = nmln(ji,jj) 
    446446               en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    447                   &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     447                  &                                 * MAX(0.,1._wp - 2.*fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    448448            END DO 
    449449         END DO 
    … …  
    461461                  zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
    462462                  en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    463                      &                        * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     463                     &                        * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    464464               END DO 
    465465            END DO 

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

    r7332 r7806  
    487487      !                                     ! Diagnostics 
    488488      IF( lk_floats     )   CALL     flo_init   ! drifting Floats 
    489       IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag 
    490489                            CALL dia_ptr_init   ! Poleward TRansports initialization 
    491490      IF( lk_diadct     )   CALL dia_dct_init   ! Sections tranports 
    … …  
    755754      ! ilfax contains the set of allowed factors. 
    756755      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    757       !!---------------------------------------------------------------------- 
    758       ! ilfax contains the set of allowed factors. 
    759       ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    760756 
    761757      ! Clear the error flag and initialise output vars 

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

    r7256 r7806  
    237237      IF( lk_diaar5  )      CALL dia_ar5( kstp )         ! ar5 diag 
    238238      IF( lk_diaharm )      CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     239                            CALL dia_prod( kstp )        ! ocean model: product diagnostics 
    239240                            CALL dia_wri( kstp )         ! ocean model: outputs 
    240241      ! 

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

    r7256 r7806  
    9595   USE diahsb           ! heat, salt and volume budgets    (dia_hsb routine) 
    9696   USE diaharm 
     97   USE diaprod          ! ocean model: product diagnostics 
    9798   USE flo_oce          ! floats variables 
    9899   USE floats           ! floats computation               (flo_stp routine) 

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

    r7256 r7806  
    180180      ENDIF 
    181181 
    182 9200  FORMAT('it:', i8, ' iter:', i4, ' r: ',e16.10, ' b: ',e16.10 ) 
    183 9300  FORMAT(' it :', i8, ' ssh2: ', e16.10, ' Umax: ',e16.10,' Smin: ',e16.10) 
     1829200  FORMAT('it:', i8, ' iter:', i4, ' r: ',d23.16, ' b: ',d23.16 ) 
     1839300  FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 
    184184      ! 
    185185   END SUBROUTINE stp_ctl 

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

    r7256 r7806  
    621621      ! 
    622622      ! lfax contains the set of allowed factors. 
    623       data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    624          &                            128,   64,   32,   16,    8,   4,   2  / 
    625       !!---------------------------------------------------------------------- 
     623      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    626624 
    627625      ! Clear the error flag and initialise output vars 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/par_my_trc.F90

    r3680 r7806  
    77   !!---------------------------------------------------------------------- 
    88   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    9    !! $Id$  
     9   !! $Id$ 
    1010   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    1111   !!---------------------------------------------------------------------- 
    … …  
    2525   USE par_c14b   , ONLY : jp_c14b_trd     !: number of tracers in C14 
    2626 
     27   USE par_age   , ONLY : jp_age         !: number of tracers in AGE 
     28   USE par_age   , ONLY : jp_age_2d      !: number of tracers in AGE 
     29   USE par_age   , ONLY : jp_age_3d      !: number of tracers in AGE 
     30   USE par_age   , ONLY : jp_age_trd     !: number of tracers in AGE 
     31 
    2732   IMPLICIT NONE 
    2833 
    29    INTEGER, PARAMETER ::   jp_lm      =  jp_pisces     + jp_cfc     + jp_c14b     !:  
    30    INTEGER, PARAMETER ::   jp_lm_2d   =  jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d  !: 
    31    INTEGER, PARAMETER ::   jp_lm_3d   =  jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d  !: 
    32    INTEGER, PARAMETER ::   jp_lm_trd  =  jp_pisces_trd + jp_cfc_trd + jp_c14b_trd !: 
     34   INTEGER, PARAMETER ::   jp_lm      =  jp_pisces     + jp_cfc     + jp_c14b     + jp_age      !:  
     35   INTEGER, PARAMETER ::   jp_lm_2d   =  jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d  + jp_age_2d   !: 
     36   INTEGER, PARAMETER ::   jp_lm_3d   =  jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d  + jp_age_3d   !: 
     37   INTEGER, PARAMETER ::   jp_lm_trd  =  jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_age_trd  !: 
    3338 
    3439#if defined key_my_trc 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90

    r7398 r7806  
    1111   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
    1212   !!                  !  2011-02  (J. Simeon, J.Orr ) update O2 solubility constants 
     13   !!             3.6  !  2016-03  (O. Aumont) Change chemistry to MOCSY standards 
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_pisces 
    1516   !!---------------------------------------------------------------------- 
    16    !!   'key_pisces'                                       PISCES bio-model 
     17   !!   'key_pisces*'                                      PISCES bio-model 
    1718   !!---------------------------------------------------------------------- 
    1819   !!   p4z_che      :  Sea water chemistry computed following OCMIP protocol 
    … …  
    2122   USE sms_pisces    !  PISCES Source Minus Sink variables 
    2223   USE lib_mpp       !  MPP library 
     24   USE eosbn2, ONLY : nn_eos 
    2325 
    2426   IMPLICIT NONE 
    2527   PRIVATE 
    2628 
    27    PUBLIC   p4z_che         ! 
    28    PUBLIC   p4z_che_alloc   ! 
    29  
    30    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sio3eq   ! chemistry of Si 
    31    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   fekeq    ! chemistry of Fe 
    32    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemc    ! Solubilities of O2 and CO2 
    33    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2   ! Solubilities of O2 and CO2 
     29   PUBLIC   p4z_che          ! 
     30   PUBLIC   p4z_che_alloc    ! 
     31   PUBLIC   p4z_che_ahini    ! 
     32   PUBLIC   p4z_che_solve_hi ! 
     33 
     34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: sio3eq   ! chemistry of Si 
     35   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: fekeq    ! chemistry of Fe 
     36   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: chemc    ! Solubilities of O2 and CO2 
     37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: chemo2    ! Solubilities of O2 and CO2 
     38   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: fesol    ! solubility of Fe 
    3439   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tempis   ! In situ temperature 
     40   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   salinprac  ! Practical salinity 
     41 
     42   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akb3       !: ??? 
     43   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akw3       !: ??? 
     44   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akf3       !: ??? 
     45   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aks3       !: ??? 
     46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ak1p3      !: ??? 
     47   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ak2p3      !: ??? 
     48   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ak3p3      !: ??? 
     49   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aksi3      !: ??? 
     50   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   borat      !: ??? 
     51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   fluorid    !: ??? 
     52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sulfat     !: ??? 
     53 
     54   !!* Variable for chemistry of the CO2 cycle 
    3555 
    3656   REAL(wp), PUBLIC ::   atcox  = 0.20946         ! units atm 
    3757 
    38    REAL(wp) ::   salchl = 1. / 1.80655    ! conversion factor for salinity --> chlorinity (Wooster et al. 1969) 
    3958   REAL(wp) ::   o2atm  = 1. / ( 1000. * 0.20946 )   
    4059 
    41    REAL(wp) ::   rgas   = 83.14472       ! universal gas constants 
    42    REAL(wp) ::   oxyco  = 1. / 22.4144   ! converts from liters of an ideal gas to moles 
    43  
    44    REAL(wp) ::   bor1   = 0.00023        ! borat constants 
    45    REAL(wp) ::   bor2   = 1. / 10.82 
    46  
    47    REAL(wp) ::   st1    =      0.14     ! constants for calculate concentrations for sulfate 
    48    REAL(wp) ::   st2    =  1./96.062    !  (Morris & Riley 1966) 
    49  
    50    REAL(wp) ::   ft1    =    0.000067   ! constants for calculate concentrations for fluorides 
    51    REAL(wp) ::   ft2    = 1./18.9984    ! (Dickson & Riley 1979 ) 
    52  
    53    !                                    ! volumetric solubility constants for o2 in ml/L   
    54    REAL(wp) ::   ox0    =  2.00856      ! from Table 1 for Eq 8 of Garcia and Gordon, 1992. 
    55    REAL(wp) ::   ox1    =  3.22400      ! corrects for moisture and fugacity, but not total atmospheric pressure 
    56    REAL(wp) ::   ox2    =  3.99063      !      Original PISCES code noted this was a solubility, but  
    57    REAL(wp) ::   ox3    =  4.80299      ! was in fact a bunsen coefficient with units L-O2/(Lsw atm-O2) 
    58    REAL(wp) ::   ox4    =  9.78188e-1   ! Hence, need to divide EXP( zoxy ) by 1000, ml-O2 => L-O2 
    59    REAL(wp) ::   ox5    =  1.71069      ! and atcox = 0.20946 to add the 1/atm dimension. 
    60    REAL(wp) ::   ox6    = -6.24097e-3    
    61    REAL(wp) ::   ox7    = -6.93498e-3  
    62    REAL(wp) ::   ox8    = -6.90358e-3 
    63    REAL(wp) ::   ox9    = -4.29155e-3  
    64    REAL(wp) ::   ox10   = -3.11680e-7  
     60   REAL(wp) ::   rgas   = 83.14472      ! universal gas constants 
     61   REAL(wp) ::   oxyco  = 1. / 22.4144  ! converts from liters of an ideal gas to moles 
    6562 
    6663   !                                    ! coeff. for seawater pressure correction : millero 95 
    6764   !                                    ! AGRIF doesn't like the DATA instruction 
    68    REAL(wp) :: devk11  = -25.5 
    69    REAL(wp) :: devk12  = -15.82 
    70    REAL(wp) :: devk13  = -29.48 
    71    REAL(wp) :: devk14  = -25.60 
    72    REAL(wp) :: devk15  = -48.76 
     65   REAL(wp) :: devk10  = -25.5 
     66   REAL(wp) :: devk11  = -15.82 
     67   REAL(wp) :: devk12  = -29.48 
     68   REAL(wp) :: devk13  = -20.02 
     69   REAL(wp) :: devk14  = -18.03 
     70   REAL(wp) :: devk15  = -9.78 
     71   REAL(wp) :: devk16  = -48.76 
     72   REAL(wp) :: devk17  = -14.51 
     73   REAL(wp) :: devk18  = -23.12 
     74   REAL(wp) :: devk19  = -26.57 
     75   REAL(wp) :: devk110  = -29.48 
    7376   ! 
    74    REAL(wp) :: devk21  = 0.1271 
    75    REAL(wp) :: devk22  = -0.0219 
    76    REAL(wp) :: devk23  = 0.1622 
    77    REAL(wp) :: devk24  = 0.2324 
    78    REAL(wp) :: devk25  = 0.5304 
     77   REAL(wp) :: devk20  = 0.1271 
     78   REAL(wp) :: devk21  = -0.0219 
     79   REAL(wp) :: devk22  = 0.1622 
     80   REAL(wp) :: devk23  = 0.1119 
     81   REAL(wp) :: devk24  = 0.0466 
     82   REAL(wp) :: devk25  = -0.0090 
     83   REAL(wp) :: devk26  = 0.5304 
     84   REAL(wp) :: devk27  = 0.1211 
     85   REAL(wp) :: devk28  = 0.1758 
     86   REAL(wp) :: devk29  = 0.2020 
     87   REAL(wp) :: devk210  = 0.1622 
    7988   ! 
     89   REAL(wp) :: devk30  = 0. 
    8090   REAL(wp) :: devk31  = 0. 
    81    REAL(wp) :: devk32  = 0. 
    82    REAL(wp) :: devk33  = 2.608E-3 
    83    REAL(wp) :: devk34  = -3.6246E-3 
    84    REAL(wp) :: devk35  = 0. 
     91   REAL(wp) :: devk32  = 2.608E-3 
     92   REAL(wp) :: devk33  = -1.409e-3 
     93   REAL(wp) :: devk34  = 0.316e-3 
     94   REAL(wp) :: devk35  = -0.942e-3 
     95   REAL(wp) :: devk36  = 0. 
     96   REAL(wp) :: devk37  = -0.321e-3 
     97   REAL(wp) :: devk38  = -2.647e-3 
     98   REAL(wp) :: devk39  = -3.042e-3 
     99   REAL(wp) :: devk310  = -2.6080e-3 
    85100   ! 
    86    REAL(wp) :: devk41  = -3.08E-3 
    87    REAL(wp) :: devk42  = 1.13E-3 
    88    REAL(wp) :: devk43  = -2.84E-3 
    89    REAL(wp) :: devk44  = -5.13E-3 
    90    REAL(wp) :: devk45  = -11.76E-3 
     101   REAL(wp) :: devk40  = -3.08E-3 
     102   REAL(wp) :: devk41  = 1.13E-3 
     103   REAL(wp) :: devk42  = -2.84E-3 
     104   REAL(wp) :: devk43  = -5.13E-3 
     105   REAL(wp) :: devk44  = -4.53e-3 
     106   REAL(wp) :: devk45  = -3.91e-3 
     107   REAL(wp) :: devk46  = -11.76e-3 
     108   REAL(wp) :: devk47  = -2.67e-3 
     109   REAL(wp) :: devk48  = -5.15e-3 
     110   REAL(wp) :: devk49  = -4.08e-3 
     111   REAL(wp) :: devk410  = -2.84e-3 
    91112   ! 
    92    REAL(wp) :: devk51  = 0.0877E-3 
    93    REAL(wp) :: devk52  = -0.1475E-3      
    94    REAL(wp) :: devk53  = 0. 
    95    REAL(wp) :: devk54  = 0.0794E-3       
    96    REAL(wp) :: devk55  = 0.3692E-3       
     113   REAL(wp) :: devk50  = 0.0877E-3 
     114   REAL(wp) :: devk51  = -0.1475E-3      
     115   REAL(wp) :: devk52  = 0. 
     116   REAL(wp) :: devk53  = 0.0794E-3       
     117   REAL(wp) :: devk54  = 0.09e-3 
     118   REAL(wp) :: devk55  = 0.054e-3 
     119   REAL(wp) :: devk56  = 0.3692E-3 
     120   REAL(wp) :: devk57  = 0.0427e-3 
     121   REAL(wp) :: devk58  = 0.09e-3 
     122   REAL(wp) :: devk59  = 0.0714e-3 
     123   REAL(wp) :: devk510  = 0.0 
     124   ! 
     125   ! General parameters 
     126   REAL(wp), PARAMETER :: pp_rdel_ah_target = 1.E-4_wp 
     127   REAL(wp), PARAMETER :: pp_ln10 = 2.302585092994045684018_wp 
     128 
     129   ! Maximum number of iterations for each method 
     130   INTEGER, PARAMETER :: jp_maxniter_atgen    = 20 
     131 
     132   ! Bookkeeping variables for each method 
     133   ! - SOLVE_AT_GENERAL 
     134   INTEGER :: niter_atgen    = jp_maxniter_atgen 
    97135 
    98136   !!* Substitution 
    … …  
    114152      !!--------------------------------------------------------------------- 
    115153      INTEGER  ::   ji, jj, jk 
    116       REAL(wp) ::   ztkel, zt   , zt2  , zsal  , zsal2 , zbuf1 , zbuf2 
     154      REAL(wp) ::   ztkel, ztkel1, zt , zsal  , zsal2 , zbuf1 , zbuf2 
    117155      REAL(wp) ::   ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 
    118156      REAL(wp) ::   zpres, ztc  , zcl   , zcpexp, zoxy  , zcpexp2 
    119157      REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1, zc1, zplat 
    120       REAL(wp) ::   zis  , zis2 , zsal15, zisqrt, za1  , za2 
     158      REAL(wp) ::   zis  , zis2 , zsal15, zisqrt, za1, za2 
    121159      REAL(wp) ::   zckb , zck1 , zck2  , zckw  , zak1 , zak2  , zakb , zaksp0, zakw 
     160      REAL(wp) ::   zck1p, zck2p, zck3p, zcksi, zak1p, zak2p, zak3p, zaksi 
    122161      REAL(wp) ::   zst  , zft  , zcks  , zckf  , zaksp1 
     162      REAL(wp) ::   total2free, free2SWS, total2SWS, SWS2total 
     163 
    123164      !!--------------------------------------------------------------------- 
    124165      ! 
    125166      IF( nn_timing == 1 )  CALL timing_start('p4z_che') 
     167      ! 
     168      ! Computation of chemical constants require practical salinity 
     169      ! Thus, when TEOS08 is used, absolute salinity is converted to  
     170      ! practical salinity 
     171      ! ------------------------------------------------------------- 
     172      IF (nn_eos == -1) THEN 
     173         salinprac(:,:,:) = tsn(:,:,:,jp_sal) * 35.0 / 35.16504 
     174      ELSE 
     175         salinprac(:,:,:) = tsn(:,:,:,jp_sal) 
     176      ENDIF 
     177 
    126178      ! 
    127179      ! Computations of chemical constants require in situ temperature 
    … …  
    134186            DO ji = 1, jpi 
    135187               zpres = fsdept(ji,jj,jk) / 1000. 
    136                za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (tsn(ji,jj,jk,jp_sal) - 35.0) ) 
     188               za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (salinprac(ji,jj,jk) - 35.0) ) 
    137189               za2 = 0.0075 * ( 1.0 - tsn(ji,jj,jk,jp_tem) / 30.0 ) 
    138190               tempis(ji,jj,jk) = tsn(ji,jj,jk,jp_tem) - za1 * zpres + za2 * zpres**2 
    … …  
    150202            ztkel = tempis(ji,jj,1) + 273.15 
    151203            zt    = ztkel * 0.01 
    152             zt2   = zt * zt 
    153             zsal  = tsn(ji,jj,1,jp_sal) + ( 1.- tmask(ji,jj,1) ) * 35. 
    154             zsal2 = zsal * zsal 
    155             zlogt = LOG( zt ) 
     204            zsal  = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. 
    156205            !                             ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 
    157206            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    158207            zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel    & 
    159208            &       + 0.0047036e-4*ztkel**2) 
    160             !                             ! SET SOLUBILITIES OF O2 AND CO2  
    161             chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(kg uatm) 
     209            chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 * rhop(ji,jj,1) / 1000. ! mol/(L atm) 
    162210            chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 
    163211            chemc(ji,jj,3) = 57.7 - 0.118*ztkel 
    … …  
    175223            DO ji = 1, jpi 
    176224              ztkel = tempis(ji,jj,jk) + 273.15 
    177               zsal  = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 
     225              zsal  = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35. 
    178226              zsal2 = zsal * zsal 
    179227              ztgg  = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
    … …  
    182230              ztgg4 = ztgg3 * ztgg 
    183231              ztgg5 = ztgg4 * ztgg 
    184               zoxy  = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5   & 
    185                      + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) +  ox10 * zsal2 
     232 
     233              zoxy  = 2.00856 + 3.22400 * ztgg + 3.99063 * ztgg2 + 4.80299 * ztgg3    & 
     234              &       + 9.78188e-1 * ztgg4 + 1.71069 * ztgg5 + zsal * ( -6.24097e-3   & 
     235              &       - 6.93498e-3 * ztgg - 6.90358e-3 * ztgg2 - 4.29155e-3 * ztgg3 )   & 
     236              &       - 3.11680e-7 * zsal2 
    186237              chemo2(ji,jj,jk) = ( EXP( zoxy ) * o2atm ) * oxyco * atcox     ! mol/(L atm) 
    187238            END DO 
    … …  
    208259               ! SET ABSOLUTE TEMPERATURE 
    209260               ztkel   = tempis(ji,jj,jk) + 273.15 
    210                zsal    = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 
     261               zsal    = salinprac(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. 
    211262               zsqrt  = SQRT( zsal ) 
    212263               zsal15  = zsqrt * zsal 
    … …  
    219270 
    220271               ! CHLORINITY (WOOSTER ET AL., 1969) 
    221                zcl     = zsal * salchl 
     272               zcl     = zsal / 1.80655 
    222273 
    223274               ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] 
    224                zst     = st1 * zcl * st2 
     275               zst     = 0.14 * zcl /96.062 
    225276 
    226277               ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 
    227                zft     = ft1 * zcl * ft2 
     278               zft     = 0.000067 * zcl /18.9984 
    228279 
    229280               ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 
    … …  
    233284               &         - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2         & 
    234285               &         + LOG(1.0 - 0.001005 * zsal)) 
    235                ! 
    236                aphscale(ji,jj,jk) = ( 1. + zst / zcks ) 
    237286 
    238287               ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 
    … …  
    248297               &      * zlogt + 0.053105*zsqrt*ztkel 
    249298 
    250  
    251299               ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO  
    252300               ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale 
    … …  
    256304                  - 0.01781*zsal + 0.0001122*zsal*zsal) 
    257305 
    258                ! PKW (H2O) (DICKSON AND RILEY, 1979) 
    259                zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt    &  
    260                &     + (118.67*ztr - 5.977 + 1.0495 * zlogt)        & 
    261                &     * zsqrt - 0.01615 * zsal 
     306               ! PKW (H2O) (MILLERO, 1995) from composite data 
     307               zckw    = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr    & 
     308                         - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal 
     309 
     310               ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) 
     311              zck1p    = -4576.752*ztr + 115.540 - 18.453*zlogt   & 
     312              &          + (-106.736*ztr + 0.69171) * zsqrt       & 
     313              &          + (-0.65643*ztr - 0.01844) * zsal 
     314 
     315              zck2p    = -8814.715*ztr + 172.1033 - 27.927*zlogt  & 
     316              &          + (-160.340*ztr + 1.3566)*zsqrt          & 
     317              &          + (0.37335*ztr - 0.05778)*zsal 
     318 
     319              zck3p    = -3070.75*ztr - 18.126                    & 
     320              &          + (17.27039*ztr + 2.81197) * zsqrt       & 
     321              &          + (-44.99486*ztr - 0.09984) * zsal  
     322 
     323              ! CONSTANT FOR SILICATE, MILLERO (1995) 
     324              zcksi    = -8904.2*ztr  + 117.400 - 19.334*zlogt   & 
     325              &          + (-458.79*ztr + 3.5913) * zisqrt       & 
     326              &          + (188.74*ztr - 1.5998) * zis           & 
     327              &          + (-12.1652*ztr + 0.07871) * zis2       & 
     328              &          + LOG(1.0 - 0.001005*zsal) 
    262329 
    263330               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    … …  
    267334                  &      - 0.07711*zsal + 0.0041249*zsal15 
    268335 
     336               ! CONVERT FROM DIFFERENT PH SCALES 
     337               total2free  = 1.0/(1.0 + zst/zcks) 
     338               free2SWS    = 1. + zst/zcks + zft/(zckf*total2free) 
     339               total2SWS   = total2free * free2SWS 
     340               SWS2total   = 1.0 / total2SWS 
     341 
    269342               ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 
    270                zak1    = 10**(zck1) 
    271                zak2    = 10**(zck2) 
    272                zakb    = EXP( zckb  ) 
     343               zak1    = 10**(zck1) * total2SWS 
     344               zak2    = 10**(zck2) * total2SWS 
     345               zakb    = EXP( zckb ) * total2SWS 
    273346               zakw    = EXP( zckw ) 
    274347               zaksp1  = 10**(zaksp0) 
     348               zak1p   = exp( zck1p ) 
     349               zak2p   = exp( zck2p ) 
     350               zak3p   = exp( zck3p ) 
     351               zaksi   = exp( zcksi ) 
     352               zckf    = zckf * total2SWS 
    275353 
    276354               ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) 
    … …  
    284362               !        FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 
    285363               !        SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) 
    286                zcpexp  = zpres /(rgas*ztkel) 
    287                zcpexp2 = zpres * zpres/(rgas*ztkel) 
     364               zcpexp  = zpres / (rgas*ztkel) 
     365               zcpexp2 = zpres * zcpexp 
    288366 
    289367               ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE 
    … …  
    291369               !        (CF. BROECKER ET AL., 1982) 
    292370 
    293                zbuf1  = -     ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 
     371               zbuf1  = -     ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) 
     372               zbuf2  = 0.5 * ( devk40 + devk50 * ztc ) 
     373               ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     374 
     375               zbuf1  =     - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 
    294376               zbuf2  = 0.5 * ( devk41 + devk51 * ztc ) 
    295                ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     377               ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
    296378 
    297379               zbuf1  =     - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) 
    298380               zbuf2  = 0.5 * ( devk42 + devk52 * ztc ) 
    299                ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     381               akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
    300382 
    301383               zbuf1  =     - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) 
    302384               zbuf2  = 0.5 * ( devk43 + devk53 * ztc ) 
    303                akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     385               akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
    304386 
    305387               zbuf1  =     - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) 
    306388               zbuf2  = 0.5 * ( devk44 + devk54 * ztc ) 
    307                akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
    308  
     389               aks3(ji,jj,jk) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     390 
     391               zbuf1  =     - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) 
     392               zbuf2  = 0.5 * ( devk45 + devk55 * ztc ) 
     393               akf3(ji,jj,jk) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     394 
     395               zbuf1  =     - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) 
     396               zbuf2  = 0.5 * ( devk47 + devk57 * ztc ) 
     397               ak1p3(ji,jj,jk) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     398 
     399               zbuf1  =     - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) 
     400               zbuf2  = 0.5 * ( devk48 + devk58 * ztc ) 
     401               ak2p3(ji,jj,jk) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     402 
     403               zbuf1  =     - ( devk19 + devk29 * ztc + devk39 * ztc * ztc ) 
     404               zbuf2  = 0.5 * ( devk49 + devk59 * ztc ) 
     405               ak3p3(ji,jj,jk) = zak3p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     406 
     407               zbuf1  =     - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) 
     408               zbuf2  = 0.5 * ( devk410 + devk510 * ztc ) 
     409               aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     410 
     411               ! CONVERT FROM DIFFERENT PH SCALES 
     412               total2free  = 1.0/(1.0 + zst/aks3(ji,jj,jk)) 
     413               free2SWS    = 1. + zst/aks3(ji,jj,jk) + zft/akf3(ji,jj,jk) 
     414               total2SWS   = total2free * free2SWS 
     415               SWS2total   = 1.0 / total2SWS 
     416 
     417               ! Convert to total scale 
     418               ak13(ji,jj,jk)  = ak13(ji,jj,jk)  * SWS2total 
     419               ak23(ji,jj,jk)  = ak23(ji,jj,jk)  * SWS2total 
     420               akb3(ji,jj,jk)  = akb3(ji,jj,jk)  * SWS2total 
     421               akw3(ji,jj,jk)  = akw3(ji,jj,jk)  * SWS2total 
     422               ak1p3(ji,jj,jk) = ak1p3(ji,jj,jk) * SWS2total 
     423               ak2p3(ji,jj,jk) = ak2p3(ji,jj,jk) * SWS2total 
     424               ak3p3(ji,jj,jk) = ak3p3(ji,jj,jk) * SWS2total 
     425               aksi3(ji,jj,jk) = aksi3(ji,jj,jk) * SWS2total 
     426               akf3(ji,jj,jk)  = akf3(ji,jj,jk)  / total2free 
    309427 
    310428               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE  
    311429               !        AS FUNCTION OF PRESSURE FOLLOWING MILLERO 
    312430               !        (P. 1285) AND BERNER (1976) 
    313                zbuf1  =     - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) 
    314                zbuf2  = 0.5 * ( devk45 + devk55 * ztc ) 
     431               zbuf1  =     - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) 
     432               zbuf2  = 0.5 * ( devk46 + devk56 * ztc ) 
    315433               aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
    316434 
    317                ! TOTAL BORATE CONCENTR. [MOLES/L] 
    318                borat(ji,jj,jk) = bor1 * zcl * bor2 
     435               ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] 
     436               borat(ji,jj,jk) = 0.0002414 * zcl / 10.811 
     437               sulfat(ji,jj,jk) = zst 
     438               fluorid(ji,jj,jk) = zft  
    319439 
    320440               ! Iron and SIO3 saturation concentration from ... 
    321441               sio3eq(ji,jj,jk) = EXP(  LOG( 10.) * ( 6.44 - 968. / ztkel )  ) * 1.e-6 
    322                fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ( 273.15 + ztc ) ) 
    323  
     442               fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ztkel ) 
     443 
     444               ! Liu and Millero (1999) only valid 5 - 50 degC 
     445               ztkel1 = MAX( 5. , tempis(ji,jj,jk) ) + 273.16 
     446               fesol(ji,jj,jk,1) = 10**((-13.486) - (0.1856* (zis**0.5)) + (0.3073*zis) + (5254.0/ztkel1)) 
     447               fesol(ji,jj,jk,2) = 10**(2.517 - (0.885*(zis**0.5)) + (0.2139 * zis) - (1320.0/ztkel1) ) 
     448               fesol(ji,jj,jk,3) = 10**(0.4511 - (0.3305*(zis**0.5)) - (1996.0/ztkel1) ) 
     449               fesol(ji,jj,jk,4) = 10**(-0.2965 - (0.7881*(zis**0.5)) - (4086.0/ztkel1) ) 
     450               fesol(ji,jj,jk,5) = 10**(4.4466 - (0.8505*(zis**0.5)) - (7980.0/ztkel1) ) 
    324451            END DO 
    325452         END DO 
    … …  
    330457   END SUBROUTINE p4z_che 
    331458 
     459   SUBROUTINE p4z_che_ahini( p_hini ) 
     460      !!--------------------------------------------------------------------- 
     461      !!                     ***  ROUTINE ahini_for_at  *** 
     462      !! 
     463      !! Subroutine returns the root for the 2nd order approximation of the 
     464      !! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic  
     465      !! polynomial) around the local minimum, if it exists. 
     466      !! Returns * 1E-03_wp if p_alkcb <= 0 
     467      !!         * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot 
     468      !!         * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot 
     469      !!                    and the 2nd order approximation does not have  
     470      !!                    a solution 
     471      !!--------------------------------------------------------------------- 
     472      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT)  ::  p_hini 
     473      INTEGER  ::   ji, jj, jk 
     474      REAL(wp)  ::  zca1, zba1 
     475      REAL(wp)  ::  zd, zsqrtd, zhmin 
     476      REAL(wp)  ::  za2, za1, za0 
     477      REAL(wp)  ::  p_dictot, p_bortot, p_alkcb  
     478 
     479      IF( nn_timing == 1 )  CALL timing_start('p4z_che_ahini') 
     480      ! 
     481      DO jk = 1, jpk 
     482        DO jj = 1, jpj 
     483          DO ji = 1, jpi 
     484            p_alkcb  = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) 
     485            p_dictot = trb(ji,jj,jk,jpdic) * 1000. / (rhop(ji,jj,jk) + rtrn) 
     486            p_bortot = borat(ji,jj,jk) 
     487            IF (p_alkcb <= 0.) THEN 
     488                p_hini(ji,jj,jk) = 1.e-3 
     489            ELSEIF (p_alkcb >= (2.*p_dictot + p_bortot)) THEN 
     490                p_hini(ji,jj,jk) = 1.e-10_wp 
     491            ELSE 
     492                zca1 = p_dictot/( p_alkcb + rtrn ) 
     493                zba1 = p_bortot/ (p_alkcb + rtrn ) 
     494           ! Coefficients of the cubic polynomial 
     495                za2 = aKb3(ji,jj,jk)*(1. - zba1) + ak13(ji,jj,jk)*(1.-zca1) 
     496                za1 = ak13(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - zca1)    & 
     497                &     + ak13(ji,jj,jk)*ak23(ji,jj,jk)*(1. - (zca1+zca1)) 
     498                za0 = ak13(ji,jj,jk)*ak23(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - (zca1+zca1)) 
     499                                        ! Taylor expansion around the minimum 
     500                zd = za2*za2 - 3.*za1   ! Discriminant of the quadratic equation 
     501                                        ! for the minimum close to the root 
     502 
     503                IF(zd > 0.) THEN        ! If the discriminant is positive 
     504                  zsqrtd = SQRT(zd) 
     505                  IF(za2 < 0) THEN 
     506                    zhmin = (-za2 + zsqrtd)/3. 
     507                  ELSE 
     508                    zhmin = -za1/(za2 + zsqrtd) 
     509                  ENDIF 
     510                  p_hini(ji,jj,jk) = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd) 
     511                ELSE 
     512                  p_hini(ji,jj,jk) = 1.e-7 
     513                ENDIF 
     514             ! 
     515             ENDIF 
     516          END DO 
     517        END DO 
     518      END DO 
     519      ! 
     520      IF( nn_timing == 1 )  CALL timing_stop('p4z_che_ahini') 
     521      ! 
     522   END SUBROUTINE p4z_che_ahini 
     523 
     524   !=============================================================================== 
     525   SUBROUTINE anw_infsup( p_alknw_inf, p_alknw_sup ) 
     526 
     527   ! Subroutine returns the lower and upper bounds of "non-water-selfionization" 
     528   ! contributions to total alkalinity (the infimum and the supremum), i.e 
     529   ! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+]) 
     530 
     531   ! Argument variables 
     532   REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_inf 
     533   REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_sup 
     534 
     535   p_alknw_inf(:,:,:) =  -trb(:,:,:,jppo4) * 1000. / (rhop(:,:,:) + rtrn) - sulfat(:,:,:)  & 
     536   &              - fluorid(:,:,:) 
     537   p_alknw_sup(:,:,:) =   (2. * trb(:,:,:,jpdic) + 2. * trb(:,:,:,jppo4) + trb(:,:,:,jpsil) )    & 
     538   &               * 1000. / (rhop(:,:,:) + rtrn) + borat(:,:,:)  
     539 
     540   END SUBROUTINE anw_infsup 
     541 
     542 
     543   SUBROUTINE p4z_che_solve_hi( p_hini, zhi ) 
     544 
     545   ! Universal pH solver that converges from any given initial value, 
     546   ! determines upper an lower bounds for the solution if required 
     547 
     548   ! Argument variables 
     549   !-------------------- 
     550   REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(IN)   :: p_hini 
     551   REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT)  :: zhi 
     552 
     553   ! Local variables 
     554   !----------------- 
     555   INTEGER   ::  ji, jj, jk, jn 
     556   REAL(wp)  ::  zh_ini, zh, zh_prev, zh_lnfactor 
     557   REAL(wp)  ::  zdelta, zh_delta 
     558   REAL(wp)  ::  zeqn, zdeqndh, zalka 
     559   REAL(wp)  ::  aphscale 
     560   REAL(wp)  ::  znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic 
     561   REAL(wp)  ::  znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor 
     562   REAL(wp)  ::  znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4 
     563   REAL(wp)  ::  znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil 
     564   REAL(wp)  ::  znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4 
     565   REAL(wp)  ::  znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu 
     566   REAL(wp)  ::  zalk_wat, zdalk_wat 
     567   REAL(wp)  ::  zfact, p_alktot, zdic, zbot, zpt, zst, zft, zsit 
     568   LOGICAL   ::  l_exitnow 
     569   REAL(wp), PARAMETER :: pz_exp_threshold = 1.0 
     570   REAL(wp), POINTER, DIMENSION(:,:,:) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin 
     571 
     572   IF( nn_timing == 1 )  CALL timing_start('p4z_che_solve_hi') 
     573      !  Allocate temporary workspace 
     574   CALL wrk_alloc( jpi, jpj, jpk, zalknw_inf, zalknw_sup, rmask ) 
     575   CALL wrk_alloc( jpi, jpj, jpk, zh_min, zh_max, zeqn_absmin ) 
     576 
     577   CALL anw_infsup( zalknw_inf, zalknw_sup ) 
     578 
     579   rmask(:,:,:) = tmask(:,:,:) 
     580   zhi(:,:,:)   = 0. 
     581 
     582   ! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree 
     583   DO jk = 1, jpk 
     584      DO jj = 1, jpj 
     585         DO ji = 1, jpi 
     586            IF (rmask(ji,jj,jk) == 1.) THEN 
     587               p_alktot = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) 
     588               aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) 
     589               zh_ini = p_hini(ji,jj,jk) 
     590 
     591               zdelta = (p_alktot-zalknw_inf(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale 
     592 
     593               IF(p_alktot >= zalknw_inf(ji,jj,jk)) THEN 
     594                 zh_min(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_inf(ji,jj,jk) + SQRT(zdelta) ) 
     595               ELSE 
     596                 zh_min(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_inf(ji,jj,jk)) + SQRT(zdelta) ) / 2. 
     597               ENDIF 
     598 
     599               zdelta = (p_alktot-zalknw_sup(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale 
     600 
     601               IF(p_alktot <= zalknw_sup(ji,jj,jk)) THEN 
     602                 zh_max(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_sup(ji,jj,jk)) + SQRT(zdelta) ) / 2. 
     603               ELSE 
     604                 zh_max(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_sup(ji,jj,jk) + SQRT(zdelta) ) 
     605               ENDIF 
     606 
     607               zhi(ji,jj,jk) = MAX(MIN(zh_max(ji,jj,jk), zh_ini), zh_min(ji,jj,jk)) 
     608            ENDIF 
     609         END DO 
     610      END DO 
     611   END DO 
     612 
     613   zeqn_absmin(:,:,:) = HUGE(1._wp) 
     614 
     615   DO jn = 1, jp_maxniter_atgen  
     616   DO jk = 1, jpk 
     617      DO jj = 1, jpj 
     618         DO ji = 1, jpi 
     619            IF (rmask(ji,jj,jk) == 1.) THEN 
     620               zfact = rhop(ji,jj,jk) / 1000. + rtrn 
     621               p_alktot = trb(ji,jj,jk,jptal) / zfact 
     622               zdic  = trb(ji,jj,jk,jpdic) / zfact 
     623               zbot  = borat(ji,jj,jk) 
     624               zpt = trb(ji,jj,jk,jppo4) / zfact * po4r 
     625               zsit = trb(ji,jj,jk,jpsil) / zfact 
     626               zst = sulfat (ji,jj,jk) 
     627               zft = fluorid(ji,jj,jk) 
     628               aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) 
     629               zh = zhi(ji,jj,jk) 
     630               zh_prev = zh 
     631 
     632               ! H2CO3 - HCO3 - CO3 : n=2, m=0 
     633               znumer_dic = 2.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk) 
     634               zdenom_dic = ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*(ak13(ji,jj,jk) + zh) 
     635               zalk_dic   = zdic * (znumer_dic/zdenom_dic) 
     636               zdnumer_dic = ak13(ji,jj,jk)*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh     & 
     637                             *(4.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk)) 
     638               zdalk_dic   = -zdic*(zdnumer_dic/zdenom_dic**2) 
     639 
     640 
     641               ! B(OH)3 - B(OH)4 : n=1, m=0 
     642               znumer_bor = akb3(ji,jj,jk) 
     643               zdenom_bor = akb3(ji,jj,jk) + zh 
     644               zalk_bor   = zbot * (znumer_bor/zdenom_bor) 
     645               zdnumer_bor = akb3(ji,jj,jk) 
     646               zdalk_bor   = -zbot*(zdnumer_bor/zdenom_bor**2) 
     647 
     648 
     649               ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1 
     650               znumer_po4 = 3.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk)  & 
     651               &            + zh*(2.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh* ak1p3(ji,jj,jk)) 
     652               zdenom_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk)     & 
     653               &            + zh*( ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh*(ak1p3(ji,jj,jk) + zh)) 
     654               zalk_po4   = zpt * (znumer_po4/zdenom_po4 - 1.) ! Zero level of H3PO4 = 1 
     655               zdnumer_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk)  & 
     656               &             + zh*(4.*ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk)         & 
     657               &             + zh*(9.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk)                         & 
     658               &             + ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)                                & 
     659               &             + zh*(4.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh * ak1p3(ji,jj,jk) ) ) ) 
     660               zdalk_po4   = -zpt * (zdnumer_po4/zdenom_po4**2) 
     661 
     662               ! H4SiO4 - H3SiO4 : n=1, m=0 
     663               znumer_sil = aksi3(ji,jj,jk) 
     664               zdenom_sil = aksi3(ji,jj,jk) + zh 
     665               zalk_sil   = zsit * (znumer_sil/zdenom_sil) 
     666               zdnumer_sil = aksi3(ji,jj,jk) 
     667               zdalk_sil   = -zsit * (zdnumer_sil/zdenom_sil**2) 
     668 
     669               ! HSO4 - SO4 : n=1, m=1 
     670               aphscale = 1.0 + zst/aks3(ji,jj,jk) 
     671               znumer_so4 = aks3(ji,jj,jk) * aphscale 
     672               zdenom_so4 = aks3(ji,jj,jk) * aphscale + zh 
     673               zalk_so4   = zst * (znumer_so4/zdenom_so4 - 1.) 
     674               zdnumer_so4 = aks3(ji,jj,jk) 
     675               zdalk_so4   = -zst * (zdnumer_so4/zdenom_so4**2) 
     676 
     677               ! HF - F : n=1, m=1 
     678               znumer_flu =  akf3(ji,jj,jk) 
     679               zdenom_flu =  akf3(ji,jj,jk) + zh 
     680               zalk_flu   =  zft * (znumer_flu/zdenom_flu - 1.) 
     681               zdnumer_flu = akf3(ji,jj,jk) 
     682               zdalk_flu   = -zft * (zdnumer_flu/zdenom_flu**2) 
     683 
     684               ! H2O - OH 
     685               aphscale = 1.0 + zst/aks3(ji,jj,jk) 
     686               zalk_wat   = akw3(ji,jj,jk)/zh - zh/aphscale 
     687               zdalk_wat  = -akw3(ji,jj,jk)/zh**2 - 1./aphscale 
     688 
     689               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
     690               zeqn = zalk_dic + zalk_bor + zalk_po4 + zalk_sil   & 
     691               &      + zalk_so4 + zalk_flu                       & 
     692               &      + zalk_wat - p_alktot 
     693 
     694               zalka = p_alktot - (zalk_bor + zalk_po4 + zalk_sil   & 
     695               &       + zalk_so4 + zalk_flu + zalk_wat) 
     696 
     697               zdeqndh = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil & 
     698               &         + zdalk_so4 + zdalk_flu + zdalk_wat 
     699 
     700               ! Adapt bracketing interval 
     701               IF(zeqn > 0._wp) THEN 
     702                 zh_min(ji,jj,jk) = zh_prev 
     703               ELSEIF(zeqn < 0._wp) THEN 
     704                 zh_max(ji,jj,jk) = zh_prev 
     705               ENDIF 
     706 
     707               IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin(ji,jj,jk)) THEN 
     708               ! if the function evaluation at the current point is 
     709               ! not decreasing faster than with a bisection step (at least linearly) 
     710               ! in absolute value take one bisection step on [ph_min, ph_max] 
     711               ! ph_new = (ph_min + ph_max)/2d0 
     712               ! 
     713               ! In terms of [H]_new: 
     714               ! [H]_new = 10**(-ph_new) 
     715               !         = 10**(-(ph_min + ph_max)/2d0) 
     716               !         = SQRT(10**(-(ph_min + phmax))) 
     717               !         = SQRT(zh_max * zh_min) 
     718                  zh = SQRT(zh_max(ji,jj,jk) * zh_min(ji,jj,jk)) 
     719                  zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below 
     720               ELSE 
     721               ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH 
     722               !           = -zdeqndh * LOG(10) * [H] 
     723               ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10)) 
     724               ! 
     725               ! pH_new = pH_old + \deltapH 
     726               ! 
     727               ! [H]_new = 10**(-pH_new) 
     728               !         = 10**(-pH_old - \Delta pH) 
     729               !         = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10))) 
     730               !         = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10))) 
     731               !         = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old)) 
     732 
     733                  zh_lnfactor = -zeqn/(zdeqndh*zh_prev) 
     734 
     735                  IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN 
     736                     zh          = zh_prev*EXP(zh_lnfactor) 
     737                  ELSE 
     738                     zh_delta    = zh_lnfactor*zh_prev 
     739                     zh          = zh_prev + zh_delta 
     740                  ENDIF 
     741 
     742                  IF( zh < zh_min(ji,jj,jk) ) THEN 
     743                     ! if [H]_new < [H]_min 
     744                     ! i.e., if ph_new > ph_max then 
     745                     ! take one bisection step on [ph_prev, ph_max] 
     746                     ! ph_new = (ph_prev + ph_max)/2d0 
     747                     ! In terms of [H]_new: 
     748                     ! [H]_new = 10**(-ph_new) 
     749                     !         = 10**(-(ph_prev + ph_max)/2d0) 
     750                     !         = SQRT(10**(-(ph_prev + phmax))) 
     751                     !         = SQRT([H]_old*10**(-ph_max)) 
     752                     !         = SQRT([H]_old * zh_min) 
     753                     zh                = SQRT(zh_prev * zh_min(ji,jj,jk)) 
     754                     zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below 
     755                  ENDIF 
     756 
     757                  IF( zh > zh_max(ji,jj,jk) ) THEN 
     758                     ! if [H]_new > [H]_max 
     759                     ! i.e., if ph_new < ph_min, then 
     760                     ! take one bisection step on [ph_min, ph_prev] 
     761                     ! ph_new = (ph_prev + ph_min)/2d0 
     762                     ! In terms of [H]_new: 
     763                     ! [H]_new = 10**(-ph_new) 
     764                     !         = 10**(-(ph_prev + ph_min)/2d0) 
     765                     !         = SQRT(10**(-(ph_prev + ph_min))) 
     766                     !         = SQRT([H]_old*10**(-ph_min)) 
     767                     !         = SQRT([H]_old * zhmax) 
     768                     zh                = SQRT(zh_prev * zh_max(ji,jj,jk)) 
     769                     zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below 
     770                  ENDIF 
     771               ENDIF 
     772 
     773               zeqn_absmin(ji,jj,jk) = MIN( ABS(zeqn), zeqn_absmin(ji,jj,jk)) 
     774 
     775               ! Stop iterations once |\delta{[H]}/[H]| < rdel 
     776               ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel 
     777               ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)| 
     778 
     779               ! Alternatively: 
     780               ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))| 
     781               !             ~ 1/LOG(10) * |\Delta [H]|/[H] 
     782               !             < 1/LOG(10) * rdel 
     783 
     784               ! Hence |zeqn/(zdeqndh*zh)| < rdel 
     785 
     786               ! rdel <-- pp_rdel_ah_target 
     787               l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target) 
     788 
     789               IF(l_exitnow) THEN  
     790                  rmask(ji,jj,jk) = 0. 
     791               ENDIF 
     792 
     793               zhi(ji,jj,jk) =  zh 
     794 
     795               IF(jn >= jp_maxniter_atgen) THEN 
     796                  zhi(ji,jj,jk) = -1._wp 
     797               ENDIF 
     798 
     799            ENDIF 
     800         END DO 
     801      END DO 
     802   END DO 
     803   END DO 
     804   ! 
     805   CALL wrk_dealloc( jpi, jpj, jpk, zalknw_inf, zalknw_sup, rmask ) 
     806   CALL wrk_dealloc( jpi, jpj, jpk, zh_min, zh_max, zeqn_absmin ) 
     807 
     808 
     809   IF( nn_timing == 1 )  CALL timing_stop('p4z_che_solve_hi') 
     810 
     811 
     812   END SUBROUTINE p4z_che_solve_hi 
    332813 
    333814   INTEGER FUNCTION p4z_che_alloc() 
    … …  
    335816      !!                     ***  ROUTINE p4z_che_alloc  *** 
    336817      !!---------------------------------------------------------------------- 
    337       ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk),   & 
    338       &         tempis(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
     818      INTEGER ::   ierr(3)        ! Local variables 
     819      !!---------------------------------------------------------------------- 
     820 
     821      ierr(:) = 0 
     822 
     823      ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk), STAT=ierr(1) ) 
     824 
     825      ALLOCATE( akb3(jpi,jpj,jpk)     , tempis(jpi, jpj, jpk),       & 
     826         &      akw3(jpi,jpj,jpk)     , borat (jpi,jpj,jpk)  ,       & 
     827         &      aks3(jpi,jpj,jpk)     , akf3(jpi,jpj,jpk)    ,       & 
     828         &      ak1p3(jpi,jpj,jpk)    , ak2p3(jpi,jpj,jpk)   ,       & 
     829         &      ak3p3(jpi,jpj,jpk)    , aksi3(jpi,jpj,jpk)   ,       & 
     830         &      fluorid(jpi,jpj,jpk)  , sulfat(jpi,jpj,jpk)  ,       & 
     831         &      salinprac(jpi,jpj,jpk),                 STAT=ierr(2) ) 
     832 
     833      ALLOCATE( fesol(jpi,jpj,jpk,5), STAT=ierr(3) ) 
     834 
     835      !* Variable for chemistry of the CO2 cycle 
     836      p4z_che_alloc = MAXVAL( ierr ) 
    339837      ! 
    340838      IF( p4z_che_alloc /= 0 )   CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') 
    … …  
    354852 
    355853   !!====================================================================== 
    356 END MODULE p4zche 
     854END MODULE  p4zche 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r7398 r7806  
    8585      REAL(wp) ::   zfld, zflu, zfld16, zflu16, zfact 
    8686      REAL(wp) ::   zvapsw, zsal, zfco2, zxc2, xCO2approx, ztkel, zfugcoeff 
    87       REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 
     87      REAL(wp) ::   zph, zdic, zsch_o2, zsch_co2 
    8888      REAL(wp) ::   zyr_dec, zdco2dt 
    8989      CHARACTER (len=25) :: charout 
    … …  
    120120#endif 
    121121 
    122       DO jm = 1, 10 
    123 !CDIR NOVERRCHK 
    124          DO jj = 1, jpj 
    125 !CDIR NOVERRCHK 
    126             DO ji = 1, jpi 
    127  
    128                ! DUMMY VARIABLES FOR DIC, H+, AND BORATE 
    129                zbot  = borat(ji,jj,1) 
    130                zfact = rhop(ji,jj,1) / 1000. + rtrn 
    131                zdic  = trb(ji,jj,1,jpdic) / zfact 
    132                zph   = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 
    133                zalka = trb(ji,jj,1,jptal) / zfact 
    134  
    135                ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    136                zalk  = zalka - (  akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1)    & 
    137                &       + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
    138  
    139                ! CALCULATE [H+] AND [H2CO3] 
    140                zah2   = SQRT(  (zdic-zalk)**2 + 4.* ( zalk * ak23(ji,jj,1)   & 
    141                   &                                        / ak13(ji,jj,1) ) * ( 2.* zdic - zalk )  ) 
    142                zah2   = 0.5 * ak13(ji,jj,1) / zalk * ( ( zdic - zalk ) + zah2 ) 
    143                zh2co3(ji,jj) = ( 2.* zdic - zalk ) / ( 2.+ ak13(ji,jj,1) / zah2 ) * zfact 
    144                hi(ji,jj,1)   = zah2 * zfact 
    145             END DO 
     122      DO jj = 1, jpj 
     123         DO ji = 1, jpi 
     124            ! DUMMY VARIABLES FOR DIC, H+, AND BORATE 
     125            zfact = rhop(ji,jj,1) / 1000. + rtrn 
     126            zdic  = trb(ji,jj,1,jpdic) 
     127            zph   = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 
     128            ! CALCULATE [H2CO3] 
     129            zh2co3(ji,jj) = zdic/(1. + ak13(ji,jj,1)/zph + ak13(ji,jj,1)*ak23(ji,jj,1)/zph**2) 
    146130         END DO 
    147131      END DO 
    148  
    149132 
    150133      ! -------------- 
    … …  
    262245      ENDIF 
    263246      ! 
     247#if defined key_cpl_carbon_cycle 
     248      ! change units for carbon cycle coupling 
     249      oce_co2(:,:) = oce_co2(:,:) / e1e2t(:,:) * rfact2r ! in molC/m2/s 
     250#endif 
     251      ! 
    264252      CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 
    265253      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90

    r7398 r7806  
    2222   USE sms_pisces      !  PISCES Source Minus Sink variables 
    2323   USE prtctl_trc,ONLY : prt_ctl_trc_info,prt_ctl_trc !  print control for debugging 
     24   USE p4zche 
    2425 
    2526   IMPLICIT NONE 
    … …  
    5859      ! 
    5960      INTEGER, INTENT(in) ::   kt, knt ! ocean time step 
    60       INTEGER  ::   ji, jj, jk, jn 
    61       REAL(wp) ::   zalk, zdic, zph, zah2 
    62       REAL(wp) ::   zdispot, zfact, zcalcon, zalka, zaldi 
     61      INTEGER  ::   ji, jj, jk 
     62      REAL(wp) ::   zdispot, zfact, zcalcon 
    6363      REAL(wp) ::   zomegaca, zexcess, zexcess0 
    6464      CHARACTER (len=25) :: charout 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss    
     65      REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss, zhinit, zhi    
    6666      !!--------------------------------------------------------------------- 
    6767      ! 
    6868      IF( nn_timing == 1 )  CALL timing_start('p4z_lys') 
    6969      ! 
    70       CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
     70      CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss, zhinit, zhi ) 
    7171      ! 
    7272      zco3    (:,:,:) = 0. 
    7373      zcaldiss(:,:,:) = 0. 
     74      zhinit(:,:,:)   = hi(:,:,:) * 1000. / ( rhop(:,:,:) + rtrn ) 
    7475      !     ------------------------------------------- 
    7576      !     COMPUTE [CO3--] and [H+] CONCENTRATIONS 
    7677      !     ------------------------------------------- 
    77        
    78       DO jn = 1, 5                               !  BEGIN OF ITERATION 
    79          ! 
    80 !CDIR NOVERRCHK 
    81          DO jk = 1, jpkm1 
    82 !CDIR NOVERRCHK 
    83             DO jj = 1, jpj 
    84 !CDIR NOVERRCHK 
    85                DO ji = 1, jpi 
    86                   zfact = rhop(ji,jj,jk) / 1000. + rtrn 
    87                   zph  = hi(ji,jj,jk) * tmask(ji,jj,jk) / zfact + ( 1.-tmask(ji,jj,jk) ) * 1.e-9 ! [H+] 
    88                   zdic  = trb(ji,jj,jk,jpdic) / zfact 
    89                   zalka = trb(ji,jj,jk,jptal) / zfact 
    90                   ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    91                   zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn )  & 
    92                   &       + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
    93                   ! CALCULATE [H+] and [CO3--] 
    94                   zaldi = zdic - zalk 
    95                   zah2  = SQRT( zaldi * zaldi + 4.* ( zalk * ak23(ji,jj,jk) / ak13(ji,jj,jk) ) * ( zdic + zaldi ) ) 
    96                   zah2  = 0.5 * ak13(ji,jj,jk) / zalk * ( zaldi + zah2 ) 
    97                   ! 
    98                   zco3(ji,jj,jk) = zalk / ( 2. + zah2 / ak23(ji,jj,jk) ) * zfact 
    99                   hi(ji,jj,jk)   = zah2 * zfact 
    100                END DO 
     78 
     79      CALL p4z_che_solve_hi( zhinit, zhi ) 
     80 
     81      DO jk = 1, jpkm1 
     82         DO jj = 1, jpj 
     83            DO ji = 1, jpi 
     84               zco3(ji,jj,jk) = trb(ji,jj,jk,jpdic) * ak13(ji,jj,jk) * ak23(ji,jj,jk) / (zhi(ji,jj,jk)**2   & 
     85               &                + ak13(ji,jj,jk) * zhi(ji,jj,jk) + ak13(ji,jj,jk) * ak23(ji,jj,jk) + rtrn ) 
     86               hi(ji,jj,jk)   = zhi(ji,jj,jk) * rhop(ji,jj,jk) / 1000. 
    10187            END DO 
    10288         END DO 
    103          ! 
    104       END DO  
     89      END DO 
    10590 
    10691      !     --------------------------------------------------------- 
    … …  
    136121              !       AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION 
    137122              zcaldiss(ji,jj,jk)  = zdispot * rfact2 / rmtss ! calcite dissolution 
    138               zco3(ji,jj,jk)      = zco3(ji,jj,jk) + zcaldiss(ji,jj,jk) 
    139123              ! 
    140124              tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2. * zcaldiss(ji,jj,jk) 
    … …  
    165149      ENDIF 
    166150      ! 
    167       CALL wrk_dealloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
     151      CALL wrk_dealloc( jpi, jpj, jpk, zco3, zcaldiss, zhinit, zhi, zco3sat ) 
    168152      ! 
    169153      IF( nn_timing == 1 )  CALL timing_stop('p4z_lys') 
    … …  
    184168      !! 
    185169      !!---------------------------------------------------------------------- 
    186       INTEGER  ::  ji, jj, jk 
    187170      INTEGER  ::  ios                 ! Local integer output status for namelist read 
    188       REAL(wp) ::  zcaralk, zbicarb, zco3 
    189       REAL(wp) ::  ztmas, ztmas1 
    190  
    191171      NAMELIST/nampiscal/ kdca, nca 
    192172      !!---------------------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r7398 r7806  
    269269      ENDIF 
    270270 
    271       ! set the number of level over which river runoffs are applied  
    272       ! online configuration : computed in sbcrnf 
    273       IF( lk_offline ) THEN 
    274         nk_rnf(:,:) = 1 
    275         h_rnf (:,:) = e3t_0(:,:,1) 
    276       ENDIF 
    277271 
    278272      ! dust input from the atmosphere 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

    r7398 r7806  
    8383        CALL p4z_che                              ! initialize the chemical constants 
    8484        ! 
    85         IF( .NOT. ln_rsttr ) THEN  ;   CALL p4z_ph_ini   !  set PH at kt=nit000  
     85        IF( .NOT. ln_rsttr ) THEN  ;   CALL p4z_che_ahini( hi )   !  set PH at kt=nit000 
    8686        ELSE                       ;   CALL p4z_rst( nittrc000, 'READ' )  !* read or initialize all required fields  
    8787        ENDIF 
    … …  
    308308   END SUBROUTINE p4z_sms_init 
    309309 
    310    SUBROUTINE p4z_ph_ini 
    311       !!--------------------------------------------------------------------- 
    312       !!                   ***  ROUTINE p4z_ini_ph  *** 
    313       !! 
    314       !!  ** Purpose : Initialization of chemical variables of the carbon cycle 
    315       !!--------------------------------------------------------------------- 
    316       INTEGER  ::  ji, jj, jk 
    317       REAL(wp) ::  zcaralk, zbicarb, zco3 
    318       REAL(wp) ::  ztmas, ztmas1 
    319       !!--------------------------------------------------------------------- 
    320  
    321       ! Set PH from  total alkalinity, borat (???), akb3 (???) and ak23 (???) 
    322       ! -------------------------------------------------------- 
    323       DO jk = 1, jpk 
    324          DO jj = 1, jpj 
    325             DO ji = 1, jpi 
    326                ztmas   = tmask(ji,jj,jk) 
    327                ztmas1  = 1. - tmask(ji,jj,jk) 
    328                zcaralk = trb(ji,jj,jk,jptal) - borat(ji,jj,jk) / (  1. + 1.E-8 / ( rtrn + akb3(ji,jj,jk) )  ) 
    329                zco3    = ( zcaralk - trb(ji,jj,jk,jpdic) ) * ztmas + 0.5e-3 * ztmas1 
    330                zbicarb = ( 2. * trb(ji,jj,jk,jpdic) - zcaralk ) 
    331                hi(ji,jj,jk) = ( ak23(ji,jj,jk) * zbicarb / zco3 ) * ztmas + 1.e-9 * ztmas1 
    332             END DO 
    333          END DO 
    334      END DO 
    335      ! 
    336    END SUBROUTINE p4z_ph_ini 
    337  
    338310   SUBROUTINE p4z_rst( kt, cdrw ) 
    339311      !!--------------------------------------------------------------------- 
    … …  
    348320      INTEGER         , INTENT(in) ::   kt         ! ocean time-step 
    349321      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag 
    350       ! 
    351       INTEGER  ::  ji, jj, jk 
    352       REAL(wp) ::  zcaralk, zbicarb, zco3 
    353       REAL(wp) ::  ztmas, ztmas1 
    354322      !!--------------------------------------------------------------------- 
    355323 
    … …  
    363331            CALL iom_get( numrtr, jpdom_autoglo, 'PH' , hi(:,:,:)  ) 
    364332         ELSE 
    365 !            hi(:,:,:) = 1.e-9  
    366             CALL p4z_ph_ini 
     333            CALL p4z_che_ahini( hi ) 
    367334         ENDIF 
    368335         CALL iom_get( numrtr, jpdom_autoglo, 'Silicalim', xksi(:,:) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r7256 r7806  
    9393 
    9494   !!* Variable for chemistry of the CO2 cycle 
    95    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akb3       !: ??? 
    9695   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ak13       !: ??? 
    9796   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ak23       !: ??? 
    9897   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aksp       !: ??? 
    99    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akw3       !: ??? 
    100    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   borat      !: ??? 
    10198   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hi         !: ??? 
    10299   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   excess     !: ??? 
    … …  
    153150 
    154151      !* Variable for chemistry of the CO2 cycle 
    155       ALLOCATE( akb3(jpi,jpj,jpk)    , ak13  (jpi,jpj,jpk) ,       & 
     152      ALLOCATE( ak13  (jpi,jpj,jpk) ,                              & 
    156153         &      ak23(jpi,jpj,jpk)    , aksp  (jpi,jpj,jpk) ,       & 
    157          &      akw3(jpi,jpj,jpk)    , borat (jpi,jpj,jpk) ,       & 
    158154         &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,       & 
    159155         &      aphscale(jpi,jpj,jpk),                           STAT=ierr(4) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90

    r5602 r7806  
    8989         r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
    9090      ENDIF 
    91       !                                                   ! effective transport 
    92       DO jk = 1, jpkm1 
    93          !                                                ! eulerian transport only 
    94          zun(:,:,jk) = e2u  (:,:) * fse3u(:,:,jk) * un(:,:,jk) 
    95          zvn(:,:,jk) = e1v  (:,:) * fse3v(:,:,jk) * vn(:,:,jk) 
    96          zwn(:,:,jk) = e1e2t(:,:)                 * wn(:,:,jk) 
    97          ! 
    98       END DO 
    99       ! 
    100       IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
    101          zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 
    102          zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 
     91      !   
     92      IF( lk_offline ) THEN 
     93         zun(:,:,:) = un(:,:,:)     ! effective transport already in un/vn/wn 
     94         zvn(:,:,:) = vn(:,:,:) 
     95         zwn(:,:,:) = wn(:,:,:) 
     96      ELSE 
     97         !                                                         ! effective transport 
     98         DO jk = 1, jpkm1 
     99            !                                                ! eulerian transport only 
     100            zun(:,:,jk) = e2u  (:,:) * fse3u(:,:,jk) * un(:,:,jk) 
     101            zvn(:,:,jk) = e1v  (:,:) * fse3v(:,:,jk) * vn(:,:,jk) 
     102            zwn(:,:,jk) = e1e2t(:,:)                 * wn(:,:,jk) 
     103            ! 
     104         END DO 
     105         ! 
     106         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     107            zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 
     108            zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 
     109         ENDIF 
     110         ! 
     111         zun(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
     112         zvn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
     113         zwn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
     114         ! 
     115 
     116         IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif )   &  ! add the eiv transport (if necessary) 
     117            &              CALL tra_adv_eiv( kt, nittrc000, zun, zvn, zwn, 'TRC' ) 
     118         ! 
     119         IF( ln_mle    )   CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' )    ! add the mle transport (if necessary) 
     120         ! 
    103121      ENDIF 
    104       ! 
    105       zun(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    106       zvn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    107       zwn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    108  
    109       IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif )   &  ! add the eiv transport (if necessary) 
    110          &              CALL tra_adv_eiv( kt, nittrc000, zun, zvn, zwn, 'TRC' ) 
    111       ! 
    112       IF( ln_mle    )   CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' )    ! add the mle transport (if necessary) 
    113122      ! 
    114123      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcrad.F90

    r7398 r7806  
    2828   !!---------------------------------------------------------------------- 
    2929   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    30    !! $Id$  
     30   !! $Id$ 
    3131   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3232   !!---------------------------------------------------------------------- 
    … …  
    6161      ENDIF 
    6262 
     63      IF( lk_age     )   CALL trc_rad_sms( kt, trb, trn, jp_age0 , jp_age1               )  ! AGE tracer 
    6364      IF( lk_cfc     )   CALL trc_rad_sms( kt, trb, trn, jp_cfc0 , jp_cfc1               )  ! CFC model 
    6465      IF( lk_c14b    )   CALL trc_rad_sms( kt, trb, trn, jp_c14b0, jp_c14b1              )  ! bomb C14 
    6566      IF( lk_pisces  )   CALL trc_rad_sms( kt, trb, trn, jp_pcs0 , jp_pcs1, cpreserv='Y' )  ! PISCES model 
    66       IF( lk_my_trc  )   CALL trc_rad_sms( kt, trb, trn, jp_myt0 , jp_myt1              )  ! MY_TRC model 
     67      IF( lk_my_trc  )   CALL trc_rad_sms( kt, trb, trn, jp_myt0 , jp_myt1, cpreserv='Y' )  ! MY_TRC model 
    6768 
    6869      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r7256 r7806  
    129129      ! Coupling offline : runoff are in emp which contains E-P-R 
    130130      ! 
    131       IF( .NOT. lk_offline .AND. lk_vvl ) THEN  ! online coupling with vvl 
     131      IF( lk_vvl ) THEN                         ! linear free surface vvl 
    132132         zsfx(:,:) = 0._wp 
    133       ELSE                                      ! online coupling free surface or offline with free surface 
     133      ELSE                                      ! no vvl 
    134134         zsfx(:,:) = emp(:,:) 
    135135      ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r7805 r7806  
    3030   USE par_pisces , ONLY : lk_pisces, jp_pcs0 , jp_pcs1 
    3131   USE par_my_trc , ONLY : lk_my_trc, jp_myt0 , jp_myt1 
     32   USE par_age    , ONLY : lk_age   , jp_age0 , jp_age1 
    3233 
    3334   USE trc_oce    , ONLY : lk_degrad, lk_offline, facvol, r_si2, trc_oce_ext_lev 
    3435   USE trc_oce    , ONLY : nn_dttrc 
    3536   USE trc_oce    , ONLY : etot3 
    36    USE trc        , ONLY : nittrc000 
     37   USE trc        , ONLY : nittrc000,nn_rsttr 
    3738   USE trc        , ONLY : trb,trn,tra 
    3839   USE trc        , ONLY : trc2d,trc3d 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/par_trc.F90

    r4529 r7806  
    1414   USE par_c14b      ! C14 bomb tracer 
    1515   USE par_cfc       ! CFC 11 and 12 tracers 
     16   USE par_age       ! AGE  tracer 
    1617   USE par_my_trc    ! user defined passive tracers 
    1718 
    … …  
    2425   ! Passive tracers : Total size 
    2526   ! ---------------               ! total number of passive tracers, of 2d and 3d output and trend arrays 
    26    INTEGER, PUBLIC,  PARAMETER ::   jptra    =  jp_pisces     + jp_cfc     + jp_c14b    + jp_my_trc 
    27    INTEGER, PUBLIC,  PARAMETER ::   jpdia2d  =  jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d + jp_my_trc_2d 
    28    INTEGER, PUBLIC,  PARAMETER ::   jpdia3d  =  jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d + jp_my_trc_3d 
     27   INTEGER, PUBLIC,  PARAMETER ::   jptra    =  jp_pisces     + jp_cfc     + jp_c14b    + jp_age    + jp_my_trc 
     28   INTEGER, PUBLIC,  PARAMETER ::   jpdia2d  =  jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d + jp_age_2d + jp_my_trc_2d 
     29   INTEGER, PUBLIC,  PARAMETER ::   jpdia3d  =  jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d + jp_age_3d + jp_my_trc_3d 
    2930   !                     ! total number of sms diagnostic arrays 
    30    INTEGER, PUBLIC,  PARAMETER ::   jpdiabio =  jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_my_trc_trd 
     31   INTEGER, PUBLIC,  PARAMETER ::   jpdiabio =  jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_age_trd + jp_my_trc_trd 
    3132    
    3233   !  1D configuration ("key_c1d") 
    … …  
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    44    !! $Id$  
     45   !! $Id$ 
    4546   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    4647   !!====================================================================== 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r7398 r7806  
    2323   USE trcini_pisces   ! PISCES   initialisation 
    2424   USE trcini_c14b     ! C14 bomb initialisation 
     25   USE trcini_age      ! AGE      initialisation 
    2526   USE trcini_my_trc   ! MY_TRC   initialisation 
    2627   USE trcdta          ! initialisation from files 
    … …  
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/TOP 4.0 , NEMO Consortium (2011) 
    45    !! $Id$  
     46   !! $Id$ 
    4647   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4748   !!---------------------------------------------------------------------- 
    … …  
    9899 
    99100      IF( lk_pisces  )       CALL trc_ini_pisces       ! PISCES  bio-model 
    100       IF( lk_cfc     )       CALL trc_ini_cfc          ! CFC     tracers 
     101      IF( lk_cfc     )       CALL trc_ini_cfc          ! CFC       tracers 
    101102      IF( lk_c14b    )       CALL trc_ini_c14b         ! C14 bomb  tracer 
    102       IF( lk_my_trc  )       CALL trc_ini_my_trc       ! MY_TRC  tracers 
     103      IF( lk_age     )       CALL trc_ini_age          ! AGE       tracer 
     104      IF( lk_my_trc  )       CALL trc_ini_my_trc       ! MY_TRC    tracers 
    103105 
    104106      CALL trc_ice_ini                                 ! Tracers in sea ice 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

    r7256 r7806  
    2424   USE trcnam_cfc        ! CFC SMS namelist 
    2525   USE trcnam_c14b       ! C14 SMS namelist 
     26   USE trcnam_age        ! AGE SMS namelist 
    2627   USE trcnam_my_trc     ! MY_TRC SMS namelist 
    2728   USE trd_oce        
    … …  
    6162       
    6263      !                                        !  passive tracer informations 
    63       CALL trc_nam_trc 
     64                             CALL trc_nam_trc 
    6465       
    6566      !                                        !   Parameters of additional diagnostics 
    66       CALL trc_nam_dia 
     67      IF( .NOT. lk_iomput)   CALL trc_nam_dia 
    6768 
    6869      !                                        !   namelist of transport 
    69       CALL trc_nam_trp 
     70                             CALL trc_nam_trp 
    7071 
    7172 
    … …  
    161162      ENDIF 
    162163 
    163       IF( lk_c14b     ) THEN   ;   CALL trc_nam_c14b         ! C14 bomb     tracers 
    164       ELSE                    ;   IF(lwp) WRITE(numout,*) '          C14 not used' 
    165       ENDIF 
    166  
    167       IF( lk_my_trc  ) THEN   ;   CALL trc_nam_my_trc      ! MY_TRC  tracers 
    168       ELSE                    ;   IF(lwp) WRITE(numout,*) '          MY_TRC not used' 
     164      IF( lk_c14b    ) THEN  ;   CALL trc_nam_c14b         ! C14 bomb     tracers 
     165      ELSE                   ;   IF(lwp) WRITE(numout,*) '          C14 not used' 
     166      ENDIF 
     167 
     168      IF( lk_age     ) THEN  ;   CALL trc_nam_age         ! AGE     tracer 
     169      ELSE                   ;   IF(lwp) WRITE(numout,*) '          AGE not used' 
     170      ENDIF 
     171 
     172      IF( lk_my_trc  ) THEN  ;   CALL trc_nam_my_trc      ! MY_TRC  tracers 
     173      ELSE                   ;   IF(lwp) WRITE(numout,*) '          MY_TRC not used' 
    169174      ENDIF 
    170175      ! 
    … …  
    359364      ENDIF 
    360365 
    361       IF( ln_diatrc .AND. .NOT. lk_iomput ) THEN  
     366      IF( ln_diatrc ) THEN  
    362367         ALLOCATE( trc2d(jpi,jpj,jpdia2d), trc3d(jpi,jpj,jpk,jpdia3d),  & 
    363368           &       ctrc2d(jpdia2d), ctrc2l(jpdia2d), ctrc2u(jpdia2d) ,  &  
    … …  
    370375      ENDIF 
    371376 
    372       IF( ( ln_diabio .AND. .NOT. lk_iomput ) .OR. l_trdtrc ) THEN 
     377      IF( ln_diabio .OR. l_trdtrc ) THEN 
    373378         ALLOCATE( trbio (jpi,jpj,jpk,jpdiabio) , & 
    374379           &       ctrbio(jpdiabio), ctrbil(jpdiabio), ctrbiu(jpdiabio), STAT = ierr )  

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsms.F90

    r7256 r7806  
    1818   USE trcsms_cfc         ! CFC 11 & 12 
    1919   USE trcsms_c14b        ! C14b tracer  
     20   USE trcsms_age         ! AGE tracer  
    2021   USE trcsms_my_trc      ! MY_TRC  tracers 
    2122   USE prtctl_trc         ! Print control for debbuging 
    … …  
    2829   !!---------------------------------------------------------------------- 
    2930   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    30    !! $Id$  
     31   !! $Id$ 
    3132   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3233   !!---------------------------------------------------------------------- 
    … …  
    5152      IF( lk_cfc     )   CALL trc_sms_cfc    ( kt )    ! surface fluxes of CFC 
    5253      IF( lk_c14b    )   CALL trc_sms_c14b   ( kt )    ! surface fluxes of C14 
     54      IF( lk_age     )   CALL trc_sms_age    ( kt )    ! AGE tracer 
    5355      IF( lk_my_trc  )   CALL trc_sms_my_trc ( kt )    ! MY_TRC  tracers 
    5456 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r7398 r7806  
    3232   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr ! save qsr during TOP time-step 
    3333   REAL(wp) :: rdt_sampl 
    34    INTEGER  :: nb_rec_per_day 
     34   INTEGER  :: nb_rec_per_day, ktdcy 
    3535   REAL(wp) :: rsecfst, rseclast 
    3636   LOGICAL  :: llnew 
    … …  
    8686         tra(:,:,:,:) = 0.e0 
    8787         ! 
    88                                    CALL trc_rst_opn  ( kt )       ! Open tracer restart file  
     88         IF( .NOT.lk_offline )     CALL trc_rst_opn  ( kt )       ! Open tracer restart file  
    8989         IF( lrst_trc )            CALL trc_rst_cal  ( kt, 'WRITE' )   ! calendar 
    9090         IF( lk_iomput ) THEN  ;   CALL trc_wri      ( kt )       ! output of passive tracers with iom I/O manager 
    … …  
    131131      INTEGER, INTENT(in) ::   kt 
    132132      INTEGER  :: jn 
    133       REAL(wp) :: zkt 
     133      REAL(wp) :: zkt, zrec 
    134134      CHARACTER(len=1)               ::   cl1                      ! 1 character 
    135135      CHARACTER(len=2)               ::   cl2                      ! 2 characters 
    … …  
    153153         ! 
    154154         !                                            !* Restart: read in restart file 
    155          IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 .AND. & 
    156                             iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 .AND. & 
    157                             iom_varid( numrtr, 'ktdcy'    , ldstop = .FALSE. ) > 0 ) THEN  
    158             CALL iom_get( numrtr, 'ktdcy', zkt )   !  A mean of qsr 
     155         IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0  & 
     156           &                              .AND. iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0  & 
     157           &                              .AND. iom_varid( numrtr, 'ktdcy'    , ldstop = .FALSE. ) > 0  & 
     158           &                              .AND. iom_varid( numrtr, 'nrdcy'    , ldstop = .FALSE. ) > 0  ) THEN 
     159 
     160            CALL iom_get( numrtr, 'ktdcy', zkt )   
    159161            rsecfst = INT( zkt ) * rdttrc(1) 
    160162            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' 
    161163            CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean )   !  A mean of qsr 
    162             DO jn = 1, nb_rec_per_day  
    163              IF( jn <= 9 )  THEN 
    164                WRITE(cl1,'(i1)') jn 
    165                CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) )   !  A mean of qsr 
    166              ELSE 
    167                WRITE(cl2,'(i2.2)') jn 
    168                CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) )   !  A mean of qsr 
    169              ENDIF 
    170            ENDDO 
     164            CALL iom_get( numrtr, 'nrdcy', zrec )   !  Number of record per days 
     165            IF( INT( zrec ) == nb_rec_per_day ) THEN 
     166               DO jn = 1, nb_rec_per_day  
     167                  IF( jn <= 9 )  THEN 
     168                    WRITE(cl1,'(i1)') jn 
     169                    CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) )   !  A mean of qsr 
     170                  ELSE 
     171                    WRITE(cl2,'(i2.2)') jn 
     172                    CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) )   !  A mean of qsr 
     173                  ENDIF 
     174              ENDDO 
     175            ELSE 
     176               DO jn = 1, nb_rec_per_day 
     177                  qsr_arr(:,:,jn) = qsr_mean(:,:) 
     178               ENDDO 
     179            ENDIF 
    171180         ELSE                                         !* no restart: set from nit000 values 
    172181            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean set to nit000 values' 
    … …  
    185194      llnew   = ( rseclast - rsecfst ) .ge.  rdt_sampl    !   new shortwave to store 
    186195      IF( llnew ) THEN 
    187           IF( lwp ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', kt, & 
     196          ktdcy = kt 
     197          IF( lwp .AND. kt < nittrc000 + 100 ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', ktdcy, & 
    188198             &                      ' time = ', rseclast/3600.,'hours ' 
    189199          rsecfst = rseclast 
    … …  
    199209         IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file  kt =', kt 
    200210         IF(lwp) WRITE(numout,*) '~~~~~~~' 
    201          zkt = REAL( kt, wp ) 
    202          CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) 
     211         zkt  = REAL( ktdcy, wp ) 
     212         zrec = REAL( nb_rec_per_day, wp ) 
     213         CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt  ) 
     214         CALL iom_rstput( kt, nitrst, numrtw, 'nrdcy', zrec ) 
    203215          DO jn = 1, nb_rec_per_day  
    204216             IF( jn <= 9 )  THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcwri.F90

    r6101 r7806  
    2020   USE trcwri_cfc 
    2121   USE trcwri_c14b 
     22   USE trcwri_age 
    2223   USE trcwri_my_trc 
    2324 
    … …  
    5960      IF( lk_cfc     )   CALL trc_wri_cfc        ! surface fluxes of CFC 
    6061      IF( lk_c14b    )   CALL trc_wri_c14b       ! surface fluxes of C14 
     62      IF( lk_age     )   CALL trc_wri_age        ! AGE tracer 
    6163      IF( lk_my_trc  )   CALL trc_wri_my_trc     ! MY_TRC  tracers 
    6264      ! 
    … …  
    7880   !!---------------------------------------------------------------------- 
    7981   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    80    !! $Id$  
     82   !! $Id$ 
    8183   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    8284   !!====================================================================== 
Note: See TracChangeset for help on using the changeset viewer.