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 3680 for branches/2012/dev_MERGE_2012/NEMOGCM/NEMO – NEMO

Ignore:
Timestamp:
2012-11-27T15:42:24+01:00 (11 years ago)
Author:
rblod
Message:

First commit of the final branch for 2012 (future nemo_3_5), see ticket #1028

Location:
branches/2012/dev_MERGE_2012/NEMOGCM/NEMO
Files:
18 deleted
99 edited
10 copied

Legend:

Unmodified
Added
Removed

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/LIM_SRC_2/limrhg_2.F90

    r3625 r3680  
    3232   USE oce     , ONLY : snwice_mass, snwice_mass_b 
    3333   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     34#if defined key_agrif 
     35   USE agrif_lim2_interp ! nesting 
     36#endif 
    3437 
    3538   IMPLICIT NONE 
    … …  
    148151         zpice(:,:) = ssh_m(:,:) 
    149152      ENDIF 
     153#if defined key_agrif 
     154      ! load the boundary value of velocity in special array zuive and zvice 
     155      CALL agrif_rhg_lim2_load 
     156#endif 
    150157 
    151158      ! Ice mass, ice strength, and wind stress at the center            | 
    … …  
    552559            CALL lbc_lnk( zv_n(:,1:jpj), 'I', -1. ) 
    553560 
     561#if defined key_agrif 
     562            ! copy the boundary value from u_ice_nst and v_ice_nst to u_ice and v_ice 
     563            ! before next interations 
     564            CALL agrif_rhg_lim2(zu_n,zv_n) 
     565#endif 
     566 
    554567            ! Test of Convergence 
    555568            DO jj = k_j1+1 , k_jpj-1 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/LIM_SRC_2/limtrp_2.F90

    r3294 r3680  
    2828   USE lib_mpp         ! MPP library 
    2929   USE wrk_nemo        ! work arrays 
     30# if defined key_agrif 
     31   USE agrif_lim2_interp ! nesting 
     32# endif 
    3033 
    3134   IMPLICIT NONE 
    … …  
    8083 
    8184      IF( kt == nit000  )   CALL lim_trp_init_2      ! Initialization (first time-step only) 
     85 
     86# if defined key_agrif 
     87      CALL agrif_trp_lim2_load      ! First interpolation 
     88# endif 
    8289 
    8390      zsm(:,:) = area(:,:) 
    … …  
    269276      ENDIF 
    270277      ! 
     278# if defined key_agrif 
     279      CALL agrif_trp_lim2      ! Fill boundaries of the fine grid 
     280# endif 
     281      !  
    271282      CALL wrk_dealloc( jpi, jpj, zui_u , zvi_v , zsm, zs0ice, zs0sn , zs0a, zs0c0 , zs0c1 , zs0c2 , zs0st ) 
    272283      ! 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r3625 r3680  
    88   !!             -   !  2008-11  (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy  
    99   !!            3.3  !  2009-05  (G.Garric) addition of the lim2_evp cas 
    10    !!            4.0  !  2011-01  (A Porter)  dynamical allocation  
     10   !!            3.4  !  2011-01  (A. Porter)  dynamical allocation  
     11   !!            3.5  !  2012-08  (R. Benshila)  AGRIF  
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_lim3 || (  defined key_lim2 && ! defined key_lim2_vp ) 
    … …  
    3738   USE prtctl         ! Print control 
    3839   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     40#if defined key_agrif && defined key_lim2 
     41   USE agrif_lim2_interp 
     42#endif 
    3943 
    4044   IMPLICIT NONE 
    … …  
    168172     at_i(:,:) = 1. - frld(:,:) 
    169173#endif 
     174#if defined key_agrif && defined key_lim2  
     175    CALL agrif_rhg_lim2_load      ! First interpolation of coarse values 
     176#endif 
    170177      ! 
    171178      !------------------------------------------------------------------------------! 
    … …  
    510517 
    511518            CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
     519#if defined key_agrif 
     520            CALL agrif_rhg_lim2( jter, nevp, 'U' ) 
     521#endif 
    512522 
    513523!CDIR NOVERRCHK 
    … …  
    535545 
    536546            CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
     547#if defined key_agrif 
     548            CALL agrif_rhg_lim2( jter, nevp, 'V' ) 
     549#endif 
    537550 
    538551         ELSE  
    … …  
    561574 
    562575            CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
     576#if defined key_agrif 
     577            CALL agrif_rhg_lim2( jter, nevp , 'V' ) 
     578#endif 
    563579 
    564580!CDIR NOVERRCHK 
    … …  
    589605 
    590606            CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
     607#if defined key_agrif 
     608            CALL agrif_rhg_lim2( jter, nevp, 'U' ) 
     609#endif 
    591610 
    592611         ENDIF 
    … …  
    629648      CALL lbc_lnk( u_ice(:,:), 'U', -1. )  
    630649      CALL lbc_lnk( v_ice(:,:), 'V', -1. )  
     650#if defined key_agrif 
     651      CALL agrif_rhg_lim2( nevp , nevp, 'U' ) 
     652      CALL agrif_rhg_lim2( nevp , nevp, 'V' ) 
     653#endif 
    631654 
    632655      DO jj = k_j1+1, k_jpj-1  

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r2528 r3680  
    55   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    66   !!---------------------------------------------------------------------- 
     7   SUBROUTINE Agrif2Model 
     8      !!--------------------------------------------- 
     9      !!   *** ROUTINE Agrif2Model *** 
     10      !!---------------------------------------------  
     11   END SUBROUTINE Agrif2model 
    712 
    813   SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r3294 r3680  
    2525 
    2626   !                                              !!! OLD namelist names 
     27   INTEGER , PUBLIC ::   nbcline = 0               !: update counter 
    2728   INTEGER , PUBLIC ::   nbclineupdate             !: update frequency  
    2829   REAL(wp), PUBLIC ::   visc_tra                  !: sponge coeff. for tracers 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r3294 r3680  
    1 #define SPONGE 
     1#define SPONGE && define SPONGE_TOP 
    22 
    33Module agrif_opa_sponge 
    … …  
    1313   PRIVATE 
    1414 
    15    PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
    16  
     15   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
     16 
     17  !! * Substitutions 
     18#  include "domzgr_substitute.h90" 
    1719   !!---------------------------------------------------------------------- 
    1820   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    … …  
    2729      !!   *** ROUTINE Agrif_Sponge_Tra *** 
    2830      !!--------------------------------------------- 
    29 #include "domzgr_substitute.h90" 
    3031      !! 
    3132      INTEGER :: ji,jj,jk,jn 
    32       INTEGER :: spongearea 
    3333      REAL(wp) :: timecoeff 
    3434      REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
    35       REAL(wp), POINTER, DIMENSION(:,:    ) :: localviscsponge 
    3635      REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
    3736      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    … …  
    3938 
    4039#if defined SPONGE 
    41       CALL wrk_alloc( jpi, jpj, localviscsponge, ztu, ztv ) 
     40      CALL wrk_alloc( jpi, jpj, ztu, ztv ) 
    4241      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    4342 
    … …  
    5251      tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 
    5352 
    54       spongearea = 2 + 2 * Agrif_irhox() 
    55  
    56       localviscsponge = 0. 
    57        
    58       IF (.NOT. spongedoneT) THEN 
    59          spe1ur(:,:) = 0. 
    60          spe2vr(:,:) = 0. 
    61  
    62       IF ((nbondi == -1).OR.(nbondi == 2)) THEN 
    63          DO ji = 2, spongearea 
    64             localviscsponge(ji,:) = visc_tra * (spongearea-ji)/real(spongearea-2) 
    65          ENDDO 
    66      
    67     spe1ur(2:spongearea-1,:)=0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) & 
    68           * e2u(2:spongearea-1,:) / e1u(2:spongearea-1,:) 
    69  
    70          spe2vr(2:spongearea,1:jpjm1) = 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + & 
    71              localviscsponge(2:spongearea,2:jpj)) & 
    72            * e1v(2:spongearea,1:jpjm1) / e2v(2:spongearea,1:jpjm1) 
    73       ENDIF 
    74  
    75       IF ((nbondi == 1).OR.(nbondi == 2)) THEN 
    76          DO ji = nlci-spongearea + 1,nlci-1 
    77             localviscsponge(ji,:) = visc_tra * (ji - (nlci-spongearea+1))/real(spongearea-2) 
    78          ENDDO 
    79      
    80     spe1ur(nlci-spongearea + 1:nlci-2,:)=0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + & 
    81            localviscsponge(nlci-spongearea + 2:nlci-1,:)) & 
    82           * e2u(nlci-spongearea + 1:nlci-2,:) / e1u(nlci-spongearea + 1:nlci-2,:) 
    83  
    84          spe2vr(nlci-spongearea + 1:nlci-1,1:jpjm1) = 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) & 
    85               + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) & 
    86            * e1v(nlci-spongearea + 1:nlci-1,1:jpjm1) / e2v(nlci-spongearea + 1:nlci-1,1:jpjm1) 
    87       ENDIF 
    88  
    89  
    90       IF ((nbondj == -1).OR.(nbondj == 2)) THEN 
    91          DO jj = 2, spongearea 
    92             localviscsponge(:,jj) = visc_tra * (spongearea-jj)/real(spongearea-2) 
    93          ENDDO 
    94      
    95     spe1ur(1:jpim1,2:spongearea)=0.5 * (localviscsponge(1:jpim1,2:spongearea) + & 
    96            localviscsponge(2:jpi,2:spongearea)) & 
    97           * e2u(1:jpim1,2:spongearea) / e1u(1:jpim1,2:spongearea) 
    98  
    99          spe2vr(:,2:spongearea-1) = 0.5 * (localviscsponge(:,2:spongearea-1) + & 
    100              localviscsponge(:,3:spongearea)) & 
    101            * e1v(:,2:spongearea-1) / e2v(:,2:spongearea-1) 
    102       ENDIF 
    103  
    104       IF ((nbondj == 1).OR.(nbondj == 2)) THEN 
    105          DO jj = nlcj-spongearea + 1,nlcj-1 
    106             localviscsponge(:,jj) = visc_tra * (jj - (nlcj-spongearea+1))/real(spongearea-2) 
    107          ENDDO 
    108      
    109     spe1ur(1:jpim1,nlcj-spongearea + 1:nlcj-1)=0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + & 
    110             localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) & 
    111           * e2u(1:jpim1,nlcj-spongearea + 1:nlcj-1) / e1u(1:jpim1,nlcj-spongearea + 1:nlcj-1) 
    112  
    113          spe2vr(:,nlcj-spongearea + 1:nlcj-2) = 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + & 
    114             localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) & 
    115            * e1v(:,nlcj-spongearea + 1:nlcj-2) / e2v(:,nlcj-spongearea + 1:nlcj-2) 
    116       ENDIF 
    117        
    118          spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:)) 
    119  
    120          spongedoneT = .TRUE. 
    121       ENDIF 
     53      CALL Agrif_Sponge 
    12254 
    12355      DO jn = 1, jpts 
    … …  
    14779      ENDDO 
    14880 
    149       CALL wrk_dealloc( jpi, jpj, localviscsponge, ztu, ztv ) 
     81      CALL wrk_dealloc( jpi, jpj, ztu, ztv ) 
    15082      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    15183#endif 
    … …  
    15789      !!   *** ROUTINE Agrif_Sponge_dyn *** 
    15890      !!--------------------------------------------- 
    159 #include "domzgr_substitute.h90" 
    16091      !! 
    16192      INTEGER :: ji,jj,jk 
    162       INTEGER :: spongearea 
    16393      REAL(wp) :: timecoeff 
    16494      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    165       REAL(wp), POINTER, DIMENSION(:,:) :: localviscsponge 
    16695      REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff 
    16796      REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff 
    … …  
    16998 
    17099#if defined SPONGE 
    171       CALL wrk_alloc( jpi, jpj, localviscsponge ) 
    172100      CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    173101 
    … …  
    180108      Agrif_UseSpecialValue = .FALSE. 
    181109 
    182       ubdiff(:,:,:) = (ub(:,:,:) - ztab(:,:,:))*umask(:,:,:) 
     110      ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:) 
    183111 
    184112      ztab = 0.e0 
    … …  
    188116      Agrif_UseSpecialValue = .FALSE. 
    189117 
    190       vbdiff(:,:,:) = (vb(:,:,:) - ztab(:,:,:))*vmask(:,:,:) 
    191  
    192       spongearea = 2 + 2 * Agrif_irhox() 
    193  
    194       localviscsponge = 0. 
    195  
    196       IF (.NOT. spongedoneU) THEN 
    197          spe1ur2(:,:) = 0. 
    198          spe2vr2(:,:) = 0. 
    199  
    200       IF ((nbondi == -1).OR.(nbondi == 2)) THEN 
    201          DO ji = 2, spongearea 
    202             localviscsponge(ji,:) = visc_dyn * (spongearea-ji)/real(spongearea-2) 
    203          ENDDO 
    204      
    205     spe1ur2(2:spongearea-1,:)=0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) 
    206  
    207          spe2vr2(2:spongearea,1:jpjm1) = 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + & 
    208              localviscsponge(2:spongearea,2:jpj)) 
    209       ENDIF 
    210  
    211       IF ((nbondi == 1).OR.(nbondi == 2)) THEN 
    212          DO ji = nlci-spongearea + 1,nlci-1 
    213             localviscsponge(ji,:) = visc_dyn * (ji - (nlci-spongearea+1))/real(spongearea-2) 
    214          ENDDO 
    215      
    216     spe1ur2(nlci-spongearea + 1:nlci-2,:)=0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + & 
    217            localviscsponge(nlci-spongearea + 2:nlci-1,:)) 
    218  
    219          spe2vr2(nlci-spongearea + 1:nlci-1,1:jpjm1) = 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) & 
    220               + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) 
    221       ENDIF 
    222  
    223  
    224       IF ((nbondj == -1).OR.(nbondj == 2)) THEN 
    225          DO jj = 2, spongearea 
    226             localviscsponge(:,jj) = visc_dyn * (spongearea-jj)/real(spongearea-2) 
    227          ENDDO 
    228      
    229     spe1ur2(1:jpim1,2:spongearea)=0.5 * (localviscsponge(1:jpim1,2:spongearea) + & 
    230            localviscsponge(2:jpi,2:spongearea)) 
    231  
    232          spe2vr2(:,2:spongearea-1) = 0.5 * (localviscsponge(:,2:spongearea-1) + & 
    233              localviscsponge(:,3:spongearea)) 
    234       ENDIF 
    235  
    236       IF ((nbondj == 1).OR.(nbondj == 2)) THEN 
    237          DO jj = nlcj-spongearea + 1,nlcj-1 
    238             localviscsponge(:,jj) = visc_dyn * (jj - (nlcj-spongearea+1))/real(spongearea-2) 
    239          ENDDO 
    240      
    241     spe1ur2(1:jpim1,nlcj-spongearea + 1:nlcj-1)=0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + & 
    242             localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) 
    243  
    244          spe2vr2(:,nlcj-spongearea + 1:nlcj-2) = 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + & 
    245             localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) 
    246       ENDIF 
    247  
    248          spongedoneU = .TRUE. 
    249      
    250      spbtr3(:,:) = 1./( e1f(:,:) * e2f(:,:)) 
    251       ENDIF 
    252        
    253       IF (.NOT. spongedoneT) THEN 
    254         spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:))       
    255       ENDIF 
    256        
    257       DO jk=1,jpkm1 
    258       ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 
    259       vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 
     118      vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:) 
     119 
     120      CALL Agrif_Sponge 
     121 
     122      DO jk = 1,jpkm1 
     123         ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 
     124         vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 
    260125      ENDDO 
    261126       
    … …  
    272137            DO ji = 2, jpim1   ! vector opt. 
    273138               zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    274                hdivdiff(ji,jj,jk) =   & 
    275                   (  e2u(ji,jj)*fse3u(ji,jj,jk) * &  
    276                   ubdiff(ji,jj,jk) - e2u(ji-1,jj  )* & 
    277                   fse3u(ji-1,jj  ,jk)  * ubdiff(ji-1,jj  ,jk)       & 
    278                   + e1v(ji,jj)*fse3v(ji,jj,jk) * & 
    279                   vbdiff(ji,jj,jk) - e1v(ji  ,jj-1)* & 
    280                   fse3v(ji  ,jj-1,jk)  * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
     139               hdivdiff(ji,jj,jk) =  (  e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) * ubdiff(ji  ,jj  ,jk)     & 
     140                  &                   - e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) * ubdiff(ji-1,jj  ,jk)     & 
     141                  &                   + e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) * vbdiff(ji  ,jj  ,jk)     & 
     142                  &                   - e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
    281143            END DO 
    282144         END DO 
    … …  
    286148               zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    287149               rotdiff(ji,jj,jk) = (  e2v(ji+1,jj  ) * vbdiff(ji+1,jj  ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)    & 
    288                   &              - e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
    289                   &           * fmask(ji,jj,jk) * zbtr 
     150                  &                 - e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
     151                  &               * fmask(ji,jj,jk) * zbtr 
    290152            END DO 
    291153         END DO 
    … …  
    298160         DO jj = 2, jpjm1 
    299161            DO ji = 2, jpim1   ! vector opt. 
    300                ze2u = rotdiff (ji,jj,jk) 
    301                ze1v = hdivdiff(ji,jj,jk) 
    302162               ! horizontal diffusive trends 
    303                zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
    304                   + ( hdivdiff(ji+1,jj,jk) - ze1v      & 
    305                   ) / e1u(ji,jj) 
    306  
    307                zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
    308                   + ( hdivdiff(ji,jj+1,jk) - ze1v    & 
    309                   ) / e2v(ji,jj) 
    310  
     163               zua = - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
     164                     + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk) ) / e1u(ji,jj) 
     165 
     166               zva = + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
     167                     + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) / e2v(ji,jj) 
    311168               ! add it to the general momentum trends 
    312169               ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    … …  
    317174      END DO                                           !   End of slab 
    318175      !                                                ! =============== 
    319       CALL wrk_dealloc( jpi, jpj, localviscsponge ) 
    320176      CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    321  
    322177#endif 
    323178 
    324179   END SUBROUTINE Agrif_Sponge_dyn 
    325180 
     181   SUBROUTINE Agrif_Sponge 
     182      !!--------------------------------------------- 
     183      !!   *** ROUTINE  Agrif_Sponge *** 
     184      !!--------------------------------------------- 
     185      INTEGER  :: ji,jj,jk 
     186      INTEGER  :: ispongearea, ilci, ilcj 
     187      REAL(wp) :: z1spongearea 
     188      REAL(wp), POINTER, DIMENSION(:,:) :: zlocalviscsponge 
     189 
     190#if defined SPONGE || defined SPONGE_TOP 
     191 
     192      CALL wrk_alloc( jpi, jpj, zlocalviscsponge ) 
     193 
     194      ispongearea  = 2 + 2 * Agrif_irhox() 
     195      ilci = nlci - ispongearea 
     196      ilcj = nlcj - ispongearea  
     197      z1spongearea = 1._wp / REAL( ispongearea - 2 ) 
     198      spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
     199 
     200      ! Tracers 
     201      IF( .NOT. spongedoneT ) THEN 
     202         zlocalviscsponge(:,:) = 0. 
     203         spe1ur(:,:) = 0. 
     204         spe2vr(:,:) = 0. 
     205 
     206         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
     207            DO ji = 2, ispongearea 
     208               zlocalviscsponge(ji,:) = visc_tra * ( ispongearea-ji ) * z1spongearea 
     209            ENDDO 
     210            spe1ur(2:ispongearea-1,:      ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,:      ) + zlocalviscsponge(3:ispongearea,:    ) ) & 
     211               &                         * e2u(2:ispongearea-1,:      ) / e1u(2:ispongearea-1,:      ) 
     212            spe2vr(2:ispongearea  ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea  ,1:jpjm1) + zlocalviscsponge(2:ispongearea,2:jpj) ) & 
     213               &                         * e1v(2:ispongearea  ,1:jpjm1) / e2v(2:ispongearea  ,1:jpjm1) 
     214         ENDIF 
     215 
     216         IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
     217            DO ji = ilci+1,nlci-1 
     218               zlocalviscsponge(ji,:) = visc_tra * (ji - (ilci+1) ) * z1spongearea 
     219            ENDDO 
     220   
     221            spe1ur(ilci+1:nlci-2,:      ) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-2,:) + zlocalviscsponge(ilci+2:nlci-1,:) )  & 
     222               &                                   * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
     223 
     224            spe2vr(ilci+1:nlci-1,1:jpjm1) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) + zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  ) &  
     225               &                                   * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
     226         ENDIF 
     227 
     228         IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
     229            DO jj = 2, ispongearea 
     230               zlocalviscsponge(:,jj) = visc_tra * ( ispongearea-jj ) * z1spongearea 
     231            ENDDO 
     232            spe1ur(1:jpim1,2:ispongearea  ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea) + zlocalviscsponge(2:jpi,2:ispongearea) ) & 
     233               &                                * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
     234    
     235            spe2vr(:      ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1)     + zlocalviscsponge(:,3:ispongearea)     ) & 
     236               &                                  * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
     237         ENDIF 
     238 
     239         IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
     240            DO jj = ilcj+1,nlcj-1 
     241               zlocalviscsponge(:,jj) = visc_tra * (jj - (ilcj+1) ) * z1spongearea 
     242            ENDDO 
     243            spe1ur(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) ) & 
     244               &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
     245            spe2vr(:      ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2      ) + zlocalviscsponge(:,ilcj+2:nlcj-1)     ) & 
     246               &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
     247         ENDIF 
     248         spongedoneT = .TRUE. 
     249      ENDIF 
     250 
     251      ! Dynamics 
     252      IF( .NOT. spongedoneU ) THEN 
     253         zlocalviscsponge(:,:) = 0. 
     254         spe1ur2(:,:) = 0. 
     255         spe2vr2(:,:) = 0. 
     256 
     257         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
     258            DO ji = 2, ispongearea 
     259               zlocalviscsponge(ji,:) = visc_dyn * ( ispongearea-ji ) * z1spongearea 
     260            ENDDO 
     261            spe1ur2(2:ispongearea-1,:      ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,:      ) + zlocalviscsponge(3:ispongearea,:    ) ) 
     262            spe2vr2(2:ispongearea  ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea  ,1:jpjm1) + zlocalviscsponge(2:ispongearea,2:jpj) )  
     263         ENDIF 
     264 
     265         IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
     266            DO ji = ilci+1,nlci-1 
     267               zlocalviscsponge(ji,:) = visc_dyn * (ji - (ilci+1) ) * z1spongearea 
     268            ENDDO 
     269            spe1ur2(ilci+1:nlci-2,:      ) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-2,:) + zlocalviscsponge(ilci+2:nlci-1,:) )   
     270            spe2vr2(ilci+1:nlci-1,1:jpjm1) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) + zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  )  
     271         ENDIF 
     272 
     273         IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
     274            DO jj = 2, ispongearea 
     275               zlocalviscsponge(:,jj) = visc_dyn * ( ispongearea-jj ) * z1spongearea 
     276            ENDDO 
     277            spe1ur2(1:jpim1,2:ispongearea  ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea) + zlocalviscsponge(2:jpi,2:ispongearea) )  
     278            spe2vr2(:      ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1)     + zlocalviscsponge(:,3:ispongearea)     ) 
     279         ENDIF 
     280 
     281         IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
     282            DO jj = ilcj+1,nlcj-1 
     283               zlocalviscsponge(:,jj) = visc_dyn * (jj - (ilcj+1) ) * z1spongearea 
     284            ENDDO 
     285            spe1ur2(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) )  
     286            spe2vr2(:      ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2      ) + zlocalviscsponge(:,ilcj+2:nlcj-1)     ) 
     287         ENDIF 
     288         spongedoneU = .TRUE. 
     289         spbtr3(:,:) = 1. / ( e1f(:,:) * e2f(:,:) ) 
     290      ENDIF 
     291      ! 
     292      CALL wrk_dealloc( jpi, jpj, zlocalviscsponge ) 
     293      ! 
     294#endif 
     295 
     296   END SUBROUTINE Agrif_Sponge 
     297 
    326298   SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    327299      !!--------------------------------------------- 
    328300      !!   *** ROUTINE interptsn *** 
    329301      !!--------------------------------------------- 
    330 #  include "domzgr_substitute.h90"        
    331        
    332302      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    333303      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    … …  
    341311      !!   *** ROUTINE interpun *** 
    342312      !!--------------------------------------------- 
    343 #  include "domzgr_substitute.h90"        
    344        
    345313      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    346314      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    … …  
    354322      !!   *** ROUTINE interpvn *** 
    355323      !!--------------------------------------------- 
    356 #  include "domzgr_substitute.h90"        
    357        
    358324      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    359325      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r3294 r3680  
    2727 
    2828   SUBROUTINE Agrif_trc 
    29       !!--------------------------------------------- 
    30       !!   *** ROUTINE Agrif_trc *** 
    31       !!--------------------------------------------- 
    32        
    33       INTEGER :: ji,jj,jk,jn 
    34       REAL(wp) :: zrhox 
    35       REAL(wp) :: alpha1, alpha2, alpha3, alpha4 
    36       REAL(wp) :: alpha5, alpha6, alpha7 
     29      !!---------------------------------------------------------------------- 
     30      !!                  ***  ROUTINE Agrif_Tra  *** 
     31      !!---------------------------------------------------------------------- 
     32      !! 
     33      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     34      REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
     35      REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    3736      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
    38             
    39       IF (Agrif_Root()) RETURN 
     37      !!---------------------------------------------------------------------- 
     38      ! 
     39      IF( Agrif_Root() )   RETURN 
    4040 
    4141      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    4242 
    43       Agrif_SpecialValue=0. 
     43      Agrif_SpecialValue    = 0.e0 
    4444      Agrif_UseSpecialValue = .TRUE. 
    45       ztra = 0.e0 
     45      ztra(:,:,:,:) = 0.e0 
    4646 
    47       CALL Agrif_Bc_variable(ztra,trn_id, procname = interptrn ) 
     47      CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
    4848      Agrif_UseSpecialValue = .FALSE. 
    4949 
    5050      zrhox = Agrif_Rhox() 
    5151 
    52       alpha1 = (zrhox-1.)/2. 
    53       alpha2 = 1.-alpha1 
     52      alpha1 = ( zrhox - 1. ) * 0.5 
     53      alpha2 = 1. - alpha1 
    5454 
    55       alpha3 = (zrhox-1)/(zrhox+1) 
    56       alpha4 = 1.-alpha3 
     55      alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     56      alpha4 = 1. - alpha3 
    5757 
    58       alpha6 = 2.*(zrhox-1.)/(zrhox+1.) 
    59       alpha7 = -(zrhox-1)/(zrhox+3) 
     58      alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     59      alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    6060      alpha5 = 1. - alpha6 - alpha7 
     61      IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    6162 
    62       IF ((nbondi == 1).OR.(nbondi == 2)) THEN 
    63          tra(nlci,:,:,:) = alpha1 * ztra(nlci,:,:,:) + alpha2 * ztra(nlci-1,:,:,:) 
    64          DO jn=1,jptra  
    65             DO jk=1,jpk       
    66                DO jj=1,jpj 
    67                   IF (umask(nlci-2,jj,jk).EQ.0.) THEN 
     63         DO jn = 1, jptra 
     64            tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 
     65            DO jk = 1, jpkm1 
     66               DO jj = 1, jpj 
     67                  IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    6868                     tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    6969                  ELSE 
    7070                     tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    71                      IF (un(nlci-2,jj,jk).GT.0.) THEN 
    72                         tra(nlci-1,jj,jk,jn)=(alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) & 
    73                            +alpha7*tra(nlci-3,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     71                     IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     72                        tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn)  & 
     73                           &                 + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     74                     ENDIF 
     75                  ENDIF 
     76               END DO 
     77            END DO 
     78         ENDDO 
     79      ENDIF 
     80 
     81      IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
     82 
     83         DO jn = 1, jptra 
     84            tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 
     85            DO jk = 1, jpkm1 
     86               DO ji = 1, jpi 
     87                  IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     88                     tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     89                  ELSE 
     90                     tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 
     91                     IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     92                        tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn)  & 
     93                           &                 + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     94                     ENDIF 
     95                  ENDIF 
     96               END DO 
     97            END DO 
     98         ENDDO 
     99      ENDIF 
     100      IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
     101         DO jn = 1, jptra 
     102            tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 
     103            DO jk = 1, jpkm1 
     104               DO jj = 1, jpj 
     105                  IF( umask(2,jj,jk) == 0.e0 ) THEN 
     106                     tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     107                  ELSE 
     108                     tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 
     109                     IF( un(2,jj,jk) < 0.e0 ) THEN 
     110                        tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    74111                     ENDIF 
    75112                  ENDIF 
    … …  
    79116      ENDIF 
    80117 
    81       IF ((nbondj == 1).OR.(nbondj == 2)) THEN 
    82          tra(:,nlcj,:,:) = alpha1 * ztra(:,nlcj,:,:) + alpha2 * ztra(:,nlcj-1,:,:) 
    83          DO jn=1, jptra             
    84             DO jk=1,jpk       
     118      IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
     119         DO jn = 1, jptra 
     120            tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 
     121            DO jk=1,jpk 
    85122               DO ji=1,jpi 
    86                   IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN 
    87                      tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     123                  IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     124                     tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    88125                  ELSE 
    89                      tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    90                      IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN 
    91                         tra(ji,nlcj-1,jk,jn)=(alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) & 
    92                            +alpha7*tra(ji,nlcj-3,jk,jn))*tmask(ji,nlcj-1,jk) 
     126                     tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     127                     IF( vn(ji,2,jk) < 0.e0 ) THEN 
     128                        tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    93129                     ENDIF 
    94130                  ENDIF 
    95131               END DO 
    96132            END DO 
    97          END DO 
     133         ENDDO 
    98134      ENDIF 
    99  
    100       IF ((nbondi == -1).OR.(nbondi == 2)) THEN 
    101          tra(1,:,:,:) = alpha1 * ztra(1,:,:,:) + alpha2 * ztra(2,:,:,:) 
    102          DO jn=1, jptra 
    103             DO jk=1,jpk       
    104                DO jj=1,jpj 
    105                   IF (umask(2,jj,jk).EQ.0.) THEN 
    106                      tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    107                   ELSE 
    108                      tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
    109                      IF (un(2,jj,jk).LT.0.) THEN 
    110                         tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn) & 
    111                            +alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    112                      ENDIF 
    113                   ENDIF 
    114                END DO 
    115             END DO 
    116          END DO 
    117       ENDIF 
    118  
    119       IF ((nbondj == -1).OR.(nbondj == 2)) THEN 
    120          tra(:,1,:,:) = alpha1 * ztra(:,1,:,:) + alpha2 * ztra(:,2,:,:) 
    121          DO jn=1, jptra   
    122             DO jk=1,jpk       
    123                DO ji=1,jpi 
    124                   IF (vmask(ji,2,jk).EQ.0.) THEN 
    125                      tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    126                   ELSE 
    127                      tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    128                      IF (vn(ji,2,jk) .LT. 0.) THEN 
    129                         tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)& 
    130                            +alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    131                      ENDIF 
    132                   ENDIF 
    133                END DO 
    134             END DO 
    135          END DO 
    136       ENDIF 
    137  
     135      ! 
    138136      CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
     137      ! 
    139138 
    140139   END SUBROUTINE Agrif_trc 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r3294 r3680  
    88   USE in_out_manager 
    99   USE agrif_oce 
     10   USE agrif_opa_sponge 
    1011   USE trc 
    1112   USE lib_mpp 
    … …  
    1718   PUBLIC Agrif_Sponge_Trc, interptrn 
    1819 
     20  !! * Substitutions 
     21#  include "domzgr_substitute.h90" 
    1922   !!---------------------------------------------------------------------- 
    2023   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    … …  
    2932      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3033      !!--------------------------------------------- 
    31 #include "domzgr_substitute.h90" 
    3234      !!  
    33       INTEGER :: ji,jj,jk,jl 
    34       INTEGER :: spongearea 
     35      INTEGER :: ji,jj,jk,jn 
    3536      REAL(wp) :: timecoeff 
    3637      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
    37       REAL(wp), POINTER, DIMENSION(:,:) :: localviscsponge 
    38       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff, ztru, ztrv, ztab 
     38      REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv 
     39      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr 
     40      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff 
    3941 
    4042#if defined SPONGE_TOP 
    41       CALL wrk_alloc( jpi, jpj, localviscsponge ) 
    42       CALL wrk_alloc( jpi, jpj, jpk, jptra, trbdiff, ztru, ztrv, ztab ) 
     43      CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
     44      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
    4345 
    4446      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    … …  
    4648      Agrif_SpecialValue=0. 
    4749      Agrif_UseSpecialValue = .TRUE. 
    48       ztab = 0.e0 
    49       CALL Agrif_Bc_Variable(ztab, tra_id,calledweight=timecoeff,procname=interptrn) 
     50      ztabr = 0.e0 
     51      CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
    5052      Agrif_UseSpecialValue = .FALSE. 
    5153 
    52       trbdiff(:,:,:,:) = trb(:,:,:,:) - ztab(:,:,:,:) 
     54      trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:) 
    5355 
    54       spongearea = 2 + 2 * Agrif_irhox() 
     56      CALL Agrif_sponge 
    5557 
    56       localviscsponge = 0. 
    57        
    58       IF (.NOT. spongedoneT) THEN 
    59          spe1ur(:,:) = 0. 
    60          spe2vr(:,:) = 0. 
     58      DO jn = 1, jptra 
     59         DO jk = 1, jpkm1 
     60            ! 
     61            DO jj = 1, jpjm1 
     62               DO ji = 1, jpim1 
     63                  zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
     64                  zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
     65                  ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     66                  ztrv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     67               ENDDO 
     68            ENDDO 
    6169 
    62       IF ((nbondi == -1).OR.(nbondi == 2)) THEN 
    63          DO ji = 2, spongearea 
    64             localviscsponge(ji,:) = visc_tra * (spongearea-ji)/real(spongearea-2) 
     70            DO jj = 2,jpjm1 
     71               DO ji = 2,jpim1 
     72                  zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
     73                  ! horizontal diffusive trends 
     74                  ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1)  ) 
     75                  ! add it to the general tracer trends 
     76                  tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     77               END DO 
     78            END DO 
     79            ! 
    6580         ENDDO 
    66      
    67     spe1ur(2:spongearea-1,:)=0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) & 
    68           * e2u(2:spongearea-1,:) / e1u(2:spongearea-1,:) 
    69  
    70          spe2vr(2:spongearea,1:jpjm1) = 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + & 
    71              localviscsponge(2:spongearea,2:jpj)) & 
    72            * e1v(2:spongearea,1:jpjm1) / e2v(2:spongearea,1:jpjm1) 
    73       ENDIF 
    74  
    75       IF ((nbondi == 1).OR.(nbondi == 2)) THEN 
    76          DO ji = nlci-spongearea + 1,nlci-1 
    77             localviscsponge(ji,:) = visc_tra * (ji - (nlci-spongearea+1))/real(spongearea-2) 
    78          ENDDO 
    79      
    80     spe1ur(nlci-spongearea + 1:nlci-2,:)=0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + & 
    81            localviscsponge(nlci-spongearea + 2:nlci-1,:)) & 
    82           * e2u(nlci-spongearea + 1:nlci-2,:) / e1u(nlci-spongearea + 1:nlci-2,:) 
    83  
    84          spe2vr(nlci-spongearea + 1:nlci-1,1:jpjm1) = 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) & 
    85               + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) & 
    86            * e1v(nlci-spongearea + 1:nlci-1,1:jpjm1) / e2v(nlci-spongearea + 1:nlci-1,1:jpjm1) 
    87       ENDIF 
    88  
    89  
    90       IF ((nbondj == -1).OR.(nbondj == 2)) THEN 
    91          DO jj = 2, spongearea 
    92             localviscsponge(:,jj) = visc_tra * (spongearea-jj)/real(spongearea-2) 
    93          ENDDO 
    94      
    95     spe1ur(1:jpim1,2:spongearea)=0.5 * (localviscsponge(1:jpim1,2:spongearea) + & 
    96            localviscsponge(2:jpi,2:spongearea)) & 
    97           * e2u(1:jpim1,2:spongearea) / e1u(1:jpim1,2:spongearea) 
    98  
    99          spe2vr(:,2:spongearea-1) = 0.5 * (localviscsponge(:,2:spongearea-1) + & 
    100              localviscsponge(:,3:spongearea)) & 
    101            * e1v(:,2:spongearea-1) / e2v(:,2:spongearea-1) 
    102       ENDIF 
    103  
    104       IF ((nbondj == 1).OR.(nbondj == 2)) THEN 
    105          DO jj = nlcj-spongearea + 1,nlcj-1 
    106             localviscsponge(:,jj) = visc_tra * (jj - (nlcj-spongearea+1))/real(spongearea-2) 
    107          ENDDO 
    108      
    109     spe1ur(1:jpim1,nlcj-spongearea + 1:nlcj-1)=0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + & 
    110             localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) & 
    111           * e2u(1:jpim1,nlcj-spongearea + 1:nlcj-1) / e1u(1:jpim1,nlcj-spongearea + 1:nlcj-1) 
    112  
    113          spe2vr(:,nlcj-spongearea + 1:nlcj-2) = 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + & 
    114             localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) & 
    115            * e1v(:,nlcj-spongearea + 1:nlcj-2) / e2v(:,nlcj-spongearea + 1:nlcj-2) 
    116       ENDIF 
    117        
    118          spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:)) 
    119  
    120          spongedoneT = .TRUE. 
    121       ENDIF 
    122  
    123       DO jl = 1, jptra 
    124       DO jk = 1, jpkm1 
    125          DO jj = 1, jpjm1 
    126             DO ji = 1, jpim1 
    127                zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    128                zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    129                ztru(ji,jj,jk,jl) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jl) - trbdiff(ji,jj,jk,jl) ) 
    130                ztrv(ji,jj,jk,jl) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jl) - trbdiff(ji,jj,jk,jl) ) 
    131             ENDDO 
    132          ENDDO 
    133  
    134          DO jj = 2,jpjm1 
    135             DO ji = 2,jpim1 
    136                zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    137                ! horizontal diffusive trends 
    138                ztra = zbtr * (  ztru(ji,jj,jk,jl) - ztru(ji-1,jj,jk,jl)   & 
    139                   &          + ztrv(ji,jj,jk,jl) - ztrv(ji,jj-1,jk,jl)  ) 
    140                ! add it to the general tracer trends 
    141                tra(ji,jj,jk,jl) = (tra(ji,jj,jk,jl) + ztra) 
    142             END DO 
    143          END DO 
    144  
    145       ENDDO 
    14681      ENDDO 
    14782  
    148       CALL wrk_dealloc( jpi, jpj, localviscsponge ) 
    149       CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztru, ztrv, ztab ) 
     83      CALL wrk_dealloc( jpi, jpj, ztru, ztrv ) 
     84      CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr ) 
    15085 
    15186#endif 
    … …  
    15388   END SUBROUTINE Agrif_Sponge_Trc 
    15489 
    155    SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,l1,l2) 
     90   SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    15691      !!--------------------------------------------- 
    15792      !!   *** ROUTINE interptn *** 
    15893      !!--------------------------------------------- 
    159 #  include "domzgr_substitute.h90"        
    160        
    161       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,l1,l2 
    162       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,l1:l2), INTENT(inout) :: tabres 
    163  
    164       tabres(i1:i2,j1:j2,k1:k2,l1:l2) = trn(i1:i2,j1:j2,k1:k2,l1:l2) 
     94      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     95      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     96      ! 
     97      tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
    16598 
    16699   END SUBROUTINE interptrn 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r3294 r3680  
    3838 
    3939#if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztra ) 
     40      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    4141 
    4242      Agrif_UseSpecialValueInUpdate = .TRUE. 
    … …  
    5252      nbcline_trc = nbcline_trc + 1 
    5353 
    54       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztra ) 
     54      CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5555#endif 
    5656 
    5757   END SUBROUTINE Agrif_Update_Trc 
    5858 
    59    SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,l1,l2,before) 
     59   SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    6060      !!--------------------------------------------- 
    6161      !!   *** ROUTINE UpdateTrc *** 
    6262      !!--------------------------------------------- 
    63 #  include "domzgr_substitute.h90" 
    64  
    65       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,l1,l2 
    66       REAL, DIMENSION(i1:i2,j1:j2,k1:k2,l1:l2), INTENT(inout) :: tabres 
     63      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     64      REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    6765      LOGICAL, INTENT(in) :: before 
    6866    
    69       INTEGER :: ji,jj,jk,jl 
     67      INTEGER :: ji,jj,jk,jn 
    7068 
    71          IF (before) THEN 
    72             DO jl=l1,l2 
    73                DO jk=k1,k2 
    74                   DO jj=j1,j2 
    75                      DO ji=i1,i2 
    76                         tabres(ji,jj,jk,jl) = trn(ji,jj,jk,jl) 
     69         IF( before ) THEN 
     70            DO jn = n1, n2 
     71               DO jk = k1, k2 
     72                  DO jj = j1, j2 
     73                     DO ji = i1, i2 
     74                        tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    7775                     ENDDO 
    7876                  ENDDO 
    … …  
    8078            ENDDO 
    8179         ELSE 
    82             DO jl=l1,l2 
    83                DO jk=k1,k2 
    84                   DO jj=j1,j2 
    85                      DO ji=i1,i2 
    86                         IF (tabres(ji,jj,jk,jl).NE.0.) THEN 
    87                            trn(ji,jj,jk,jl) = tabres(ji,jj,jk,jl) * tmask(ji,jj,jk) 
     80            DO jn = n1, n2 
     81               DO jk = k1, k2 
     82                  DO jj = j1, j2 
     83                     DO ji = i1, i2 
     84                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
     85                           trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
    8886                        ENDIF 
    8987                     ENDDO 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r3294 r3680  
    11#if defined key_agrif 
    2    !!---------------------------------------------------------------------- 
    3    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    4    !! $Id$ 
    5    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6    !!---------------------------------------------------------------------- 
    7    SUBROUTINE agrif_before_regridding 
    8    END SUBROUTINE 
    9  
    10    SUBROUTINE Agrif_InitWorkspace 
    11       !!---------------------------------------------------------------------- 
    12       !!                 *** ROUTINE Agrif_InitWorkspace *** 
    13       !!---------------------------------------------------------------------- 
    14       USE par_oce 
    15       USE dom_oce 
    16       USE Agrif_Util 
    17       USE nemogcm 
    18       ! 
    19       IMPLICIT NONE 
    20       !!---------------------------------------------------------------------- 
    21       ! 
    22       IF( .NOT. Agrif_Root() ) THEN 
    23          jpni = Agrif_Parent(jpni) 
    24          jpnj = Agrif_Parent(jpnj) 
    25          jpnij = Agrif_Parent(jpnij) 
    26          jpiglo  = nbcellsx + 2 + 2*nbghostcells 
    27          jpjglo  = nbcellsy + 2 + 2*nbghostcells 
    28          jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    29          jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    30          jpk     = jpkdta 
    31          jpim1   = jpi-1 
    32          jpjm1   = jpj-1 
    33          jpkm1   = jpk-1                                         
    34          jpij    = jpi*jpj 
    35          jpidta  = jpiglo 
    36          jpjdta  = jpjglo 
    37          jpizoom = 1 
    38          jpjzoom = 1 
    39          nperio  = 0 
    40          jperio  = 0 
    41       ENDIF 
    42       ! 
    43    END SUBROUTINE Agrif_InitWorkspace 
    44  
    45  
    46    SUBROUTINE Agrif_InitValues 
    47       !!---------------------------------------------------------------------- 
    48       !!                 *** ROUTINE Agrif_InitValues *** 
    49       !! 
    50       !! ** Purpose :: Declaration of variables to be interpolated 
    51       !!---------------------------------------------------------------------- 
    52       USE Agrif_Util 
    53       USE oce  
    54       USE dom_oce 
    55       USE nemogcm 
    56       USE tradmp 
    57       USE obc_par 
    58       USE bdy_par 
    59  
    60       IMPLICIT NONE 
    61       !!---------------------------------------------------------------------- 
    62  
    63       ! 0. Initializations 
    64       !------------------- 
     2!!---------------------------------------------------------------------- 
     3!! NEMO/NST 3.4 , NEMO Consortium (2012) 
     4!! $Id$ 
     5!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     6!!---------------------------------------------------------------------- 
     7SUBROUTINE agrif_user 
     8END SUBROUTINE agrif_user 
     9 
     10SUBROUTINE agrif_before_regridding 
     11END SUBROUTINE agrif_before_regridding 
     12 
     13SUBROUTINE Agrif_InitWorkspace 
     14   !!---------------------------------------------------------------------- 
     15   !!                 *** ROUTINE Agrif_InitWorkspace *** 
     16   !!---------------------------------------------------------------------- 
     17   USE par_oce 
     18   USE dom_oce 
     19   USE Agrif_Util 
     20   USE nemogcm 
     21   ! 
     22   IMPLICIT NONE 
     23   !!---------------------------------------------------------------------- 
     24   ! 
     25   IF( .NOT. Agrif_Root() ) THEN 
     26      jpni = Agrif_Parent(jpni) 
     27      jpnj = Agrif_Parent(jpnj) 
     28      jpnij = Agrif_Parent(jpnij) 
     29      jpiglo  = nbcellsx + 2 + 2*nbghostcells 
     30      jpjglo  = nbcellsy + 2 + 2*nbghostcells 
     31      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
     32      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
     33      jpk     = jpkdta 
     34      jpim1   = jpi-1 
     35      jpjm1   = jpj-1 
     36      jpkm1   = jpk-1                                         
     37      jpij    = jpi*jpj 
     38      jpidta  = jpiglo 
     39      jpjdta  = jpjglo 
     40      jpizoom = 1 
     41      jpjzoom = 1 
     42      nperio  = 0 
     43      jperio  = 0 
     44   ENDIF 
     45   ! 
     46END SUBROUTINE Agrif_InitWorkspace 
     47 
     48 
     49SUBROUTINE Agrif_InitValues 
     50   !!---------------------------------------------------------------------- 
     51   !!                 *** ROUTINE Agrif_InitValues *** 
     52   !! 
     53   !! ** Purpose :: Declaration of variables to be interpolated 
     54   !!---------------------------------------------------------------------- 
     55   USE Agrif_Util 
     56   USE oce  
     57   USE dom_oce 
     58   USE nemogcm 
     59   USE tradmp 
     60   USE obc_par 
     61   USE bdy_par 
     62 
     63   IMPLICIT NONE 
     64   !!---------------------------------------------------------------------- 
     65 
     66   ! 0. Initializations 
     67   !------------------- 
    6568#if defined key_orca_r025 || defined key_orca_r05 || defined key_orca_r2 || defined key_orca_r4 
    66       jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    67       cp_cfg = "default" 
     69   jp_cfg = -1    ! set special value for jp_cfg on fine grids 
     70   cp_cfg = "default" 
    6871#endif 
    6972 
    70       ! Specific fine grid Initializations 
    71       ! no tracer damping on fine grids 
    72       ln_tradmp = .FALSE. 
    73       ! no open boundary on fine grids 
    74       lk_obc = .FALSE. 
    75       lk_bdy = .FALSE. 
    76  
    77       CALL nemo_init  ! Initializations of each fine grid 
    78       CALL agrif_nemo_init 
     73   ! Specific fine grid Initializations 
     74   ! no tracer damping on fine grids 
     75   ln_tradmp = .FALSE. 
     76   ! no open boundary on fine grids 
     77   lk_obc = .FALSE. 
     78   lk_bdy = .FALSE. 
     79 
     80   CALL nemo_init  ! Initializations of each fine grid 
     81   CALL agrif_nemo_init 
     82   CALL Agrif_InitValues_cont_dom 
    7983# if ! defined key_offline 
    80       CALL Agrif_InitValues_cont 
     84   CALL Agrif_InitValues_cont 
    8185# endif        
    8286# if defined key_top 
    83       CALL Agrif_InitValues_cont_top 
     87   CALL Agrif_InitValues_cont_top 
    8488# endif       
    85    END SUBROUTINE Agrif_initvalues 
     89END SUBROUTINE Agrif_initvalues 
     90 
     91 
     92SUBROUTINE Agrif_InitValues_cont_dom 
     93   !!---------------------------------------------------------------------- 
     94   !!                 *** ROUTINE Agrif_InitValues_cont *** 
     95   !! 
     96   !! ** Purpose ::   Declaration of variables to be interpolated 
     97   !!---------------------------------------------------------------------- 
     98   USE Agrif_Util 
     99   USE oce  
     100   USE dom_oce 
     101   USE nemogcm 
     102   USE sol_oce 
     103   USE in_out_manager 
     104   USE agrif_opa_update 
     105   USE agrif_opa_interp 
     106   USE agrif_opa_sponge 
     107   ! 
     108   IMPLICIT NONE 
     109   ! 
     110   !!---------------------------------------------------------------------- 
     111 
     112   ! Declaration of the type of variable which have to be interpolated 
     113   !--------------------------------------------------------------------- 
     114   CALL agrif_declare_var_dom 
     115   ! 
     116END SUBROUTINE Agrif_InitValues_cont_dom 
     117 
     118 
     119SUBROUTINE agrif_declare_var_dom 
     120   !!---------------------------------------------------------------------- 
     121   !!                 *** ROUTINE agrif_declarE_var *** 
     122   !! 
     123   !! ** Purpose :: Declaration of variables to be interpolated 
     124   !!---------------------------------------------------------------------- 
     125   USE agrif_util 
     126   USE par_oce       !   ONLY : jpts 
     127   USE oce 
     128   IMPLICIT NONE 
     129   !!---------------------------------------------------------------------- 
     130 
     131   ! 1. Declaration of the type of variable which have to be interpolated 
     132   !--------------------------------------------------------------------- 
     133   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
     134   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
     135 
     136 
     137   ! 2. Type of interpolation 
     138   !------------------------- 
     139   Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     140   Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     141 
     142   ! 3. Location of interpolation 
     143   !----------------------------- 
     144   Call Agrif_Set_bc(e1u_id,(/0,0/)) 
     145   Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     146 
     147   ! 5. Update type 
     148   !---------------  
     149   Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     150   Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     151 
     152END SUBROUTINE agrif_declare_var_dom 
     153 
    86154 
    87155# if ! defined key_offline 
    88156 
    89    SUBROUTINE Agrif_InitValues_cont 
    90       !!---------------------------------------------------------------------- 
    91       !!                 *** ROUTINE Agrif_InitValues_cont *** 
    92       !! 
    93       !! ** Purpose ::   Declaration of variables to be interpolated 
    94       !!---------------------------------------------------------------------- 
    95       USE Agrif_Util 
    96       USE oce  
    97       USE dom_oce 
    98       USE nemogcm 
    99       USE sol_oce 
    100       USE in_out_manager 
    101       USE agrif_opa_update 
    102       USE agrif_opa_interp 
    103       USE agrif_opa_sponge 
    104       ! 
    105       IMPLICIT NONE 
    106       ! 
    107       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    108       REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    109       LOGICAL :: check_namelist 
    110       !!---------------------------------------------------------------------- 
    111  
    112       ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
    113       ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
    114  
    115  
    116       ! 1. Declaration of the type of variable which have to be interpolated 
    117       !--------------------------------------------------------------------- 
    118       CALL agrif_declare_var 
    119  
    120       ! 2. First interpolations of potentially non zero fields 
    121       !------------------------------------------------------- 
    122       Agrif_SpecialValue=0. 
    123       Agrif_UseSpecialValue = .TRUE. 
    124       Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
    125       Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
    126  
    127       Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
    128       Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
    129       Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
    130       Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    131       Agrif_UseSpecialValue = .FALSE. 
    132  
    133       ! 3. Some controls 
    134       !----------------- 
    135       check_namelist = .true. 
    136              
    137       IF( check_namelist ) THEN 
    138       
    139          ! Check time steps            
    140          IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
    141             WRITE(*,*) 'incompatible time step between grids' 
    142             WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    143             WRITE(*,*) 'child  grid value : ',nint(rdt) 
    144             WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
     157SUBROUTINE Agrif_InitValues_cont 
     158   !!---------------------------------------------------------------------- 
     159   !!                 *** ROUTINE Agrif_InitValues_cont *** 
     160   !! 
     161   !! ** Purpose ::   Declaration of variables to be interpolated 
     162   !!---------------------------------------------------------------------- 
     163   USE Agrif_Util 
     164   USE oce  
     165   USE dom_oce 
     166   USE nemogcm 
     167   USE sol_oce 
     168   USE in_out_manager 
     169   USE agrif_opa_update 
     170   USE agrif_opa_interp 
     171   USE agrif_opa_sponge 
     172   ! 
     173   IMPLICIT NONE 
     174   ! 
     175   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
     176   REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
     177   LOGICAL :: check_namelist 
     178   !!---------------------------------------------------------------------- 
     179 
     180   ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
     181   ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
     182 
     183 
     184   ! 1. Declaration of the type of variable which have to be interpolated 
     185   !--------------------------------------------------------------------- 
     186   CALL agrif_declare_var 
     187 
     188   ! 2. First interpolations of potentially non zero fields 
     189   !------------------------------------------------------- 
     190   Agrif_SpecialValue=0. 
     191   Agrif_UseSpecialValue = .TRUE. 
     192   Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
     193   Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
     194 
     195   Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
     196   Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
     197   Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
     198   Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
     199   Agrif_UseSpecialValue = .FALSE. 
     200 
     201   ! 3. Some controls 
     202   !----------------- 
     203   check_namelist = .true. 
     204 
     205   IF( check_namelist ) THEN 
     206 
     207      ! Check time steps            
     208      IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
     209         WRITE(*,*) 'incompatible time step between grids' 
     210         WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
     211         WRITE(*,*) 'child  grid value : ',nint(rdt) 
     212         WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
     213         STOP 
     214      ENDIF 
     215 
     216      ! Check run length 
     217      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     218           Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
     219         WRITE(*,*) 'incompatible run length between grids' 
     220         WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
     221              Agrif_Parent(nit000)+1),' time step' 
     222         WRITE(*,*) 'child  grid value : ', & 
     223              (nitend-nit000+1),' time step' 
     224         WRITE(*,*) 'value on child grid should be : ', & 
     225              Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     226              Agrif_Parent(nit000)+1) 
     227         STOP 
     228      ENDIF 
     229 
     230      ! Check coordinates 
     231      IF( ln_zps ) THEN 
     232         ! check parameters for partial steps  
     233         IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     234            WRITE(*,*) 'incompatible e3zps_min between grids' 
     235            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
     236            WRITE(*,*) 'child grid  :',e3zps_min 
     237            WRITE(*,*) 'those values should be identical' 
    145238            STOP 
    146239         ENDIF 
    147           
    148          ! Check run length 
    149          IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    150             Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    151             WRITE(*,*) 'incompatible run length between grids' 
    152             WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    153                Agrif_Parent(nit000)+1),' time step' 
    154             WRITE(*,*) 'child  grid value : ', & 
    155                (nitend-nit000+1),' time step' 
    156             WRITE(*,*) 'value on child grid should be : ', & 
    157                Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    158                Agrif_Parent(nit000)+1) 
     240         IF( Agrif_Parent(e3zps_rat) /= e3zps_rat ) THEN 
     241            WRITE(*,*) 'incompatible e3zps_rat between grids' 
     242            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
     243            WRITE(*,*) 'child grid  :',e3zps_rat 
     244            WRITE(*,*) 'those values should be identical'                   
    159245            STOP 
    160246         ENDIF 
    161           
    162          ! Check coordinates 
    163          IF( ln_zps ) THEN 
    164             ! check parameters for partial steps  
    165             IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
    166                WRITE(*,*) 'incompatible e3zps_min between grids' 
    167                WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    168                WRITE(*,*) 'child grid  :',e3zps_min 
    169                WRITE(*,*) 'those values should be identical' 
    170                STOP 
    171             ENDIF           
    172             IF( Agrif_Parent(e3zps_rat) /= e3zps_rat ) THEN 
    173                WRITE(*,*) 'incompatible e3zps_rat between grids' 
    174                WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    175                WRITE(*,*) 'child grid  :',e3zps_rat 
    176                WRITE(*,*) 'those values should be identical'                   
    177                STOP 
    178             ENDIF 
     247      ENDIF 
     248   ENDIF 
     249 
     250   CALL Agrif_Update_tra(0) 
     251   CALL Agrif_Update_dyn(0) 
     252 
     253   nbcline = 0 
     254   ! 
     255   DEALLOCATE(tabtstemp) 
     256   DEALLOCATE(tabuvtemp) 
     257   ! 
     258END SUBROUTINE Agrif_InitValues_cont 
     259 
     260 
     261SUBROUTINE agrif_declare_var 
     262   !!---------------------------------------------------------------------- 
     263   !!                 *** ROUTINE agrif_declarE_var *** 
     264   !! 
     265   !! ** Purpose :: Declaration of variables to be interpolated 
     266   !!---------------------------------------------------------------------- 
     267   USE agrif_util 
     268   USE par_oce       !   ONLY : jpts 
     269   USE oce 
     270   IMPLICIT NONE 
     271   !!---------------------------------------------------------------------- 
     272 
     273   ! 1. Declaration of the type of variable which have to be interpolated 
     274   !--------------------------------------------------------------------- 
     275   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
     276   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
     277   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
     278 
     279   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
     280   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
     281   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
     282   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
     283 
     284   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
     285   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
     286 
     287   ! 2. Type of interpolation 
     288   !------------------------- 
     289   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
     290   CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
     291 
     292   Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     293   Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     294 
     295   Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     296   Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     297 
     298   ! 3. Location of interpolation 
     299   !----------------------------- 
     300   Call Agrif_Set_bc(un_id,(/0,1/)) 
     301   Call Agrif_Set_bc(vn_id,(/0,1/)) 
     302 
     303   Call Agrif_Set_bc(tsn_id,(/0,1/)) 
     304   Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
     305 
     306   Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
     307   Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
     308 
     309   ! 5. Update type 
     310   !---------------  
     311   Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     312   Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
     313 
     314   Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     315   Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
     316 
     317   Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     318   Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     319 
     320END SUBROUTINE agrif_declare_var 
     321# endif 
     322 
     323#  if defined key_lim2 
     324SUBROUTINE Agrif_InitValues_cont_lim2 
     325   !!---------------------------------------------------------------------- 
     326   !!                 *** ROUTINE Agrif_InitValues_cont_lim2 *** 
     327   !! 
     328   !! ** Purpose :: Initialisation of variables to be interpolated for LIM2 
     329   !!---------------------------------------------------------------------- 
     330   USE Agrif_Util 
     331   USE ice_2 
     332   USE agrif_ice 
     333   USE in_out_manager 
     334   USE agrif_lim2_update 
     335   USE agrif_lim2_interp 
     336   USE lib_mpp 
     337   ! 
     338   IMPLICIT NONE 
     339   ! 
     340   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
     341   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
     342   !!---------------------------------------------------------------------- 
     343 
     344   ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
     345 
     346   ! 1. Declaration of the type of variable which have to be interpolated 
     347   !--------------------------------------------------------------------- 
     348   CALL agrif_declare_var_lim2 
     349 
     350   ! 2. First interpolations of potentially non zero fields 
     351   !------------------------------------------------------- 
     352   Agrif_SpecialValue=-9999. 
     353   Agrif_UseSpecialValue = .TRUE. 
     354   !     Call Agrif_Bc_variable(zadv ,adv_ice_id ,calledweight=1.,procname=interp_adv_ice ) 
     355   !     Call Agrif_Bc_variable(zvel ,u_ice_id   ,calledweight=1.,procname=interp_u_ice   ) 
     356   !     Call Agrif_Bc_variable(zvel ,v_ice_id   ,calledweight=1.,procname=interp_v_ice   ) 
     357   Agrif_SpecialValue=0. 
     358   Agrif_UseSpecialValue = .FALSE. 
     359 
     360   ! 3. Some controls 
     361   !----------------- 
     362 
     363#   if ! defined key_lim2_vp 
     364   lim_nbstep = 1. 
     365   CALL agrif_rhg_lim2_load 
     366   CALL agrif_trp_lim2_load 
     367   lim_nbstep = 0. 
     368#   endif 
     369   !RB mandatory but why ??? 
     370   !      IF( nbclineupdate /= nn_fsbc .AND. nn_ice == 2 )THEN 
     371   !         CALL ctl_warn ('With ice model on child grid, nbclineupdate is set to nn_fsbc') 
     372   !         nbclineupdate = nn_fsbc 
     373   !       ENDIF 
     374   CALL Agrif_Update_lim2(0) 
     375   ! 
     376   DEALLOCATE( zvel, zadv ) 
     377   ! 
     378END SUBROUTINE Agrif_InitValues_cont_lim2 
     379 
     380SUBROUTINE agrif_declare_var_lim2 
     381   !!---------------------------------------------------------------------- 
     382   !!                 *** ROUTINE agrif_declare_var_lim2 *** 
     383   !! 
     384   !! ** Purpose :: Declaration of variables to be interpolated for LIM2 
     385   !!---------------------------------------------------------------------- 
     386   USE agrif_util 
     387   USE ice_2 
     388 
     389   IMPLICIT NONE 
     390   !!---------------------------------------------------------------------- 
     391 
     392   ! 1. Declaration of the type of variable which have to be interpolated 
     393   !--------------------------------------------------------------------- 
     394   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj, 7/),adv_ice_id ) 
     395#   if defined key_lim2_vp 
     396   CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id) 
     397   CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id) 
     398#   else 
     399   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id) 
     400   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id) 
     401#   endif 
     402 
     403   ! 2. Type of interpolation 
     404   !------------------------- 
     405   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
     406   Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     407   Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     408 
     409   ! 3. Location of interpolation 
     410   !----------------------------- 
     411   Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     412   Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
     413   Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     414 
     415   ! 5. Update type 
     416   !--------------- 
     417   Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     418   Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     419   Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     420 
     421END SUBROUTINE agrif_declare_var_lim2 
     422#  endif 
     423 
     424 
     425# if defined key_top 
     426SUBROUTINE Agrif_InitValues_cont_top 
     427   !!---------------------------------------------------------------------- 
     428   !!                 *** ROUTINE Agrif_InitValues_cont_top *** 
     429   !! 
     430   !! ** Purpose :: Declaration of variables to be interpolated 
     431   !!---------------------------------------------------------------------- 
     432   USE Agrif_Util 
     433   USE oce  
     434   USE dom_oce 
     435   USE nemogcm 
     436   USE par_trc 
     437   USE trc 
     438   USE in_out_manager 
     439   USE agrif_top_update 
     440   USE agrif_top_interp 
     441   USE agrif_top_sponge 
     442   ! 
     443   IMPLICIT NONE 
     444   ! 
     445   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
     446   LOGICAL :: check_namelist 
     447   !!---------------------------------------------------------------------- 
     448 
     449   ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
     450 
     451 
     452   ! 1. Declaration of the type of variable which have to be interpolated 
     453   !--------------------------------------------------------------------- 
     454   CALL agrif_declare_var_top 
     455 
     456   ! 2. First interpolations of potentially non zero fields 
     457   !------------------------------------------------------- 
     458   Agrif_SpecialValue=0. 
     459   Agrif_UseSpecialValue = .TRUE. 
     460   Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
     461   Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     462   Agrif_UseSpecialValue = .FALSE. 
     463 
     464   ! 3. Some controls 
     465   !----------------- 
     466   check_namelist = .true. 
     467 
     468   IF( check_namelist ) THEN 
     469#  if defined offline      
     470      ! Check time steps 
     471      IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
     472         WRITE(*,*) 'incompatible time step between grids' 
     473         WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
     474         WRITE(*,*) 'child  grid value : ',nint(rdt) 
     475         WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
     476         STOP 
     477      ENDIF 
     478 
     479      ! Check run length 
     480      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     481           Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
     482         WRITE(*,*) 'incompatible run length between grids' 
     483         WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
     484              Agrif_Parent(nit000)+1),' time step' 
     485         WRITE(*,*) 'child  grid value : ', & 
     486              (nitend-nit000+1),' time step' 
     487         WRITE(*,*) 'value on child grid should be : ', & 
     488              Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     489              Agrif_Parent(nit000)+1) 
     490         STOP 
     491      ENDIF 
     492 
     493      ! Check coordinates 
     494      IF( ln_zps ) THEN 
     495         ! check parameters for partial steps  
     496         IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     497            WRITE(*,*) 'incompatible e3zps_min between grids' 
     498            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
     499            WRITE(*,*) 'child grid  :',e3zps_min 
     500            WRITE(*,*) 'those values should be identical' 
     501            STOP 
     502         ENDIF 
     503         IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     504            WRITE(*,*) 'incompatible e3zps_rat between grids' 
     505            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
     506            WRITE(*,*) 'child grid  :',e3zps_rat 
     507            WRITE(*,*) 'those values should be identical'                   
     508            STOP 
    179509         ENDIF 
    180510      ENDIF 
    181         
    182       CALL Agrif_Update_tra(0) 
    183       CALL Agrif_Update_dyn(0) 
    184  
    185       nbcline = 0 
    186       ! 
    187       DEALLOCATE(tabtstemp) 
    188       DEALLOCATE(tabuvtemp) 
    189       ! 
    190    END SUBROUTINE Agrif_InitValues_cont 
    191  
    192  
    193    SUBROUTINE agrif_declare_var 
    194       !!---------------------------------------------------------------------- 
    195       !!                 *** ROUTINE agrif_declarE_var *** 
    196       !! 
    197       !! ** Purpose :: Declaration of variables to be interpolated 
    198       !!---------------------------------------------------------------------- 
    199       USE agrif_util 
    200       USE par_oce       !   ONLY : jpts 
    201       USE oce 
    202       IMPLICIT NONE 
    203       !!---------------------------------------------------------------------- 
    204     
    205       ! 1. Declaration of the type of variable which have to be interpolated 
    206       !--------------------------------------------------------------------- 
    207       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
    208       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
    209       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
    210  
    211       CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    212       CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    213       CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    214       CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
    215     
    216       CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    217       CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    218  
    219       CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
    220       CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    221         
    222       ! 2. Type of interpolation 
    223       !------------------------- 
    224       CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    225       CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    226     
    227       Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    228       Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    229  
    230       Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    231       Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    232  
    233       Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    234       Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    235  
    236       ! 3. Location of interpolation 
    237       !----------------------------- 
    238       Call Agrif_Set_bc(un_id,(/0,1/)) 
    239       Call Agrif_Set_bc(vn_id,(/0,1/)) 
    240  
    241       Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    242       Call Agrif_Set_bc(e2v_id,(/0,0/)) 
    243  
    244       Call Agrif_Set_bc(tsn_id,(/0,1/)) 
    245       Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    246  
    247       Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    248       Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
    249  
    250       ! 5. Update type 
    251       !---------------  
    252       Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    253       Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    254  
    255       Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    256       Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
    257  
    258       Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    259       Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    260  
    261       Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    262       Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    263  
    264    END SUBROUTINE agrif_declare_var 
     511#  endif          
     512      ! Check passive tracer cell 
     513      IF( nn_dttrc .ne. 1 ) THEN 
     514         WRITE(*,*) 'nn_dttrc should be equal to 1' 
     515      ENDIF 
     516   ENDIF 
     517 
     518!ch   CALL Agrif_Update_trc(0) 
     519   nbcline_trc = 0 
     520   ! 
     521   DEALLOCATE(tabtrtemp) 
     522   ! 
     523END SUBROUTINE Agrif_InitValues_cont_top 
     524 
     525 
     526SUBROUTINE agrif_declare_var_top 
     527   !!---------------------------------------------------------------------- 
     528   !!                 *** ROUTINE agrif_declare_var_top *** 
     529   !! 
     530   !! ** Purpose :: Declaration of TOP variables to be interpolated 
     531   !!---------------------------------------------------------------------- 
     532   USE agrif_util 
     533   USE dom_oce 
     534   USE trc 
     535 
     536   IMPLICIT NONE 
     537 
     538   ! 1. Declaration of the type of variable which have to be interpolated 
     539   !--------------------------------------------------------------------- 
     540   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
     541   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
     542   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
     543 
     544   ! 2. Type of interpolation 
     545   !------------------------- 
     546   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
     547   CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     548 
     549   ! 3. Location of interpolation 
     550   !----------------------------- 
     551   Call Agrif_Set_bc(trn_id,(/0,1/)) 
     552   Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     553 
     554   ! 5. Update type 
     555   !---------------  
     556   Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     557   Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
     558 
     559 
     560END SUBROUTINE agrif_declare_var_top 
    265561# endif 
    266     
    267 # if defined key_top 
    268    SUBROUTINE Agrif_InitValues_cont_top 
    269       !!---------------------------------------------------------------------- 
    270       !!                 *** ROUTINE Agrif_InitValues_cont_top *** 
    271       !! 
    272       !! ** Purpose :: Declaration of variables to be interpolated 
    273       !!---------------------------------------------------------------------- 
    274       USE Agrif_Util 
    275       USE oce  
    276       USE dom_oce 
    277       USE nemogcm 
    278       USE trc 
    279       USE in_out_manager 
    280       USE agrif_top_update 
    281       USE agrif_top_interp 
    282       USE agrif_top_sponge 
    283       ! 
    284       IMPLICIT NONE 
    285       ! 
    286       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
    287       LOGICAL :: check_namelist 
    288       !!---------------------------------------------------------------------- 
    289  
    290       ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    291        
    292        
    293       ! 1. Declaration of the type of variable which have to be interpolated 
    294       !--------------------------------------------------------------------- 
    295       CALL agrif_declare_var_top 
    296  
    297       ! 2. First interpolations of potentially non zero fields 
    298       !------------------------------------------------------- 
    299       Agrif_SpecialValue=0. 
    300       Agrif_UseSpecialValue = .TRUE. 
    301       Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.) 
    302       Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
    303       Agrif_UseSpecialValue = .FALSE. 
    304  
    305       ! 3. Some controls 
    306       !----------------- 
    307       check_namelist = .true. 
    308              
    309       IF( check_namelist ) THEN 
    310 #  if defined offline      
    311          ! Check time steps 
    312          IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    313             WRITE(*,*) 'incompatible time step between grids' 
    314             WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    315             WRITE(*,*) 'child  grid value : ',nint(rdt) 
    316             WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    317             STOP 
    318          ENDIF 
    319  
    320          ! Check run length 
    321          IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    322             Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    323             WRITE(*,*) 'incompatible run length between grids' 
    324             WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    325                Agrif_Parent(nit000)+1),' time step' 
    326             WRITE(*,*) 'child  grid value : ', & 
    327                (nitend-nit000+1),' time step' 
    328             WRITE(*,*) 'value on child grid should be : ', & 
    329                Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    330                Agrif_Parent(nit000)+1) 
    331             STOP 
    332          ENDIF 
    333           
    334          ! Check coordinates 
    335          IF( ln_zps ) THEN 
    336             ! check parameters for partial steps  
    337             IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
    338                WRITE(*,*) 'incompatible e3zps_min between grids' 
    339                WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    340                WRITE(*,*) 'child grid  :',e3zps_min 
    341                WRITE(*,*) 'those values should be identical' 
    342                STOP 
    343             ENDIF           
    344             IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
    345                WRITE(*,*) 'incompatible e3zps_rat between grids' 
    346                WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    347                WRITE(*,*) 'child grid  :',e3zps_rat 
    348                WRITE(*,*) 'those values should be identical'                   
    349                STOP 
    350             ENDIF 
    351          ENDIF 
    352 #  endif          
    353         ! Check passive tracer cell 
    354         IF( nn_dttrc .ne. 1 ) THEN 
    355            WRITE(*,*) 'nn_dttrc should be equal to 1' 
    356         ENDIF 
    357       ENDIF 
    358         
    359       CALL Agrif_Update_trc(0) 
    360       nbcline_trc = 0 
    361       ! 
    362       DEALLOCATE(tabtrtemp) 
    363       ! 
    364    END SUBROUTINE Agrif_InitValues_cont_top 
    365  
    366  
    367    SUBROUTINE agrif_declare_var_top 
    368       !!---------------------------------------------------------------------- 
    369       !!                 *** ROUTINE agrif_declare_var_top *** 
    370       !! 
    371       !! ** Purpose :: Declaration of TOP variables to be interpolated 
    372       !!---------------------------------------------------------------------- 
    373       USE agrif_util 
    374       USE dom_oce 
    375       USE trc 
    376        
    377       IMPLICIT NONE 
    378     
    379       ! 1. Declaration of the type of variable which have to be interpolated 
    380       !--------------------------------------------------------------------- 
    381       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
    382       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
    383       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
    384 #  if defined key_offline 
    385       CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    386       CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    387 #  endif 
    388         
    389       ! 2. Type of interpolation 
    390       !------------------------- 
    391       CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    392       CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
    393     
    394 #  if defined key_offline 
    395       Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    396       Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    397 #  endif 
    398  
    399       ! 3. Location of interpolation 
    400       !----------------------------- 
    401 #  if defined key_offline 
    402       Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    403       Call Agrif_Set_bc(e2v_id,(/0,0/)) 
    404 #  endif 
    405       Call Agrif_Set_bc(trn_id,(/0,1/)) 
    406       Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
    407  
    408       ! 5. Update type 
    409       !---------------  
    410       Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    411       Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    412  
    413 #  if defined key_offline 
    414       Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    415       Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    416 #  endif 
    417  
    418    END SUBROUTINE agrif_declare_var_top 
     562 
     563SUBROUTINE Agrif_detect( kg, ksizex ) 
     564   !!---------------------------------------------------------------------- 
     565   !!   *** ROUTINE Agrif_detect *** 
     566   !!---------------------------------------------------------------------- 
     567   USE Agrif_Types 
     568   ! 
     569   INTEGER, DIMENSION(2) :: ksizex 
     570   INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg  
     571   !!---------------------------------------------------------------------- 
     572   ! 
     573   RETURN 
     574   ! 
     575END SUBROUTINE Agrif_detect 
     576 
     577 
     578SUBROUTINE agrif_nemo_init 
     579   !!---------------------------------------------------------------------- 
     580   !!                     *** ROUTINE agrif_init *** 
     581   !!---------------------------------------------------------------------- 
     582   USE agrif_oce  
     583   USE agrif_ice 
     584   USE in_out_manager 
     585   USE lib_mpp 
     586   IMPLICIT NONE 
     587   ! 
     588   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
     589   !!---------------------------------------------------------------------- 
     590   ! 
     591   REWIND( numnam )                ! Read namagrif namelist 
     592   READ  ( numnam, namagrif ) 
     593   ! 
     594   IF(lwp) THEN                    ! control print 
     595      WRITE(numout,*) 
     596      WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
     597      WRITE(numout,*) '~~~~~~~~~~~~~~~' 
     598      WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
     599      WRITE(numout,*) '      baroclinic update frequency       nn_cln_update = ', nn_cln_update 
     600      WRITE(numout,*) '      sponge coefficient for tracers    rn_sponge_tra = ', rn_sponge_tra, ' s' 
     601      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
     602      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     603      WRITE(numout,*)  
     604   ENDIF 
     605   ! 
     606   ! convert DOCTOR namelist name into OLD names 
     607   nbclineupdate = nn_cln_update 
     608   visc_tra      = rn_sponge_tra 
     609   visc_dyn      = rn_sponge_dyn 
     610   ! 
     611   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
     612# if defined key_lim2 
     613   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    419614# endif 
    420     
    421    SUBROUTINE Agrif_detect( kg, ksizex ) 
    422       !!---------------------------------------------------------------------- 
    423       !!   *** ROUTINE Agrif_detect *** 
    424       !!---------------------------------------------------------------------- 
    425       USE Agrif_Types 
    426       ! 
    427       INTEGER, DIMENSION(2) :: ksizex 
    428       INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg  
    429       !!---------------------------------------------------------------------- 
    430       ! 
    431       RETURN 
    432       ! 
    433    END SUBROUTINE Agrif_detect 
    434  
    435  
    436    SUBROUTINE agrif_nemo_init 
    437       !!---------------------------------------------------------------------- 
    438       !!                     *** ROUTINE agrif_init *** 
    439       !!---------------------------------------------------------------------- 
    440       USE agrif_oce  
    441       USE in_out_manager 
    442       USE lib_mpp 
    443       IMPLICIT NONE 
    444       ! 
    445       NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    446       !!---------------------------------------------------------------------- 
    447       ! 
    448       REWIND( numnam )                ! Read namagrif namelist 
    449       READ  ( numnam, namagrif ) 
    450       ! 
    451       IF(lwp) THEN                    ! control print 
    452          WRITE(numout,*) 
    453          WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
    454          WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    455          WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
    456          WRITE(numout,*) '      baroclinic update frequency       nn_cln_update = ', nn_cln_update 
    457          WRITE(numout,*) '      sponge coefficient for tracers    rn_sponge_tra = ', rn_sponge_tra, ' s' 
    458          WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    459          WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
    460          WRITE(numout,*)  
    461       ENDIF 
    462       ! 
    463       ! convert DOCTOR namelist name into OLD names 
    464       nbclineupdate = nn_cln_update 
    465       visc_tra      = rn_sponge_tra 
    466       visc_dyn      = rn_sponge_dyn 
    467       ! 
    468       IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
    469       ! 
    470     END SUBROUTINE agrif_nemo_init 
     615   ! 
     616END SUBROUTINE agrif_nemo_init 
    471617 
    472618# if defined key_mpp_mpi 
    473619 
    474    SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 
    475       !!---------------------------------------------------------------------- 
    476       !!                     *** ROUTINE Agrif_detect *** 
    477       !!---------------------------------------------------------------------- 
    478       USE dom_oce 
    479       IMPLICIT NONE 
    480       ! 
    481       INTEGER :: indglob, indloc, nprocloc, i 
    482       !!---------------------------------------------------------------------- 
    483       ! 
    484       SELECT CASE( i ) 
    485       CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    486       CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
    487       CASE(3)   ;   indglob = indloc 
    488       CASE(4)   ;   indglob = indloc 
    489       END SELECT 
    490       ! 
    491    END SUBROUTINE Agrif_InvLoc 
     620SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 
     621   !!---------------------------------------------------------------------- 
     622   !!                     *** ROUTINE Agrif_detect *** 
     623   !!---------------------------------------------------------------------- 
     624   USE dom_oce 
     625   IMPLICIT NONE 
     626   ! 
     627   INTEGER :: indglob, indloc, nprocloc, i 
     628   !!---------------------------------------------------------------------- 
     629   ! 
     630   SELECT CASE( i ) 
     631   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
     632   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
     633   CASE(3)   ;   indglob = indloc 
     634   CASE(4)   ;   indglob = indloc 
     635   END SELECT 
     636   ! 
     637END SUBROUTINE Agrif_InvLoc 
    492638 
    493639# endif 
    494640 
    495641#else 
    496    SUBROUTINE Subcalledbyagrif 
    497       !!---------------------------------------------------------------------- 
    498       !!                   *** ROUTINE Subcalledbyagrif *** 
    499       !!---------------------------------------------------------------------- 
    500       WRITE(*,*) 'Impossible to be here' 
    501    END SUBROUTINE Subcalledbyagrif 
     642SUBROUTINE Subcalledbyagrif 
     643   !!---------------------------------------------------------------------- 
     644   !!                   *** ROUTINE Subcalledbyagrif *** 
     645   !!---------------------------------------------------------------------- 
     646   WRITE(*,*) 'Impossible to be here' 
     647END SUBROUTINE Subcalledbyagrif 
    502648#endif 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r3294 r3680  
    113113         CALL iom_get( inum2, jpdom_data, 'vmask', vmask ) 
    114114         CALL iom_get( inum2, jpdom_data, 'fmask', fmask ) 
     115 
     116         CALL lbc_lnk( tmask, 'T', 1._wp )    ! Lateral boundary conditions 
     117         CALL lbc_lnk( umask, 'U', 1._wp )       
     118         CALL lbc_lnk( vmask, 'V', 1._wp ) 
     119         CALL lbc_lnk( fmask, 'F', 1._wp ) 
    115120 
    116121#if defined key_c1d 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r3625 r3680  
    6161   INTEGER  , SAVE      ::   jf_mld         ! index of mixed layer deptht 
    6262   INTEGER  , SAVE      ::   jf_emp         ! index of water flux 
     63   INTEGER  , SAVE      ::   jf_emps        ! index of water flux - concentr/dilution 
    6364   INTEGER  , SAVE      ::   jf_qsr         ! index of solar radiation 
    6465   INTEGER  , SAVE      ::   jf_wnd         ! index of wind speed 
    … …  
    242243      ENDIF 
    243244      ! 
    244       tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:)    ! temperature 
    245       tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:)    ! salinity 
     245      tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:)  * tmask(:,:,:)    ! temperature 
     246      tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:)  * tmask(:,:,:)    ! salinity 
    246247      ! 
    247248      CALL eos    ( tsn, rhd, rhop )                                       ! In any case, we need rhop 
    248249      CALL zdf_mxl( kt )                                                   ! In any case, we need mxl  
    249250      ! 
    250       avt(:,:,:)       = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:)    ! vertical diffusive coefficient  
    251       un (:,:,:)       = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:)    ! u-velocity 
    252       vn (:,:,:)       = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:)    ! v-velocity  
     251      avt(:,:,:)       = sf_dyn(jf_avt)%fnow(:,:,:)  * tmask(:,:,:)    ! vertical diffusive coefficient  
     252      un (:,:,:)       = sf_dyn(jf_uwd)%fnow(:,:,:)  * umask(:,:,:)    ! u-velocity 
     253      vn (:,:,:)       = sf_dyn(jf_vwd)%fnow(:,:,:)  * vmask(:,:,:)    ! v-velocity  
    253254      IF( .NOT.ln_dynwzv ) &                                          ! w-velocity read in file  
    254255         wn (:,:,:)    = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:)     
    … …  
    305306         CALL prt_ctl(tab2d_1=hmld             , clinfo1=' hmld    - : ', mask1=tmask, ovlap=1 ) 
    306307         CALL prt_ctl(tab2d_1=sfx              , clinfo1=' sfx     - : ', mask1=tmask, ovlap=1 ) 
     308         CALL prt_ctl(tab2d_1=emp              , clinfo1=' emp     - : ', mask1=tmask, ovlap=1 ) 
    307309         CALL prt_ctl(tab2d_1=wndm             , clinfo1=' wspd    - : ', mask1=tmask, ovlap=1 ) 
    308310         CALL prt_ctl(tab2d_1=qsr              , clinfo1=' qsr     - : ', mask1=tmask, ovlap=1 ) 
    … …  
    349351      sn_sal  = FLD_N( 'dyna_grid_T' ,    120    , 'vosaline' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) 
    350352      sn_mld  = FLD_N( 'dyna_grid_T' ,    120    , 'somixght' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) 
    351       sn_emp  = FLD_N( 'dyna_grid_T' ,    120    , 'sowaflcd' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) 
     353      sn_emp  = FLD_N( 'dyna_grid_T' ,    120    , 'sowaflup' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) 
     354      sn_emps = FLD_N( 'dyna_grid_T' ,    120    , 'sowaflcd' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) 
    352355!!    sn_emp  = FLD_N( 'dyna_grid_T' ,    120    , 'sowaflup' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) ! v3.5+ 
    353356      sn_sfx  = FLD_N( 'dyna_grid_T' ,    120    , 'sosfldow' ,  .true.    , .true. ,   'yearly'  , ''       , ''         ) ! v3.5+ 
    … …  
    392395      ENDIF 
    393396 
    394       jf_tem = 1   ;   jf_sal = 2   ;  jf_mld = 3   ;  jf_emp = 4   ;   jf_ice = 5   ;   jf_qsr = 6  
    395       jf_wnd = 7   ;   jf_uwd = 8   ;  jf_vwd = 9   ;  jf_wwd = 10  ;   jf_avt = 11  ;   jfld  = 11 
    396       ! 
    397       slf_d(jf_tem) = sn_tem   ;   slf_d(jf_sal) = sn_sal   ;   slf_d(jf_mld) = sn_mld 
    398       slf_d(jf_emp) = sn_emp   ;   slf_d(jf_ice) = sn_ice   ;   slf_d(jf_qsr) = sn_qsr 
    399       slf_d(jf_wnd) = sn_wnd   ;   slf_d(jf_uwd) = sn_uwd   ;   slf_d(jf_vwd) = sn_vwd 
    400       slf_d(jf_wwd) = sn_wwd   ;   slf_d(jf_avt) = sn_avt  
     397      jf_tem = 1   ;   jf_sal = 2   ;  jf_mld = 3   ;  jf_emp = 4   ;   jf_emps = 5   ;  jf_ice = 6   ;   jf_qsr = 7 
     398      jf_wnd = 8   ;   jf_uwd = 9   ;  jf_vwd = 10  ;  jf_wwd = 11  ;   jf_avt  = 12  ;  jfld  = 12 
     399      ! 
     400      slf_d(jf_tem) = sn_tem   ;   slf_d(jf_sal)  = sn_sal   ;   slf_d(jf_mld) = sn_mld 
     401      slf_d(jf_emp) = sn_emp   ;   slf_d(jf_emps) = sn_emps  ;   slf_d(jf_ice) = sn_ice  
     402      slf_d(jf_qsr) = sn_qsr   ;   slf_d(jf_wnd)  = sn_wnd   ;   slf_d(jf_avt) = sn_avt  
     403      slf_d(jf_uwd) = sn_uwd   ;   slf_d(jf_vwd)  = sn_vwd   ;   slf_d(jf_wwd) = sn_wwd 
    401404      ! 
    402405      IF( .NOT.ln_degrad ) THEN     ! no degrad option 
    403406         IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN        ! eiv & bbl 
    404                  jf_ubl  = 12      ;         jf_vbl  = 13      ;         jf_eiw  = 14   ;   jfld = 14 
     407                 jf_ubl  = 13      ;         jf_vbl  = 14      ;         jf_eiw  = 15   ;   jfld = 15 
    405408           slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl  ;   slf_d(jf_eiw) = sn_eiw 
    406409         ENDIF 
    407410         IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN   ! no eiv & bbl 
    408                  jf_ubl  = 12      ;         jf_vbl  = 13      ;   jfld = 13 
     411                 jf_ubl  = 13      ;         jf_vbl  = 14      ;   jfld = 14 
    409412           slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl 
    410413         ENDIF 
    411414         IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN   ! eiv & no bbl 
    412            jf_eiw = 12   ;   jfld = 12   ;   slf_d(jf_eiw) = sn_eiw 
     415           jf_eiw = 13   ;   jfld = 13   ;   slf_d(jf_eiw) = sn_eiw 
    413416         ENDIF 
    414417      ELSE 
    415               jf_ahu  = 12      ;         jf_ahv  = 13      ;         jf_ahw  = 14   ;   jfld = 14 
     418              jf_ahu  = 13      ;         jf_ahv  = 14      ;         jf_ahw  = 15   ;   jfld = 15 
    416419        slf_d(jf_ahu) = sn_ahu  ;   slf_d(jf_ahv) = sn_ahv  ;   slf_d(jf_ahw) = sn_ahw 
    417420        IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN         ! eiv & bbl 
    418                  jf_ubl  = 15      ;         jf_vbl  = 16       
     421                 jf_ubl  = 16      ;         jf_vbl  = 17       
    419422           slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl   
    420                  jf_eiu  = 17      ;         jf_eiv  = 18      ;          jf_eiw  = 19   ;   jfld = 19 
     423                 jf_eiu  = 18      ;         jf_eiv  = 19      ;          jf_eiw  = 20   ;   jfld = 20 
    421424           slf_d(jf_eiu) = sn_eiu  ;   slf_d(jf_eiv) = sn_eiv  ;    slf_d(jf_eiw) = sn_eiw 
    422425        ENDIF 
    423426        IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN    ! no eiv & bbl 
    424                  jf_ubl  = 15      ;         jf_vbl  = 16      ;   jfld = 16 
     427                 jf_ubl  = 16      ;         jf_vbl  = 17      ;   jfld = 17 
    425428           slf_d(jf_ubl) = sn_ubl  ;   slf_d(jf_vbl) = sn_vbl 
    426429        ENDIF 
    427430        IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN    ! eiv & no bbl 
    428                  jf_eiu  = 15      ;         jf_eiv  = 16      ;         jf_eiw  = 17   ;   jfld = 17 
     431                 jf_eiu  = 16      ;         jf_eiv  = 17      ;         jf_eiw  = 18   ;   jfld = 18 
    429432           slf_d(jf_eiu) = sn_eiu  ;   slf_d(jf_eiv) = sn_eiv  ;   slf_d(jf_eiw) = sn_eiw 
    430433        ENDIF 
    … …  
    440443      ! Open file for each variable to get his number of dimension 
    441444      DO ifpr = 1, jfld 
    442          CALL iom_open( slf_d(ifpr)%clname, inum ) 
     445         CALL iom_open( TRIM( cn_dir )//TRIM( slf_d(ifpr)%clname ), inum ) 
    443446         idv   = iom_varid( inum , slf_d(ifpr)%clvar )  ! id of the variable sdjf%clvar 
    444447         idimv = iom_file ( inum )%ndims(idv)             ! number of dimension for variable sdjf%clvar 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r3294 r3680  
    184184         ! 
    185185         WRITE(numout,*) 
    186          WRITE(numout,*) '         CNRS - NERC - Met OFFICE - MERCATOR-ocean' 
     186         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC' 
    187187         WRITE(numout,*) '                       NEMO team' 
    188188         WRITE(numout,*) '            Ocean General Circulation Model' 
    189          WRITE(numout,*) '                  version 3.3  (2010) ' 
     189         WRITE(numout,*) '                  version 3.5  (2012) ' 
    190190         WRITE(numout,*) 
    191191         WRITE(numout,*) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r3294 r3680  
    55   !!====================================================================== 
    66   !! History :  3.4  !  2011     (D. Storkey) new module as part of BDY rewrite 
     7   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications 
    78   !!---------------------------------------------------------------------- 
    89#if defined key_bdy  
    … …  
    5152            CYCLE 
    5253         CASE(jp_frs) 
    53             CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy) ) 
     54            CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    5455         CASE(jp_flather) 
    55             CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy) ) 
     56            CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    5657         CASE DEFAULT 
    5758            CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 
    … …  
    6162   END SUBROUTINE bdy_dyn2d 
    6263 
    63    SUBROUTINE bdy_dyn2d_frs( idx, dta ) 
     64   SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy ) 
    6465      !!---------------------------------------------------------------------- 
    6566      !!                  ***  SUBROUTINE bdy_dyn2d_frs  *** 
    … …  
    7475      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    7576      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     77      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    7678      !! 
    7779      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    9799         pv2d(ii,ij) = ( pv2d(ii,ij) + zwgt * ( dta%v2d(jb) - pv2d(ii,ij) ) ) * vmask(ii,ij,1) 
    98100      END DO  
    99       CALL lbc_lnk( pu2d, 'U', -1. )  
    100       CALL lbc_lnk( pv2d, 'V', -1. )   ! Boundary points should be updated 
     101      CALL lbc_bdy_lnk( pu2d, 'U', -1., ib_bdy )  
     102      CALL lbc_bdy_lnk( pv2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
    101103      ! 
    102104      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_frs') 
    … …  
    106108 
    107109 
    108    SUBROUTINE bdy_dyn2d_fla( idx, dta ) 
     110   SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy ) 
    109111      !!---------------------------------------------------------------------- 
    110112      !!                 ***  SUBROUTINE bdy_dyn2d_fla  *** 
    … …  
    127129      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
    128130      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
     131      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    129132 
    130133      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    … …  
    177180         pv2d(ii,ij) = zforc + zcorr * vmask(ii,ij,1) 
    178181      END DO 
    179       CALL lbc_lnk( pu2d, 'U', -1. )   ! Boundary points should be updated 
    180       CALL lbc_lnk( pv2d, 'V', -1. )   ! 
     182      CALL lbc_bdy_lnk( pu2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
     183      CALL lbc_bdy_lnk( pv2d, 'V', -1., ib_bdy )   ! 
    181184      ! 
    182185      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_fla') 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90

    r3651 r3680  
    55   !!====================================================================== 
    66   !! History :  3.4  !  2011     (D. Storkey) new module as part of BDY rewrite  
     7   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications 
    78   !!---------------------------------------------------------------------- 
    89#if defined key_bdy  
    … …  
    5960            CYCLE 
    6061         CASE(jp_frs) 
    61             CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     62            CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    6263         CASE(2) 
    63             CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     64            CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    6465         CASE(3) 
    65             CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     66            CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    6667         CASE DEFAULT 
    6768            CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    … …  
    7172   END SUBROUTINE bdy_dyn3d 
    7273 
    73    SUBROUTINE bdy_dyn3d_spe( idx, dta, kt ) 
     74   SUBROUTINE bdy_dyn3d_spe( idx, dta, kt , ib_bdy ) 
    7475      !!---------------------------------------------------------------------- 
    7576      !!                  ***  SUBROUTINE bdy_dyn3d_spe  *** 
    … …  
    8283      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    8384      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     85      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    8486      !! 
    8587      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    107109         END DO 
    108110      END DO 
    109       CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )   ! Boundary points should be updated 
     111      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    110112      ! 
    111113      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 
    … …  
    115117   END SUBROUTINE bdy_dyn3d_spe 
    116118 
    117    SUBROUTINE bdy_dyn3d_zro( idx, dta, kt ) 
     119   SUBROUTINE bdy_dyn3d_zro( idx, dta, kt, ib_bdy ) 
    118120      !!---------------------------------------------------------------------- 
    119121      !!                  ***  SUBROUTINE bdy_dyn3d_zro  *** 
    … …  
    125127      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    126128      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     129      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    127130      !! 
    128131      INTEGER  ::   ib, ik         ! dummy loop indices 
    … …  
    151154      END DO 
    152155      ! 
    153       CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )   ! Boundary points should be updated 
     156      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    154157      ! 
    155158      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 
    … …  
    159162   END SUBROUTINE bdy_dyn3d_zro 
    160163 
    161    SUBROUTINE bdy_dyn3d_frs( idx, dta, kt ) 
     164   SUBROUTINE bdy_dyn3d_frs( idx, dta, kt, ib_bdy ) 
    162165      !!---------------------------------------------------------------------- 
    163166      !!                  ***  SUBROUTINE bdy_dyn3d_frs  *** 
    … …  
    173176      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    174177      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     178      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    175179      !! 
    176180      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    200204         END DO 
    201205      END DO  
    202       CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )   ! Boundary points should be updated 
     206      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    203207      ! 
    204208      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim2.F90

    r3610 r3680  
    66   !!  History :  3.3  !  2010-09 (D. Storkey)  Original code 
    77   !!             3.4  !  2011    (D. Storkey) rewrite in preparation for OBC-BDY merge 
     8   !!             3.5  !  2012    (S. Mocavero, I. Epicoco) Optimization of BDY communications 
    89   !!---------------------------------------------------------------------- 
    910#if defined   key_bdy   &&   defined key_lim2 
    … …  
    5354            CYCLE 
    5455         CASE(jp_frs) 
    55             CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy) ) 
     56            CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    5657         CASE DEFAULT 
    5758            CALL ctl_stop( 'bdy_ice_lim_2 : unrecognised option for open boundaries for ice fields' ) 
    … …  
    6162   END SUBROUTINE bdy_ice_lim_2 
    6263 
    63    SUBROUTINE bdy_ice_frs( idx, dta ) 
     64   SUBROUTINE bdy_ice_frs( idx, dta, ib_bdy ) 
    6465      !!------------------------------------------------------------------------------ 
    6566      !!                 ***  SUBROUTINE bdy_ice_frs  *** 
    … …  
    7374      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    7475      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     76      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    7577      !! 
    7678      INTEGER  ::   jb, jk, jgrd   ! dummy loop indices 
    … …  
    9496         END DO 
    9597      END DO  
    96       CALL lbc_lnk( frld, 'T', 1. )                                         ! lateral boundary conditions 
    97       CALL lbc_lnk( hicif, 'T', 1. )   ;   CALL lbc_lnk( hsnif, 'T', 1. ) 
     98      CALL lbc_bdy_lnk( frld, 'T', 1., ib_bdy )                                         ! lateral boundary conditions 
     99      CALL lbc_bdy_lnk( hicif, 'T', 1., ib_bdy )   ;   CALL lbc_bdy_lnk( hsnif, 'T', 1., ib_bdy ) 
    98100      !       
    99101      IF( nn_timing == 1 ) CALL timing_stop('bdy_ice_frs') 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r3651 r3680  
    1212   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge 
    1313   !!            3.4  !  2012     (J. Chanut) straight open boundary case update 
     14   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Updates for the  
     15   !!                             optimization of BDY communications 
    1416   !!---------------------------------------------------------------------- 
    1517#if defined key_bdy 
    … …  
    8587      INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbrdta           ! Discrete distance from rim points 
    8688      CHARACTER(LEN=1),DIMENSION(jpbgrd)      ::   cgrid 
     89      INTEGER :: com_east, com_west, com_south, com_north          ! Flags for boundaries sending 
     90      INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving 
     91      INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates 
     92 
    8793      !! 
    8894      NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file,             & 
    … …  
    673679      in = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
    674680 
     681      ALLOCATE( nbondi_bdy(nb_bdy)) 
     682      ALLOCATE( nbondj_bdy(nb_bdy)) 
     683      nbondi_bdy(:)=2 
     684      nbondj_bdy(:)=2 
     685      ALLOCATE( nbondi_bdy_b(nb_bdy)) 
     686      ALLOCATE( nbondj_bdy_b(nb_bdy)) 
     687      nbondi_bdy_b(:)=2 
     688      nbondj_bdy_b(:)=2 
     689 
     690      ! Work out dimensions of boundary data on each neighbour process 
     691      IF(nbondi .eq. 0) THEN 
     692         iw_b(1) = jpizoom + nimppt(nowe+1) 
     693         ie_b(1) = jpizoom + nimppt(nowe+1)+nlcit(nowe+1)-3 
     694         is_b(1) = jpjzoom + njmppt(nowe+1) 
     695         in_b(1) = jpjzoom + njmppt(nowe+1)+nlcjt(nowe+1)-3 
     696 
     697         iw_b(2) = jpizoom + nimppt(noea+1) 
     698         ie_b(2) = jpizoom + nimppt(noea+1)+nlcit(noea+1)-3 
     699         is_b(2) = jpjzoom + njmppt(noea+1) 
     700         in_b(2) = jpjzoom + njmppt(noea+1)+nlcjt(noea+1)-3 
     701      ELSEIF(nbondi .eq. 1) THEN 
     702         iw_b(1) = jpizoom + nimppt(nowe+1) 
     703         ie_b(1) = jpizoom + nimppt(nowe+1)+nlcit(nowe+1)-3 
     704         is_b(1) = jpjzoom + njmppt(nowe+1) 
     705         in_b(1) = jpjzoom + njmppt(nowe+1)+nlcjt(nowe+1)-3 
     706      ELSEIF(nbondi .eq. -1) THEN 
     707         iw_b(2) = jpizoom + nimppt(noea+1) 
     708         ie_b(2) = jpizoom + nimppt(noea+1)+nlcit(noea+1)-3 
     709         is_b(2) = jpjzoom + njmppt(noea+1) 
     710         in_b(2) = jpjzoom + njmppt(noea+1)+nlcjt(noea+1)-3 
     711      ENDIF 
     712 
     713      IF(nbondj .eq. 0) THEN 
     714         iw_b(3) = jpizoom + nimppt(noso+1) 
     715         ie_b(3) = jpizoom + nimppt(noso+1)+nlcit(noso+1)-3 
     716         is_b(3) = jpjzoom + njmppt(noso+1) 
     717         in_b(3) = jpjzoom + njmppt(noso+1)+nlcjt(noso+1)-3 
     718 
     719         iw_b(4) = jpizoom + nimppt(nono+1) 
     720         ie_b(4) = jpizoom + nimppt(nono+1)+nlcit(nono+1)-3 
     721         is_b(4) = jpjzoom + njmppt(nono+1) 
     722         in_b(4) = jpjzoom + njmppt(nono+1)+nlcjt(nono+1)-3 
     723      ELSEIF(nbondj .eq. 1) THEN 
     724         iw_b(3) = jpizoom + nimppt(noso+1) 
     725         ie_b(3) = jpizoom + nimppt(noso+1)+nlcit(noso+1)-3 
     726         is_b(3) = jpjzoom + njmppt(noso+1) 
     727         in_b(3) = jpjzoom + njmppt(noso+1)+nlcjt(noso+1)-3 
     728      ELSEIF(nbondj .eq. -1) THEN 
     729         iw_b(4) = jpizoom + nimppt(nono+1) 
     730         ie_b(4) = jpizoom + nimppt(nono+1)+nlcit(nono+1)-3 
     731         is_b(4) = jpjzoom + njmppt(nono+1) 
     732         in_b(4) = jpjzoom + njmppt(nono+1)+nlcjt(nono+1)-3 
     733      ENDIF 
     734 
    675735      DO ib_bdy = 1, nb_bdy 
    676736         DO igrd = 1, jpbgrd 
    … …  
    716776         ! ----------------------------------------------------------------- 
    717777 
     778         com_east = 0 
     779         com_west = 0 
     780         com_south = 0 
     781         com_north = 0 
     782 
     783         com_east_b = 0 
     784         com_west_b = 0 
     785         com_south_b = 0 
     786         com_north_b = 0 
    718787         DO igrd = 1, jpbgrd 
    719788            icount  = 0 
    … …  
    734803                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+jpizoom 
    735804                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+jpjzoom 
     805                     ! check if point has to be sent 
     806                     ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 
     807                     ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 
     808                     if((com_east .ne. 1) .and. (ii .eq. (nlci-1)) .and. (nbondi .le. 0)) then 
     809                        com_east = 1 
     810                     elseif((com_west .ne. 1) .and. (ii .eq. 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 
     811                        com_west = 1 
     812                     endif  
     813                     if((com_south .ne. 1) .and. (ij .eq. 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 
     814                        com_south = 1 
     815                     elseif((com_north .ne. 1) .and. (ij .eq. (nlcj-1)) .and. (nbondj .le. 0)) then 
     816                        com_north = 1 
     817                     endif  
    736818                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy) 
    737819                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 
    738820                  ENDIF 
     821                  ! check if point has to be received from a neighbour 
     822                  IF(nbondi .eq. 0) THEN 
     823                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
     824                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
     825                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     826                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
     827                       if((com_west_b .ne. 1) .and. (ii .eq. (nlcit(nowe+1)-1))) then 
     828                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
     829                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     830                            com_south = 1 
     831                          elseif((ij .eq. nlcjt(nowe+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     832                            com_north = 1 
     833                          endif 
     834                          com_west_b = 1 
     835                       endif  
     836                     ENDIF 
     837                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
     838                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
     839                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     840                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
     841                       if((com_east_b .ne. 1) .and. (ii .eq. 2)) then 
     842                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
     843                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     844                            com_south = 1 
     845                          elseif((ij .eq. nlcjt(noea+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     846                            com_north = 1 
     847                          endif 
     848                          com_east_b = 1 
     849                       endif  
     850                     ENDIF 
     851                  ELSEIF(nbondi .eq. 1) THEN 
     852                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
     853                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
     854                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     855                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
     856                       if((com_west_b .ne. 1) .and. (ii .eq. (nlcit(nowe+1)-1))) then 
     857                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
     858                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     859                            com_south = 1 
     860                          elseif((ij .eq. nlcjt(nowe+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     861                            com_north = 1 
     862                          endif 
     863                          com_west_b = 1 
     864                       endif  
     865                     ENDIF 
     866                  ELSEIF(nbondi .eq. -1) THEN 
     867                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
     868                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
     869                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     870                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
     871                       if((com_east_b .ne. 1) .and. (ii .eq. 2)) then 
     872                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
     873                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     874                            com_south = 1 
     875                          elseif((ij .eq. nlcjt(noea+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     876                            com_north = 1 
     877                          endif 
     878                          com_east_b = 1 
     879                       endif  
     880                     ENDIF 
     881                  ENDIF 
     882                  IF(nbondj .eq. 0) THEN 
     883                     IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
     884                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     885                       com_north_b = 1  
     886                     ENDIF 
     887                     IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
     888                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     889                       com_south_b = 1  
     890                     ENDIF 
     891                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
     892                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
     893                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     894                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
     895                       if((com_south_b .ne. 1) .and. (ij .eq. (nlcjt(noso+1)-1))) then 
     896                          com_south_b = 1 
     897                       endif  
     898                     ENDIF 
     899                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
     900                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
     901                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     902                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
     903                       if((com_north_b .ne. 1) .and. (ij .eq. 2)) then 
     904                          com_north_b = 1 
     905                       endif  
     906                     ENDIF 
     907                  ELSEIF(nbondj .eq. 1) THEN 
     908                     IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
     909                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     910                       com_south_b = 1  
     911                     ENDIF 
     912                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
     913                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
     914                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     915                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
     916                       if((com_south_b .ne. 1) .and. (ij .eq. (nlcjt(noso+1)-1))) then 
     917                          com_south_b = 1 
     918                       endif  
     919                     ENDIF 
     920                  ELSEIF(nbondj .eq. -1) THEN 
     921                     IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
     922                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     923                       com_north_b = 1  
     924                     ENDIF 
     925                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
     926                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
     927                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     928                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
     929                       if((com_north_b .ne. 1) .and. (ij .eq. 2)) then 
     930                          com_north_b = 1 
     931                       endif  
     932                     ENDIF 
     933                  ENDIF 
    739934               ENDDO 
    740935            ENDDO 
    741936         ENDDO  
     937         ! definition of the i- and j- direction local boundaries arrays 
     938         ! used for sending the boudaries 
     939         IF((com_east .eq. 1) .and. (com_west .eq. 1)) THEN 
     940            nbondi_bdy(ib_bdy) = 0 
     941         ELSEIF ((com_east .eq. 1) .and. (com_west .eq. 0)) THEN 
     942            nbondi_bdy(ib_bdy) = -1 
     943         ELSEIF ((com_east .eq. 0) .and. (com_west .eq. 1)) THEN 
     944            nbondi_bdy(ib_bdy) = 1 
     945         ENDIF 
     946 
     947         IF((com_north .eq. 1) .and. (com_south .eq. 1)) THEN 
     948            nbondj_bdy(ib_bdy) = 0 
     949         ELSEIF ((com_north .eq. 1) .and. (com_south .eq. 0)) THEN 
     950            nbondj_bdy(ib_bdy) = -1 
     951         ELSEIF ((com_north .eq. 0) .and. (com_south .eq. 1)) THEN 
     952            nbondj_bdy(ib_bdy) = 1 
     953         ENDIF 
     954 
     955         ! definition of the i- and j- direction local boundaries arrays 
     956         ! used for receiving the boudaries 
     957         IF((com_east_b .eq. 1) .and. (com_west_b .eq. 1)) THEN 
     958            nbondi_bdy_b(ib_bdy) = 0 
     959         ELSEIF ((com_east_b .eq. 1) .and. (com_west_b .eq. 0)) THEN 
     960            nbondi_bdy_b(ib_bdy) = -1 
     961         ELSEIF ((com_east_b .eq. 0) .and. (com_west_b .eq. 1)) THEN 
     962            nbondi_bdy_b(ib_bdy) = 1 
     963         ENDIF 
     964 
     965         IF((com_north_b .eq. 1) .and. (com_south_b .eq. 1)) THEN 
     966            nbondj_bdy_b(ib_bdy) = 0 
     967         ELSEIF ((com_north_b .eq. 1) .and. (com_south_b .eq. 0)) THEN 
     968            nbondj_bdy_b(ib_bdy) = -1 
     969         ELSEIF ((com_north_b .eq. 0) .and. (com_south_b .eq. 1)) THEN 
     970            nbondj_bdy_b(ib_bdy) = 1 
     971         ENDIF 
    742972 
    743973         ! Compute rim weights for FRS scheme 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdytra.F90

    r3651 r3680  
    77   !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    88   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge 
     9   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications 
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_bdy 
    … …  
    5455            CYCLE 
    5556         CASE(jp_frs) 
    56             CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     57            CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    5758         CASE(2) 
    5859            CALL bdy_tra_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
    … …  
    7273   END SUBROUTINE bdy_tra 
    7374 
    74    SUBROUTINE bdy_tra_frs( idx, dta, kt ) 
     75   SUBROUTINE bdy_tra_frs( idx, dta, kt, ib_bdy ) 
    7576      !!---------------------------------------------------------------------- 
    7677      !!                 ***  SUBROUTINE bdy_tra_frs  *** 
    … …  
    8384      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    8485      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     86      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    8587      !!  
    8688      REAL(wp) ::   zwgt           ! boundary weight 
    … …  
    101103         END DO 
    102104      END DO  
     105      CALL lbc_bdy_lnk( tsa(:,:,:,jp_tem), 'T', 1., ib_bdy )   ; CALL lbc_bdy_lnk( tsa(:,:,:,jp_sal), 'T', 1., ib_bdy )    ! Boundary points should be updated 
    103106      ! 
    104107      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r3294 r3680  
    1919   USE dyncor_c1d      ! Coriolis term (c1d case)         (dyn_cor_1d     ) 
    2020   USE dynnxt_c1d      ! time-stepping                    (dyn_nxt routine) 
     21   USE restart         ! restart  
    2122 
    2223   IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    r3632 r3680  
    2121  !!---------------------------------------------------------------------- 
    2222  !!---------------------------------------------------------------------- 
    23   !!   dia_dct      :  compute the transport through a sec. 
    24   !!   dia_dct_init :  read namelist. 
    25   !!   readsec      :  read sections description and pathway 
    26   !!   removepoints :  remove points which are common to 2 procs 
     23  !!   dia_dct      :  Compute the transport through a sec. 
     24  !!   dia_dct_init :  Read namelist. 
     25  !!   readsec      :  Read sections description and pathway 
     26  !!   removepoints :  Remove points which are common to 2 procs 
    2727  !!   transport    :  Compute transport for each sections 
    28   !!   dia_dct_wri  :  write tranports results in ascii files 
    29   !!   interp       :  compute Temperature/Salinity/density on U-point or V-point 
     28  !!   dia_dct_wri  :  Write tranports results in ascii files 
     29  !!   interp       :  Compute temperature/salinity/density at U-point or V-point 
    3030  !!    
    3131  !!---------------------------------------------------------------------- 
    … …  
    5252 
    5353  !! * Routine accessibility 
    54   PUBLIC   dia_dct     ! routine called by step.F90 
    55   PUBLIC   dia_dct_init! routine called by opa.F90 
     54  PUBLIC   dia_dct      ! routine called by step.F90 
     55  PUBLIC   dia_dct_init ! routine called by opa.F90 
     56  PUBLIC   diadct_alloc ! routine called by nemo_init in nemogcm.F90  
    5657  PRIVATE  readsec 
    5758  PRIVATE  removepoints 
    … …  
    7273  INTEGER, PARAMETER :: nb_sec_max    = 150 
    7374  INTEGER, PARAMETER :: nb_point_max  = 2000 
    74   INTEGER, PARAMETER :: nb_type_class = 14 
     75  INTEGER, PARAMETER :: nb_type_class = 10 
     76  INTEGER, PARAMETER :: nb_3d_vars    = 3  
     77  INTEGER, PARAMETER :: nb_2d_vars    = 2  
    7578  INTEGER            :: nb_sec  
    7679 
    … …  
    9295     INTEGER                                      :: nb_class          ! number of boundaries for density classes 
    9396     INTEGER, DIMENSION(nb_point_max)             :: direction         ! vector direction of the point in the section 
    94      CHARACTER(len=40),DIMENSION(nb_class_max)    :: classname         ! caracteristics of the class 
     97     CHARACTER(len=40),DIMENSION(nb_class_max)    :: classname         ! characteristics of the class 
    9598     REAL(wp), DIMENSION(nb_class_max)            :: zsigi           ,&! in-situ   density classes    (99 if you don't want) 
    9699                                                     zsigp           ,&! potential density classes    (99 if you don't want) 
    … …  
    106109  TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections 
    107110  
    108   
     111  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::  transports_3d  
     112  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d   
     113 
    109114CONTAINS 
     115 
     116  
     117  INTEGER FUNCTION diadct_alloc()  
     118     !!----------------------------------------------------------------------  
     119     !!                   ***  FUNCTION diadct_alloc  ***  
     120     !!----------------------------------------------------------------------  
     121     INTEGER :: ierr(2)  
     122     !!----------------------------------------------------------------------  
     123 
     124     ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) )  
     125     ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max)    , STAT=ierr(2) )  
     126 
     127     diadct_alloc = MAXVAL( ierr )  
     128     IF( diadct_alloc /= 0 )   CALL ctl_warn('diadct_alloc: failed to allocate arrays')  
     129  
     130  END FUNCTION diadct_alloc  
    110131 
    111132  SUBROUTINE dia_dct_init 
    … …  
    113134     !!               ***  ROUTINE diadct  ***   
    114135     !! 
    115      !!  ** Purpose: Read the namelist parametres 
     136     !!  ** Purpose: Read the namelist parameters 
    116137     !!              Open output files 
    117138     !! 
    … …  
    154175     ENDIF 
    155176 
     177     ! Initialise arrays to zero  
     178     transports_3d(:,:,:,:)=0.0  
     179     transports_2d(:,:,:)  =0.0  
     180 
    156181     IF( nn_timing == 1 )   CALL timing_stop('dia_dct_init') 
    157182     ! 
    … …  
    163188     !!               ***  ROUTINE diadct  ***   
    164189     !! 
    165      !!  ** Purpose: Compute sections tranport and write it in numdct file 
     190     !!  Purpose :: Compute section transports and write it in numdct files  
     191     !!    
     192     !!  Method  :: All arrays initialised to zero in dct_init  
     193     !!             Each nn_dct time step call subroutine 'transports' for  
     194     !!               each section to sum the transports over each grid cell.  
     195     !!             Each nn_dctwri time step:  
     196     !!               Divide the arrays by the number of summations to gain  
     197     !!               an average value  
     198     !!               Call dia_dct_sum to sum relevant grid boxes to obtain  
     199     !!               totals for each class (density, depth, temp or sal)  
     200     !!               Call dia_dct_wri to write the transports into file  
     201     !!               Reinitialise all relevant arrays to zero  
    166202     !!--------------------------------------------------------------------- 
    167203     !! * Arguments 
    … …  
    170206     !! * Local variables 
    171207     INTEGER             :: jsec,            &! loop on sections 
    172                             iost,            &! error for opening fileout 
    173208                            itotal            ! nb_sec_max*nb_type_class*nb_class_max 
    174209     LOGICAL             :: lldebug =.FALSE.  ! debug a section   
    175      CHARACTER(len=160)  :: clfileout         ! fileout name 
    176  
    177210      
    178211     INTEGER , DIMENSION(1)             :: ish   ! tmp array for mpp_sum 
    … …  
    190223     ENDIF     
    191224  
     225     ! Initialise arrays 
     226     zwork(:) = 0.0  
     227     zsum(:,:,:) = 0.0 
     228 
    192229     IF( lwp .AND. kt==nit000+nn_dct-1 ) THEN 
    193230         WRITE(numout,*) " " 
    … …  
    208245 
    209246           !Compute transport through section   
    210            CALL transport(secs(jsec),lldebug)  
     247           CALL transport(secs(jsec),lldebug,jsec)  
    211248 
    212249        ENDDO 
    … …  
    214251        IF( MOD(kt,nn_dctwri)==0 )THEN 
    215252 
    216            IF( lwp .AND. kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: write at kt = ",kt          
     253           IF( lwp .AND. kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: average transports and write at kt = ",kt          
    217254   
     255           !! divide arrays by nn_dctwri/nn_dct to obtain average  
     256           transports_3d(:,:,:,:)=transports_3d(:,:,:,:)/(nn_dctwri/nn_dct)  
     257           transports_2d(:,:,:)  =transports_2d(:,:,:)  /(nn_dctwri/nn_dct)  
     258  
     259           ! Sum over each class  
     260           DO jsec=1,nb_sec  
     261              CALL dia_dct_sum(secs(jsec),jsec)  
     262           ENDDO  
     263 
    218264           !Sum on all procs  
    219265           IF( lk_mpp )THEN 
    … …  
    233279             
    234280              !nullify transports values after writing 
     281              transports_3d(:,jsec,:,:)=0. 
     282              transports_2d(:,jsec,:  )=0. 
    235283              secs(jsec)%transport(:,:)=0.   
    236284 
    … …  
    265313     INTEGER :: isec, iiglo, ijglo, iiloc, ijloc,iost,i1 ,i2  ! temporary  integer 
    266314     INTEGER :: jsec, jpt                                     ! dummy loop indices 
    267                                                               ! heat/salt tranport is actived 
    268315 
    269316     INTEGER, DIMENSION(2) :: icoord  
    … …  
    457504     !!             *** function removepoints 
    458505     !! 
    459      !!   ** Purpose :: 
    460      !!              remove points which are common to 2 procs 
    461      !! 
     506     !!   ** Purpose :: Remove points which are common to 2 procs 
    462507     !! 
    463508     !---------------------------------------------------------------------------- 
    … …  
    535580  END SUBROUTINE removepoints 
    536581 
    537   SUBROUTINE transport(sec,ld_debug) 
     582  SUBROUTINE transport(sec,ld_debug,jsec) 
    538583     !!------------------------------------------------------------------------------------------- 
    539584     !!                     ***  ROUTINE transport  *** 
    540585     !! 
    541      !!  ** Purpose : Compute the transport through a section 
    542      !! 
    543      !!  ** Method  :Transport through a given section is equal to the sum of transports 
    544      !!              computed on each proc. 
    545      !!              On each proc,transport is equal to the sum of transport computed through 
    546      !!               segments linking each point of sec%listPoint  with the next one.    
    547      !! 
    548      !!              !BE carefull :           
    549      !!              one section is a sum of segments 
    550      !!              one segment is defined by 2 consectuve points in sec%listPoint 
    551      !!              all points of sec%listPoint are positioned on the F-point of the cell.  
     586     !!  Purpose ::  Compute the transport for each point in a section  
    552587     !!  
    553      !!              There are several loops:                  
    554      !!              loop on the density/temperature/salinity/level classes 
    555      !!              loop on the segment between 2 nodes 
    556      !!              loop on the level jk 
    557      !!              test on the density/temperature/salinity/level 
    558      !! 
    559      !! ** Output: sec%transport: volume/mass/ice/heat/salt transport in the 2 directions 
    560      !! 
     588     !!  Method  ::  Loop over each segment, and each vertical level and add the transport  
     589     !!              Be aware :            
     590     !!              One section is a sum of segments  
     591     !!              One segment is defined by 2 consecutive points in sec%listPoint  
     592     !!              All points of sec%listPoint are positioned on the F-point of the cell  
     593     !!  
     594     !!              There are two loops:                   
     595     !!              loop on the segment between 2 nodes  
     596     !!              loop on the level jk !! 
     597     !!  
     598     !!  Output  ::  Arrays containing the volume,density,heat,salt transports for each i 
     599     !!              point in a section, summed over each nn_dct.  
    561600     !! 
    562601     !!------------------------------------------------------------------------------------------- 
    … …  
    564603     TYPE(SECTION),INTENT(INOUT) :: sec 
    565604     LOGICAL      ,INTENT(IN)    :: ld_debug 
     605     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
    566606     
    567607     !! * Local variables 
    568      INTEGER             :: jk,jseg,jclass,   &!loop on level/segment/classes  
    569                             isgnu  , isgnv     ! 
    570      INTEGER :: ii, ij ! local integer 
    571      REAL(wp):: zumid        , zvmid        ,&!U/V velocity on a cell segment 
    572                 zumid_ice    , zvmid_ice    ,&!U/V ice velocity 
    573                 zTnorm                      ,&!transport of velocity through one cell's sides 
    574                 ztransp1     , ztransp2     ,&!total        transport in directions 1 and 2 
    575                 ztemp1       , ztemp2       ,&!temperature  transport     " 
    576                 zrhoi1       , zrhoi2       ,&!mass         transport     " 
    577                 zrhop1       , zrhop2       ,&!mass         transport     " 
    578                 zsal1        , zsal2        ,&!salinity     transport     " 
    579                 zice_vol_pos , zice_vol_neg ,&!volume  ice  transport     " 
    580                 zice_surf_pos, zice_surf_neg  !surface ice  transport     " 
    581      REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point 
     608     INTEGER             :: jk, jseg, jclass,                    &!loop on level/segment/classes   
     609                            isgnu, isgnv                          !  
     610     REAL(wp)            :: zumid, zvmid,                        &!U/V velocity on a cell segment  
     611                            zumid_ice, zvmid_ice,                &!U/V ice velocity  
     612                            zTnorm                                !transport of velocity through one cell's sides  
     613     REAL(wp)            :: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep !temperature/salinity/potential density/ssh/depth at u/v point 
    582614 
    583615     TYPE(POINT_SECTION) :: k 
    584      REAL(wp), POINTER, DIMENSION(:,:):: zsum ! 2D work array 
    585616     !!-------------------------------------------------------- 
    586      CALL wrk_alloc( nb_type_class , nb_class_max , zsum   ) 
    587617 
    588618     IF( ld_debug )WRITE(numout,*)'      Compute transport' 
    589  
    590      !----------------! 
    591      ! INITIALIZATION ! 
    592      !----------------! 
    593      zsum    = 0._wp 
    594      zice_surf_neg = 0._wp ; zice_surf_pos = 0._wp 
    595      zice_vol_pos  = 0._wp ; zice_vol_neg  = 0._wp 
    596619 
    597620     !---------------------------! 
    … …  
    670693           END SELECT 
    671694 
    672            !------------------------------- 
    673            !  LOOP ON THE DENSITY CLASSES | 
    674            !------------------------------- 
    675            !The computation is made for each density class 
    676            DO jclass=1,MAX(1,sec%nb_class-1) 
    677  
    678               ztransp1=0._wp ; zrhoi1=0._wp ; zrhop1=0._wp ; ztemp1=0._wp ;zsal1=0._wp 
    679               ztransp2=0._wp ; zrhoi2=0._wp ; zrhop2=0._wp ; ztemp2=0._wp ;zsal2=0._wp 
    680      
    681               !---------------------------| 
    682               !     LOOP ON THE LEVEL     | 
    683               !---------------------------| 
    684               !Sum of the transport on the vertical  
    685               DO jk=1,jpk 
    686                      
    687  
    688                  ! compute temparature, salinity, insitu & potential density, ssh and depth at U/V point 
    689                  SELECT CASE( sec%direction(jseg) ) 
    690                  CASE(0,1) 
    691                     ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
    692                     zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
    693                     zrhop = interp(k%I,k%J,jk,'V',rhop) 
    694                     zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
    695                     zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
    696                  CASE(2,3) 
    697                     ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
    698                     zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
    699                     zrhop = interp(k%I,k%J,jk,'U',rhop) 
    700                     zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
    701                     zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
    702                  END SELECT 
    703  
    704                  zfsdep= gdept(k%I,k%J,jk) 
    705   
    706                  !----------------------------------------------! 
    707                  !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!  
    708                  !----------------------------------------------! 
    709   
    710                  IF ( (    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.    & 
    711                            (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.    & 
    712                            ( sec%zsigp(jclass) .EQ. 99.)) .AND.                 & 
    713                            ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    & 
    714                            (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.    & 
    715                            ( sec%zsigi(jclass) .EQ. 99.)) .AND.                 & 
    716                            ((( zsn .GT. sec%zsal(jclass)) .AND.                & 
    717                            (   zsn .LE. sec%zsal(jclass+1))) .OR.              & 
    718                            ( sec%zsal(jclass) .EQ. 99.)) .AND.                 & 
    719                            ((( ztn .GE. sec%ztem(jclass)) .AND.                & 
    720                            (   ztn .LE. sec%ztem(jclass+1))) .OR.              & 
    721                            ( sec%ztem(jclass) .EQ.99.)) .AND.                  & 
    722                            ((( zfsdep .GE. sec%zlay(jclass)) .AND.            & 
    723                            (   zfsdep .LE. sec%zlay(jclass+1))) .OR.          & 
    724                            ( sec%zlay(jclass) .EQ. 99. ))))   THEN 
    725  
    726  
    727                     !compute velocity with the correct direction 
    728                     SELECT CASE( sec%direction(jseg) ) 
    729                     CASE(0,1)   
    730                        zumid=0. 
    731                        zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) 
    732                     CASE(2,3) 
    733                        zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk) 
    734                        zvmid=0. 
    735                     END SELECT 
    736  
    737                     !velocity* cell's length * cell's thickness 
    738                     zTnorm=zumid*e2u(k%I,k%J)*  fse3u(k%I,k%J,jk)+     & 
    739                            zvmid*e1v(k%I,k%J)*  fse3v(k%I,k%J,jk) 
     695           !---------------------------|  
     696           !     LOOP ON THE LEVEL     |  
     697           !---------------------------|  
     698           !Sum of the transport on the vertical   
     699           DO jk=1,mbathy(k%I,k%J)  
     700  
     701              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point  
     702              SELECT CASE( sec%direction(jseg) )  
     703              CASE(0,1)  
     704                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) )  
     705                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) )  
     706                 zrhop = interp(k%I,k%J,jk,'V',rhop)  
     707                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0)  
     708                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1)  
     709              CASE(2,3)  
     710                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) )  
     711                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) )  
     712                 zrhop = interp(k%I,k%J,jk,'U',rhop)  
     713                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0)  
     714                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)   
     715              END SELECT  
     716  
     717              zfsdep= gdept(k%I,k%J,jk)  
     718   
     719              !compute velocity with the correct direction  
     720              SELECT CASE( sec%direction(jseg) )  
     721              CASE(0,1)    
     722                 zumid=0.  
     723                 zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk)  
     724              CASE(2,3)  
     725                 zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk)  
     726                 zvmid=0.  
     727              END SELECT  
     728  
     729              !zTnorm=transport through one cell;  
     730              !velocity* cell's length * cell's thickness  
     731              zTnorm=zumid*e2u(k%I,k%J)*  fse3u(k%I,k%J,jk)+     &  
     732                     zvmid*e1v(k%I,k%J)*  fse3v(k%I,k%J,jk)  
    740733 
    741734#if ! defined key_vvl 
    742                     !add transport due to free surface 
    743                     IF( jk==1 )THEN 
    744                        zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) + & 
    745                                          zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) 
    746                     ENDIF 
     735              !add transport due to free surface  
     736              IF( jk==1 )THEN  
     737                 zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) + &  
     738                                   zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk)  
     739              ENDIF  
    747740#endif 
    748                     !COMPUTE TRANSPORT  
    749                     !zTnorm=transport through one cell for one class 
    750                     !ztransp1 or ztransp2=transport through one cell i 
    751                     !                     for one class for one direction 
    752                     IF( zTnorm .GE. 0 )THEN 
    753  
    754                        ztransp1=zTnorm+ztransp1 
    755   
    756                        IF ( sec%llstrpond ) THEN 
    757                           ztemp1 = ztemp1  + zTnorm * ztn  
    758                           zsal1  = zsal1   + zTnorm * zsn 
    759                           zrhoi1 = zrhoi1  + zTnorm * zrhoi 
    760                           zrhop1 = zrhop1  + zTnorm * zrhop 
    761                        ENDIF 
    762  
    763                     ELSE 
    764  
    765                        ztransp2=(zTnorm)+ztransp2 
    766  
    767                        IF ( sec%llstrpond ) THEN 
    768                           ztemp2 = ztemp2  + zTnorm * ztn  
    769                           zsal2  = zsal2   + zTnorm * zsn 
    770                           zrhoi2 = zrhoi2  + zTnorm * zrhoi 
    771                           zrhop2 = zrhop2  + zTnorm * zrhop 
    772                        ENDIF 
    773                     ENDIF 
    774   
    775              
    776                  ENDIF ! end of density test 
    777               ENDDO!end of loop on the level 
    778  
    779               !ZSUM=TRANSPORT FOR EACH CLASSES FOR THE  DIRECTIONS 
    780               !--------------------------------------------------- 
    781               zsum(1,jclass)     = zsum(1,jclass)+ztransp1 
    782               zsum(2,jclass)     = zsum(2,jclass)+ztransp2 
    783               IF( sec%llstrpond )THEN 
    784                  zsum(3 ,jclass) = zsum( 3,jclass)+zrhoi1 
    785                  zsum(4 ,jclass) = zsum( 4,jclass)+zrhoi2 
    786                  zsum(5 ,jclass) = zsum( 5,jclass)+zrhop1 
    787                  zsum(6 ,jclass) = zsum( 6,jclass)+zrhop2 
    788                  zsum(7 ,jclass) = zsum( 7,jclass)+ztemp1 
    789                  zsum(8 ,jclass) = zsum( 8,jclass)+ztemp2 
    790                  zsum(9 ,jclass) = zsum( 9,jclass)+zsal1 
    791                  zsum(10,jclass) = zsum(10,jclass)+zsal2 
     741              !COMPUTE TRANSPORT   
     742  
     743              transports_3d(1,jsec,jseg,jk) = transports_3d(1,jsec,jseg,jk) + zTnorm  
     744   
     745              IF ( sec%llstrpond ) THEN  
     746                 transports_3d(2,jsec,jseg,jk) = transports_3d(2,jsec,jseg,jk)  + zTnorm * ztn * zrhop * rcp 
     747                 transports_3d(3,jsec,jseg,jk) = transports_3d(3,jsec,jseg,jk)  + zTnorm * zsn * zrhop * 0.001 
    792748              ENDIF 
    793749    
    794            ENDDO !end of loop on the density classes 
     750           ENDDO !end of loop on the level 
    795751 
    796752#if defined key_lim2 || defined key_lim3 
    … …  
    816772              zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) 
    817773    
    818               IF( zTnorm .GE. 0)THEN 
    819                  zice_vol_pos = (zTnorm)*   & 
    820                                       (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    821                                      *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  & 
    822                                        hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) & 
    823                                       +zice_vol_pos 
    824                  zice_surf_pos = (zTnorm)*   & 
    825                                        (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    826                                       +zice_surf_pos 
    827               ELSE 
    828                  zice_vol_neg=(zTnorm)*   & 
    829                                    (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    830                                   *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  & 
    831                                     hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) & 
    832                                   +zice_vol_neg 
    833                  zice_surf_neg=(zTnorm)*   & 
    834                                     (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    835                                      +zice_surf_neg 
    836               ENDIF 
    837     
    838               zsum(11,1) = zsum(11,1)+zice_vol_pos 
    839               zsum(12,1) = zsum(12,1)+zice_vol_neg 
    840               zsum(13,1) = zsum(13,1)+zice_surf_pos 
    841               zsum(14,1) = zsum(14,1)+zice_surf_neg 
     774              transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*   &  
     775                                   (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  &  
     776                                  *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  &  
     777                                    hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) 
     778              transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)*   &  
     779                                    (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) 
    842780    
    843781           ENDIF !end of ice case 
    … …  
    846784        ENDDO !end of loop on the segment 
    847785 
    848  
    849      ELSE  !if sec%nb_point =0 
    850         zsum(1:2,:)=0. 
    851         IF (sec%llstrpond) zsum(3:10,:)=0. 
    852         zsum( 11:14,:)=0. 
    853      ENDIF   !end of sec%nb_point =0 case 
    854  
    855      !-------------------------------| 
    856      !FINISH COMPUTING TRANSPORTS    | 
    857      !-------------------------------| 
    858      DO jclass=1,MAX(1,sec%nb_class-1) 
    859         sec%transport(1,jclass)=sec%transport(1,jclass)+zsum(1,jclass)*1.E-6 
    860         sec%transport(2,jclass)=sec%transport(2,jclass)+zsum(2,jclass)*1.E-6 
    861         IF( sec%llstrpond ) THEN 
    862            IF( zsum(1,jclass) .NE. 0._wp ) THEN 
    863               sec%transport( 3,jclass) = sec%transport( 3,jclass) + zsum( 3,jclass)/zsum(1,jclass) 
    864               sec%transport( 5,jclass) = sec%transport( 5,jclass) + zsum( 5,jclass)/zsum(1,jclass) 
    865               sec%transport( 7,jclass) = sec%transport( 7,jclass) + zsum( 7,jclass) 
    866               sec%transport( 9,jclass) = sec%transport( 9,jclass) + zsum( 9,jclass) 
    867            ENDIF 
    868            IF( zsum(2,jclass) .NE. 0._wp )THEN 
    869               sec%transport( 4,jclass) = sec%transport( 4,jclass) + zsum( 4,jclass)/zsum(2,jclass) 
    870               sec%transport( 6,jclass) = sec%transport( 6,jclass) + zsum( 6,jclass)/zsum(2,jclass) 
    871               sec%transport( 8,jclass) = sec%transport( 8,jclass) + zsum( 8,jclass) 
    872               sec%transport(10,jclass) = sec%transport(10,jclass) + zsum(10,jclass) 
    873            ENDIF 
    874         ELSE 
    875            sec%transport( 3,jclass) = 0._wp 
    876            sec%transport( 4,jclass) = 0._wp 
    877            sec%transport( 5,jclass) = 0._wp 
    878            sec%transport( 6,jclass) = 0._wp 
    879            sec%transport( 7,jclass) = 0._wp 
    880            sec%transport( 8,jclass) = 0._wp 
    881            sec%transport(10,jclass) = 0._wp 
    882         ENDIF 
    883      ENDDO    
    884  
    885      IF( sec%ll_ice_section ) THEN 
    886         sec%transport( 9,1)=sec%transport( 9,1)+zsum( 9,1)*1.E-6 
    887         sec%transport(10,1)=sec%transport(10,1)+zsum(10,1)*1.E-6 
    888         sec%transport(11,1)=sec%transport(11,1)+zsum(11,1)*1.E-6 
    889         sec%transport(12,1)=sec%transport(12,1)+zsum(12,1)*1.E-6 
    890      ENDIF 
    891  
    892      CALL wrk_dealloc( nb_type_class , nb_class_max , zsum   ) 
     786     ENDIF !end of sec%nb_point =0 case 
    893787     ! 
    894788  END SUBROUTINE transport 
     789   
     790  SUBROUTINE dia_dct_sum(sec,jsec)  
     791     !!-------------------------------------------------------------  
     792     !! Purpose: Average the transport over nn_dctwri time steps   
     793     !! and sum over the density/salinity/temperature/depth classes  
     794     !!  
     795     !! Method:   Sum over relevant grid cells to obtain values   
     796     !!           for each class 
     797     !!              There are several loops:                   
     798     !!              loop on the segment between 2 nodes  
     799     !!              loop on the level jk  
     800     !!              loop on the density/temperature/salinity/level classes  
     801     !!              test on the density/temperature/salinity/level  
     802     !!  
     803     !!  Note:    Transport through a given section is equal to the sum of transports  
     804     !!           computed on each proc.  
     805     !!           On each proc,transport is equal to the sum of transport computed through  
     806     !!           segments linking each point of sec%listPoint  with the next one.     
     807     !!  
     808     !!-------------------------------------------------------------  
     809     !! * arguments  
     810     TYPE(SECTION),INTENT(INOUT) :: sec  
     811     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section  
     812  
     813     TYPE(POINT_SECTION) :: k  
     814     INTEGER  :: jk,jseg,jclass                        ! dummy variables for looping on level/segment/classes   
     815     REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point  
     816     !!-------------------------------------------------------------  
     817  
     818     !! Sum the relevant segments to obtain values for each class  
     819     IF(sec%nb_point .NE. 0)THEN     
     820  
     821        !--------------------------------------!  
     822        ! LOOP ON THE SEGMENT BETWEEN 2 NODES  !  
     823        !--------------------------------------!  
     824        DO jseg=1,MAX(sec%nb_point-1,0)  
     825             
     826           !-------------------------------------------------------------------------------------------  
     827           ! Select the appropriate coordinate for computing the velocity of the segment  
     828           !  
     829           !                      CASE(0)                                    Case (2)  
     830           !                      -------                                    --------  
     831           !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)        
     832           !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               |  
     833           !                                                                            |  
     834           !                                                                            |  
     835           !                                                                            |  
     836           !                      Case (3)                                            U(i,j)  
     837           !                      --------                                              |  
     838           !                                                                            |  
     839           !  listPoint(jseg+1) F(i,j+1)                                                |  
     840           !                        |                                                   |  
     841           !                        |                                                   |  
     842           !                        |                                 listPoint(jseg+1) F(i,j-1)  
     843           !                        |                                              
     844           !                        |                                              
     845           !                     U(i,j+1)                                              
     846           !                        |                                       Case(1)       
     847           !                        |                                       ------        
     848           !                        |                                              
     849           !                        |                 listPoint(jseg+1)             listPoint(jseg)                             
     850           !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                             
     851           ! listPoint(jseg)     F(i,j)  
     852           !   
     853           !-------------------------------------------------------------------------------------------  
     854  
     855           SELECT CASE( sec%direction(jseg) )  
     856           CASE(0)  ;   k = sec%listPoint(jseg)  
     857           CASE(1)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J)  
     858           CASE(2)  ;   k = sec%listPoint(jseg)  
     859           CASE(3)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1)  
     860           END SELECT  
     861  
     862           !---------------------------|  
     863           !     LOOP ON THE LEVEL     |  
     864           !---------------------------|  
     865           !Sum of the transport on the vertical   
     866           DO jk=1,mbathy(k%I,k%J)  
     867  
     868              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point  
     869              SELECT CASE( sec%direction(jseg) )  
     870              CASE(0,1)  
     871                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) )  
     872                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) )  
     873                 zrhop = interp(k%I,k%J,jk,'V',rhop)  
     874                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0)  
     875 
     876              CASE(2,3)  
     877                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) )  
     878                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) )  
     879                 zrhop = interp(k%I,k%J,jk,'U',rhop)  
     880                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0)  
     881                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)   
     882              END SELECT  
     883  
     884              zfsdep= gdept(k%I,k%J,jk)  
     885   
     886              !-------------------------------  
     887              !  LOOP ON THE DENSITY CLASSES |  
     888              !-------------------------------  
     889              !The computation is made for each density/temperature/salinity/depth class  
     890              DO jclass=1,MAX(1,sec%nb_class-1)  
     891  
     892                 !----------------------------------------------!  
     893                 !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!   
     894                 !----------------------------------------------!  
     895 
     896                 IF ( (                                                    &  
     897                    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.      &  
     898                    (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.     &  
     899                    ( sec%zsigp(jclass) .EQ. 99.)) .AND.                   &  
     900  
     901                    ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    &  
     902                    (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.     &  
     903                    ( sec%zsigi(jclass) .EQ. 99.)) .AND.                   &  
     904  
     905                    ((( zsn .GT. sec%zsal(jclass)) .AND.                   &  
     906                    (   zsn .LE. sec%zsal(jclass+1))) .OR.                 &  
     907                    ( sec%zsal(jclass) .EQ. 99.)) .AND.                    &  
     908  
     909                    ((( ztn .GE. sec%ztem(jclass)) .AND.                   &  
     910                    (   ztn .LE. sec%ztem(jclass+1))) .OR.                 &  
     911                    ( sec%ztem(jclass) .EQ.99.)) .AND.                     &  
     912  
     913                    ((( zfsdep .GE. sec%zlay(jclass)) .AND.                &  
     914                    (   zfsdep .LE. sec%zlay(jclass+1))) .OR.              &  
     915                    ( sec%zlay(jclass) .EQ. 99. ))                         &  
     916                                                                   ))   THEN  
     917  
     918                    !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS  
     919                    !----------------------------------------------------------------------------  
     920                    IF (transports_3d(1,jsec,jseg,jk) .GE. 0.0) THEN   
     921                       sec%transport(1,jclass) = sec%transport(1,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6  
     922                    ELSE  
     923                       sec%transport(2,jclass) = sec%transport(2,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6  
     924                    ENDIF  
     925                    IF( sec%llstrpond )THEN  
     926  
     927                       IF ( transports_3d(2,jsec,jseg,jk) .GE. 0.0 ) THEN  
     928                          sec%transport(3,jclass) = sec%transport(3,jclass)+transports_3d(2,jsec,jseg,jk)  
     929                       ELSE  
     930                          sec%transport(4,jclass) = sec%transport(4,jclass)+transports_3d(2,jsec,jseg,jk)  
     931                       ENDIF  
     932  
     933                       IF ( transports_3d(3,jsec,jseg,jk) .GE. 0.0 ) THEN  
     934                          sec%transport(5,jclass) = sec%transport(5,jclass)+transports_3d(3,jsec,jseg,jk)  
     935                       ELSE  
     936                          sec%transport(6,jclass) = sec%transport(6,jclass)+transports_3d(3,jsec,jseg,jk)  
     937                       ENDIF  
     938  
     939                    ELSE  
     940                       sec%transport( 3,jclass) = 0._wp  
     941                       sec%transport( 4,jclass) = 0._wp  
     942                       sec%transport( 5,jclass) = 0._wp  
     943                       sec%transport( 6,jclass) = 0._wp  
     944                    ENDIF  
     945  
     946                 ENDIF ! end of test if point is in class  
     947     
     948              ENDDO ! end of loop on the classes  
     949  
     950           ENDDO ! loop over jk  
     951  
     952#if defined key_lim2 || defined key_lim3  
     953  
     954           !ICE CASE      
     955           IF( sec%ll_ice_section )THEN  
     956  
     957              IF ( transports_2d(1,jsec,jseg) .GE. 0.0 ) THEN  
     958                 sec%transport( 7,1) = sec%transport( 7,1)+transports_2d(1,jsec,jseg)*1.E-6  
     959              ELSE  
     960                 sec%transport( 8,1) = sec%transport( 8,1)+transports_2d(1,jsec,jseg)*1.E-6  
     961              ENDIF  
     962  
     963              IF ( transports_2d(3,jsec,jseg) .GE. 0.0 ) THEN  
     964                 sec%transport( 9,1) = sec%transport( 9,1)+transports_2d(2,jsec,jseg)*1.E-6  
     965              ELSE  
     966                 sec%transport(10,1) = sec%transport(10,1)+transports_2d(2,jsec,jseg)*1.E-6  
     967              ENDIF  
     968  
     969           ENDIF !end of ice case  
     970#endif  
     971   
     972        ENDDO !end of loop on the segment  
     973  
     974     ELSE  !if sec%nb_point =0  
     975        sec%transport(1:2,:)=0.  
     976        IF (sec%llstrpond) sec%transport(3:6,:)=0.  
     977        IF (sec%ll_ice_section) sec%transport(7:10,:)=0.  
     978     ENDIF !end of sec%nb_point =0 case  
     979  
     980  END SUBROUTINE dia_dct_sum  
    895981   
    896982  SUBROUTINE dia_dct_wri(kt,ksec,sec) 
    … …  
    905991     !!  
    906992     !!        2. Write heat transports in "heat_transport" 
    907      !!           Unit: Peta W : area * Velocity * T * rhau * Cp / 1.e15 
     993     !!           Unit: Peta W : area * Velocity * T * rhop * Cp * 1.e-15 
    908994     !!  
    909995     !!        3. Write salt transports in "salt_transport" 
    910      !!           Unit: 10^9 g m^3 / s : area * Velocity * S / 1.e6 
     996     !!           Unit: 10^9 Kg/m^2/s : area * Velocity * S * rhop * 1.e-9  
    911997     !! 
    912998     !!-------------------------------------------------------------  
    … …  
    9171003 
    9181004     !!local declarations 
    919      INTEGER               :: jcl,ji             ! Dummy loop 
     1005     INTEGER               :: jclass             ! Dummy loop 
    9201006     CHARACTER(len=2)      :: classe             ! Classname  
    9211007     REAL(wp)              :: zbnd1,zbnd2        ! Class bounds 
    9221008     REAL(wp)              :: zslope             ! section's slope coeff 
    9231009     ! 
    924      REAL(wp), POINTER, DIMENSION(:):: zsumclass ! 1D workspace  
     1010     REAL(wp), POINTER, DIMENSION(:):: zsumclasses ! 1D workspace  
    9251011     !!-------------------------------------------------------------  
    926      CALL wrk_alloc(nb_type_class , zsumclass )   
    927  
    928      zsumclass(:)=0._wp 
     1012     CALL wrk_alloc(nb_type_class , zsumclasses )   
     1013 
     1014     zsumclasses(:)=0._wp 
    9291015     zslope = sec%slopeSection        
    9301016 
    9311017  
    932      DO jcl=1,MAX(1,sec%nb_class-1) 
    933  
    934         ! Mean computation 
    935         sec%transport(:,jcl)=sec%transport(:,jcl)/(nn_dctwri/nn_dct) 
     1018     DO jclass=1,MAX(1,sec%nb_class-1) 
     1019 
    9361020        classe   = 'N       ' 
    9371021        zbnd1   = 0._wp 
    9381022        zbnd2   = 0._wp 
    939         zsumclass(1:nb_type_class)=zsumclass(1:nb_type_class)+sec%transport(1:nb_type_class,jcl) 
     1023        zsumclasses(1:nb_type_class)=zsumclasses(1:nb_type_class)+sec%transport(1:nb_type_class,jclass) 
    9401024 
    9411025    
    9421026        !insitu density classes transports 
    943         IF( ( sec%zsigi(jcl)   .NE. 99._wp ) .AND. & 
    944             ( sec%zsigi(jcl+1) .NE. 99._wp )       )THEN 
     1027        IF( ( sec%zsigi(jclass)   .NE. 99._wp ) .AND. & 
     1028            ( sec%zsigi(jclass+1) .NE. 99._wp )       )THEN 
    9451029           classe = 'DI       ' 
    946            zbnd1 = sec%zsigi(jcl) 
    947            zbnd2 = sec%zsigi(jcl+1) 
     1030           zbnd1 = sec%zsigi(jclass) 
     1031           zbnd2 = sec%zsigi(jclass+1) 
    9481032        ENDIF 
    9491033        !potential density classes transports 
    950         IF( ( sec%zsigp(jcl)   .NE. 99._wp ) .AND. & 
    951             ( sec%zsigp(jcl+1) .NE. 99._wp )       )THEN 
     1034        IF( ( sec%zsigp(jclass)   .NE. 99._wp ) .AND. & 
     1035            ( sec%zsigp(jclass+1) .NE. 99._wp )       )THEN 
    9521036           classe = 'DP      ' 
    953            zbnd1 = sec%zsigp(jcl) 
    954            zbnd2 = sec%zsigp(jcl+1) 
     1037           zbnd1 = sec%zsigp(jclass) 
     1038           zbnd2 = sec%zsigp(jclass+1) 
    9551039        ENDIF 
    9561040        !depth classes transports 
    957         IF( ( sec%zlay(jcl)    .NE. 99._wp ) .AND. & 
    958             ( sec%zlay(jcl+1)  .NE. 99._wp )       )THEN  
     1041        IF( ( sec%zlay(jclass)    .NE. 99._wp ) .AND. & 
     1042            ( sec%zlay(jclass+1)  .NE. 99._wp )       )THEN  
    9591043           classe = 'Z       ' 
    960            zbnd1 = sec%zlay(jcl) 
    961            zbnd2 = sec%zlay(jcl+1) 
     1044           zbnd1 = sec%zlay(jclass) 
     1045           zbnd2 = sec%zlay(jclass+1) 
    9621046        ENDIF 
    9631047        !salinity classes transports 
    964         IF( ( sec%zsal(jcl) .NE. 99._wp    ) .AND. & 
    965             ( sec%zsal(jcl+1) .NE. 99._wp  )       )THEN 
     1048        IF( ( sec%zsal(jclass) .NE. 99._wp    ) .AND. & 
     1049            ( sec%zsal(jclass+1) .NE. 99._wp  )       )THEN 
    9661050           classe = 'S       ' 
    967            zbnd1 = sec%zsal(jcl) 
    968            zbnd2 = sec%zsal(jcl+1)    
     1051           zbnd1 = sec%zsal(jclass) 
     1052           zbnd2 = sec%zsal(jclass+1)    
    9691053        ENDIF 
    9701054        !temperature classes transports 
    971         IF( ( sec%ztem(jcl) .NE. 99._wp     ) .AND. & 
    972             ( sec%ztem(jcl+1) .NE. 99._wp     )       ) THEN 
     1055        IF( ( sec%ztem(jclass) .NE. 99._wp     ) .AND. & 
     1056            ( sec%ztem(jclass+1) .NE. 99._wp     )       ) THEN 
    9731057           classe = 'T       ' 
    974            zbnd1 = sec%ztem(jcl) 
    975            zbnd2 = sec%ztem(jcl+1) 
     1058           zbnd1 = sec%ztem(jclass) 
     1059           zbnd2 = sec%ztem(jclass+1) 
    9761060        ENDIF 
    9771061                   
    9781062        !write volume transport per class 
    9791063        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & 
    980                               jcl,classe,zbnd1,zbnd2,& 
    981                               sec%transport(1,jcl),sec%transport(2,jcl), & 
    982                               sec%transport(1,jcl)+sec%transport(2,jcl) 
     1064                              jclass,classe,zbnd1,zbnd2,& 
     1065                              sec%transport(1,jclass),sec%transport(2,jclass), & 
     1066                              sec%transport(1,jclass)+sec%transport(2,jclass) 
    9831067 
    9841068        IF( sec%llstrpond )THEN 
    … …  
    9861070           !write heat transport per class: 
    9871071           WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope,  & 
    988                               jcl,classe,zbnd1,zbnd2,& 
    989                               sec%transport(7,jcl)*1000._wp*rcp/1.e15,sec%transport(8,jcl)*1000._wp*rcp/1.e15, & 
    990                               ( sec%transport(7,jcl)+sec%transport(8,jcl) )*1000._wp*rcp/1.e15 
     1072                              jclass,classe,zbnd1,zbnd2,& 
     1073                              sec%transport(3,jclass)*1.e-15,sec%transport(4,jclass)*1.e-15, & 
     1074                              ( sec%transport(3,jclass)+sec%transport(4,jclass) )*1.e-15 
    9911075           !write salt transport per class 
    9921076           WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope,  & 
    993                               jcl,classe,zbnd1,zbnd2,& 
    994                               sec%transport(9,jcl)*1000._wp/1.e9,sec%transport(10,jcl)*1000._wp/1.e9,& 
    995                               (sec%transport(9,jcl)+sec%transport(10,jcl))*1000._wp/1.e9 
     1077                              jclass,classe,zbnd1,zbnd2,& 
     1078                              sec%transport(5,jclass)*1.e-9,sec%transport(6,jclass)*1.e-9,& 
     1079                              (sec%transport(5,jclass)+sec%transport(6,jclass))*1.e-9 
    9961080        ENDIF 
    9971081 
    … …  
    10001084     zbnd1 = 0._wp 
    10011085     zbnd2 = 0._wp 
    1002      jcl=0 
     1086     jclass=0 
    10031087 
    10041088     !write total volume transport 
    10051089     WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & 
    1006                            jcl,"total",zbnd1,zbnd2,& 
    1007                            zsumclass(1),zsumclass(2),zsumclass(1)+zsumclass(2) 
     1090                           jclass,"total",zbnd1,zbnd2,& 
     1091                           zsumclasses(1),zsumclasses(2),zsumclasses(1)+zsumclasses(2) 
    10081092 
    10091093     IF( sec%llstrpond )THEN 
    … …  
    10111095        !write total heat transport 
    10121096        WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & 
    1013                            jcl,"total",zbnd1,zbnd2,& 
    1014                            zsumclass(7)* 1000._wp*rcp/1.e15,zsumclass(8)* 1000._wp*rcp/1.e15,& 
    1015                            (zsumclass(7)+zsumclass(8) )* 1000._wp*rcp/1.e15 
     1097                           jclass,"total",zbnd1,zbnd2,& 
     1098                           zsumclasses(3)*1.e-15,zsumclasses(4)*1.e-15,& 
     1099                           (zsumclasses(3)+zsumclasses(4) )*1.e-15 
    10161100        !write total salt transport 
    10171101        WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & 
    1018                            jcl,"total",zbnd1,zbnd2,& 
    1019                            zsumclass(9)*1000._wp/1.e9,zsumclass(10)*1000._wp/1.e9,& 
    1020                            (zsumclass(9)+zsumclass(10))*1000._wp/1.e9 
     1102                           jclass,"total",zbnd1,zbnd2,& 
     1103                           zsumclasses(5)*1.e-9,zsumclasses(6)*1.e-9,& 
     1104                           (zsumclasses(5)+zsumclasses(6))*1.e-9 
    10211105     ENDIF 
    10221106 
    … …  
    10251109        !write total ice volume transport 
    10261110        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& 
    1027                               jcl,"ice_vol",zbnd1,zbnd2,& 
    1028                               sec%transport(9,1),sec%transport(10,1),& 
    1029                               sec%transport(9,1)+sec%transport(10,1) 
     1111                              jclass,"ice_vol",zbnd1,zbnd2,& 
     1112                              sec%transport(7,1),sec%transport(8,1),& 
     1113                              sec%transport(7,1)+sec%transport(8,1) 
    10301114        !write total ice surface transport 
    10311115        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& 
    1032                               jcl,"ice_surf",zbnd1,zbnd2,& 
    1033                               sec%transport(11,1),sec%transport(12,1), & 
    1034                               sec%transport(11,1)+sec%transport(12,1)  
     1116                              jclass,"ice_surf",zbnd1,zbnd2,& 
     1117                              sec%transport(9,1),sec%transport(10,1), & 
     1118                              sec%transport(9,1)+sec%transport(10,1)  
    10351119     ENDIF 
    10361120                                               
    … …  
    10381122119 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3E15.6) 
    10391123 
    1040      CALL wrk_dealloc(nb_type_class , zsumclass )   
     1124     CALL wrk_dealloc(nb_type_class , zsumclasses )   
    10411125  END SUBROUTINE dia_dct_wri 
    10421126 
    … …  
    10441128  !!---------------------------------------------------------------------- 
    10451129  !! 
    1046   !!   Purpose: compute Temperature/Salinity/density at U-point or V-point 
     1130  !!   Purpose: compute temperature/salinity/density at U-point or V-point 
    10471131  !!   -------- 
    10481132  !! 
    … …  
    10531137  !!  
    10541138  !! 
    1055   !!    |    I          |    I+1           |    Z=Temperature/Salinity/density at U-poinT 
     1139  !!    |    I          |    I+1           |    Z=temperature/salinity/density at U-poinT 
    10561140  !!    |               |                  | 
    1057   !!  ----------------------------------------  1. Veritcale interpolation: compute zbis 
     1141  !!  ----------------------------------------  1. Veritcal interpolation: compute zbis 
    10581142  !!    |               |                  |       interpolation between ptab(I,J,K) and ptab(I,J,K+1) 
    10591143  !!    |               |                  |       zbis =  
    … …  
    11361220     zdep2 = fsdept(ii2,ij2,kk) - zdepu 
    11371221 
    1138      !weights 
     1222     ! weights 
    11391223     zwgt1 = SQRT( ( 0.5 * zet1 ) * ( 0.5 * zet1 ) + ( zdep1 * zdep1 ) ) 
    11401224     zwgt2 = SQRT( ( 0.5 * zet2 ) * ( 0.5 * zet2 ) + ( zdep2 * zdep2 ) ) 
    … …  
    11631247 
    11641248        IF( ze3t >= 0. )THEN  
    1165            !zbis 
     1249           ! zbis 
    11661250           zbis = ptab(ii2,ij2,kk) + zwgt1 * ( ptab(ii2,ij2,kk-1) - ptab(ii2,ij2,kk) )  
    11671251           ! result 
    11681252            interp = umask(ii1,ij1,kk) * ( zet2 * ptab(ii1,ij1,kk) + zet1 * zbis )/( zet1 + zet2 ) 
    11691253        ELSE 
    1170            !zbis 
     1254           ! zbis 
    11711255           zbis = ptab(ii1,ij1,kk) + zwgt2 * ( ptab(ii1,ij1,kk-1) - ptab(ii1,ij2,kk) ) 
    11721256           ! result 
    … …  
    11951279   END SUBROUTINE dia_dct_init 
    11961280 
    1197    SUBROUTINE dia_dct( kt )           ! Dummy routine 
    1198       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
     1281   SUBROUTINE dia_dct( kt )         ! Dummy routine 
     1282      INTEGER, INTENT( in ) :: kt   ! ocean time-step index 
    11991283      WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 
    12001284   END SUBROUTINE dia_dct 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r3294 r3680  
    3232   USE ioipsl, ONLY :   ymds2ju   ! for calendar 
    3333   USE prtctl          ! Print control 
    34    USE restart         !  
    3534   USE trc_oce, ONLY : lk_offline ! offline flag 
    3635   USE timing          ! Timing 
     36   USE restart         ! restart 
    3737 
    3838   IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r3632 r3680  
    88   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
    99   !!            4.0  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
     10   !!            3.5  ! 2012     (S. Mocavero, I. Epicoco) Add arrays associated 
     11   !!                             to the optimization of BDY communications 
    1012   !!---------------------------------------------------------------------- 
    1113 
    … …  
    8082   INTEGER, PUBLIC ::   narea             !: number for local area 
    8183   INTEGER, PUBLIC ::   nbondi, nbondj    !: mark of i- and j-direction local boundaries 
     84   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy(:)    !: mark i-direction local boundaries for BDY open boundaries 
     85   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy(:)    !: mark j-direction local boundaries for BDY open boundaries 
     86   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries   
     87   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries   
     88 
    8289   INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4) 
    8390   INTEGER, PUBLIC ::   nlci, nldi, nlei  !: i-dimensions of the local subdomain and its first and last indoor indices 
    … …  
    174181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff     !: interface depth between stretching at  V--F 
    175182   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu     !: and quasi-uniform spacing              T--U  points (m) 
     183   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rx1              !: Maximum grid stiffness ratio 
    176184 
    177185   !!---------------------------------------------------------------------- 
    … …  
    294302         &      scosrf(jpi,jpj) , scobot(jpi,jpj) ,     & 
    295303         &      hifv  (jpi,jpj) , hiff  (jpi,jpj) ,     & 
    296          &      hift  (jpi,jpj) , hifu  (jpi,jpj) , STAT=ierr(8) ) 
     304         &      hift  (jpi,jpj) , hifu  (jpi,jpj) , rx1 (jpi,jpj) , STAT=ierr(8) ) 
    297305 
    298306      ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) ,                     & 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r3632 r3680  
    3636   USE dyncor_c1d      ! Coriolis term (c1d case)         (cor_c1d routine) 
    3737   USE timing          ! Timing 
     38   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    3839 
    3940   IMPLICIT NONE 
    … …  
    8485                             CALL dom_zgr      ! Vertical mesh and bathymetry 
    8586                             CALL dom_msk      ! Masks 
     87      IF( ln_sco )           CALL dom_stiff    ! Maximum stiffness ratio/hydrostatic consistency 
    8688      IF( lk_vvl         )   CALL dom_vvl      ! Vertical variable mesh 
    8789      ! 
    … …  
    322324   END SUBROUTINE dom_ctl 
    323325 
     326   SUBROUTINE dom_stiff 
     327      !!---------------------------------------------------------------------- 
     328      !!                  ***  ROUTINE dom_stiff  *** 
     329      !!                      
     330      !! ** Purpose :   Diagnose maximum grid stiffness/hydrostatic consistency 
     331      !! 
     332      !! ** Method  :   Compute Haney (1991) hydrostatic condition ratio 
     333      !!                Save the maximum in the vertical direction 
     334      !!                (this number is only relevant in s-coordinates) 
     335      !! 
     336      !!                Haney, R. L., 1991: On the pressure gradient force 
     337      !!                over steep topography in sigma coordinate ocean models.  
     338      !!                J. Phys. Oceanogr., 21, 610???619. 
     339      !!---------------------------------------------------------------------- 
     340      INTEGER  ::   ji, jj, jk  
     341      REAL(wp) ::   zrxmax 
     342      REAL(wp), DIMENSION(4) :: zr1 
     343      !!---------------------------------------------------------------------- 
     344      rx1(:,:) = 0.e0 
     345      zrxmax   = 0.e0 
     346      zr1(:)   = 0.e0 
     347       
     348      DO ji = 2, jpim1 
     349         DO jj = 2, jpjm1 
     350            DO jk = 1, jpkm1 
     351               zr1(1) = umask(ji-1,jj  ,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji-1,jj  ,jk  )  &  
     352                    &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1)) & 
     353                    &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji-1,jj  ,jk  )  & 
     354                    &                         -gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1) + rsmall) ) 
     355               zr1(2) = umask(ji  ,jj  ,jk) *abs( (gdepw(ji+1,jj  ,jk  )-gdepw(ji  ,jj  ,jk  )  & 
     356                    &                         +gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
     357                    &                        /(gdepw(ji+1,jj  ,jk  )+gdepw(ji  ,jj  ,jk  )  & 
     358                    &                         -gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
     359               zr1(3) = vmask(ji  ,jj  ,jk) *abs( (gdepw(ji  ,jj+1,jk  )-gdepw(ji  ,jj  ,jk  )  & 
     360                    &                         +gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
     361                    &                        /(gdepw(ji  ,jj+1,jk  )+gdepw(ji  ,jj  ,jk  )  & 
     362                    &                         -gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
     363               zr1(4) = vmask(ji  ,jj-1,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji  ,jj-1,jk  )  & 
     364                    &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1)) & 
     365                    &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji  ,jj-1,jk  )  & 
     366                    &                         -gdepw(ji,  jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1) + rsmall) ) 
     367               zrxmax = MAXVAL(zr1(1:4)) 
     368               rx1(ji,jj) = MAX(rx1(ji,jj), zrxmax) 
     369            END DO 
     370         END DO 
     371      END DO 
     372 
     373      CALL lbc_lnk( rx1, 'T', 1. ) 
     374 
     375      zrxmax = MAXVAL(rx1) 
     376 
     377      IF( lk_mpp )   CALL mpp_max( zrxmax ) ! max over the global domain 
     378 
     379      IF(lwp) THEN 
     380         WRITE(numout,*) 
     381         WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax 
     382         WRITE(numout,*) '~~~~~~~~~' 
     383      ENDIF 
     384 
     385   END SUBROUTINE dom_stiff 
     386 
     387 
     388 
    324389   !!====================================================================== 
    325390END MODULE domain 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r3294 r3680  
    172172             
    173173      IF( ln_sco ) THEN                                         ! s-coordinate 
    174          CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt )         !    ! depth 
    175          CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu )  
     174         CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) 
     175         CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu ) 
    176176         CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv ) 
    177177         CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf ) 
    … …  
    187187         CALL iom_rstput( 0, 0, inum4, 'e3v', e3v ) 
    188188         CALL iom_rstput( 0, 0, inum4, 'e3w', e3w ) 
    189          ! 
    190          CALL iom_rstput( 0, 0, inum4, 'gdept_0' , gdept_0 )    !    ! stretched system 
    191          CALL iom_rstput( 0, 0, inum4, 'gdepw_0' , gdepw_0 ) 
     189         CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 )             !    ! Max. grid stiffness ratio 
     190         ! 
     191         CALL iom_rstput( 0, 0, inum4, 'gdept' , gdept )    !    ! stretched system 
     192         CALL iom_rstput( 0, 0, inum4, 'gdepw' , gdepw ) 
    192193      ENDIF 
    193194       

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r3632 r3680  
    1515   !!            3.2  ! 2009-07  (R. Benshila) Suppression of rigid-lid option 
    1616   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
     17   !!            3.4  ! 2012-08  (J. Siddorn) added Siddorn and Furner stretching function 
    1718   !!---------------------------------------------------------------------- 
    1819 
    … …  
    2728   !!       zgr_zps      : z-coordinate with partial steps 
    2829   !!       zgr_sco      : s-coordinate 
    29    !!       fssig        : sigma coordinate non-dimensional function 
    30    !!       dfssig       : derivative of the sigma coordinate function    !!gm  (currently missing!) 
     30   !!       fssig        : tanh stretch function 
     31   !!       fssig1       : Song and Haidvogel 1994 stretch function 
     32   !!       fgamma       : Siddorn and Furner 2012 stretching function 
    3133   !!--------------------------------------------------------------------- 
    3234   USE oce               ! ocean variables 
    … …  
    4749 
    4850   !                                       !!* Namelist namzgr_sco * 
     51   LOGICAL  ::   ln_s_sh94   = .false.      ! use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 (ln_sco=T) 
     52   LOGICAL  ::   ln_s_sf12   = .true.       ! use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma (ln_sco=T) 
     53   ! 
    4954   REAL(wp) ::   rn_sbot_min =  300._wp     ! minimum depth of s-bottom surface (>0) (m) 
    5055   REAL(wp) ::   rn_sbot_max = 5250._wp     ! maximum depth of s-bottom surface (= ocean depth) (>0) (m) 
     56   REAL(wp) ::   rn_rmax     =    0.15_wp   ! maximum cut-off r-value allowed (0<rn_rmax<1) 
     57   REAL(wp) ::   rn_hc       =  150._wp     ! Critical depth for transition from sigma to stretched coordinates 
     58   ! Song and Haidvogel 1994 stretching parameters 
    5159   REAL(wp) ::   rn_theta    =    6.00_wp   ! surface control parameter (0<=rn_theta<=20) 
    5260   REAL(wp) ::   rn_thetb    =    0.75_wp   ! bottom control parameter  (0<=rn_thetb<= 1) 
    53    REAL(wp) ::   rn_rmax     =    0.15_wp   ! maximum cut-off r-value allowed (0<rn_rmax<1) 
    54    LOGICAL  ::   ln_s_sigma  = .false.      ! use hybrid s-sigma -coordinate & stretching function fssig1 (ln_sco=T) 
    55    REAL(wp) ::   rn_bb       =    0.80_wp   ! stretching parameter for song and haidvogel stretching 
     61   REAL(wp) ::   rn_bb       =    0.80_wp   ! stretching parameter  
    5662   !                                        ! ( rn_bb=0; top only, rn_bb =1; top and bottom) 
    57    REAL(wp) ::   rn_hc       =  150._wp     ! Critical depth for s-sigma coordinates 
     63   ! Siddorn and Furner stretching parameters 
     64   LOGICAL  ::   ln_sigcrit  = .false.      ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch  
     65   REAL(wp) ::   rn_alpha    =    4.4_wp    ! control parameter ( > 1 stretch towards surface, < 1 towards seabed) 
     66   REAL(wp) ::   rn_efold    =    0.0_wp    !  efold length scale for transition to stretched coord 
     67   REAL(wp) ::   rn_zs       =    1.0_wp    !  depth of surface grid box 
     68                           !  bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b 
     69   REAL(wp) ::   rn_zb_a     =    0.024_wp  !  bathymetry scaling factor for calculating Zb 
     70   REAL(wp) ::   rn_zb_b     =   -0.2_wp    !  offset for calculating Zb 
    5871 
    5972  !! * Substitutions 
    … …  
    10341047   END SUBROUTINE zgr_zps 
    10351048 
    1036  
    1037    FUNCTION fssig( pk ) RESULT( pf ) 
    1038       !!---------------------------------------------------------------------- 
    1039       !!                 ***  ROUTINE eos_init  *** 
    1040       !!        
    1041       !! ** Purpose :   provide the analytical function in s-coordinate 
    1042       !!           
    1043       !! ** Method  :   the function provide the non-dimensional position of 
    1044       !!                T and W (i.e. between 0 and 1) 
    1045       !!                T-points at integer values (between 1 and jpk) 
    1046       !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
    1047       !!---------------------------------------------------------------------- 
    1048       REAL(wp), INTENT(in) ::   pk   ! continuous "k" coordinate 
    1049       REAL(wp)             ::   pf   ! sigma value 
    1050       !!---------------------------------------------------------------------- 
    1051       ! 
    1052       pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb )  )   & 
    1053          &     - TANH( rn_thetb * rn_theta                                )  )   & 
    1054          & * (   COSH( rn_theta                           )                      & 
    1055          &     + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) )  )              & 
    1056          & / ( 2._wp * SINH( rn_theta ) ) 
    1057       ! 
    1058    END FUNCTION fssig 
    1059  
    1060  
    1061    FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) 
    1062       !!---------------------------------------------------------------------- 
    1063       !!                 ***  ROUTINE eos_init  *** 
    1064       !! 
    1065       !! ** Purpose :   provide the Song and Haidvogel version of the analytical function in s-coordinate 
    1066       !! 
    1067       !! ** Method  :   the function provides the non-dimensional position of 
    1068       !!                T and W (i.e. between 0 and 1) 
    1069       !!                T-points at integer values (between 1 and jpk) 
    1070       !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
    1071       !!---------------------------------------------------------------------- 
    1072       REAL(wp), INTENT(in) ::   pk1   ! continuous "k" coordinate 
    1073       REAL(wp), INTENT(in) ::   pbb   ! Stretching coefficient 
    1074       REAL(wp)             ::   pf1   ! sigma value 
    1075       !!---------------------------------------------------------------------- 
    1076       ! 
    1077       IF ( rn_theta == 0 ) then      ! uniform sigma 
    1078          pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 
    1079       ELSE                        ! stretched sigma 
    1080          pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta )              & 
    1081             &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
    1082             &        / ( 2._wp * TANH( 0.5_wp * rn_theta ) )  ) 
    1083       ENDIF 
    1084       ! 
    1085    END FUNCTION fssig1 
    1086  
    1087  
    10881049   SUBROUTINE zgr_sco 
    10891050      !!---------------------------------------------------------------------- 
    … …  
    11041065      !!            hbatv = mj( hbatt ) 
    11051066      !!            hbatf = mi( mj( hbatt ) ) 
    1106       !!          - Compute gsigt, gsigw, esigt, esigw from an analytical 
     1067      !!          - Compute z_gsigt, z_gsigw, z_esigt, z_esigw from an analytical 
    11071068      !!         function and its derivative given as function. 
    1108       !!            gsigt(k) = fssig (k    ) 
    1109       !!            gsigw(k) = fssig (k-0.5) 
    1110       !!            esigt(k) = fsdsig(k    ) 
    1111       !!            esigw(k) = fsdsig(k-0.5) 
    1112       !!      This routine is given as an example, it must be modified 
    1113       !!      following the user s desiderata. nevertheless, the output as 
     1069      !!            z_gsigt(k) = fssig (k    ) 
     1070      !!            z_gsigw(k) = fssig (k-0.5) 
     1071      !!            z_esigt(k) = fsdsig(k    ) 
     1072      !!            z_esigw(k) = fsdsig(k-0.5) 
     1073      !!      Three options for stretching are give, and they can be modified 
     1074      !!      following the users requirements. Nevertheless, the output as 
    11141075      !!      well as the way to compute the model levels and scale factors 
    1115       !!      must be respected in order to insure second order a!!uracy 
     1076      !!      must be respected in order to insure second order accuracy 
    11161077      !!      schemes. 
    11171078      !! 
    1118       !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. 
     1079      !!      The three methods for stretching available are: 
     1080      !!  
     1081      !!           s_sh94 (Song and Haidvogel 1994) 
     1082      !!                a sinh/tanh function that allows sigma and stretched sigma 
     1083      !! 
     1084      !!           s_sf12 (Siddorn and Furner 2012?) 
     1085      !!                allows the maintenance of fixed surface and or 
     1086      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1087      !!                within an analytically derived stretched S-coordinate framework. 
     1088      !!  
     1089      !!          s_tanh  (Madec et al 1996) 
     1090      !!                a cosh/tanh function that gives stretched coordinates         
     1091      !! 
    11191092      !!---------------------------------------------------------------------- 
    11201093      ! 
    11211094      INTEGER  ::   ji, jj, jk, jl           ! dummy loop argument 
    11221095      INTEGER  ::   iip1, ijp1, iim1, ijm1   ! temporary integers 
    1123       REAL(wp) ::   zcoeft, zcoefw, zrmax, ztaper   ! temporary scalars 
     1096      REAL(wp) ::   zrmax, ztaper   ! temporary scalars 
    11241097      ! 
    11251098      REAL(wp), POINTER, DIMENSION(:,:  ) :: zenv, ztmp, zmsk, zri, zrj, zhbat 
    1126       REAL(wp), POINTER, DIMENSION(:,:,:) :: gsigw3, gsigt3, gsi3w3 
    1127       REAL(wp), POINTER, DIMENSION(:,:,:) :: esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3            
    1128  
    1129       NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, rn_rmax, ln_s_sigma, rn_bb, rn_hc 
    1130       !!---------------------------------------------------------------------- 
     1099 
     1100      NAMELIST/namzgr_sco/ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & 
     1101                           rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b 
     1102     !!---------------------------------------------------------------------- 
    11311103      ! 
    11321104      IF( nn_timing == 1 )  CALL timing_start('zgr_sco') 
    11331105      ! 
    11341106      CALL wrk_alloc( jpi, jpj,      zenv, ztmp, zmsk, zri, zrj, zhbat                           ) 
    1135       CALL wrk_alloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
    1136       CALL wrk_alloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
    11371107      ! 
    11381108      REWIND( numnam )                       ! Read Namelist namzgr_sco : sigma-stretching parameters 
    … …  
    11441114         WRITE(numout,*) '~~~~~~~~~~~' 
    11451115         WRITE(numout,*) '   Namelist namzgr_sco' 
    1146          WRITE(numout,*) '      sigma-stretching coeffs ' 
    1147          WRITE(numout,*) '      maximum depth of s-bottom surface (>0)       rn_sbot_max   = ' ,rn_sbot_max 
    1148          WRITE(numout,*) '      minimum depth of s-bottom surface (>0)       rn_sbot_min   = ' ,rn_sbot_min 
    1149          WRITE(numout,*) '      surface control parameter (0<=rn_theta<=20)  rn_theta      = ', rn_theta 
    1150          WRITE(numout,*) '      bottom  control parameter (0<=rn_thetb<= 1)  rn_thetb      = ', rn_thetb 
    1151          WRITE(numout,*) '      maximum cut-off r-value allowed              rn_rmax       = ', rn_rmax 
    1152          WRITE(numout,*) '      Hybrid s-sigma-coordinate                    ln_s_sigma    = ', ln_s_sigma 
    1153          WRITE(numout,*) '      stretching parameter (song and haidvogel)    rn_bb         = ', rn_bb 
    1154          WRITE(numout,*) '      Critical depth                               rn_hc         = ', rn_hc 
    1155       ENDIF 
    1156  
    1157       gsigw3  = 0._wp   ;   gsigt3  = 0._wp   ;   gsi3w3  = 0._wp 
    1158       esigt3  = 0._wp   ;   esigw3  = 0._wp  
    1159       esigtu3 = 0._wp   ;   esigtv3 = 0._wp   ;   esigtf3 = 0._wp 
    1160       esigwu3 = 0._wp   ;   esigwv3 = 0._wp 
     1116         WRITE(numout,*) '     stretching coeffs ' 
     1117         WRITE(numout,*) '        maximum depth of s-bottom surface (>0)       rn_sbot_max   = ',rn_sbot_max 
     1118         WRITE(numout,*) '        minimum depth of s-bottom surface (>0)       rn_sbot_min   = ',rn_sbot_min 
     1119         WRITE(numout,*) '        Critical depth                               rn_hc         = ',rn_hc 
     1120         WRITE(numout,*) '        maximum cut-off r-value allowed              rn_rmax       = ',rn_rmax 
     1121         WRITE(numout,*) '     Song and Haidvogel 1994 stretching              ln_s_sh94     = ',ln_s_sh94 
     1122         WRITE(numout,*) '        Song and Haidvogel 1994 stretching coefficients' 
     1123         WRITE(numout,*) '        surface control parameter (0<=rn_theta<=20)  rn_theta      = ',rn_theta 
     1124         WRITE(numout,*) '        bottom  control parameter (0<=rn_thetb<= 1)  rn_thetb      = ',rn_thetb 
     1125         WRITE(numout,*) '        stretching parameter (song and haidvogel)    rn_bb         = ',rn_bb 
     1126         WRITE(numout,*) '     Siddorn and Furner 2012 stretching              ln_s_sf12     = ',ln_s_sf12 
     1127         WRITE(numout,*) '        switching to sigma (T) or Z (F) at H<Hc      ln_sigcrit    = ',ln_sigcrit 
     1128         WRITE(numout,*) '        Siddorn and Furner 2012 stretching coefficients' 
     1129         WRITE(numout,*) '        stretchin parameter ( >1 surface; <1 bottom) rn_alpha      = ',rn_alpha 
     1130         WRITE(numout,*) '        e-fold length scale for transition region    rn_efold      = ',rn_efold 
     1131         WRITE(numout,*) '        Surface cell depth (Zs) (m)                  rn_zs         = ',rn_zs 
     1132         WRITE(numout,*) '        Bathymetry multiplier for Zb                 rn_zb_a       = ',rn_zb_a 
     1133         WRITE(numout,*) '        Offset for Zb                                rn_zb_b       = ',rn_zb_b 
     1134         WRITE(numout,*) '        Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' 
     1135      ENDIF 
    11611136 
    11621137      hift(:,:) = rn_sbot_min                     ! set the minimum depth for the s-coordinate 
    … …  
    13521327      ! non-dimensional "sigma" for model level depth at w- and t-levels 
    13531328 
    1354       IF( ln_s_sigma ) THEN        ! Song and Haidvogel style stretched sigma for depths 
    1355          !                         ! below rn_hc, with uniform sigma in shallower waters 
    1356          DO ji = 1, jpi 
    1357             DO jj = 1, jpj 
    1358  
    1359                IF( hbatt(ji,jj) > rn_hc ) THEN    !deep water, stretched sigma 
    1360                   DO jk = 1, jpk 
    1361                      gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) 
    1362                      gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp)       , rn_bb ) 
    1363                   END DO 
    1364                ELSE ! shallow water, uniform sigma 
    1365                   DO jk = 1, jpk 
    1366                      gsigw3(ji,jj,jk) =   REAL(jk-1,wp)            / REAL(jpk-1,wp) 
    1367                      gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 
    1368                   END DO 
    1369                ENDIF 
    1370                IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'gsigw3 1 jpk    ', gsigw3(ji,jj,1), gsigw3(ji,jj,jpk) 
    1371                ! 
    1372                DO jk = 1, jpkm1 
    1373                   esigt3(ji,jj,jk  ) = gsigw3(ji,jj,jk+1) - gsigw3(ji,jj,jk) 
    1374                   esigw3(ji,jj,jk+1) = gsigt3(ji,jj,jk+1) - gsigt3(ji,jj,jk) 
    1375                END DO 
    1376                esigw3(ji,jj,1  ) = 2._wp * ( gsigt3(ji,jj,1  ) - gsigw3(ji,jj,1  ) ) 
    1377                esigt3(ji,jj,jpk) = 2._wp * ( gsigt3(ji,jj,jpk) - gsigw3(ji,jj,jpk) ) 
    1378                ! 
    1379                ! Coefficients for vertical depth as the sum of e3w scale factors 
    1380                gsi3w3(ji,jj,1) = 0.5_wp * esigw3(ji,jj,1) 
    1381                DO jk = 2, jpk 
    1382                   gsi3w3(ji,jj,jk) = gsi3w3(ji,jj,jk-1) + esigw3(ji,jj,jk) 
    1383                END DO 
    1384                ! 
    1385                DO jk = 1, jpk 
    1386                   zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    1387                   zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1388                   gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
    1389                   gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
    1390                   gdep3w(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
    1391                END DO 
    1392                ! 
    1393             END DO   ! for all jj's 
    1394          END DO    ! for all ji's 
    1395  
    1396          DO ji = 1, jpim1 
    1397             DO jj = 1, jpjm1 
    1398                DO jk = 1, jpk 
    1399                   esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk) )   & 
    1400                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
    1401                   esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji,jj+1)*esigt3(ji,jj+1,jk) )   & 
    1402                      &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    1403                   esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk)     & 
    1404                      &                + hbatt(ji,jj+1)*esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*esigt3(ji+1,jj+1,jk) )   & 
    1405                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
    1406                   esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji+1,jj)*esigw3(ji+1,jj,jk) )   & 
    1407                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
    1408                   esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji,jj+1)*esigw3(ji,jj+1,jk) )   & 
    1409                      &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    1410                   ! 
    1411                   e3t(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigt3 (ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1412                   e3u(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigtu3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1413                   e3v(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigtv3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1414                   e3f(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*esigtf3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1415                   ! 
    1416                   e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigw3 (ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1417                   e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigwu3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1418                   e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigwv3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1419                END DO 
    1420             END DO 
    1421          END DO 
    1422  
    1423          CALL lbc_lnk( e3t , 'T', 1._wp ) 
    1424          CALL lbc_lnk( e3u , 'U', 1._wp ) 
    1425          CALL lbc_lnk( e3v , 'V', 1._wp ) 
    1426          CALL lbc_lnk( e3f , 'F', 1._wp ) 
    1427          CALL lbc_lnk( e3w , 'W', 1._wp ) 
    1428          CALL lbc_lnk( e3uw, 'U', 1._wp ) 
    1429          CALL lbc_lnk( e3vw, 'V', 1._wp ) 
    1430  
    1431          ! 
    1432       ELSE   ! not ln_s_sigma 
    1433          ! 
    1434          DO jk = 1, jpk 
    1435            gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) 
    1436            gsigt(jk) = -fssig( REAL(jk,wp)        ) 
    1437          END DO 
    1438          IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'gsigw 1 jpk    ', gsigw(1), gsigw(jpk) 
    1439          ! 
    1440          ! Coefficients for vertical scale factors at w-, t- levels 
    1441 !!gm bug :  define it from analytical function, not like juste bellow.... 
    1442 !!gm        or betteroffer the 2 possibilities.... 
    1443          DO jk = 1, jpkm1 
    1444             esigt(jk  ) = gsigw(jk+1) - gsigw(jk) 
    1445             esigw(jk+1) = gsigt(jk+1) - gsigt(jk) 
    1446          END DO 
    1447          esigw( 1 ) = 2._wp * ( gsigt(1  ) - gsigw(1  ) )  
    1448          esigt(jpk) = 2._wp * ( gsigt(jpk) - gsigw(jpk) ) 
    1449  
    1450 !!gm  original form 
    1451 !!org DO jk = 1, jpk 
    1452 !!org    esigt(jk)=fsdsig( FLOAT(jk)     ) 
    1453 !!org    esigw(jk)=fsdsig( FLOAT(jk)-0.5 ) 
    1454 !!org END DO 
    1455 !!gm 
    1456          ! 
    1457          ! Coefficients for vertical depth as the sum of e3w scale factors 
    1458          gsi3w(1) = 0.5_wp * esigw(1) 
    1459          DO jk = 2, jpk 
    1460             gsi3w(jk) = gsi3w(jk-1) + esigw(jk) 
    1461          END DO 
    1462 !!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) 
    1463          DO jk = 1, jpk 
    1464             zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    1465             zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1466             gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigt(jk) + hift(:,:)*zcoeft ) 
    1467             gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigw(jk) + hift(:,:)*zcoefw ) 
    1468             gdep3w(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsi3w(jk) + hift(:,:)*zcoeft ) 
    1469          END DO 
    1470 !!gm: e3uw, e3vw can be suppressed  (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 
    1471          DO jj = 1, jpj 
    1472             DO ji = 1, jpi 
    1473                DO jk = 1, jpk 
    1474                  e3t(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1475                  e3u(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1476                  e3v(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    1477                  e3f(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
    1478                  ! 
    1479                  e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1480                  e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1481                  e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    1482                END DO 
    1483             END DO 
    1484          END DO 
    1485          ! 
    1486       ENDIF ! ln_s_sigma 
    1487  
    1488  
     1329 
     1330!======================================================================== 
     1331! Song and Haidvogel  1994 (ln_s_sh94=T) 
     1332! Siddorn and Furner 2012 (ln_sf12=T) 
     1333! or  tanh function       (both false)                     
     1334!======================================================================== 
     1335      IF      ( ln_s_sh94 ) THEN  
     1336                           CALL s_sh94() 
     1337      ELSE IF ( ln_s_sf12 ) THEN 
     1338                           CALL s_sf12() 
     1339      ELSE                  
     1340                           CALL s_tanh() 
     1341      ENDIF  
     1342 
     1343      CALL lbc_lnk( e3t , 'T', 1._wp ) 
     1344      CALL lbc_lnk( e3u , 'U', 1._wp ) 
     1345      CALL lbc_lnk( e3v , 'V', 1._wp ) 
     1346      CALL lbc_lnk( e3f , 'F', 1._wp ) 
     1347      CALL lbc_lnk( e3w , 'W', 1._wp ) 
     1348      CALL lbc_lnk( e3uw, 'U', 1._wp ) 
     1349      CALL lbc_lnk( e3vw, 'V', 1._wp ) 
     1350 
     1351      fsdepw(:,:,:) = gdepw (:,:,:) 
     1352      fsde3w(:,:,:) = gdep3w(:,:,:) 
    14891353      ! 
    14901354      where (e3t   (:,:,:).eq.0.0)  e3t(:,:,:) = 1.0 
    … …  
    15201384         &                                                       ' MAX ', MAXVAL( mbathy(:,:) ) 
    15211385 
    1522       !                                               ! ============= 
    1523       IF(lwp) THEN                                    ! Control print 
    1524          !                                            ! ============= 
    1525          WRITE(numout,*)  
    1526          WRITE(numout,*) ' domzgr: vertical coefficients for model level' 
    1527          WRITE(numout, "(9x,'  level    gsigt      gsigw      esigt      esigw      gsi3w')" ) 
    1528          WRITE(numout, "(10x,i4,5f11.4)" ) ( jk, gsigt(jk), gsigw(jk), esigt(jk), esigw(jk), gsi3w(jk), jk=1,jpk ) 
    1529       ENDIF 
    15301386      IF( nprint == 1  .AND. lwp )   THEN         ! min max values over the local domain 
    15311387         WRITE(numout,*) ' MIN val mbathy  ', MINVAL( mbathy(:,:)   ), ' MAX ', MAXVAL( mbathy(:,:) ) 
    … …  
    15441400            &                          ' w ', MAXVAL( fse3w (:,:,:) ) 
    15451401      ENDIF 
    1546       ! 
     1402      !  END DO 
    15471403      IF(lwp) THEN                                  ! selected vertical profiles 
    15481404         WRITE(numout,*) 
    … …  
    15741430      ENDIF 
    15751431 
    1576 !!gm bug?  no more necessary?  if ! defined key_helsinki 
     1432!================================================================================ 
     1433! check the coordinate makes sense 
     1434!================================================================================ 
     1435      DO ji = 1, jpi 
     1436         DO jj = 1, jpj 
     1437 
     1438            IF( hbatt(ji,jj) > 0._wp) THEN 
     1439               DO jk = 1, mbathy(ji,jj) 
     1440                 ! check coordinate is monotonically increasing 
     1441                 IF (fse3w(ji,jj,jk) <= 0._wp .OR. fse3t(ji,jj,jk) <= 0._wp ) THEN 
     1442                    WRITE(ctmp1,*) 'ERROR zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1443                    WRITE(numout,*) 'ERROR zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1444                    WRITE(numout,*) 'e3w',fse3w(ji,jj,:) 
     1445                    WRITE(numout,*) 'e3t',fse3t(ji,jj,:) 
     1446                    CALL ctl_stop( ctmp1 ) 
     1447                 ENDIF 
     1448                 ! and check it has never gone negative 
     1449                 IF( fsdepw(ji,jj,jk) < 0._wp .OR. fsdept(ji,jj,jk) < 0._wp ) THEN 
     1450                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdepw or gdept =< 0  at point (i,j,k)= ', ji, jj, jk 
     1451                    WRITE(numout,*) 'ERROR zgr_sco :   gdepw   or gdept   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1452                    WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) 
     1453                    WRITE(numout,*) 'gdept',fsdept(ji,jj,:) 
     1454                    CALL ctl_stop( ctmp1 ) 
     1455                 ENDIF 
     1456                 ! and check it never exceeds the total depth 
     1457                 IF( fsdepw(ji,jj,jk) > hbatt(ji,jj) ) THEN 
     1458                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdepw > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1459                    WRITE(numout,*) 'ERROR zgr_sco :   gdepw > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1460                    WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) 
     1461                    CALL ctl_stop( ctmp1 ) 
     1462                 ENDIF 
     1463               END DO 
     1464 
     1465               DO jk = 1, mbathy(ji,jj)-1 
     1466                 ! and check it never exceeds the total depth 
     1467                IF( fsdept(ji,jj,jk) > hbatt(ji,jj) ) THEN 
     1468                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdept > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1469                    WRITE(numout,*) 'ERROR zgr_sco :   gdept > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1470                    WRITE(numout,*) 'gdept',fsdept(ji,jj,:) 
     1471                    CALL ctl_stop( ctmp1 ) 
     1472                 ENDIF 
     1473               END DO 
     1474 
     1475            ENDIF 
     1476 
     1477         END DO 
     1478      END DO 
     1479      ! 
     1480      CALL wrk_dealloc( jpi, jpj,      zenv, ztmp, zmsk, zri, zrj, zhbat                           ) 
     1481      ! 
     1482      IF( nn_timing == 1 )  CALL timing_stop('zgr_sco') 
     1483      ! 
     1484   END SUBROUTINE zgr_sco 
     1485 
     1486!!====================================================================== 
     1487   SUBROUTINE s_sh94() 
     1488 
     1489      !!---------------------------------------------------------------------- 
     1490      !!                  ***  ROUTINE s_sh94  *** 
     1491      !!                      
     1492      !! ** Purpose :   stretch the s-coordinate system 
     1493      !! 
     1494      !! ** Method  :   s-coordinate stretch using the Song and Haidvogel 1994 
     1495      !!                mixed S/sigma coordinate 
     1496      !! 
     1497      !! Reference : Song and Haidvogel 1994.  
     1498      !!---------------------------------------------------------------------- 
     1499      ! 
     1500      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1501      REAL(wp) ::   zcoeft, zcoefw   ! temporary scalars 
     1502      ! 
     1503      REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 
     1504      REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3            
     1505 
     1506      CALL wrk_alloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3                                      ) 
     1507      CALL wrk_alloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 
     1508 
     1509      z_gsigw3  = 0._wp   ;   z_gsigt3  = 0._wp   ;   z_gsi3w3  = 0._wp 
     1510      z_esigt3  = 0._wp   ;   z_esigw3  = 0._wp  
     1511      z_esigtu3 = 0._wp   ;   z_esigtv3 = 0._wp   ;   z_esigtf3 = 0._wp 
     1512      z_esigwu3 = 0._wp   ;   z_esigwv3 = 0._wp 
     1513 
     1514      DO ji = 1, jpi 
     1515         DO jj = 1, jpj 
     1516 
     1517            IF( hbatt(ji,jj) > rn_hc ) THEN    !deep water, stretched sigma 
     1518               DO jk = 1, jpk 
     1519                  z_gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) 
     1520                  z_gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp)       , rn_bb ) 
     1521               END DO 
     1522            ELSE ! shallow water, uniform sigma 
     1523               DO jk = 1, jpk 
     1524                  z_gsigw3(ji,jj,jk) =   REAL(jk-1,wp)            / REAL(jpk-1,wp) 
     1525                  z_gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 
     1526                  END DO 
     1527            ENDIF 
     1528            ! 
     1529            DO jk = 1, jpkm1 
     1530               z_esigt3(ji,jj,jk  ) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) 
     1531               z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) 
     1532            END DO 
     1533            z_esigw3(ji,jj,1  ) = 2._wp * ( z_gsigt3(ji,jj,1  ) - z_gsigw3(ji,jj,1  ) ) 
     1534            z_esigt3(ji,jj,jpk) = 2._wp * ( z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk) ) 
     1535            ! 
     1536            ! Coefficients for vertical depth as the sum of e3w scale factors 
     1537            z_gsi3w3(ji,jj,1) = 0.5_wp * z_esigw3(ji,jj,1) 
     1538            DO jk = 2, jpk 
     1539               z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) 
     1540            END DO 
     1541            ! 
     1542            DO jk = 1, jpk 
     1543               zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
     1544               zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
     1545               gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
     1546               gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
     1547               gdep3w(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
     1548            END DO 
     1549           ! 
     1550         END DO   ! for all jj's 
     1551      END DO    ! for all ji's 
     1552 
     1553      DO ji = 1, jpim1 
     1554         DO jj = 1, jpjm1 
     1555            DO jk = 1, jpk 
     1556               z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) )   & 
     1557                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1558               z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) )   & 
     1559                  &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1560               z_esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk)     & 
     1561                  &                + hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) )   & 
     1562                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
     1563               z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) )   & 
     1564                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1565               z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) )   & 
     1566                  &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1567               ! 
     1568               e3t(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1569               e3u(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1570               e3v(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1571               e3f(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1572               ! 
     1573               e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1574               e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1575               e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1576            END DO 
     1577        END DO 
     1578      END DO 
     1579 
     1580      CALL wrk_dealloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3                                      ) 
     1581      CALL wrk_dealloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 
     1582 
     1583   END SUBROUTINE s_sh94 
     1584 
     1585   SUBROUTINE s_sf12 
     1586 
     1587      !!---------------------------------------------------------------------- 
     1588      !!                  ***  ROUTINE s_sf12 ***  
     1589      !!                      
     1590      !! ** Purpose :   stretch the s-coordinate system 
     1591      !! 
     1592      !! ** Method  :   s-coordinate stretch using the Siddorn and Furner 2012? 
     1593      !!                mixed S/sigma/Z coordinate 
     1594      !! 
     1595      !!                This method allows the maintenance of fixed surface and or 
     1596      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1597      !!                within an analytically derived stretched S-coordinate framework. 
     1598      !! 
     1599      !! 
     1600      !! Reference : Siddorn and Furner 2012 (submitted Ocean modelling). 
     1601      !!---------------------------------------------------------------------- 
     1602      ! 
     1603      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1604      REAL(wp) ::   zsmth               ! smoothing around critical depth 
     1605      REAL(wp) ::   zzs, zzb           ! Surface and bottom cell thickness in sigma space 
     1606      ! 
     1607      REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 
     1608      REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3            
     1609 
     1610      ! 
     1611      CALL wrk_alloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3                                      ) 
     1612      CALL wrk_alloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 
     1613 
     1614      z_gsigw3  = 0._wp   ;   z_gsigt3  = 0._wp   ;   z_gsi3w3  = 0._wp 
     1615      z_esigt3  = 0._wp   ;   z_esigw3  = 0._wp  
     1616      z_esigtu3 = 0._wp   ;   z_esigtv3 = 0._wp   ;   z_esigtf3 = 0._wp 
     1617      z_esigwu3 = 0._wp   ;   z_esigwv3 = 0._wp 
     1618 
     1619      DO ji = 1, jpi 
     1620         DO jj = 1, jpj 
     1621 
     1622          IF (hbatt(ji,jj)>rn_hc) THEN !deep water, stretched sigma 
     1623               
     1624              zzb = hbatt(ji,jj)*rn_zb_a + rn_zb_b   ! this forces a linear bottom cell depth relationship with H,. 
     1625                                                     ! could be changed by users but care must be taken to do so carefully 
     1626              zzb = 1.0_wp-(zzb/hbatt(ji,jj)) 
     1627             
     1628              zzs = rn_zs / hbatt(ji,jj)  
     1629               
     1630              IF (rn_efold /= 0.0_wp) THEN 
     1631                zsmth   = tanh( (hbatt(ji,jj)- rn_hc ) / rn_efold ) 
     1632              ELSE 
     1633                zsmth = 1.0_wp  
     1634              ENDIF 
     1635                
     1636              DO jk = 1, jpk 
     1637                z_gsigw3(ji,jj,jk) =  REAL(jk-1,wp)        /REAL(jpk-1,wp) 
     1638                z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp) 
     1639              ENDDO 
     1640              z_gsigw3(ji,jj,:) = fgamma( z_gsigw3(ji,jj,:), zzb, zzs, zsmth  ) 
     1641              z_gsigt3(ji,jj,:) = fgamma( z_gsigt3(ji,jj,:), zzb, zzs, zsmth  ) 
     1642  
     1643          ELSE IF (ln_sigcrit) THEN ! shallow water, uniform sigma 
     1644 
     1645            DO jk = 1, jpk 
     1646              z_gsigw3(ji,jj,jk) =  REAL(jk-1,wp)     /REAL(jpk-1,wp) 
     1647              z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) 
     1648            END DO 
     1649 
     1650          ELSE  ! shallow water, z coordinates 
     1651 
     1652            DO jk = 1, jpk 
     1653              z_gsigw3(ji,jj,jk) =  REAL(jk-1,wp)        /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 
     1654              z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 
     1655            END DO 
     1656 
     1657          ENDIF 
     1658 
     1659          DO jk = 1, jpkm1 
     1660             z_esigt3(ji,jj,jk) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) 
     1661             z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) 
     1662          END DO 
     1663          z_esigw3(ji,jj,1  ) = 2.0_wp * (z_gsigt3(ji,jj,1  ) - z_gsigw3(ji,jj,1  )) 
     1664          z_esigt3(ji,jj,jpk) = 2.0_wp * (z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk)) 
     1665 
     1666          ! Coefficients for vertical depth as the sum of e3w scale factors 
     1667          z_gsi3w3(ji,jj,1) = 0.5 * z_esigw3(ji,jj,1) 
     1668          DO jk = 2, jpk 
     1669             z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) 
     1670          END DO 
     1671 
     1672          DO jk = 1, jpk 
     1673             gdept (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) 
     1674             gdepw (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) 
     1675             gdep3w(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) 
     1676          END DO 
     1677 
     1678        ENDDO   ! for all jj's 
     1679      ENDDO    ! for all ji's 
     1680 
     1681      DO ji=1,jpi 
     1682        DO jj=1,jpj 
     1683 
     1684          DO jk = 1, jpk 
     1685                z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) / & 
     1686                                    ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1687                z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) / & 
     1688                                    ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1689                z_esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) +  & 
     1690                                      hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) / & 
     1691                                    ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
     1692                z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) / & 
     1693                                    ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1694                z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) / & 
     1695                                    ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1696 
     1697             e3t(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) 
     1698             e3u(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) 
     1699             e3v(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) 
     1700             e3f(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) 
     1701             ! 
     1702             e3w(ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) 
     1703             e3uw(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) 
     1704             e3vw(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) 
     1705          END DO 
     1706 
     1707        ENDDO 
     1708      ENDDO 
     1709      !                                               ! ============= 
     1710 
     1711      CALL wrk_dealloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3                                      ) 
     1712      CALL wrk_dealloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 
     1713 
     1714   END SUBROUTINE s_sf12 
     1715 
     1716   SUBROUTINE s_tanh() 
     1717 
     1718      !!---------------------------------------------------------------------- 
     1719      !!                  ***  ROUTINE s_tanh***  
     1720      !!                      
     1721      !! ** Purpose :   stretch the s-coordinate system 
     1722      !! 
     1723      !! ** Method  :   s-coordinate stretch  
     1724      !! 
     1725      !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. 
     1726      !!---------------------------------------------------------------------- 
     1727 
     1728      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1729      REAL(wp) ::   zcoeft, zcoefw   ! temporary scalars 
     1730 
     1731      REAL(wp), POINTER, DIMENSION(:) :: z_gsigw, z_gsigt, z_gsi3w 
     1732      REAL(wp), POINTER, DIMENSION(:) :: z_esigt, z_esigw 
     1733 
     1734      CALL wrk_alloc( jpk, z_gsigw, z_gsigt, z_gsi3w                                      ) 
     1735      CALL wrk_alloc( jpk, z_esigt, z_esigw                                               ) 
     1736 
     1737      z_gsigw  = 0._wp   ;   z_gsigt  = 0._wp   ;   z_gsi3w  = 0._wp 
     1738      z_esigt  = 0._wp   ;   z_esigw  = 0._wp  
     1739 
    15771740      DO jk = 1, jpk 
    1578          DO jj = 1, jpj 
    1579             DO ji = 1, jpi 
    1580                IF( fse3w(ji,jj,jk) <= 0._wp .OR. fse3t(ji,jj,jk) <= 0._wp ) THEN 
    1581                   WRITE(ctmp1,*) 'zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
    1582                   CALL ctl_stop( ctmp1 ) 
    1583                ENDIF 
    1584                IF( fsdepw(ji,jj,jk) < 0._wp .OR. fsdept(ji,jj,jk) < 0._wp ) THEN 
    1585                   WRITE(ctmp1,*) 'zgr_sco :   gdepw or gdept =< 0  at point (i,j,k)= ', ji, jj, jk 
    1586                   CALL ctl_stop( ctmp1 ) 
    1587                ENDIF 
    1588             END DO 
    1589          END DO 
    1590       END DO 
    1591 !!gm bug    #endif 
    1592       ! 
    1593       CALL wrk_dealloc( jpi, jpj,      zenv, ztmp, zmsk, zri, zrj, zhbat                           ) 
    1594       CALL wrk_dealloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
    1595       CALL wrk_dealloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
    1596       ! 
    1597       IF( nn_timing == 1 )  CALL timing_stop('zgr_sco') 
    1598       ! 
    1599    END SUBROUTINE zgr_sco 
     1741        z_gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) 
     1742        z_gsigt(jk) = -fssig( REAL(jk,wp)        ) 
     1743      END DO 
     1744      IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'z_gsigw 1 jpk    ', z_gsigw(1), z_gsigw(jpk) 
     1745      ! 
     1746      ! Coefficients for vertical scale factors at w-, t- levels 
     1747!!gm bug :  define it from analytical function, not like juste bellow.... 
     1748!!gm        or betteroffer the 2 possibilities.... 
     1749      DO jk = 1, jpkm1 
     1750         z_esigt(jk  ) = z_gsigw(jk+1) - z_gsigw(jk) 
     1751         z_esigw(jk+1) = z_gsigt(jk+1) - z_gsigt(jk) 
     1752      END DO 
     1753      z_esigw( 1 ) = 2._wp * ( z_gsigt(1  ) - z_gsigw(1  ) )  
     1754      z_esigt(jpk) = 2._wp * ( z_gsigt(jpk) - z_gsigw(jpk) ) 
     1755      ! 
     1756      ! Coefficients for vertical depth as the sum of e3w scale factors 
     1757      z_gsi3w(1) = 0.5_wp * z_esigw(1) 
     1758      DO jk = 2, jpk 
     1759         z_gsi3w(jk) = z_gsi3w(jk-1) + z_esigw(jk) 
     1760      END DO 
     1761!!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) 
     1762      DO jk = 1, jpk 
     1763         zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
     1764         zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
     1765         gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) 
     1766         gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) 
     1767         gdep3w(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) 
     1768      END DO 
     1769!!gm: e3uw, e3vw can be suppressed  (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 
     1770      DO jj = 1, jpj 
     1771         DO ji = 1, jpi 
     1772            DO jk = 1, jpk 
     1773              e3t(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1774              e3u(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1775              e3v(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1776              e3f(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
     1777              ! 
     1778              e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1779              e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1780              e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1781            END DO 
     1782         END DO 
     1783      END DO 
     1784 
     1785      CALL wrk_dealloc( jpk, z_gsigw, z_gsigt, z_gsi3w                                      ) 
     1786      CALL wrk_dealloc( jpk, z_esigt, z_esigw                                               ) 
     1787 
     1788   END SUBROUTINE s_tanh 
     1789 
     1790   FUNCTION fssig( pk ) RESULT( pf ) 
     1791      !!---------------------------------------------------------------------- 
     1792      !!                 ***  ROUTINE fssig *** 
     1793      !!        
     1794      !! ** Purpose :   provide the analytical function in s-coordinate 
     1795      !!           
     1796      !! ** Method  :   the function provide the non-dimensional position of 
     1797      !!                T and W (i.e. between 0 and 1) 
     1798      !!                T-points at integer values (between 1 and jpk) 
     1799      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1800      !!---------------------------------------------------------------------- 
     1801      REAL(wp), INTENT(in) ::   pk   ! continuous "k" coordinate 
     1802      REAL(wp)             ::   pf   ! sigma value 
     1803      !!---------------------------------------------------------------------- 
     1804      ! 
     1805      pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb )  )   & 
     1806         &     - TANH( rn_thetb * rn_theta                                )  )   & 
     1807         & * (   COSH( rn_theta                           )                      & 
     1808         &     + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) )  )              & 
     1809         & / ( 2._wp * SINH( rn_theta ) ) 
     1810      ! 
     1811   END FUNCTION fssig 
     1812 
     1813 
     1814   FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) 
     1815      !!---------------------------------------------------------------------- 
     1816      !!                 ***  ROUTINE fssig1 *** 
     1817      !! 
     1818      !! ** Purpose :   provide the Song and Haidvogel version of the analytical function in s-coordinate 
     1819      !! 
     1820      !! ** Method  :   the function provides the non-dimensional position of 
     1821      !!                T and W (i.e. between 0 and 1) 
     1822      !!                T-points at integer values (between 1 and jpk) 
     1823      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1824      !!---------------------------------------------------------------------- 
     1825      REAL(wp), INTENT(in) ::   pk1   ! continuous "k" coordinate 
     1826      REAL(wp), INTENT(in) ::   pbb   ! Stretching coefficient 
     1827      REAL(wp)             ::   pf1   ! sigma value 
     1828      !!---------------------------------------------------------------------- 
     1829      ! 
     1830      IF ( rn_theta == 0 ) then      ! uniform sigma 
     1831         pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 
     1832      ELSE                        ! stretched sigma 
     1833         pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta )              & 
     1834            &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
     1835            &        / ( 2._wp * TANH( 0.5_wp * rn_theta ) )  ) 
     1836      ENDIF 
     1837      ! 
     1838   END FUNCTION fssig1 
     1839 
     1840 
     1841   FUNCTION fgamma( pk1, pzb, pzs, psmth) RESULT( p_gamma ) 
     1842      !!---------------------------------------------------------------------- 
     1843      !!                 ***  ROUTINE fgamma  *** 
     1844      !! 
     1845      !! ** Purpose :   provide analytical function for the s-coordinate 
     1846      !! 
     1847      !! ** Method  :   the function provides the non-dimensional position of 
     1848      !!                T and W (i.e. between 0 and 1) 
     1849      !!                T-points at integer values (between 1 and jpk) 
     1850      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1851      !! 
     1852      !!                This method allows the maintenance of fixed surface and or 
     1853      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1854      !!                within an analytically derived stretched S-coordinate framework. 
     1855      !! 
     1856      !! Reference  :   Siddorn and Furner, in prep 
     1857      !!---------------------------------------------------------------------- 
     1858      REAL(wp), INTENT(in   ) ::   pk1(jpk)       ! continuous "k" coordinate 
     1859      REAL(wp)                ::   p_gamma(jpk)   ! stretched coordinate 
     1860      REAL(wp), INTENT(in   ) ::   pzb           ! Bottom box depth 
     1861      REAL(wp), INTENT(in   ) ::   pzs           ! surface box depth 
     1862      REAL(wp), INTENT(in   ) ::   psmth       ! Smoothing parameter 
     1863      REAL(wp)                ::   za1,za2,za3    ! local variables 
     1864      REAL(wp)                ::   zn1,zn2        ! local variables 
     1865      REAL(wp)                ::   za,zb,zx       ! local variables 
     1866      integer                 ::   jk 
     1867      !!---------------------------------------------------------------------- 
     1868      ! 
     1869 
     1870      zn1  =  1./(jpk-1.) 
     1871      zn2  =  1. -  zn1 
     1872 
     1873      za1 = (rn_alpha+2.0_wp)*zn1**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn1**(rn_alpha+2.0_wp)  
     1874      za2 = (rn_alpha+2.0_wp)*zn2**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn2**(rn_alpha+2.0_wp) 
     1875      za3 = (zn2**3.0_wp - za2)/( zn1**3.0_wp - za1) 
     1876      
     1877      za = pzb - za3*(pzs-za1)-za2 
     1878      za = za/( zn2-0.5_wp*(za2+zn2**2.0_wp) - za3*(zn1-0.5_wp*(za1+zn1**2.0_wp) ) ) 
     1879      zb = (pzs - za1 - za*( zn1-0.5_wp*(za1+zn1**2.0_wp ) ) ) / (zn1**3.0_wp - za1) 
     1880      zx = 1.0_wp-za/2.0_wp-zb 
     1881  
     1882      DO jk = 1, jpk 
     1883        p_gamma(jk) = za*(pk1(jk)*(1.0_wp-pk1(jk)/2.0_wp))+zb*pk1(jk)**3.0_wp + zx*( (rn_alpha+2.0_wp)*pk1(jk)**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*pk1(jk)**(rn_alpha+2.0_wp) ) 
     1884        p_gamma(jk) = p_gamma(jk)*psmth+pk1(jk)*(1.0_wp-psmth) 
     1885      ENDDO  
     1886 
     1887      ! 
     1888   END FUNCTION fgamma 
    16001889 
    16011890   !!====================================================================== 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r3294 r3680  
    3232   USE phycst          ! physical constants 
    3333   USE dtatsd          ! data temperature and salinity   (dta_tsd routine) 
    34    USE restart         ! ocean restart                   (rst_read routine) 
    3534   USE in_out_manager  ! I/O manager 
    3635   USE iom             ! I/O library 
    … …  
    4342   USE dynspg_ts       ! pressure gradient schemes 
    4443   USE lib_mpp         ! MPP library 
     44   USE restart         ! restart 
    4545   USE wrk_nemo        ! Memory allocation 
    4646   USE timing          ! Timing 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90

    r3294 r3680  
    2727   USE prtctl          ! Print control 
    2828   USE iom             ! I/O library 
    29    USE restart         ! only for lrst_oce 
    3029   USE timing          ! Timing 
    3130 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r3609 r3680  
    4545   USE prtctl          ! Print control 
    4646   USE iom 
    47    USE restart         ! only for lrst_oce 
    4847   USE lib_fortran 
    4948#if defined key_agrif 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r3651 r3680  
    4141   USE in_out_manager  ! I/O manager 
    4242   USE iom             ! IOM library 
    43    USE restart         ! only for lrst_oce 
    4443   USE zdf_oce         ! Vertical diffusion 
    4544   USE wrk_nemo        ! Memory Allocation 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r3294 r3680  
    2020   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    2121   USE iom             ! I/O library 
    22    USE restart         ! only for lrst_oce 
    2322   USE in_out_manager  ! I/O manager 
    2423   USE prtctl          ! Print control 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r3294 r3680  
    8080   !! was in restart but moved here because of the OFF line... better solution should be found... 
    8181   !!---------------------------------------------------------------------- 
    82    INTEGER ::   nitrst   !: time step at which restart file should be written 
     82   INTEGER ::   nitrst                !: time step at which restart file should be written 
     83   LOGICAL ::   lrst_oce              !: logical to control the oce restart write  
     84   INTEGER ::   numror, numrow        !: logical unit for cean restart (read and write) 
    8385 
    8486   !!---------------------------------------------------------------------- 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM/iom_def.F90

    r2528 r3680  
    4343   INTEGER, PARAMETER, PUBLIC ::   jp_i1    = 204      !: write INTEGER(1) 
    4444 
    45    INTEGER, PARAMETER, PUBLIC ::   jpmax_files  = 50   !: maximum number of simultaneously opened file 
     45   INTEGER, PARAMETER, PUBLIC ::   jpmax_files  = 100   !: maximum number of simultaneously opened file 
    4646   INTEGER, PARAMETER, PUBLIC ::   jpmax_vars   = 360  !: maximum number of variables in one file 
    4747   INTEGER, PARAMETER, PUBLIC ::   jpmax_dims   =  4   !: maximum number of dimensions for one variable 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90

    r3625 r3680  
    3333   PUBLIC prt_ctl_info    ! called by all subroutines 
    3434   PUBLIC prt_ctl_init    ! called by opa.F90 
     35   PUBLIC sub_dom         ! called by opa.F90 
    3536 
    3637   !!---------------------------------------------------------------------- 
    … …  
    422423         nrecil, nrecjl, nldil, nleil, nldjl, nlejl 
    423424 
    424       INTEGER, DIMENSION(:,:), ALLOCATABLE ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! workspace 
     425      INTEGER, POINTER, DIMENSION(:,:) ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! workspace 
    425426      REAL(wp) ::   zidom, zjdom            ! temporary scalars 
    426427      !!---------------------------------------------------------------------- 
    427428 
     429      ! 
     430      CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) 
     431      ! 
    428432      !  1. Dimension arrays for subdomains 
    429433      ! ----------------------------------- 
    … …  
    442446#endif 
    443447 
    444       ALLOCATE(ilcitl (isplt,jsplt)) 
    445       ALLOCATE(ilcjtl (isplt,jsplt)) 
    446448 
    447449      nrecil  = 2 * jpreci 
    … …  
    516518      ! ------------------------------- 
    517519 
    518       ALLOCATE(iimpptl(isplt,jsplt)) 
    519       ALLOCATE(ijmpptl(isplt,jsplt)) 
    520        
    521520      iimpptl(:,:) = 1 
    522521      ijmpptl(:,:) = 1 
    … …  
    576575      END DO 
    577576      ! 
    578       DEALLOCATE( iimpptl, ijmpptl, ilcitl, ilcjtl ) 
     577      ! 
     578      CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) 
     579      ! 
    579580      ! 
    580581   END SUBROUTINE sub_dom 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r3294 r3680  
    2424   USE trdmld_oce      ! ocean active mixed layer tracers trends variables 
    2525   USE domvvl          ! variable volume 
     26   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    2627 
    2728   IMPLICIT NONE 
    … …  
    3132   PUBLIC   rst_write  ! routine called by step module 
    3233   PUBLIC   rst_read   ! routine called by opa  module 
    33  
    34    LOGICAL, PUBLIC ::   lrst_oce =  .FALSE.   !: logical to control the oce restart write  
    35    INTEGER, PUBLIC ::   numror, numrow        !: logical unit for cean restart (read and write) 
    3634 
    3735   !! * Substitutions 
    … …  
    183181      ENDIF 
    184182      !  
    185                      CALL iom_get( numror, jpdom_autoglo, 'ub'     , ub      )   ! before fields 
    186                      CALL iom_get( numror, jpdom_autoglo, 'vb'     , vb      ) 
    187                      CALL iom_get( numror, jpdom_autoglo, 'tb'     , tsb(:,:,:,jp_tem) ) 
    188                      CALL iom_get( numror, jpdom_autoglo, 'sb'     , tsb(:,:,:,jp_sal) ) 
    189                      CALL iom_get( numror, jpdom_autoglo, 'rotb'   , rotb    ) 
    190                      CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    191                      CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
    192       IF( lk_vvl )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    193                      ! 
    194                      CALL iom_get( numror, jpdom_autoglo, 'un'     , un      )   ! now    fields 
    195                      CALL iom_get( numror, jpdom_autoglo, 'vn'     , vn      ) 
    196                      CALL iom_get( numror, jpdom_autoglo, 'tn'     , tsn(:,:,:,jp_tem) ) 
    197                      CALL iom_get( numror, jpdom_autoglo, 'sn'     , tsn(:,:,:,jp_sal) ) 
    198                      CALL iom_get( numror, jpdom_autoglo, 'rotn'   , rotn    ) 
    199                      CALL iom_get( numror, jpdom_autoglo, 'hdivn'  , hdivn   ) 
    200                      CALL iom_get( numror, jpdom_autoglo, 'sshn'   , sshn    ) 
    201                      CALL iom_get( numror, jpdom_autoglo, 'rhop'   , rhop    )   ! now    potential density 
     183      IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 
     184         CALL iom_get( numror, jpdom_autoglo, 'ub'     , ub      )   ! before fields 
     185         CALL iom_get( numror, jpdom_autoglo, 'vb'     , vb      ) 
     186         CALL iom_get( numror, jpdom_autoglo, 'tb'     , tsb(:,:,:,jp_tem) ) 
     187         CALL iom_get( numror, jpdom_autoglo, 'sb'     , tsb(:,:,:,jp_sal) ) 
     188         CALL iom_get( numror, jpdom_autoglo, 'rotb'   , rotb    ) 
     189         CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
     190         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
     191         IF( lk_vvl )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
     192      ELSE 
     193         neuler = 0 
     194      ENDIF 
     195      ! 
     196      CALL iom_get( numror, jpdom_autoglo, 'un'     , un      )   ! now    fields 
     197      CALL iom_get( numror, jpdom_autoglo, 'vn'     , vn      ) 
     198      CALL iom_get( numror, jpdom_autoglo, 'tn'     , tsn(:,:,:,jp_tem) ) 
     199      CALL iom_get( numror, jpdom_autoglo, 'sn'     , tsn(:,:,:,jp_sal) ) 
     200      CALL iom_get( numror, jpdom_autoglo, 'sshn'   , sshn    ) 
     201      IF( iom_varid( numror, 'rotn', ldstop = .FALSE. ) > 0 ) THEN 
     202         CALL iom_get( numror, jpdom_autoglo, 'rotn'   , rotn    ) 
     203         CALL iom_get( numror, jpdom_autoglo, 'hdivn'  , hdivn   ) 
     204      ELSE 
     205         CALL div_cur( 0 )                              ! Horizontal divergence & Relative vorticity 
     206      ENDIF 
     207      IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
     208         CALL iom_get( numror, jpdom_autoglo, 'rhop'   , rhop    )   ! now    potential density 
     209      ELSE 
     210         CALL eos    ( tsn, rhd, rhop )    
     211      ENDIF 
    202212#if defined key_zdfkpp 
    203213      IF( iom_varid( numror, 'rhd', ldstop = .FALSE. ) > 0 ) THEN 
    204                      CALL iom_get( numror, jpdom_autoglo, 'rhd'    , rhd     )   ! now    in situ density anomaly 
    205       ELSE 
    206                      CALL eos( tsn, rhd )   ! compute rhd 
     214         CALL iom_get( numror, jpdom_autoglo, 'rhd'    , rhd     )   ! now    in situ density anomaly 
     215      ELSE 
     216         CALL eos( tsn, rhd )   ! compute rhd 
    207217      ENDIF 
    208218#endif 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r3609 r3680  
    77   !!   NEMO     1.0  ! 2002-09  (G. Madec)     F90: Free form and module 
    88   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment   
     9   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) Add 'lbc_bdy_lnk'  
     10   !!                            and lbc_obc_lnk' routine to optimize   
     11   !!                            the BDY/OBC communications 
    912   !!---------------------------------------------------------------------- 
    1013#if   defined key_mpp_mpi 
    … …  
    1417   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    1518   !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
     19   !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
     20   !!   lbc_obc_lnk  : generic interface for mpp_lnk_obc_2d and mpp_lnk_obc_3d routines defined in lib_mpp 
    1621   !!---------------------------------------------------------------------- 
    1722   USE lib_mpp          ! distributed memory computing library 
    … …  
    2126   END INTERFACE 
    2227 
     28   INTERFACE lbc_bdy_lnk 
     29      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
     30   END INTERFACE 
     31   INTERFACE lbc_obc_lnk 
     32      MODULE PROCEDURE mpp_lnk_obc_2d, mpp_lnk_obc_3d 
     33   END INTERFACE 
     34 
    2335   INTERFACE lbc_lnk_e 
    2436      MODULE PROCEDURE mpp_lnk_2d_e 
    … …  
    2739   PUBLIC lbc_lnk       ! ocean lateral boundary conditions 
    2840   PUBLIC lbc_lnk_e 
     41   PUBLIC lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
     42   PUBLIC lbc_obc_lnk   ! ocean lateral BDY boundary conditions 
    2943 
    3044   !!---------------------------------------------------------------------- 
    … …  
    4155   !!   lbc_lnk_3d   : set the lateral boundary condition on a 3D variable on ocean mesh 
    4256   !!   lbc_lnk_2d   : set the lateral boundary condition on a 2D variable on ocean mesh 
     57   !!   lbc_bdy_lnk  : set the lateral BDY boundary condition 
     58   !!   lbc_obc_lnk  : set the lateral OBC boundary condition 
    4359   !!---------------------------------------------------------------------- 
    4460   USE oce             ! ocean dynamics and tracers    
    … …  
    5874   END INTERFACE 
    5975 
     76   INTERFACE lbc_bdy_lnk 
     77      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     78   END INTERFACE 
     79   INTERFACE lbc_obc_lnk 
     80      MODULE PROCEDURE lbc_lnk_2d, lbc_lnk_3d 
     81   END INTERFACE 
     82 
    6083   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    6184   PUBLIC   lbc_lnk_e  
     85   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
     86   PUBLIC   lbc_obc_lnk   ! ocean lateral OBC boundary conditions 
    6287    
    6388   !!---------------------------------------------------------------------- 
    … …  
    180205   END SUBROUTINE lbc_lnk_3d 
    181206 
     207   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
     208      !!--------------------------------------------------------------------- 
     209      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     210      !! 
     211      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     212      !!                to maintain the same interface with regards to the mpp case 
     213      !! 
     214      !!---------------------------------------------------------------------- 
     215      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     216      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     217      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     218      INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
     219      !! 
     220      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
     221 
     222   END SUBROUTINE lbc_bdy_lnk_3d 
     223 
     224   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
     225      !!--------------------------------------------------------------------- 
     226      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     227      !! 
     228      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     229      !!                to maintain the same interface with regards to the mpp case 
     230      !! 
     231      !!---------------------------------------------------------------------- 
     232      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     233      REAL(wp), DIMENSION(jpi,jpj),     INTENT(inout)           ::   pt2d      ! 3D array on which the lbc is applied 
     234      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     235      INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
     236      !! 
     237      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
     238 
     239   END SUBROUTINE lbc_bdy_lnk_2d 
    182240 
    183241   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r3632 r3680  
    1919   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl  
    2020   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager 
     21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',  
     22   !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 
     23   !!                          the mppobc routine to optimize the BDY and OBC communications 
    2124   !!---------------------------------------------------------------------- 
    2225 
    … …  
    6972   PUBLIC   mppsend, mpprecv                          ! needed by ICB routines 
    7073   PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90 
     74   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
     75   PUBLIC   mpp_lnk_obc_2d, mpp_lnk_obc_3d 
    7176 
    7277   !! * Interfaces 
    … …  
    348353   END FUNCTION mynode 
    349354 
    350  
    351    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    352       !!---------------------------------------------------------------------- 
    353       !!                  ***  routine mpp_lnk_3d  *** 
     355   SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 
     356      !!---------------------------------------------------------------------- 
     357      !!                  ***  routine mpp_lnk_obc_3d  *** 
    354358      !! 
    355359      !! ** Purpose :   Message passing manadgement 
    356360      !! 
    357       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     361      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    358362      !!      between processors following neighboring subdomains. 
    359363      !!            domain parameters 
    … …  
    375379      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    376380      !                                                             ! =  1. , the sign is kept 
    377       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    378       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    379381      !! 
    380382      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    … …  
    385387      !!---------------------------------------------------------------------- 
    386388 
    387       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    388       ELSE                         ;   zland = 0.e0      ! zero by default 
    389       ENDIF 
     389      zland = 0.e0      ! zero by default 
    390390 
    391391      ! 1. standard boundary treatment 
    392392      ! ------------------------------ 
    393       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    394          ! 
    395          ! WARNING ptab is defined only between nld and nle 
    396          DO jk = 1, jpk 
    397             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    398                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
    399                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    400                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    401             END DO 
    402             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    403                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    404                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    405                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    406             END DO 
    407          END DO 
    408          ! 
    409       ELSE                              ! standard close or cyclic treatment  
    410          ! 
    411          !                                   ! East-West boundaries 
    412          !                                        !* Cyclic east-west 
    413          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    414             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    415             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    416          ELSE                                     !* closed 
    417             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    418                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    419          ENDIF 
    420          !                                   ! North-South boundaries (always closed) 
    421          IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    422                                       ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    423          ! 
     393      IF( nbondi == 2) THEN 
     394        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     395          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     396          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     397        ELSE 
     398          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     399          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     400        ENDIF 
     401      ELSEIF(nbondi == -1) THEN 
     402        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     403      ELSEIF(nbondi == 1) THEN 
     404        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     405      ENDIF                                     !* closed 
     406 
     407      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     408        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     409      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     410        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    424411      ENDIF 
    425412 
    … …  
    428415      ! we play with the neigbours AND the row number because of the periodicity  
    429416      ! 
     417      IF(nbondj .ne. 0) THEN 
    430418      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    431419      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    … …  
    466454            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    467455         END DO 
    468       CASE ( 0 )  
     456      CASE ( 0 ) 
    469457         DO jl = 1, jpreci 
    470458            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
    … …  
    476464         END DO 
    477465      END SELECT 
     466      ENDIF 
    478467 
    479468 
    … …  
    482471      ! always closed : we play only with the neigbours 
    483472      ! 
     473      IF(nbondi .ne. 0) THEN 
    484474      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    485475         ijhom = nlcj-nrecj 
    … …  
    519509            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    520510         END DO 
    521       CASE ( 0 )  
     511      CASE ( 0 ) 
    522512         DO jl = 1, jprecj 
    523513            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
    … …  
    529519         END DO 
    530520      END SELECT 
     521      ENDIF 
    531522 
    532523 
    … …  
    534525      ! ----------------------- 
    535526      ! 
    536       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     527      IF( npolj /= 0 ) THEN 
    537528         ! 
    538529         SELECT CASE ( jpni ) 
    … …  
    543534      ENDIF 
    544535      ! 
    545    END SUBROUTINE mpp_lnk_3d 
    546  
    547  
    548    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    549       !!---------------------------------------------------------------------- 
    550       !!                  ***  routine mpp_lnk_2d  *** 
     536   END SUBROUTINE mpp_lnk_obc_3d 
     537 
     538 
     539   SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 
     540      !!---------------------------------------------------------------------- 
     541      !!                  ***  routine mpp_lnk_obc_2d  *** 
    551542      !!                   
    552543      !! ** Purpose :   Message passing manadgement for 2d array 
    553544      !! 
    554       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     545      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    555546      !!      between processors following neighboring subdomains. 
    556547      !!            domain parameters 
    … …  
    570561      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    571562      !                                                         ! =  1. , the sign is kept 
    572       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    573       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    574563      !! 
    575564      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    … …  
    580569      !!---------------------------------------------------------------------- 
    581570 
    582       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    583       ELSE                         ;   zland = 0.e0      ! zero by default 
    584       ENDIF 
     571      zland = 0.e0      ! zero by default 
    585572 
    586573      ! 1. standard boundary treatment 
    587574      ! ------------------------------ 
    588575      ! 
    589       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    590          ! 
    591          ! WARNING pt2d is defined only between nld and nle 
    592          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    593             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
    594             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    595             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    596          END DO 
    597          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    598             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    599             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    600             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    601          END DO 
    602          ! 
    603       ELSE                              ! standard close or cyclic treatment  
    604          ! 
    605          !                                   ! East-West boundaries 
    606          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    607             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    608             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    609             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    610          ELSE                                     ! closed 
    611             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    612                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    613          ENDIF 
    614          !                                   ! North-South boundaries (always closed) 
    615             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    616                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    617          ! 
     576      IF( nbondi == 2) THEN 
     577        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     578          pt2d( 1 ,:) = pt2d(jpim1,:) 
     579          pt2d(jpi,:) = pt2d(  2  ,:) 
     580        ELSE 
     581          IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     582          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     583        ENDIF 
     584      ELSEIF(nbondi == -1) THEN 
     585        IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     586      ELSEIF(nbondi == 1) THEN 
     587        pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     588      ENDIF                                     !* closed 
     589 
     590      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     591        IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland       ! south except F-point 
     592      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     593        pt2d(:,nlcj-jprecj+1:jpj) = zland       ! north 
    618594      ENDIF 
    619595 
    … …  
    728704      ! ----------------------- 
    729705      ! 
     706      IF( npolj /= 0 ) THEN 
     707         ! 
     708         SELECT CASE ( jpni ) 
     709         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     710         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
     711         END SELECT 
     712         ! 
     713      ENDIF 
     714      ! 
     715   END SUBROUTINE mpp_lnk_obc_2d 
     716 
     717   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     718      !!---------------------------------------------------------------------- 
     719      !!                  ***  routine mpp_lnk_3d  *** 
     720      !! 
     721      !! ** Purpose :   Message passing manadgement 
     722      !! 
     723      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     724      !!      between processors following neighboring subdomains. 
     725      !!            domain parameters 
     726      !!                    nlci   : first dimension of the local subdomain 
     727      !!                    nlcj   : second dimension of the local subdomain 
     728      !!                    nbondi : mark for "east-west local boundary" 
     729      !!                    nbondj : mark for "north-south local boundary" 
     730      !!                    noea   : number for local neighboring processors  
     731      !!                    nowe   : number for local neighboring processors 
     732      !!                    noso   : number for local neighboring processors 
     733      !!                    nono   : number for local neighboring processors 
     734      !! 
     735      !! ** Action  :   ptab with update value at its periphery 
     736      !! 
     737      !!---------------------------------------------------------------------- 
     738      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     739      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     740      !                                                             ! = T , U , V , F , W points 
     741      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     742      !                                                             ! =  1. , the sign is kept 
     743      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     744      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     745      !! 
     746      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     747      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     748      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     749      REAL(wp) ::   zland 
     750      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     751      !!---------------------------------------------------------------------- 
     752 
     753      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     754      ELSE                         ;   zland = 0.e0      ! zero by default 
     755      ENDIF 
     756 
     757      ! 1. standard boundary treatment 
     758      ! ------------------------------ 
     759      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     760         ! 
     761         ! WARNING ptab is defined only between nld and nle 
     762         DO jk = 1, jpk 
     763            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     764               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
     765               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
     766               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     767            END DO 
     768            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     769               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
     770               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
     771               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
     772            END DO 
     773         END DO 
     774         ! 
     775      ELSE                              ! standard close or cyclic treatment  
     776         ! 
     777         !                                   ! East-West boundaries 
     778         !                                        !* Cyclic east-west 
     779         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     780            ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     781            ptab(jpi,:,:) = ptab(  2  ,:,:) 
     782         ELSE                                     !* closed 
     783            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     784                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     785         ENDIF 
     786         !                                   ! North-South boundaries (always closed) 
     787         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     788                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     789         ! 
     790      ENDIF 
     791 
     792      ! 2. East and west directions exchange 
     793      ! ------------------------------------ 
     794      ! we play with the neigbours AND the row number because of the periodicity  
     795      ! 
     796      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     797      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     798         iihom = nlci-nreci 
     799         DO jl = 1, jpreci 
     800            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     801            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     802         END DO 
     803      END SELECT   
     804      ! 
     805      !                           ! Migrations 
     806      imigr = jpreci * jpj * jpk 
     807      ! 
     808      SELECT CASE ( nbondi )  
     809      CASE ( -1 ) 
     810         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     811         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     812         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     813      CASE ( 0 ) 
     814         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     815         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     816         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     817         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     818         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     819         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     820      CASE ( 1 ) 
     821         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     822         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     823         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     824      END SELECT 
     825      ! 
     826      !                           ! Write Dirichlet lateral conditions 
     827      iihom = nlci-jpreci 
     828      ! 
     829      SELECT CASE ( nbondi ) 
     830      CASE ( -1 ) 
     831         DO jl = 1, jpreci 
     832            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     833         END DO 
     834      CASE ( 0 )  
     835         DO jl = 1, jpreci 
     836            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     837            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     838         END DO 
     839      CASE ( 1 ) 
     840         DO jl = 1, jpreci 
     841            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     842         END DO 
     843      END SELECT 
     844 
     845 
     846      ! 3. North and south directions 
     847      ! ----------------------------- 
     848      ! always closed : we play only with the neigbours 
     849      ! 
     850      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     851         ijhom = nlcj-nrecj 
     852         DO jl = 1, jprecj 
     853            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     854            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     855         END DO 
     856      ENDIF 
     857      ! 
     858      !                           ! Migrations 
     859      imigr = jprecj * jpi * jpk 
     860      ! 
     861      SELECT CASE ( nbondj )      
     862      CASE ( -1 ) 
     863         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     864         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     865         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     866      CASE ( 0 ) 
     867         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     868         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     869         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     870         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     871         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     872         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     873      CASE ( 1 )  
     874         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     875         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     876         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     877      END SELECT 
     878      ! 
     879      !                           ! Write Dirichlet lateral conditions 
     880      ijhom = nlcj-jprecj 
     881      ! 
     882      SELECT CASE ( nbondj ) 
     883      CASE ( -1 ) 
     884         DO jl = 1, jprecj 
     885            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     886         END DO 
     887      CASE ( 0 )  
     888         DO jl = 1, jprecj 
     889            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     890            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     891         END DO 
     892      CASE ( 1 ) 
     893         DO jl = 1, jprecj 
     894            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     895         END DO 
     896      END SELECT 
     897 
     898 
     899      ! 4. north fold treatment 
     900      ! ----------------------- 
     901      ! 
     902      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     903         ! 
     904         SELECT CASE ( jpni ) 
     905         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     906         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     907         END SELECT 
     908         ! 
     909      ENDIF 
     910      ! 
     911   END SUBROUTINE mpp_lnk_3d 
     912 
     913 
     914   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     915      !!---------------------------------------------------------------------- 
     916      !!                  ***  routine mpp_lnk_2d  *** 
     917      !!                   
     918      !! ** Purpose :   Message passing manadgement for 2d array 
     919      !! 
     920      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     921      !!      between processors following neighboring subdomains. 
     922      !!            domain parameters 
     923      !!                    nlci   : first dimension of the local subdomain 
     924      !!                    nlcj   : second dimension of the local subdomain 
     925      !!                    nbondi : mark for "east-west local boundary" 
     926      !!                    nbondj : mark for "north-south local boundary" 
     927      !!                    noea   : number for local neighboring processors  
     928      !!                    nowe   : number for local neighboring processors 
     929      !!                    noso   : number for local neighboring processors 
     930      !!                    nono   : number for local neighboring processors 
     931      !! 
     932      !!---------------------------------------------------------------------- 
     933      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
     934      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     935      !                                                         ! = T , U , V , F , W and I points 
     936      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     937      !                                                         ! =  1. , the sign is kept 
     938      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     939      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     940      !! 
     941      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     942      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     943      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     944      REAL(wp) ::   zland 
     945      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     946      !!---------------------------------------------------------------------- 
     947 
     948      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     949      ELSE                         ;   zland = 0.e0      ! zero by default 
     950      ENDIF 
     951 
     952      ! 1. standard boundary treatment 
     953      ! ------------------------------ 
     954      ! 
     955      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     956         ! 
     957         ! WARNING pt2d is defined only between nld and nle 
     958         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     959            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
     960            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
     961            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
     962         END DO 
     963         DO ji = nlci+1, jpi                 ! added column(s) (full) 
     964            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
     965            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
     966            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
     967         END DO 
     968         ! 
     969      ELSE                              ! standard close or cyclic treatment  
     970         ! 
     971         !                                   ! East-West boundaries 
     972         IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
     973            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     974            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
     975            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
     976         ELSE                                     ! closed 
     977            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     978                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     979         ENDIF 
     980         !                                   ! North-South boundaries (always closed) 
     981            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
     982                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
     983         ! 
     984      ENDIF 
     985 
     986      ! 2. East and west directions exchange 
     987      ! ------------------------------------ 
     988      ! we play with the neigbours AND the row number because of the periodicity  
     989      ! 
     990      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     991      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     992         iihom = nlci-nreci 
     993         DO jl = 1, jpreci 
     994            t2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     995            t2we(:,jl,1) = pt2d(iihom +jl,:) 
     996         END DO 
     997      END SELECT 
     998      ! 
     999      !                           ! Migrations 
     1000      imigr = jpreci * jpj 
     1001      ! 
     1002      SELECT CASE ( nbondi ) 
     1003      CASE ( -1 ) 
     1004         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     1005         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1006         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1007      CASE ( 0 ) 
     1008         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1009         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     1010         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1011         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1012         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1013         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1014      CASE ( 1 ) 
     1015         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1016         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1017         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1018      END SELECT 
     1019      ! 
     1020      !                           ! Write Dirichlet lateral conditions 
     1021      iihom = nlci - jpreci 
     1022      ! 
     1023      SELECT CASE ( nbondi ) 
     1024      CASE ( -1 ) 
     1025         DO jl = 1, jpreci 
     1026            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1027         END DO 
     1028      CASE ( 0 ) 
     1029         DO jl = 1, jpreci 
     1030            pt2d(jl      ,:) = t2we(:,jl,2) 
     1031            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1032         END DO 
     1033      CASE ( 1 ) 
     1034         DO jl = 1, jpreci 
     1035            pt2d(jl      ,:) = t2we(:,jl,2) 
     1036         END DO 
     1037      END SELECT 
     1038 
     1039 
     1040      ! 3. North and south directions 
     1041      ! ----------------------------- 
     1042      ! always closed : we play only with the neigbours 
     1043      ! 
     1044      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     1045         ijhom = nlcj-nrecj 
     1046         DO jl = 1, jprecj 
     1047            t2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     1048            t2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     1049         END DO 
     1050      ENDIF 
     1051      ! 
     1052      !                           ! Migrations 
     1053      imigr = jprecj * jpi 
     1054      ! 
     1055      SELECT CASE ( nbondj ) 
     1056      CASE ( -1 ) 
     1057         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     1058         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1059         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1060      CASE ( 0 ) 
     1061         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1062         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     1063         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1064         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1065         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1066         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1067      CASE ( 1 ) 
     1068         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1069         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1070         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1071      END SELECT 
     1072      ! 
     1073      !                           ! Write Dirichlet lateral conditions 
     1074      ijhom = nlcj - jprecj 
     1075      ! 
     1076      SELECT CASE ( nbondj ) 
     1077      CASE ( -1 ) 
     1078         DO jl = 1, jprecj 
     1079            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1080         END DO 
     1081      CASE ( 0 ) 
     1082         DO jl = 1, jprecj 
     1083            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1084            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1085         END DO 
     1086      CASE ( 1 )  
     1087         DO jl = 1, jprecj 
     1088            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1089         END DO 
     1090      END SELECT 
     1091 
     1092 
     1093      ! 4. north fold treatment 
     1094      ! ----------------------- 
     1095      ! 
    7301096      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    7311097         ! 
    … …  
    17822148      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend 
    17832149      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace 
     2150      LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 
    17842151      !!---------------------------------------------------------------------- 
    17852152 
    … …  
    18072174         CALL mppstop 
    18082175      ENDIF 
    1809        
     2176 
    18102177      ! Communication level by level 
    18112178      ! ---------------------------- 
    18122179!!gm Remark : this is very time consumming!!! 
    18132180      !                                         ! ------------------------ ! 
     2181            IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 
     2182            ! there is nothing to be migrated 
     2183               lmigr = .FALSE. 
     2184            ELSE 
     2185              lmigr = .TRUE. 
     2186            ENDIF 
     2187 
     2188      IF( lmigr ) THEN 
     2189 
    18142190      DO jk = 1, kk                             !   Loop over the levels   ! 
    18152191         !                                      ! ------------------------ ! 
    … …  
    18332209         ! --------------------------- 
    18342210         ! 
     2211       IF( ktype == 1 ) THEN 
     2212 
    18352213         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18362214            iihom = nlci-nreci 
    1837             DO jl = 1, jpreci 
    1838                t2ew(:,jl,1) = ztab(jpreci+jl,:) 
    1839                t2we(:,jl,1) = ztab(iihom +jl,:) 
    1840             END DO 
     2215            t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 
     2216            t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 
    18412217         ENDIF 
    18422218         ! 
    18432219         !                              ! Migrations 
    1844          imigr=jpreci*jpj 
     2220         imigr = jpreci 
    18452221         ! 
    18462222         IF( nbondi == -1 ) THEN 
    … …  
    18652241         ! 
    18662242         IF( nbondi == 0 .OR. nbondi == 1 ) THEN 
    1867             DO jl = 1, jpreci 
    1868                ztab(jl,:) = t2we(:,jl,2) 
    1869             END DO 
     2243            ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 
    18702244         ENDIF 
    18712245         IF( nbondi == -1 .OR. nbondi == 0 ) THEN 
    1872             DO jl = 1, jpreci 
    1873                ztab(iihom+jl,:) = t2ew(:,jl,2) 
    1874             END DO 
     2246            ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 
    18752247         ENDIF 
    1876  
     2248       ENDIF  ! (ktype == 1) 
    18772249 
    18782250         ! 2. North and south directions 
    18792251         ! ----------------------------- 
    18802252         ! 
     2253       IF(ktype == 2 ) THEN 
    18812254         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18822255            ijhom = nlcj-nrecj 
    1883             DO jl = 1, jprecj 
    1884                t2sn(:,jl,1) = ztab(:,ijhom +jl) 
    1885                t2ns(:,jl,1) = ztab(:,jprecj+jl) 
    1886             END DO 
     2256            t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 
     2257            t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 
    18872258         ENDIF 
    18882259         ! 
    18892260         !                              ! Migrations 
    1890          imigr = jprecj * jpi 
     2261         imigr = jprecj 
    18912262         ! 
    18922263         IF( nbondj == -1 ) THEN 
    … …  
    19102281         ijhom = nlcj - jprecj 
    19112282         IF( nbondj == 0 .OR. nbondj == 1 ) THEN 
    1912             DO jl = 1, jprecj 
    1913                ztab(:,jl) = t2sn(:,jl,2) 
    1914             END DO 
     2283            ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 
    19152284         ENDIF 
    19162285         IF( nbondj == 0 .OR. nbondj == -1 ) THEN 
    1917             DO jl = 1, jprecj 
    1918                ztab(:,ijhom+jl) = t2ns(:,jl,2) 
    1919             END DO 
     2286            ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 
    19202287         ENDIF 
     2288         ENDIF    ! (ktype == 2) 
    19212289         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 
    19222290            DO jj = ijpt0, ijpt1            ! north/south boundaries 
    19232291               DO ji = iipt0,ilpt1 
    1924                   ptab(ji,jk) = ztab(ji,jj)   
     2292                  ptab(ji,jk) = ztab(ji,jj) 
    19252293               END DO 
    19262294            END DO 
    … …  
    19282296            DO jj = ijpt0, ilpt1            ! east/west boundaries 
    19292297               DO ji = iipt0,iipt1 
    1930                   ptab(jj,jk) = ztab(ji,jj)  
     2298                  ptab(jj,jk) = ztab(ji,jj) 
    19312299               END DO 
    19322300            END DO 
    … …  
    19352303      END DO 
    19362304      ! 
     2305      ENDIF ! ( lmigr ) 
    19372306      CALL wrk_dealloc( jpi,jpj, ztab ) 
    19382307      ! 
    … …  
    25342903   END SUBROUTINE mpp_lbc_north_e 
    25352904 
     2905      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
     2906      !!---------------------------------------------------------------------- 
     2907      !!                  ***  routine mpp_lnk_bdy_3d  *** 
     2908      !! 
     2909      !! ** Purpose :   Message passing management 
     2910      !! 
     2911      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     2912      !!      between processors following neighboring subdomains. 
     2913      !!            domain parameters 
     2914      !!                    nlci   : first dimension of the local subdomain 
     2915      !!                    nlcj   : second dimension of the local subdomain 
     2916      !!                    nbondi_bdy : mark for "east-west local boundary" 
     2917      !!                    nbondj_bdy : mark for "north-south local boundary" 
     2918      !!                    noea   : number for local neighboring processors  
     2919      !!                    nowe   : number for local neighboring processors 
     2920      !!                    noso   : number for local neighboring processors 
     2921      !!                    nono   : number for local neighboring processors 
     2922      !! 
     2923      !! ** Action  :   ptab with update value at its periphery 
     2924      !! 
     2925      !!---------------------------------------------------------------------- 
     2926 
     2927      USE lbcnfd          ! north fold 
     2928 
     2929      INCLUDE 'mpif.h' 
     2930 
     2931      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     2932      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     2933      !                                                             ! = T , U , V , F , W points 
     2934      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     2935      !                                                             ! =  1. , the sign is kept 
     2936      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     2937      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     2938      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     2939      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     2940      REAL(wp) ::   zland 
     2941      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     2942      !!---------------------------------------------------------------------- 
     2943 
     2944      zland = 0.e0 
     2945 
     2946      ! 1. standard boundary treatment 
     2947      ! ------------------------------ 
     2948       
     2949      !                                   ! East-West boundaries 
     2950      !                                        !* Cyclic east-west 
     2951 
     2952      IF( nbondi == 2) THEN 
     2953        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     2954          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     2955          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     2956        ELSE 
     2957          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2958          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2959        ENDIF 
     2960      ELSEIF(nbondi == -1) THEN 
     2961        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2962      ELSEIF(nbondi == 1) THEN 
     2963        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2964      ENDIF                                     !* closed 
     2965 
     2966      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     2967        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     2968      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     2969        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     2970      ENDIF 
     2971       
     2972      ! 
     2973 
     2974      ! 2. East and west directions exchange 
     2975      ! ------------------------------------ 
     2976      ! we play with the neigbours AND the row number because of the periodicity  
     2977      ! 
     2978      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     2979      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     2980         iihom = nlci-nreci 
     2981         DO jl = 1, jpreci 
     2982            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     2983            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     2984         END DO 
     2985      END SELECT 
     2986      ! 
     2987      !                           ! Migrations 
     2988      imigr = jpreci * jpj * jpk 
     2989      ! 
     2990      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     2991      CASE ( -1 ) 
     2992         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     2993      CASE ( 0 ) 
     2994         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2995         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     2996      CASE ( 1 ) 
     2997         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2998      END SELECT 
     2999      ! 
     3000      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3001      CASE ( -1 ) 
     3002         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3003      CASE ( 0 ) 
     3004         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3005         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3006      CASE ( 1 ) 
     3007         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3008      END SELECT 
     3009      ! 
     3010      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3011      CASE ( -1 ) 
     3012         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3013      CASE ( 0 ) 
     3014         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3015         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3016      CASE ( 1 ) 
     3017         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3018      END SELECT 
     3019      ! 
     3020      !                           ! Write Dirichlet lateral conditions 
     3021      iihom = nlci-jpreci 
     3022      ! 
     3023      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3024      CASE ( -1 ) 
     3025         DO jl = 1, jpreci 
     3026            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3027         END DO 
     3028      CASE ( 0 ) 
     3029         DO jl = 1, jpreci 
     3030            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3031            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3032         END DO 
     3033      CASE ( 1 ) 
     3034         DO jl = 1, jpreci 
     3035            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3036         END DO 
     3037      END SELECT 
     3038 
     3039 
     3040      ! 3. North and south directions 
     3041      ! ----------------------------- 
     3042      ! always closed : we play only with the neigbours 
     3043      ! 
     3044      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3045         ijhom = nlcj-nrecj 
     3046         DO jl = 1, jprecj 
     3047            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     3048            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     3049         END DO 
     3050      ENDIF 
     3051      ! 
     3052      !                           ! Migrations 
     3053      imigr = jprecj * jpi * jpk 
     3054      ! 
     3055      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3056      CASE ( -1 ) 
     3057         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     3058      CASE ( 0 ) 
     3059         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3060         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     3061      CASE ( 1 ) 
     3062         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3063      END SELECT 
     3064      ! 
     3065      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3066      CASE ( -1 ) 
     3067         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3068      CASE ( 0 ) 
     3069         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3070         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3071      CASE ( 1 ) 
     3072         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3073      END SELECT 
     3074      ! 
     3075      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3076      CASE ( -1 ) 
     3077         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3078      CASE ( 0 ) 
     3079         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3080         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3081      CASE ( 1 ) 
     3082         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3083      END SELECT 
     3084      ! 
     3085      !                           ! Write Dirichlet lateral conditions 
     3086      ijhom = nlcj-jprecj 
     3087      ! 
     3088      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3089      CASE ( -1 ) 
     3090         DO jl = 1, jprecj 
     3091            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3092         END DO 
     3093      CASE ( 0 ) 
     3094         DO jl = 1, jprecj 
     3095            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     3096            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3097         END DO 
     3098      CASE ( 1 ) 
     3099         DO jl = 1, jprecj 
     3100            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     3101         END DO 
     3102      END SELECT 
     3103 
     3104 
     3105      ! 4. north fold treatment 
     3106      ! ----------------------- 
     3107      ! 
     3108      IF( npolj /= 0) THEN 
     3109         ! 
     3110         SELECT CASE ( jpni ) 
     3111         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3112         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3113         END SELECT 
     3114         ! 
     3115      ENDIF 
     3116      ! 
     3117   END SUBROUTINE mpp_lnk_bdy_3d 
     3118 
     3119      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
     3120      !!---------------------------------------------------------------------- 
     3121      !!                  ***  routine mpp_lnk_bdy_2d  *** 
     3122      !! 
     3123      !! ** Purpose :   Message passing management 
     3124      !! 
     3125      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     3126      !!      between processors following neighboring subdomains. 
     3127      !!            domain parameters 
     3128      !!                    nlci   : first dimension of the local subdomain 
     3129      !!                    nlcj   : second dimension of the local subdomain 
     3130      !!                    nbondi_bdy : mark for "east-west local boundary" 
     3131      !!                    nbondj_bdy : mark for "north-south local boundary" 
     3132      !!                    noea   : number for local neighboring processors  
     3133      !!                    nowe   : number for local neighboring processors 
     3134      !!                    noso   : number for local neighboring processors 
     3135      !!                    nono   : number for local neighboring processors 
     3136      !! 
     3137      !! ** Action  :   ptab with update value at its periphery 
     3138      !! 
     3139      !!---------------------------------------------------------------------- 
     3140 
     3141      USE lbcnfd          ! north fold 
     3142 
     3143      INCLUDE 'mpif.h' 
     3144 
     3145      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3146      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     3147      !                                                             ! = T , U , V , F , W points 
     3148      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     3149      !                                                             ! =  1. , the sign is kept 
     3150      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     3151      INTEGER  ::   ji, jj, jl             ! dummy loop indices 
     3152      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     3153      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     3154      REAL(wp) ::   zland 
     3155      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     3156      !!---------------------------------------------------------------------- 
     3157 
     3158      zland = 0.e0 
     3159 
     3160      ! 1. standard boundary treatment 
     3161      ! ------------------------------ 
     3162       
     3163      !                                   ! East-West boundaries 
     3164      !                                        !* Cyclic east-west 
     3165 
     3166      IF( nbondi == 2) THEN 
     3167        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     3168          ptab( 1 ,:) = ptab(jpim1,:) 
     3169          ptab(jpi,:) = ptab(  2  ,:) 
     3170        ELSE 
     3171          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3172          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3173        ENDIF 
     3174      ELSEIF(nbondi == -1) THEN 
     3175        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3176      ELSEIF(nbondi == 1) THEN 
     3177        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3178      ENDIF                                     !* closed 
     3179 
     3180      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     3181        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point 
     3182      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     3183        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north 
     3184      ENDIF 
     3185       
     3186      ! 
     3187 
     3188      ! 2. East and west directions exchange 
     3189      ! ------------------------------------ 
     3190      ! we play with the neigbours AND the row number because of the periodicity  
     3191      ! 
     3192      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     3193      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     3194         iihom = nlci-nreci 
     3195         DO jl = 1, jpreci 
     3196            t2ew(:,jl,1) = ptab(jpreci+jl,:) 
     3197            t2we(:,jl,1) = ptab(iihom +jl,:) 
     3198         END DO 
     3199      END SELECT 
     3200      ! 
     3201      !                           ! Migrations 
     3202      imigr = jpreci * jpj 
     3203      ! 
     3204      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3205      CASE ( -1 ) 
     3206         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     3207      CASE ( 0 ) 
     3208         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3209         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     3210      CASE ( 1 ) 
     3211         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3212      END SELECT 
     3213      ! 
     3214      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3215      CASE ( -1 ) 
     3216         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3217      CASE ( 0 ) 
     3218         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3219         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3220      CASE ( 1 ) 
     3221         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3222      END SELECT 
     3223      ! 
     3224      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3225      CASE ( -1 ) 
     3226         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3227      CASE ( 0 ) 
     3228         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3229         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3230      CASE ( 1 ) 
     3231         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3232      END SELECT 
     3233      ! 
     3234      !                           ! Write Dirichlet lateral conditions 
     3235      iihom = nlci-jpreci 
     3236      ! 
     3237      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3238      CASE ( -1 ) 
     3239         DO jl = 1, jpreci 
     3240            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3241         END DO 
     3242      CASE ( 0 ) 
     3243         DO jl = 1, jpreci 
     3244            ptab(jl      ,:) = t2we(:,jl,2) 
     3245            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3246         END DO 
     3247      CASE ( 1 ) 
     3248         DO jl = 1, jpreci 
     3249            ptab(jl      ,:) = t2we(:,jl,2) 
     3250         END DO 
     3251      END SELECT 
     3252 
     3253 
     3254      ! 3. North and south directions 
     3255      ! ----------------------------- 
     3256      ! always closed : we play only with the neigbours 
     3257      ! 
     3258      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3259         ijhom = nlcj-nrecj 
     3260         DO jl = 1, jprecj 
     3261            t2sn(:,jl,1) = ptab(:,ijhom +jl) 
     3262            t2ns(:,jl,1) = ptab(:,jprecj+jl) 
     3263         END DO 
     3264      ENDIF 
     3265      ! 
     3266      !                           ! Migrations 
     3267      imigr = jprecj * jpi 
     3268      ! 
     3269      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3270      CASE ( -1 ) 
     3271         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     3272      CASE ( 0 ) 
     3273         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3274         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     3275      CASE ( 1 ) 
     3276         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3277      END SELECT 
     3278      ! 
     3279      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3280      CASE ( -1 ) 
     3281         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3282      CASE ( 0 ) 
     3283         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3284         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3285      CASE ( 1 ) 
     3286         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3287      END SELECT 
     3288      ! 
     3289      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3290      CASE ( -1 ) 
     3291         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3292      CASE ( 0 ) 
     3293         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3294         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3295      CASE ( 1 ) 
     3296         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3297      END SELECT 
     3298      ! 
     3299      !                           ! Write Dirichlet lateral conditions 
     3300      ijhom = nlcj-jprecj 
     3301      ! 
     3302      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3303      CASE ( -1 ) 
     3304         DO jl = 1, jprecj 
     3305            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3306         END DO 
     3307      CASE ( 0 ) 
     3308         DO jl = 1, jprecj 
     3309            ptab(:,jl      ) = t2sn(:,jl,2) 
     3310            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3311         END DO 
     3312      CASE ( 1 ) 
     3313         DO jl = 1, jprecj 
     3314            ptab(:,jl) = t2sn(:,jl,2) 
     3315         END DO 
     3316      END SELECT 
     3317 
     3318 
     3319      ! 4. north fold treatment 
     3320      ! ----------------------- 
     3321      ! 
     3322      IF( npolj /= 0) THEN 
     3323         ! 
     3324         SELECT CASE ( jpni ) 
     3325         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3326         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3327         END SELECT 
     3328         ! 
     3329      ENDIF 
     3330      ! 
     3331   END SUBROUTINE mpp_lnk_bdy_2d 
    25363332 
    25373333   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn.F90

    r3294 r3680  
    55   !! Ocean dynamics:   Radiation of velocities on each open boundary 
    66   !!================================================================================= 
    7  
     7   !! History :  3.5  !  2012     (S. Mocavero, I. Epicoco) Updates for the  
     8   !!                             optimization of OBC communications 
    89   !!--------------------------------------------------------------------------------- 
    910   !!   obc_dyn        : call the subroutine for each open boundary 
    … …  
    105106      IF( lk_mpp ) THEN 
    106107         IF( kt >= nit000+3 .AND. ln_rstart ) THEN 
    107             CALL lbc_lnk( ub, 'U', -1. ) 
    108             CALL lbc_lnk( vb, 'V', -1. ) 
     108            CALL lbc_obc_lnk( ub, 'U', -1. ) 
     109            CALL lbc_obc_lnk( vb, 'V', -1. ) 
    109110         END IF 
    110          CALL lbc_lnk( ua, 'U', -1. ) 
    111          CALL lbc_lnk( va, 'V', -1. ) 
     111         CALL lbc_obc_lnk( ua, 'U', -1. ) 
     112         CALL lbc_obc_lnk( va, 'V', -1. ) 
    112113      ENDIF 
    113114 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn_bt.F90

    r3294 r3680  
    55   !!====================================================================== 
    66   !! History :  1.0  ! 2005-12  (V. Garnier) original code 
     7   !!            3.5  ! 2012     (S. Mocavero, I. Epicoco) Updates for the  
     8   !!                             optimization of OBC communications 
    79   !!---------------------------------------------------------------------- 
    810#if ( defined key_dynspg_ts || defined key_dynspg_exp ) && defined key_obc 
    … …  
    6567      IF( lk_mpp ) THEN 
    6668         IF( kt >= nit000+3 .AND. ln_rstart ) THEN 
    67             CALL lbc_lnk( sshb, 'T',  1. ) 
    68             CALL lbc_lnk( ub  , 'U', -1. ) 
    69             CALL lbc_lnk( vb  , 'V', -1. ) 
     69            CALL lbc_obc_lnk( sshb, 'T',  1. ) 
     70            CALL lbc_obc_lnk( ub  , 'U', -1. ) 
     71            CALL lbc_obc_lnk( vb  , 'V', -1. ) 
    7072         END IF 
    71          CALL lbc_lnk( sshn, 'T',  1. ) 
    72          CALL lbc_lnk( ua  , 'U', -1. ) 
    73          CALL lbc_lnk( va  , 'V', -1. ) 
     73         CALL lbc_obc_lnk( sshn, 'T',  1. ) 
     74         CALL lbc_obc_lnk( ua  , 'U', -1. ) 
     75         CALL lbc_obc_lnk( va  , 'V', -1. ) 
    7476      ENDIF 
    7577 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90

    r3294 r3680  
    44   !! Ocean tracers:   Radiation of tracers on each open boundary 
    55   !!================================================================================= 
     6   !! History :  3.5  !  2012     (S. Mocavero, I. Epicoco) Updates for the  
     7   !!                             optimization of OBC communications 
    68#if defined key_obc 
    79   !!--------------------------------------------------------------------------------- 
    … …  
    101103      IF( lk_mpp ) THEN                  !!bug ??? 
    102104         IF( kt >= nit000+3 .AND. ln_rstart ) THEN 
    103             CALL lbc_lnk( tsb(:,:,:,jp_tem), 'T', 1. ) 
    104             CALL lbc_lnk( tsb(:,:,:,jp_sal), 'T', 1. ) 
     105            CALL lbc_obc_lnk( tsb(:,:,:,jp_tem), 'T', 1. ) 
     106            CALL lbc_obc_lnk( tsb(:,:,:,jp_sal), 'T', 1. ) 
    105107         END IF 
    106          CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) 
    107          CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
     108         CALL lbc_obc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) 
     109         CALL lbc_obc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    108110      ENDIF 
    109111 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r3651 r3680  
    629629      INTEGER                  ::   ipk    ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    630630      INTEGER                  ::   iw     ! index into wgts array 
    631       !!--------------------------------------------------------------------- 
    632              
     631      INTEGER                  ::   ipdom  ! index of the domain 
     632      !!--------------------------------------------------------------------- 
     633      !       
    633634      ipk = SIZE( sdjf%fnow, 3 ) 
    634  
     635      ! 
    635636      IF( PRESENT(map) ) THEN 
    636637         IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 
    … …  
    643644         ENDIF 
    644645      ELSE 
     646         IF( SIZE(sdjf%fnow, 1) == jpi ) THEN  ;  ipdom = jpdom_data 
     647         ELSE                                  ;  ipdom = jpdom_unknown 
     648         ENDIF 
    645649         SELECT CASE( ipk ) 
    646          CASE(1)    
    647             IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, jpdom_data, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) ) 
    648             ELSE                      ;   CALL iom_get( sdjf%num, jpdom_data, sdjf%clvar, sdjf%fnow(:,:,1  ), sdjf%nrec_a(1) ) 
     650         CASE(1) 
     651            IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) ) 
     652            ELSE                      ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1  ), sdjf%nrec_a(1) ) 
    649653            ENDIF 
    650654         CASE DEFAULT 
    651             IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, jpdom_data, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) 
    652             ELSE                      ;   CALL iom_get( sdjf%num, jpdom_data, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1) ) 
     655            IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) 
     656            ELSE                      ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1) ) 
    653657            ENDIF 
    654658         END SELECT 
    … …  
    850854         IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 
    851855         sdf(jf)%vcomp   = sdf_n(jf)%vcomp 
     856         sdf(jf)%rotn    = .FALSE. 
    852857      END DO 
    853858 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r3625 r3680  
    4949   !                                             !:  = 1 global mean of e-p-r set to zero at each nn_fsbc time step 
    5050   !                                             !:  = 2 annual global mean of e-p-r set to zero 
    51    LOGICAL , PUBLIC ::   ln_cdgw     = .FALSE.   !: true if neutral drag coefficient read from wave model 
     51   LOGICAL , PUBLIC ::   ln_wave     = .FALSE.   !: true if some coupling with wave model 
     52   LOGICAL , PUBLIC ::   ln_cdgw     = .FALSE.   !: true if neutral drag coefficient from wave model 
     53   LOGICAL , PUBLIC ::   ln_sdw      = .FALSE.   !: true if 3d stokes drift from wave model 
    5254 
    5355   !!---------------------------------------------------------------------- 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90

    r3651 r3680  
    2020   USE iom             ! IOM library 
    2121   USE lib_mpp         ! MPP library 
    22    USE restart         ! ocean restart 
    2322 
    2423   IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r3625 r3680  
    2929   USE fldread         ! read input fields 
    3030   USE sbc_oce         ! Surface boundary condition: ocean fields 
     31   USE cyclone         ! Cyclone 10m wind form trac of cyclone centres 
    3132   USE sbcdcy          ! surface boundary condition: diurnal cycle 
    3233   USE iom             ! I/O manager library 
    … …  
    186187 
    187188      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    188       IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce_core( sf, sst_m, ssu_m, ssv_m ) 
     189      IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce_core( kt, sf, sst_m, ssu_m, ssv_m ) 
    189190 
    190191#if defined key_cice 
    … …  
    204205    
    205206    
    206    SUBROUTINE blk_oce_core( sf, pst, pu, pv ) 
     207   SUBROUTINE blk_oce_core( kt, sf, pst, pu, pv ) 
    207208      !!--------------------------------------------------------------------- 
    208209      !!                     ***  ROUTINE blk_core  *** 
    … …  
    225226      !!  ** Nota  :   sf has to be a dummy argument for AGRIF on NEC 
    226227      !!--------------------------------------------------------------------- 
    227       TYPE(fld), INTENT(in), DIMENSION(:)   ::   sf    ! input data 
    228       REAL(wp) , INTENT(in), DIMENSION(:,:) ::   pst   ! surface temperature                      [Celcius] 
    229       REAL(wp) , INTENT(in), DIMENSION(:,:) ::   pu    ! surface current at U-point (i-component) [m/s] 
    230       REAL(wp) , INTENT(in), DIMENSION(:,:) ::   pv    ! surface current at V-point (j-component) [m/s] 
     228      INTEGER  , INTENT(in   )                 ::   kt    ! time step index 
     229      TYPE(fld), INTENT(inout), DIMENSION(:)   ::   sf    ! input data 
     230      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pst   ! surface temperature                      [Celcius] 
     231      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pu    ! surface current at U-point (i-component) [m/s] 
     232      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pv    ! surface current at V-point (j-component) [m/s] 
    231233      ! 
    232234      INTEGER  ::   ji, jj               ! dummy loop indices 
    … …  
    261263      zwnd_i(:,:) = 0.e0   
    262264      zwnd_j(:,:) = 0.e0 
     265#if defined key_cyclone 
     266# if defined key_vectopt_loop 
     267!CDIR COLLAPSE 
     268# endif 
     269      CALL wnd_cyc( kt, zwnd_i, zwnd_j )    ! add Manu ! 
     270      DO jj = 2, jpjm1 
     271         DO ji = fs_2, fs_jpim1   ! vect. opt. 
     272            sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) 
     273            sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) 
     274         END DO 
     275      END DO 
     276#endif 
    263277#if defined key_vectopt_loop 
    264278!CDIR COLLAPSE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r3632 r3680  
    4141#endif 
    4242   USE geo2ocean       !  
    43    USE restart         ! 
    4443   USE oce   , ONLY : tsn, un, vn 
    4544   USE albedo          ! 
    … …  
    381380         &     srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE.  
    382381      ! 
     382      IF( TRIM( sn_rcv_tau%clvor  ) == 'local grid' ) THEN        ! already on local grid -> no need of the second grid 
     383            srcv(jpr_otx2:jpr_otz2)%laction = .FALSE.  
     384            srcv(jpr_itx2:jpr_itz2)%laction = .FALSE.  
     385            srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid   ! not needed but cleaner... 
     386            srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid   ! not needed but cleaner... 
     387      ENDIF 
     388      ! 
    383389      IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN        ! 'oce and ice' case ocean stress on ocean mesh used 
    384390         srcv(jpr_itx1:jpr_itz2)%laction = .FALSE.    ! ice components not received 
    … …  
    520526      ssnd(jps_tmix)%clname = 'O_TepMix' 
    521527      SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 
     528      CASE( 'none'         )       ! nothing to do 
    522529      CASE( 'oce only'             )   ;   ssnd(   jps_toce             )%laction = .TRUE. 
    523530      CASE( 'weighted oce and ice' ) 
    … …  
    562569 
    563570      SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 
    564       CASE ( 'ice and snow' )  
     571      CASE( 'none'         )       ! nothing to do 
     572      CASE( 'ice and snow' )  
    565573         ssnd(jps_hice:jps_hsnw)%laction = .TRUE. 
    566574         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 
    … …  
    568576         ELSE 
    569577            IF ( jpl > 1 ) THEN 
    570                CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' ) 
     578CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' ) 
    571579            ENDIF 
    572580         ENDIF 
    … …  
    13571365      !                                                      !    Surface temperature    !   in Kelvin 
    13581366      !                                                      ! ------------------------- ! 
    1359       SELECT CASE( sn_snd_temp%cldes) 
    1360       CASE( 'oce only'             )   ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0 
    1361       CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)    
    1362          SELECT CASE( sn_snd_temp%clcat ) 
    1363          CASE( 'yes' )    
    1364             ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1365          CASE( 'no' ) 
    1366             ztmp3(:,:,:) = 0._wp 
     1367      IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN 
     1368         SELECT CASE( sn_snd_temp%cldes) 
     1369         CASE( 'oce only'             )   ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0 
     1370         CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)    
     1371            SELECT CASE( sn_snd_temp%clcat ) 
     1372            CASE( 'yes' )    
     1373               ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1374            CASE( 'no' ) 
     1375               ztmp3(:,:,:) = 0.0 
     1376               DO jl=1,jpl 
     1377                  ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1378               ENDDO 
     1379            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1380            END SELECT 
     1381         CASE( 'mixed oce-ice'        )    
     1382            ztmp1(:,:) = ( tsn(:,:,1,1) + rt0 ) * zfr_l(:,:)  
    13671383            DO jl=1,jpl 
    1368                ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1384               ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    13691385            ENDDO 
    1370          CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1386         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    13711387         END SELECT 
    1372       CASE( 'mixed oce-ice'        )    
    1373          ztmp1(:,:) = ( tsn(:,:,1,1) + rt0 ) * zfr_l(:,:)  
    1374          DO jl=1,jpl 
    1375             ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    1376          ENDDO 
    1377       CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    1378       END SELECT 
    1379       IF( ssnd(jps_toce)%laction )   CALL cpl_prism_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
    1380       IF( ssnd(jps_tice)%laction )   CALL cpl_prism_snd( jps_tice, isec, ztmp3, info ) 
    1381       IF( ssnd(jps_tmix)%laction )   CALL cpl_prism_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
     1388         IF( ssnd(jps_toce)%laction )   CALL cpl_prism_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
     1389         IF( ssnd(jps_tice)%laction )   CALL cpl_prism_snd( jps_tice, isec, ztmp3, info ) 
     1390         IF( ssnd(jps_tmix)%laction )   CALL cpl_prism_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
     1391      ENDIF 
    13821392      ! 
    13831393      !                                                      ! ------------------------- ! 
    … …  
    13991409      !                                                      ! ------------------------- ! 
    14001410      ! Send ice fraction field  
    1401       SELECT CASE( sn_snd_thick%clcat ) 
    1402          CASE( 'yes' )    
    1403             ztmp3(:,:,1:jpl) =  a_i(:,:,1:jpl) 
    1404          CASE( 'no' ) 
    1405             ztmp3(:,:,1) = fr_i(:,:) 
    1406       CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
    1407       END SELECT 
    1408       IF( ssnd(jps_fice)%laction ) CALL cpl_prism_snd( jps_fice, isec, ztmp3, info ) 
     1411      IF( ssnd(jps_fice)%laction ) THEN 
     1412         SELECT CASE( sn_snd_thick%clcat ) 
     1413         CASE( 'yes' )   ;   ztmp3(:,:,1:jpl) =  a_i(:,:,1:jpl) 
     1414         CASE( 'no'  )   ;   ztmp3(:,:,1    ) = fr_i(:,:      ) 
     1415         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
     1416         END SELECT 
     1417         CALL cpl_prism_snd( jps_fice, isec, ztmp3, info ) 
     1418      ENDIF 
    14091419 
    14101420      ! Send ice and snow thickness field  
    1411       SELECT CASE( sn_snd_thick%cldes) 
    1412       CASE( 'weighted ice and snow' )    
    1413          SELECT CASE( sn_snd_thick%clcat ) 
    1414          CASE( 'yes' )    
    1415             ztmp3(:,:,1:jpl) =  ht_i(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1416             ztmp4(:,:,1:jpl) =  ht_s(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1417          CASE( 'no' ) 
    1418             ztmp3(:,:,:) = 0._wp   ;  ztmp4(:,:,:) = 0._wp 
    1419             DO jl=1,jpl 
    1420                ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl) 
    1421                ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl) 
    1422             ENDDO 
    1423          CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
     1421      IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN  
     1422         SELECT CASE( sn_snd_thick%cldes) 
     1423         CASE( 'none'                  )       ! nothing to do 
     1424         CASE( 'weighted ice and snow' )    
     1425            SELECT CASE( sn_snd_thick%clcat ) 
     1426            CASE( 'yes' )    
     1427               ztmp3(:,:,1:jpl) =  ht_i(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1428               ztmp4(:,:,1:jpl) =  ht_s(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1429            CASE( 'no' ) 
     1430               ztmp3(:,:,:) = 0.0   ;  ztmp4(:,:,:) = 0.0 
     1431               DO jl=1,jpl 
     1432                  ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl) 
     1433                  ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl) 
     1434               ENDDO 
     1435            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
     1436            END SELECT 
     1437         CASE( 'ice and snow'         )    
     1438            ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
     1439            ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     1440         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 
    14241441         END SELECT 
    1425       CASE( 'ice and snow'         )    
    1426          ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
    1427          ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
    1428       CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 
    1429       END SELECT 
    1430       IF( ssnd(jps_hice)%laction )   CALL cpl_prism_snd( jps_hice, isec, ztmp3, info ) 
    1431       IF( ssnd(jps_hsnw)%laction )   CALL cpl_prism_snd( jps_hsnw, isec, ztmp4, info ) 
     1442         IF( ssnd(jps_hice)%laction )   CALL cpl_prism_snd( jps_hice, isec, ztmp3, info ) 
     1443         IF( ssnd(jps_hsnw)%laction )   CALL cpl_prism_snd( jps_hsnw, isec, ztmp4, info ) 
     1444      ENDIF 
    14321445      ! 
    14331446#if defined key_cpl_carbon_cycle 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r3625 r3680  
    4848   USE in_out_manager   ! I/O manager 
    4949   USE prtctl           ! Print control 
     50 
     51# if defined key_agrif 
     52   USE agrif_ice 
     53   USE agrif_lim2_update 
     54# endif 
    5055 
    5156   IMPLICIT NONE 
    … …  
    101106         ! 
    102107         CALL ice_init_2 
     108         ! 
     109# if defined key_agrif 
     110         IF( .NOT. Agrif_Root() ) CALL Agrif_InitValues_cont_lim2   ! AGRIF: set the meshes 
     111# endif 
    103112      ENDIF 
    104113 
    … …  
    106115      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only  ! 
    107116         !                                     !----------------------! 
     117# if defined key_agrif 
     118         IF( .NOT. Agrif_Root() ) lim_nbstep = MOD(lim_nbstep,Agrif_rhot()& 
     119         &*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) + 1 
     120# endif 
    108121         !  Bulk Formulea ! 
    109122         !----------------! 
    … …  
    211224         IF( lrst_ice  )   CALL lim_rst_write_2( kt )      ! Ice restart file 
    212225         ! 
     226# if defined key_agrif && defined key_lim2 
     227         IF( .NOT. Agrif_Root() )   CALL agrif_update_lim2( kt ) 
     228# endif 
     229         ! 
    213230      ENDIF                                    ! End sea-ice time step only 
    214231      ! 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r3632 r3680  
    4747 
    4848   USE prtctl           ! Print control                    (prt_ctl routine) 
    49    USE restart          ! ocean restart 
    5049   USE iom              ! IOM library 
    5150   USE in_out_manager   ! I/O manager 
    … …  
    8786      NAMELIST/namsbc/ nn_fsbc   , ln_ana    , ln_flx,  ln_blk_clio, ln_blk_core, ln_cpl,   & 
    8887         &             ln_blk_mfs, ln_apr_dyn, nn_ice,  nn_ice_embd, ln_dm2dc   , ln_rnf,   & 
    89          &             ln_ssr    , nn_fwb    , ln_cdgw 
     88         &             ln_ssr    , nn_fwb    , ln_cdgw , ln_wave , ln_sdw 
    9089      !!---------------------------------------------------------------------- 
    9190 
    … …  
    9695      ENDIF 
    9796 
     97      call flush(numout) 
    9898      REWIND( numnam )           ! Read Namelist namsbc 
    9999      READ  ( numnam, namsbc ) 
     100      call flush(numout) 
    100101 
    101102      !                          ! overwrite namelist parameter using CPP key information 
    … …  
    176177         &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
    177178 
    178        !drag coefficient read from wave model definable only with mfs bulk formulae and core  
    179        IF(ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) )              & 
    180           &   CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 
     179      IF ( ln_wave ) THEN 
     180      !Activated wave module but neither drag nor stokes drift activated 
     181         IF ( .NOT.(ln_cdgw .OR. ln_sdw) )   THEN 
     182            CALL ctl_warn( 'Ask for wave coupling but nor drag coefficient (ln_cdgw=F) neither stokes drift activated (ln_sdw=F)' ) 
     183      !drag coefficient read from wave model definable only with mfs bulk formulae and core  
     184         ELSEIF (ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) )       THEN        
     185             CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 
     186         ENDIF 
     187      ELSE 
     188      IF ( ln_cdgw .OR. ln_sdw  )                                         &  
     189         &   CALL ctl_stop('Not Activated Wave Module (ln_wave=F) but     & 
     190         & asked coupling with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ') 
     191      ENDIF  
    181192       
    182193      !                          ! Choice of the Surface Boudary Condition (set nsbc) 
    … …  
    266277      !                                                  ! averaged over nf_sbc time-step 
    267278 
    268       IF (ln_cdgw) CALL sbc_wave( kt ) 
     279      IF (ln_wave) CALL sbc_wave( kt ) 
    269280                                                   !==  sbc formulation  ==! 
    270281                                                             

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r3632 r3680  
    2121   USE closea          ! closed seas 
    2222   USE fldread         ! read input field at current time step 
    23    USE restart         ! restart 
    2423   USE in_out_manager  ! I/O manager 
    2524   USE iom             ! I/O module 
    … …  
    5756    
    5857 
    59    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    60    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    61    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
     58   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
     59   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
     60   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    6261  
    6362   !! * Substitutions   

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r3614 r3680  
    1818   USE sbcapr          ! surface boundary condition: atmospheric pressure 
    1919   USE prtctl          ! Print control                    (prt_ctl routine) 
    20    USE restart         ! ocean restart 
    2120   USE iom 
    2221   USE in_out_manager  ! I/O manager 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    r3294 r3680  
    44   !! Wave module  
    55   !!====================================================================== 
    6    !! History :  3.3.1  !   2011-09  (Adani M)  Original code 
     6   !! History :  3.3.1  !   2011-09  (Adani M)  Original code: Drag Coefficient  
     7   !!         :  3.4    !   2012-10  (Adani M)                 Stokes Drift  
    78   !!---------------------------------------------------------------------- 
    89   USE iom             ! I/O manager library 
    … …  
    1011   USE lib_mpp         ! distribued memory computing library 
    1112   USE fldread        ! read input fields 
     13   USE oce 
    1214   USE sbc_oce        ! Surface boundary condition: ocean fields 
     15   USE domvvl 
    1316 
    1417    
    … …  
    2225   PUBLIC   sbc_wave    ! routine called in sbc_blk_core or sbc_blk_mfs 
    2326    
    24    TYPE(FLD), ALLOCATABLE, DIMENSION(:)  :: sf_wave     ! structure of input fields (file informations, fields read) 
     27   INTEGER , PARAMETER ::   jpfld  = 3           ! maximum number of files to read for srokes drift 
     28   INTEGER , PARAMETER ::   jp_usd = 1           ! index of stokes drift  (i-component) (m/s)    at T-point 
     29   INTEGER , PARAMETER ::   jp_vsd = 2           ! index of stokes drift  (j-component) (m/s)    at T-point 
     30   INTEGER , PARAMETER ::   jp_wn  = 3           ! index of wave number                 (1/m)    at T-point 
     31   TYPE(FLD), ALLOCATABLE, DIMENSION(:)  :: sf_cd    ! structure of input fields (file informations, fields read) Drag Coefficient 
     32   TYPE(FLD), ALLOCATABLE, DIMENSION(:)  :: sf_sd    ! structure of input fields (file informations, fields read) Stokes Drift 
    2533   REAL(wp),PUBLIC,ALLOCATABLE,DIMENSION (:,:)       :: cdn_wave  
     34   REAL(wp),ALLOCATABLE,DIMENSION (:,:)              :: usd2d,vsd2d,uwavenum,vwavenum  
     35   REAL(wp),PUBLIC,ALLOCATABLE,DIMENSION (:,:,:)     :: usd3d,vsd3d,wsd3d  
    2636 
     37   !! * Substitutions 
     38#  include "domzgr_substitute.h90" 
    2739   !!---------------------------------------------------------------------- 
    2840   !! NEMO/OPA 4.0 , NEMO Consortium (2011)  
    … …  
    4052      !! ** Method  : - Read namelist namsbc_wave 
    4153      !!              - Read Cd_n10 fields in netcdf files  
     54      !!              - Read stokes drift 2d in netcdf files  
     55      !!              - Read wave number      in netcdf files  
     56      !!              - Compute 3d stokes drift using monochromatic 
    4257      !! ** action  :    
    4358      !!                
    4459      !!--------------------------------------------------------------------- 
    45       INTEGER, INTENT( in  ) ::  kt   ! ocean time step 
     60      USE oce,  ONLY : un,vn,hdivn,rotn 
     61      USE divcur 
     62      USE wrk_nemo 
     63#if defined key_bdy 
     64      USE bdy_oce, ONLY : bdytmask 
     65#endif 
     66      INTEGER, INTENT( in  ) ::  kt       ! ocean time step 
    4667      INTEGER                ::  ierror   ! return error code 
    47       CHARACTER(len=100)     ::  cn_dir_cdg                       ! Root directory for location of drag coefficient files 
    48       TYPE(FLD_N)            ::  sn_cdg                          ! informations about the fields to be read 
     68      INTEGER                ::  ifpr, jj,ji,jk  
     69      REAL(wp),DIMENSION(:,:,:),POINTER             ::  udummy,vdummy,hdivdummy,rotdummy 
     70      REAL                                          ::  z2dt,z1_2dt 
     71      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i     ! array of namelist informations on the fields to read 
     72      CHARACTER(len=100)     ::  cn_dir                          ! Root directory for location of drag coefficient files 
     73      TYPE(FLD_N)            ::  sn_cdg, sn_usd, sn_vsd, sn_wn   ! informations about the fields to be read 
    4974      !!--------------------------------------------------------------------- 
    50       NAMELIST/namsbc_wave/  sn_cdg, cn_dir_cdg 
     75      NAMELIST/namsbc_wave/  sn_cdg, cn_dir, sn_usd, sn_vsd, sn_wn 
    5176      !!--------------------------------------------------------------------- 
    5277 
    … …  
    6287         !              !   name   !  (hours)  !   name     !   (T/F)    !  (T/F)  !  'monthly'  ! filename ! pairs    ! 
    6388         sn_cdg = FLD_N('cdg_wave'  ,    1     ,'drag_coeff',  .true.    , .false. ,   'daily'   , ''       , ''       ) 
    64          cn_dir_cdg = './'          ! directory in which the Patm data are  
     89         sn_usd = FLD_N('sdw_wave'  ,    1     ,'u_sd2d',      .true.    , .false. ,   'daily'   , ''       , ''       ) 
     90         sn_vsd = FLD_N('sdw_wave'  ,    1     ,'v_sd2d',      .true.    , .false. ,   'daily'   , ''       , ''       ) 
     91         sn_wn = FLD_N( 'sdw_wave'  ,    1     ,'wave_num',    .true.    , .false. ,   'daily'   , ''       , ''       ) 
     92         cn_dir = './'          ! directory in which the wave data are  
    6593          
    6694 
    … …  
    6997         ! 
    7098 
    71          ALLOCATE( sf_wave(1), STAT=ierror )           !* allocate and fill sf_wave with sn_cdg 
    72          IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave: unable to allocate sf_wave structure' ) 
    73          ! 
    74          CALL fld_fill( sf_wave, (/ sn_cdg /), cn_dir_cdg, 'sbc_wave', 'Wave module ', 'namsbc_wave' ) 
    75                                 ALLOCATE( sf_wave(1)%fnow(jpi,jpj,1)   ) 
    76          IF( sn_cdg%ln_tint )   ALLOCATE( sf_wave(1)%fdta(jpi,jpj,1,2) ) 
    77          ALLOCATE( cdn_wave(jpi,jpj) ) 
    78          cdn_wave(:,:) = 0.0 
     99         IF ( ln_cdgw ) THEN 
     100            ALLOCATE( sf_cd(1), STAT=ierror )           !* allocate and fill sf_wave with sn_cdg 
     101            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave: unable to allocate sf_wave structure' ) 
     102            ! 
     103                                   ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1)   ) 
     104            IF( sn_cdg%ln_tint )   ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) 
     105            CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave', 'Wave module ', 'namsbc_wave' ) 
     106            ALLOCATE( cdn_wave(jpi,jpj) ) 
     107            cdn_wave(:,:) = 0.0 
     108        ENDIF 
     109         IF ( ln_sdw ) THEN 
     110            slf_i(jp_usd) = sn_usd ; slf_i(jp_vsd) = sn_vsd; slf_i(jp_wn) = sn_wn 
     111            ALLOCATE( sf_sd(3), STAT=ierror )           !* allocate and fill sf_wave with sn_cdg 
     112            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave: unable to allocate sf_wave structure' ) 
     113            ! 
     114            DO ifpr= 1, jpfld 
     115               ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) 
     116               IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) 
     117            END DO 
     118            CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave', 'Wave module ', 'namsbc_wave' ) 
     119            ALLOCATE( usd2d(jpi,jpj),vsd2d(jpi,jpj),uwavenum(jpi,jpj),vwavenum(jpi,jpj) ) 
     120            ALLOCATE( usd3d(jpi,jpj,jpk),vsd3d(jpi,jpj,jpk),wsd3d(jpi,jpj,jpk) ) 
     121            usd2d(:,:) = 0.0 ;  vsd2d(:,:) = 0.0 ; uwavenum(:,:) = 0.0 ; vwavenum(:,:) = 0.0 
     122            usd3d(:,:,:) = 0.0 ;vsd3d(:,:,:) = 0.0 ; wsd3d(:,:,:) = 0.0 
     123         ENDIF 
    79124      ENDIF 
    80125         ! 
    81126         ! 
    82       CALL fld_read( kt, nn_fsbc, sf_wave )      !* read drag coefficient from external forcing 
    83       cdn_wave(:,:) = sf_wave(1)%fnow(:,:,1) 
     127      IF ( ln_cdgw ) THEN 
     128         CALL fld_read( kt, nn_fsbc, sf_cd )      !* read drag coefficient from external forcing 
     129         cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) 
     130      ENDIF 
     131      IF ( ln_sdw )  THEN 
     132          CALL fld_read( kt, nn_fsbc, sf_sd )      !* read drag coefficient from external forcing 
    84133 
     134         ! Interpolate wavenumber, stokes drift into the grid_V and grid_V 
     135         !------------------------------------------------- 
     136 
     137         DO jj = 1, jpjm1 
     138            DO ji = 1, jpim1 
     139               uwavenum(ji,jj)=0.5 * ( 2. - umask(ji,jj,1) ) * ( sf_sd(3)%fnow(ji,jj,1) * tmask(ji,jj,1) & 
     140               &                                + sf_sd(3)%fnow(ji+1,jj,1) * tmask(ji+1,jj,1) ) 
     141 
     142               vwavenum(ji,jj)=0.5 * ( 2. - vmask(ji,jj,1) ) * ( sf_sd(3)%fnow(ji,jj,1) * tmask(ji,jj,1) & 
     143               &                                + sf_sd(3)%fnow(ji,jj+1,1) * tmask(ji,jj+1,1) ) 
     144 
     145               usd2d(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( sf_sd(1)%fnow(ji,jj,1) * tmask(ji,jj,1) & 
     146               &                                + sf_sd(1)%fnow(ji+1,jj,1) * tmask(ji+1,jj,1) ) 
     147 
     148               vsd2d(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( sf_sd(2)%fnow(ji,jj,1) * tmask(ji,jj,1) & 
     149               &                                + sf_sd(2)%fnow(ji,jj+1,1) * tmask(ji,jj+1,1) ) 
     150            END DO 
     151         END DO 
     152 
     153          !Computation of the 3d Stokes Drift 
     154          DO jk = 1, jpk 
     155             DO jj = 1, jpj-1 
     156                DO ji = 1, jpi-1 
     157                   usd3d(ji,jj,jk) = usd2d(ji,jj)*exp(2.0*uwavenum(ji,jj)*(-MIN( gdept(ji,jj,jk) , gdept(ji+1,jj  ,jk)))) 
     158                   vsd3d(ji,jj,jk) = vsd2d(ji,jj)*exp(2.0*vwavenum(ji,jj)*(-MIN( gdept(ji,jj,jk) , gdept(ji  ,jj+1,jk)))) 
     159                END DO 
     160             END DO 
     161             usd3d(jpi,:,jk) = usd2d(jpi,:)*exp( 2.0*uwavenum(jpi,:)*(-gdept(jpi,:,jk)) ) 
     162             vsd3d(:,jpj,jk) = vsd2d(:,jpj)*exp( 2.0*vwavenum(:,jpj)*(-gdept(:,jpj,jk)) ) 
     163          END DO 
     164 
     165          CALL wrk_alloc( jpi,jpj,jpk,udummy,vdummy,hdivdummy,rotdummy) 
     166           
     167          udummy(:,:,:)=un(:,:,:) 
     168          vdummy(:,:,:)=vn(:,:,:) 
     169          hdivdummy(:,:,:)=hdivn(:,:,:) 
     170          rotdummy(:,:,:)=rotn(:,:,:) 
     171          un(:,:,:)=usd3d(:,:,:) 
     172          vn(:,:,:)=vsd3d(:,:,:) 
     173          CALL div_cur(kt) 
     174      !                                           !------------------------------! 
     175      !                                           !     Now Vertical Velocity    ! 
     176      !                                           !------------------------------! 
     177          z2dt = 2._wp * rdt                              ! set time step size (Euler/Leapfrog) 
     178 
     179          z1_2dt = 1.e0 / z2dt 
     180          DO jk = jpkm1, 1, -1                             ! integrate from the bottom the hor. divergence 
     181             ! - ML - need 3 lines here because replacement of fse3t by its expression yields too long lines otherwise 
     182             wsd3d(:,:,jk) = wsd3d(:,:,jk+1) -   fse3t_n(:,:,jk) * hdivn(:,:,jk)        & 
     183                &                      - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) )    & 
     184                &                         * tmask(:,:,jk) * z1_2dt 
     185#if defined key_bdy 
     186             wsd3d(:,:,jk) = wsd3d(:,:,jk) * bdytmask(:,:) 
     187#endif 
     188          END DO 
     189          hdivn(:,:,:)=hdivdummy(:,:,:) 
     190          rotn(:,:,:)=rotdummy(:,:,:) 
     191          vn(:,:,:)=vdummy(:,:,:) 
     192          un(:,:,:)=udummy(:,:,:) 
     193          CALL wrk_dealloc( jpi,jpj,jpk,udummy,vdummy,hdivdummy,rotdummy) 
     194      ENDIF 
    85195   END SUBROUTINE sbc_wave 
    86196       

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r3294 r3680  
    4545   LOGICAL ::   ln_traadv_qck    = .FALSE.   ! QUICKEST scheme flag 
    4646 
     47 
    4748   INTEGER ::   nadv   ! choice of the type of advection scheme 
    4849 
    … …  
    152153      NAMELIST/namtra_adv/ ln_traadv_cen2 , ln_traadv_tvd,     & 
    153154         &                 ln_traadv_muscl, ln_traadv_muscl2,  & 
    154          &                 ln_traadv_ubs  , ln_traadv_qck 
     155         &                 ln_traadv_ubs  , ln_traadv_qck,     & 
     156         &                 ln_traadv_msc_ups 
    155157      !!---------------------------------------------------------------------- 
    156158 
    … …  
    169171         WRITE(numout,*) '      UBS    advection scheme        ln_traadv_ubs    = ', ln_traadv_ubs 
    170172         WRITE(numout,*) '      QUICKEST advection scheme      ln_traadv_qck    = ', ln_traadv_qck 
     173         WRITE(numout,*) '      upstream scheme within muscl   ln_traadv_msc_ups= ', ln_traadv_msc_ups 
    171174      ENDIF 
    172175 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r3294 r3680  
    2929   USE diaptr          ! poleward transport diagnostics 
    3030   USE zdf_oce         ! ocean vertical physics 
    31    USE restart         ! ocean restart 
    3231   USE trc_oce         ! share passive tracers/Ocean variables 
    3332   USE lib_mpp         ! MPP library 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r3625 r3680  
    88   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module 
    99   !!            3.2  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
     10   !!            3.4  !  2012-06  (P. Oddo, M. Vichi) include the upstream where needed 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    2829   USE timing         ! Timing 
    2930   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     31   USE eosbn2          ! equation of state 
     32   USE sbcrnf          ! river runoffs 
    3033 
    3134   IMPLICIT NONE 
    … …  
    3437   PUBLIC   tra_adv_muscl  ! routine called by step.F90 
    3538 
    36    LOGICAL  :: l_trd       ! flag to compute trends 
    37  
     39   LOGICAL  :: l_trd                        ! flag to compute trends 
     40   LOGICAL, PUBLIC  :: ln_traadv_msc_ups= .FALSE.   ! use upstream scheme within muscl 
     41 
     42   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits 
     43   !                                                             !  and in closed seas (orca 2 and 4 configurations) 
     44   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zind         !: mixed upstream/centered index 
    3845   !! * Substitutions 
    3946#  include "domzgr_substitute.h90" 
    … …  
    7986      REAL(wp) ::   ztra, zbtr, zdt, zalpha   !   -      - 
    8087      REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 
     88      INTEGER  ::   ierr 
    8189      !!---------------------------------------------------------------------- 
    8290      ! 
    … …  
    8997         IF(lwp) WRITE(numout,*) 
    9098         IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 
     99         IF(lwp) WRITE(numout,*) '        : xed up-stream            ' , ln_traadv_msc_ups 
    91100         IF(lwp) WRITE(numout,*) '~~~~~~~' 
     101         IF(lwp) WRITE(numout,*) 
     102         ! 
     103         ! 
     104         IF(ln_traadv_msc_ups) THEN 
     105           IF (.not. ALLOCATED(upsmsk))THEN 
     106               ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
     107               IF( ierr /= 0 )   CALL ctl_stop('STOP', 'tra_adv_muscl: unable to allocate upsmsk array') 
     108           ENDIF 
     109           upsmsk(:,:) = 0._wp                             ! not upstream by default 
     110         ENDIF 
     111 
     112         IF (.not. ALLOCATED(zind))THEN 
     113             ALLOCATE( zind(jpi,jpj,jpk), STAT=ierr ) 
     114             IF( ierr /= 0 )   CALL ctl_stop('STOP', 'tra_adv_muscl: unable to allocate zind array') 
     115         ENDIF 
     116         ! 
    92117         ! 
    93118         l_trd = .FALSE. 
    94119         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    95       ENDIF 
    96  
     120 
     121      ! 
     122      ! Upstream / centered scheme indicator 
     123      ! ------------------------------------ 
     124         zind(:,:,:) = 1._wp                             ! set equal to 0 where up-stream is needed 
     125 
     126         IF(ln_traadv_msc_ups) THEN 
     127           DO jk = 1, jpk 
     128              DO jj = 1, jpj 
     129                 DO ji = 1, jpi 
     130                    zind(ji,jj,jk) = 1  - MAX (           & 
     131                       rnfmsk(ji,jj) * rnfmsk_z(jk),      &  ! near runoff mouths (& closed sea outflows) 
     132                       upsmsk(ji,jj) ) * tmask(ji,jj,jk)     ! some of some straits 
     133                 END DO 
     134              END DO 
     135           END DO 
     136         ENDIF  
     137      ! 
     138      ENDIF ! end kit000 
    97139      !                                                     ! =========== 
    98140      DO jn = 1, kjpt                                       ! tracer loop 
    … …  
    149191                  zalpha = 0.5 - z0u 
    150192                  zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 
    151                   zzwx = ptb(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 
    152                   zzwy = ptb(ji  ,jj,jk,jn) + zu * zslpx(ji  ,jj,jk) 
     193                  zzwx = ptb(ji+1,jj,jk,jn) + zind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk)) 
     194                  zzwy = ptb(ji  ,jj,jk,jn) + zind(ji,jj,jk) * (zu * zslpx(ji  ,jj,jk)) 
    153195                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    154196                  ! 
    … …  
    156198                  zalpha = 0.5 - z0v 
    157199                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 
    158                   zzwx = ptb(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 
    159                   zzwy = ptb(ji,jj  ,jk,jn) + zv * zslpy(ji,jj  ,jk)  
     200                  zzwx = ptb(ji,jj+1,jk,jn) + zind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk)) 
     201                  zzwy = ptb(ji,jj  ,jk,jn) + zind(ji,jj,jk) * (zv * zslpy(ji,jj  ,jk)) 
    160202                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    161203               END DO 
    … …  
    231273                  zalpha = 0.5 + z0w 
    232274                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr  
    233                   zzwx = ptb(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 
    234                   zzwy = ptb(ji,jj,jk  ,jn) + zw * zslpx(ji,jj,jk  ) 
     275                  zzwx = ptb(ji,jj,jk+1,jn) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1)) 
     276                  zzwy = ptb(ji,jj,jk  ,jn) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk  )) 
    235277                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    236278               END DO  

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r3625 r3680  
    2727   USE iom             ! I/O manager 
    2828   USE fldread         ! read input fields 
    29    USE restart         ! ocean restart 
    3029   USE lib_mpp         ! MPP library 
    3130   USE wrk_nemo       ! Memory Allocation 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r3625 r3680  
    2323   USE in_out_manager  ! I/O manager 
    2424   USE prtctl          ! Print control 
    25    USE restart         ! ocean restart 
    2625   USE sbcrnf          ! River runoff   
    2726   USE sbcmod          ! ln_rnf   

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRD/trdmld.F90

    r3294 r3680  
    3636   USE trdmld_rst      ! restart for diagnosing the ML trends 
    3737   USE prtctl          ! Print control 
    38    USE restart         ! for lrst_oce 
    3938   USE lib_mpp         ! MPP library 
    4039   USE wrk_nemo        ! Memory allocation 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/TRD/trdmld_rst.F90

    r2528 r3680  
    1212   USE in_out_manager  ! I/O manager 
    1313   USE iom             ! I/O module 
    14    USE restart         ! only for lrst_oce 
    1514 
    1615   IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r3625 r3680  
    2323   USE phycst         ! physical constants 
    2424   USE zdfmxl         ! mixed layer 
    25    USE restart        ! only for lrst_oce 
    2625   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    2726   USE lib_mpp        ! MPP manager 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r2715 r3680  
    2626   USE tranpc          ! convection: non penetrative adjustment 
    2727   USE ldfslp          ! iso-neutral slopes 
    28    USE restart         ! ocean restart 
    2928 
    3029   USE in_out_manager  ! I/O manager 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r3632 r3680  
    4444   USE zdf_oce        ! vertical physics: ocean variables 
    4545   USE zdfmxl         ! vertical physics: mixed layer 
    46    USE restart        ! ocean restart 
    4746   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    4847   USE prtctl         ! Print control 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/lib_cray.f90

    r2528 r3680  
    1010!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    1111!!---------------------------------------------------------------------- 
     12SUBROUTINE lib_cray 
     13      WRITE(*,*) 'lib_cray: You should not have seen this print! error?' 
     14END SUBROUTINE lib_cray 
     15 
    1216SUBROUTINE wheneq ( i, x, j, t, ind, nn ) 
    1317        IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r3651 r3680  
    124124      !                            !-----------------------! 
    125125#if defined key_agrif 
    126       CALL Agrif_Declare_Var       ! AGRIF: set the meshes 
     126      CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM 
     127      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA  
    127128# if defined key_top 
    128       CALL Agrif_Declare_Var_Top   ! AGRIF: set the meshes 
     129      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
     130# endif 
     131# if defined key_lim2 
     132      CALL Agrif_Declare_Var_lim2  !  "      "   "   "      "  LIM 
    129133# endif 
    130134#endif 
    … …  
    525529      USE ldftra_oce, ONLY: ldftra_oce_alloc 
    526530      USE trc_oce   , ONLY: trc_oce_alloc 
     531#if defined key_diadct  
     532      USE diadct    , ONLY: diadct_alloc  
     533#endif  
    527534      ! 
    528535      INTEGER :: ierr 
    … …  
    538545      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges 
    539546      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays 
     547      ! 
     548#if defined key_diadct  
     549      ierr = ierr + diadct_alloc    ()          !  
     550#endif  
    540551      ! 
    541552      IF( lk_mpp    )   CALL mpp_sum( ierr ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/par_AMM_12km.h90

    r3294 r3680  
    1919      jpidta  = 198,        &  !: first horizontal dimension > or = to jpi 
    2020      jpjdta  = 224,        &  !: second                     > or = to jpj 
    21       jpkdta  = 33,         &  !: number of levels           > or = to jpk 
     21      jpkdta  = 51,         &  !: number of levels           > or = to jpk 
    2222      ! total domain matrix size 
    2323      jpiglo  = jpidta,      &  !: first  dimension of global domain --> i 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/step.F90

    r3651 r3680  
    3636   USE agrif_opa_sponge ! Momemtum and tracers sponges 
    3737#endif 
     38   USE restart          ! restart 
    3839 
    3940   IMPLICIT NONE 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r3651 r3680  
    100100 
    101101   USE stpctl           ! time stepping control            (stp_ctl routine) 
    102    USE restart          ! ocean restart                    (rst_wri routine) 
    103102   USE prtctl           ! Print control                    (prt_ctl routine) 
    104103 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/C14b/par_c14b.F90

    r2715 r3680  
    66   !! History :   2.0  !  2008-12  (C. Ethe, G. Madec)  revised architecture 
    77   !!---------------------------------------------------------------------- 
    8    USE par_lobster, ONLY : jp_lobster      !: number of tracers in LOBSTER 
    9    USE par_lobster, ONLY : jp_lobster_2d   !: number of 2D diag in LOBSTER 
    10    USE par_lobster, ONLY : jp_lobster_3d   !: number of 3D diag in LOBSTER 
    11    USE par_lobster, ONLY : jp_lobster_trd  !: number of biological diag in LOBSTER 
    12  
    138   USE par_pisces , ONLY : jp_pisces       !: number of tracers in PISCES 
    149   USE par_pisces , ONLY : jp_pisces_2d    !: number of 2D diag in PISCES 
    … …  
    2419   IMPLICIT NONE 
    2520 
    26    INTEGER, PARAMETER ::   jp_lb      = jp_lobster     + jp_pisces     + jp_cfc     !: cum. number of pass. tracers 
    27    INTEGER, PARAMETER ::   jp_lb_2d   = jp_lobster_2d  + jp_pisces_2d  + jp_cfc_2d  !: 
    28    INTEGER, PARAMETER ::   jp_lb_3d   = jp_lobster_3d  + jp_pisces_3d  + jp_cfc_3d  !: 
    29    INTEGER, PARAMETER ::   jp_lb_trd  = jp_lobster_trd + jp_pisces_trd + jp_cfc_trd !: 
     21   INTEGER, PARAMETER ::   jp_lb      = jp_pisces     + jp_cfc     !: cum. number of pass. tracers 
     22   INTEGER, PARAMETER ::   jp_lb_2d   = jp_pisces_2d  + jp_cfc_2d  !: 
     23   INTEGER, PARAMETER ::   jp_lb_3d   = jp_pisces_3d  + jp_cfc_3d  !: 
     24   INTEGER, PARAMETER ::   jp_lb_trd  = jp_pisces_trd + jp_cfc_trd !: 
    3025    
    3126#if defined key_c14b 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/C14b/trcsms_c14b.F90

    r3294 r3680  
    125125         xdecay  = EXP( - xlambda * rdt ) 
    126126         xaccum  = 1._wp -  xdecay 
     127         ! 
     128         IF( ln_rsttr ) THEN 
     129            IF(lwp) WRITE(numout,*) 
     130            IF(lwp) WRITE(numout,*) ' Read specific variables from C14b model ' 
     131            IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
     132            CALL iom_get( numrtr, jpdom_autoglo, 'qint_c14', qint_c14 ) 
     133         ENDIF 
     134         ! 
     135         IF(lwp) WRITE(numout,*) 
     136         ! 
    127137      ENDIF 
    128138 
    … …  
    271281      END DO 
    272282 
     283      ! 
     284      IF( lrst_trc ) THEN 
     285         IF(lwp) WRITE(numout,*) 
     286         IF(lwp) WRITE(numout,*) 'trc_sms_c14b : cumulated input function fields written in ocean restart file ',   & 
     287            &                    'at it= ', kt,' date= ', ndastp 
     288         IF(lwp) WRITE(numout,*) '~~~~' 
     289         CALL iom_rstput( kt, nitrst, numrtw, 'qint_c14', qint_c14 ) 
     290      ENDIF 
     291      !     
    273292      IF( ln_diatrc ) THEN 
    274293         IF( lk_iomput ) THEN 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/CFC/par_cfc.F90

    r3294 r3680  
    1010   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    1111   !!---------------------------------------------------------------------- 
    12    USE par_lobster, ONLY : jp_lobster      !: number of tracers in LOBSTER 
    13    USE par_lobster, ONLY : jp_lobster_2d   !: number of 2D diag in LOBSTER 
    14    USE par_lobster, ONLY : jp_lobster_3d   !: number of 3D diag in LOBSTER 
    15    USE par_lobster, ONLY : jp_lobster_trd  !: number of biological diag in LOBSTER 
    16  
    1712   USE par_pisces , ONLY : jp_pisces       !: number of tracers in PISCES 
    1813   USE par_pisces , ONLY : jp_pisces_2d    !: number of 2D diag in PISCES 
    … …  
    2217   IMPLICIT NONE 
    2318 
    24    INTEGER, PARAMETER ::   jp_lc      = jp_lobster     + jp_pisces     !: cumulative number of passive tracers 
    25    INTEGER, PARAMETER ::   jp_lc_2d   = jp_lobster_2d  + jp_pisces_2d  !: 
    26    INTEGER, PARAMETER ::   jp_lc_3d   = jp_lobster_3d  + jp_pisces_3d  !: 
    27    INTEGER, PARAMETER ::   jp_lc_trd  = jp_lobster_trd + jp_pisces_trd !: 
     19   INTEGER, PARAMETER ::   jp_lc      = jp_pisces     !: cumulative number of passive tracers 
     20   INTEGER, PARAMETER ::   jp_lc_2d   = jp_pisces_2d  !: 
     21   INTEGER, PARAMETER ::   jp_lc_3d   = jp_pisces_3d  !: 
     22   INTEGER, PARAMETER ::   jp_lc_trd  = jp_pisces_trd !: 
    2823    
    2924#if defined key_cfc 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/CFC/trcsms_cfc.F90

    r3294 r3680  
    1313   !!---------------------------------------------------------------------- 
    1414   !!   trc_sms_cfc  :  compute and add CFC suface forcing to CFC trends 
    15    !!   trc_cfc_cst  :  sets constants for CFC surface forcing computation 
     15   !!   cfc_init     :  sets constants for CFC surface forcing computation 
    1616   !!---------------------------------------------------------------------- 
    1717   USE oce_trc       ! Ocean variables 
    … …  
    9999      ENDIF 
    100100 
    101       IF( kt == nittrc000 )   CALL trc_cfc_cst 
     101      IF( kt == nittrc000 )   CALL cfc_init 
    102102 
    103103      ! Temporal interpolation 
    … …  
    176176         !                                                  !----------------! 
    177177      END DO                                                !  end CFC loop  ! 
    178       !                                                     !----------------! 
     178      ! 
     179      IF( lrst_trc ) THEN 
     180         IF(lwp) WRITE(numout,*) 
     181         IF(lwp) WRITE(numout,*) 'trc_sms_cfc : cumulated input function fields written in ocean restart file ',   & 
     182            &                    'at it= ', kt,' date= ', ndastp 
     183         IF(lwp) WRITE(numout,*) '~~~~' 
     184         DO jn = jp_cfc0, jp_cfc1 
     185            CALL iom_rstput( kt, nitrst, numrtw, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jn) ) 
     186         END DO 
     187      ENDIF 
     188      !                                               
    179189      IF( ln_diatrc ) THEN 
    180190        ! 
    … …  
    200210 
    201211 
    202    SUBROUTINE trc_cfc_cst 
     212   SUBROUTINE cfc_init 
    203213      !!--------------------------------------------------------------------- 
    204       !!                     ***  trc_cfc_cst  ***   
     214      !!                     ***  cfc_init  ***   
    205215      !! 
    206216      !! ** Purpose : sets constants for CFC model 
    207217      !!--------------------------------------------------------------------- 
     218      INTEGER :: jn 
    208219 
    209220      ! coefficient for CFC11  
    … …  
    245256      sca(4,2) =  -0.067430 
    246257 
    247    END SUBROUTINE trc_cfc_cst 
     258      IF( ln_rsttr ) THEN 
     259         IF(lwp) WRITE(numout,*) 
     260         IF(lwp) WRITE(numout,*) ' Read specific variables from CFC model ' 
     261         IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
     262         ! 
     263         DO jn = jp_cfc0, jp_cfc1 
     264            CALL iom_get( numrtr, jpdom_autoglo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jn) )  
     265         END DO 
     266      ENDIF 
     267      IF(lwp) WRITE(numout,*) 
     268      ! 
     269   END SUBROUTINE cfc_init 
    248270 
    249271 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/MY_TRC/par_my_trc.F90

    r2528 r3680  
    1010   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    1111   !!---------------------------------------------------------------------- 
    12    USE par_lobster, ONLY : jp_lobster      !: number of tracers in LOBSTER 
    13    USE par_lobster, ONLY : jp_lobster_2d   !: number of 2D diag in LOBSTER 
    14    USE par_lobster, ONLY : jp_lobster_3d   !: number of 3D diag in LOBSTER 
    15    USE par_lobster, ONLY : jp_lobster_trd  !: number of biological diag in LOBSTER 
    16  
    1712   USE par_pisces , ONLY : jp_pisces       !: number of tracers in PISCES 
    1813   USE par_pisces , ONLY : jp_pisces_2d    !: number of 2D diag in PISCES 
    … …  
    3227   IMPLICIT NONE 
    3328 
    34    INTEGER, PARAMETER ::   jp_lm      = jp_lobster     + jp_pisces     + jp_cfc     + jp_c14b     !:  
    35    INTEGER, PARAMETER ::   jp_lm_2d   = jp_lobster_2d  + jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d  !: 
    36    INTEGER, PARAMETER ::   jp_lm_3d   = jp_lobster_3d  + jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d  !: 
    37    INTEGER, PARAMETER ::   jp_lm_trd  = jp_lobster_trd + jp_pisces_trd + jp_cfc_trd + jp_c14b_trd !: 
     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 !: 
    3833 
    3934#if defined key_my_trc 
    … …  
    4237   !!--------------------------------------------------------------------- 
    4338   LOGICAL, PUBLIC, PARAMETER ::   lk_my_trc     = .TRUE.   !: PTS flag  
    44    INTEGER, PUBLIC, PARAMETER ::   jp_my_trc     =  2       !: number of PTS tracers 
     39   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc     =  1       !: number of PTS tracers 
    4540   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc_2d  =  0       !: additional 2d output arrays ('key_trc_diaadd') 
    4641   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc_3d  =  0       !: additional 3d output arrays ('key_trc_diaadd') 
    … …  
    4944   ! assign an index in trc arrays for each PTS prognostic variables 
    5045   INTEGER, PUBLIC, PARAMETER ::   jpmyt1 = jp_lm + 1     !: 1st MY_TRC tracer 
    51    INTEGER, PUBLIC, PARAMETER ::   jpmyt2 = jp_lm + 2     !: 2nd MY_TRC tracer 
    5246 
    5347#else 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcnam_my_trc.F90

    r2528 r3680  
    22   !!====================================================================== 
    33   !!                      ***  MODULE trcnam_my_trc  *** 
    4    !! TOP :   initialisation of some run parameters for LOBSTER bio-model 
     4   !! TOP :   initialisation of some run parameters for MY_TRC bio-model 
    55   !!====================================================================== 
    66   !! History :   2.0  !  2007-12  (C. Ethe, G. Madec) Original code 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcsms_my_trc.F90

    r3294 r3680  
    6262      END WHERE 
    6363 
    64       WHERE( ((glamt <= -165) .OR. (glamt >= 160)) .AND. (gphit <= -76) .AND. (gphit >=-80)) 
    65         trn(:,:,1,jpmyt2) = 1._wp 
    66         trb(:,:,1,jpmyt2) = 1._wp 
    67         tra(:,:,1,jpmyt2) = 0._wp 
    68       END WHERE 
    69  
    7064      IF( l_trdtrc ) THEN      ! Save the trends in the ixed layer 
    7165          DO jn = jp_myt0, jp_myt1 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r3531 r3680  
    105105            DO ji = 1, jpi 
    106106               zdep    = rfact2 / fse3t(ji,jj,1) 
    107                zwflux  = ( emps(ji,jj) - emp(ji,jj) ) & 
    108                &        * tsn(ji,jj,1,jp_sal) / ( tsn(ji,jj,1,jp_sal) - 6.0 ) / 1000. 
     107    !           zwflux  = ( emps(ji,jj) - emp(ji,jj) ) & 
     108    !           &        * tsn(ji,jj,1,jp_sal) / ( tsn(ji,jj,1,jp_sal) - 6.0 ) / 1000. 
     109               zwflux = 0. 
    109110               zfminus = MIN( 0., -zwflux ) * trn(ji,jj,1,jpfer) * zdep 
    110111               zfplus  = MAX( 0., -zwflux ) * 10E-9 * zdep 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/par_pisces.F90

    r3295 r3680  
    1010   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    1111   !!---------------------------------------------------------------------- 
    12    USE par_lobster, ONLY : jp_lobster      !: number of tracers in LOBSTER 
    13    USE par_lobster, ONLY : jp_lobster_2d   !: number of 2D diag in LOBSTER 
    14    USE par_lobster, ONLY : jp_lobster_3d   !: number of 3D diag in LOBSTER 
    15    USE par_lobster, ONLY : jp_lobster_trd  !: number of biological diag in LOBSTER 
    1612 
    1713   IMPLICIT NONE 
    1814 
    19    INTEGER, PUBLIC, PARAMETER ::   jp_lp      = jp_lobster      !: cumulative number of already defined TRC 
    20    INTEGER, PUBLIC, PARAMETER ::   jp_lp_2d   = jp_lobster_2d   !: 
    21    INTEGER, PUBLIC, PARAMETER ::   jp_lp_3d   = jp_lobster_3d   !: 
    22    INTEGER, PUBLIC, PARAMETER ::   jp_lp_trd  = jp_lobster_trd  !: 
     15#if defined key_pisces_reduced 
     16   !!--------------------------------------------------------------------- 
     17   !!   'key_pisces_reduced'   :                                LOBSTER bio-model 
     18   !!--------------------------------------------------------------------- 
     19   LOGICAL, PUBLIC, PARAMETER ::   lk_pisces     = .TRUE.  !: PISCES flag  
     20   LOGICAL, PUBLIC, PARAMETER ::   lk_p4z        = .FALSE. !: p4z flag  
     21   INTEGER, PUBLIC, PARAMETER ::   jp_pisces     =  6      !: number of passive tracers 
     22   INTEGER, PUBLIC, PARAMETER ::   jp_pisces_2d  =  19     !: additional 2d output  
     23   INTEGER, PUBLIC, PARAMETER ::   jp_pisces_3d  =   3     !: additional 3d output  
     24   INTEGER, PUBLIC, PARAMETER ::   jp_pisces_trd =   17    !: number of sms trends for PISCES 
    2325 
    24 #if defined key_pisces  &&  defined key_kriest 
     26   ! assign an index in trc arrays for each LOBSTER prognostic variables 
     27   INTEGER, PUBLIC, PARAMETER ::   jpdet     =  1        !: detritus                    [mmoleN/m3] 
     28   INTEGER, PUBLIC, PARAMETER ::   jpzoo     =  2        !: zooplancton concentration   [mmoleN/m3] 
     29   INTEGER, PUBLIC, PARAMETER ::   jpphy     =  3        !: phytoplancton concentration [mmoleN/m3] 
     30   INTEGER, PUBLIC, PARAMETER ::   jpno3     =  4        !: nitrate concentration       [mmoleN/m3] 
     31   INTEGER, PUBLIC, PARAMETER ::   jpnh4     =  5        !: ammonium concentration      [mmoleN/m3] 
     32   INTEGER, PUBLIC, PARAMETER ::   jpdom     =  6        !: dissolved organic matter    [mmoleN/m3] 
     33 
     34   ! productive layer depth 
     35   INTEGER, PUBLIC, PARAMETER ::   jpkb      = 12        !: first vertical layers where biology is active 
     36   INTEGER, PUBLIC, PARAMETER ::   jpkbm1    = jpkb - 1  !: first vertical layers where biology is active 
     37 
     38#elif defined key_pisces  &&  defined key_kriest 
    2539   !!--------------------------------------------------------------------- 
    2640   !!   'key_pisces' & 'key_kriest'                 PISCES bio-model + ??? 
    2741   !!--------------------------------------------------------------------- 
    2842   LOGICAL, PUBLIC, PARAMETER ::   lk_pisces     = .TRUE.  !: PISCES flag  
     43   LOGICAL, PUBLIC, PARAMETER ::   lk_p4z        = .TRUE. !: p4z flag  
    2944   LOGICAL, PUBLIC, PARAMETER ::   lk_kriest     = .TRUE.  !: Kriest flag  
    3045   INTEGER, PUBLIC, PARAMETER ::   jp_pisces     =  23     !: number of passive tracers 
    … …  
    3651   !    WARNING: be carefull about the order when reading the restart 
    3752        !   !!gm  this warning should be obsolet with IOM 
    38    INTEGER, PUBLIC, PARAMETER ::   jpdic = jp_lp + 1    !: dissolved inoganic carbon concentration  
    39    INTEGER, PUBLIC, PARAMETER ::   jptal = jp_lp + 2    !: total alkalinity  
    40    INTEGER, PUBLIC, PARAMETER ::   jpoxy = jp_lp + 3    !: oxygen carbon concentration  
    41    INTEGER, PUBLIC, PARAMETER ::   jpcal = jp_lp + 4    !: calcite  concentration  
    42    INTEGER, PUBLIC, PARAMETER ::   jppo4 = jp_lp + 5    !: phosphate concentration  
    43    INTEGER, PUBLIC, PARAMETER ::   jppoc = jp_lp + 6    !: small particulate organic phosphate concentration 
    44    INTEGER, PUBLIC, PARAMETER ::   jpsil = jp_lp + 7    !: silicate concentration 
    45    INTEGER, PUBLIC, PARAMETER ::   jpphy = jp_lp + 8    !: phytoplancton concentration  
    46    INTEGER, PUBLIC, PARAMETER ::   jpzoo = jp_lp + 9    !: zooplancton concentration 
    47    INTEGER, PUBLIC, PARAMETER ::   jpdoc = jp_lp + 10    !: dissolved organic carbon concentration  
    48    INTEGER, PUBLIC, PARAMETER ::   jpdia = jp_lp + 11    !: Diatoms Concentration 
    49    INTEGER, PUBLIC, PARAMETER ::   jpmes = jp_lp + 12    !: Mesozooplankton Concentration 
    50    INTEGER, PUBLIC, PARAMETER ::   jpdsi = jp_lp + 13    !: (big) Silicate Concentration 
    51    INTEGER, PUBLIC, PARAMETER ::   jpfer = jp_lp + 14    !: Iron Concentration 
    52    INTEGER, PUBLIC, PARAMETER ::   jpnum = jp_lp + 15    !: Big iron particles Concentration 
    53    INTEGER, PUBLIC, PARAMETER ::   jpsfe = jp_lp + 16    !: number of particulate organic phosphate concentration 
    54    INTEGER, PUBLIC, PARAMETER ::   jpdfe = jp_lp + 17    !: Diatoms iron Concentration 
    55    INTEGER, PUBLIC, PARAMETER ::   jpgsi = jp_lp + 18    !: Diatoms Silicate Concentration 
    56    INTEGER, PUBLIC, PARAMETER ::   jpnfe = jp_lp + 19    !: Nano iron Concentration 
    57    INTEGER, PUBLIC, PARAMETER ::   jpnch = jp_lp + 20    !: Nano Chlorophyll Concentration 
    58    INTEGER, PUBLIC, PARAMETER ::   jpdch = jp_lp + 21    !: Diatoms Chlorophyll Concentration 
    59    INTEGER, PUBLIC, PARAMETER ::   jpno3 = jp_lp + 22    !: Nitrates Concentration 
    60    INTEGER, PUBLIC, PARAMETER ::   jpnh4 = jp_lp + 23    !: Ammonium Concentration 
     53   INTEGER, PUBLIC, PARAMETER ::   jpdic = 1    !: dissolved inoganic carbon concentration  
     54   INTEGER, PUBLIC, PARAMETER ::   jptal = 2    !: total alkalinity  
     55   INTEGER, PUBLIC, PARAMETER ::   jpoxy = 3    !: oxygen carbon concentration  
     56   INTEGER, PUBLIC, PARAMETER ::   jpcal = 4    !: calcite  concentration  
     57   INTEGER, PUBLIC, PARAMETER ::   jppo4 = 5    !: phosphate concentration  
     58   INTEGER, PUBLIC, PARAMETER ::   jppoc = 6    !: small particulate organic phosphate concentration 
     59   INTEGER, PUBLIC, PARAMETER ::   jpsil = 7    !: silicate concentration 
     60   INTEGER, PUBLIC, PARAMETER ::   jpphy = 8    !: phytoplancton concentration  
     61   INTEGER, PUBLIC, PARAMETER ::   jpzoo = 9    !: zooplancton concentration 
     62   INTEGER, PUBLIC, PARAMETER ::   jpdoc = 10    !: dissolved organic carbon concentration  
     63   INTEGER, PUBLIC, PARAMETER ::   jpdia = 11    !: Diatoms Concentration 
     64   INTEGER, PUBLIC, PARAMETER ::   jpmes = 12    !: Mesozooplankton Concentration 
     65   INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: (big) Silicate Concentration 
     66   INTEGER, PUBLIC, PARAMETER ::   jpfer = 14    !: Iron Concentration 
     67   INTEGER, PUBLIC, PARAMETER ::   jpnum = 15    !: Big iron particles Concentration 
     68   INTEGER, PUBLIC, PARAMETER ::   jpsfe = 16    !: number of particulate organic phosphate concentration 
     69   INTEGER, PUBLIC, PARAMETER ::   jpdfe = 17    !: Diatoms iron Concentration 
     70   INTEGER, PUBLIC, PARAMETER ::   jpgsi = 18    !: Diatoms Silicate Concentration 
     71   INTEGER, PUBLIC, PARAMETER ::   jpnfe = 19    !: Nano iron Concentration 
     72   INTEGER, PUBLIC, PARAMETER ::   jpnch = 20    !: Nano Chlorophyll Concentration 
     73   INTEGER, PUBLIC, PARAMETER ::   jpdch = 21    !: Diatoms Chlorophyll Concentration 
     74   INTEGER, PUBLIC, PARAMETER ::   jpno3 = 22    !: Nitrates Concentration 
     75   INTEGER, PUBLIC, PARAMETER ::   jpnh4 = 23    !: Ammonium Concentration 
    6176 
    6277#elif defined key_pisces 
    … …  
    6580   !!--------------------------------------------------------------------- 
    6681   LOGICAL, PUBLIC, PARAMETER ::   lk_pisces     = .TRUE.  !: PISCES flag  
     82   LOGICAL, PUBLIC, PARAMETER ::   lk_p4z        = .TRUE.  !: p4z flag  
    6783   LOGICAL, PUBLIC, PARAMETER ::   lk_kriest     = .FALSE. !: Kriest flag  
    6884   INTEGER, PUBLIC, PARAMETER ::   jp_pisces     = 24      !: number of PISCES passive tracers 
    … …  
    7490   !    WARNING: be carefull about the order when reading the restart 
    7591        !   !!gm  this warning should be obsolet with IOM 
    76    INTEGER, PUBLIC, PARAMETER ::   jpdic = jp_lp + 1    !: dissolved inoganic carbon concentration  
    77    INTEGER, PUBLIC, PARAMETER ::   jptal = jp_lp + 2    !: total alkalinity  
    78    INTEGER, PUBLIC, PARAMETER ::   jpoxy = jp_lp + 3    !: oxygen carbon concentration  
    79    INTEGER, PUBLIC, PARAMETER ::   jpcal = jp_lp + 4    !: calcite  concentration  
    80    INTEGER, PUBLIC, PARAMETER ::   jppo4 = jp_lp + 5    !: phosphate concentration  
    81    INTEGER, PUBLIC, PARAMETER ::   jppoc = jp_lp + 6    !: small particulate organic phosphate concentration 
    82    INTEGER, PUBLIC, PARAMETER ::   jpsil = jp_lp + 7    !: silicate concentration 
    83    INTEGER, PUBLIC, PARAMETER ::   jpphy = jp_lp + 8    !: phytoplancton concentration  
    84    INTEGER, PUBLIC, PARAMETER ::   jpzoo = jp_lp + 9    !: zooplancton concentration 
    85    INTEGER, PUBLIC, PARAMETER ::   jpdoc = jp_lp + 10    !: dissolved organic carbon concentration  
    86    INTEGER, PUBLIC, PARAMETER ::   jpdia = jp_lp + 11    !: Diatoms Concentration 
    87    INTEGER, PUBLIC, PARAMETER ::   jpmes = jp_lp + 12    !: Mesozooplankton Concentration 
    88    INTEGER, PUBLIC, PARAMETER ::   jpdsi = jp_lp + 13    !: (big) Silicate Concentration 
    89    INTEGER, PUBLIC, PARAMETER ::   jpfer = jp_lp + 14    !: Iron Concentration 
    90    INTEGER, PUBLIC, PARAMETER ::   jpbfe = jp_lp + 15    !: Big iron particles Concentration 
    91    INTEGER, PUBLIC, PARAMETER ::   jpgoc = jp_lp + 16    !: big particulate organic phosphate concentration 
    92    INTEGER, PUBLIC, PARAMETER ::   jpsfe = jp_lp + 17    !: Small iron particles Concentration 
    93    INTEGER, PUBLIC, PARAMETER ::   jpdfe = jp_lp + 18    !: Diatoms iron Concentration 
    94    INTEGER, PUBLIC, PARAMETER ::   jpgsi = jp_lp + 19    !: Diatoms Silicate Concentration 
    95    INTEGER, PUBLIC, PARAMETER ::   jpnfe = jp_lp + 20    !: Nano iron Concentration 
    96    INTEGER, PUBLIC, PARAMETER ::   jpnch = jp_lp + 21    !: Nano Chlorophyll Concentration 
    97    INTEGER, PUBLIC, PARAMETER ::   jpdch = jp_lp + 22    !: Diatoms Chlorophyll Concentration 
    98    INTEGER, PUBLIC, PARAMETER ::   jpno3 = jp_lp + 23    !: Nitrates Concentration 
    99    INTEGER, PUBLIC, PARAMETER ::   jpnh4 = jp_lp + 24    !: Ammonium Concentration 
     92   INTEGER, PUBLIC, PARAMETER ::   jpdic = 1    !: dissolved inoganic carbon concentration  
     93   INTEGER, PUBLIC, PARAMETER ::   jptal = 2    !: total alkalinity  
     94   INTEGER, PUBLIC, PARAMETER ::   jpoxy = 3    !: oxygen carbon concentration  
     95   INTEGER, PUBLIC, PARAMETER ::   jpcal = 4    !: calcite  concentration  
     96   INTEGER, PUBLIC, PARAMETER ::   jppo4 = 5    !: phosphate concentration  
     97   INTEGER, PUBLIC, PARAMETER ::   jppoc = 6    !: small particulate organic phosphate concentration 
     98   INTEGER, PUBLIC, PARAMETER ::   jpsil = 7    !: silicate concentration 
     99   INTEGER, PUBLIC, PARAMETER ::   jpphy = 8    !: phytoplancton concentration  
     100   INTEGER, PUBLIC, PARAMETER ::   jpzoo = 9    !: zooplancton concentration 
     101   INTEGER, PUBLIC, PARAMETER ::   jpdoc = 10    !: dissolved organic carbon concentration  
     102   INTEGER, PUBLIC, PARAMETER ::   jpdia = 11    !: Diatoms Concentration 
     103   INTEGER, PUBLIC, PARAMETER ::   jpmes = 12    !: Mesozooplankton Concentration 
     104   INTEGER, PUBLIC, PARAMETER ::   jpdsi = 13    !: (big) Silicate Concentration 
     105   INTEGER, PUBLIC, PARAMETER ::   jpfer = 14    !: Iron Concentration 
     106   INTEGER, PUBLIC, PARAMETER ::   jpbfe = 15    !: Big iron particles Concentration 
     107   INTEGER, PUBLIC, PARAMETER ::   jpgoc = 16    !: big particulate organic phosphate concentration 
     108   INTEGER, PUBLIC, PARAMETER ::   jpsfe = 17    !: Small iron particles Concentration 
     109   INTEGER, PUBLIC, PARAMETER ::   jpdfe = 18    !: Diatoms iron Concentration 
     110   INTEGER, PUBLIC, PARAMETER ::   jpgsi = 19    !: Diatoms Silicate Concentration 
     111   INTEGER, PUBLIC, PARAMETER ::   jpnfe = 20    !: Nano iron Concentration 
     112   INTEGER, PUBLIC, PARAMETER ::   jpnch = 21    !: Nano Chlorophyll Concentration 
     113   INTEGER, PUBLIC, PARAMETER ::   jpdch = 22    !: Diatoms Chlorophyll Concentration 
     114   INTEGER, PUBLIC, PARAMETER ::   jpno3 = 23    !: Nitrates Concentration 
     115   INTEGER, PUBLIC, PARAMETER ::   jpnh4 = 24    !: Ammonium Concentration 
    100116 
    101117#else 
    … …  
    103119   !!   Default                                   No CFC geochemical model 
    104120   !!--------------------------------------------------------------------- 
    105    LOGICAL, PUBLIC, PARAMETER ::   lk_pisces     = .FALSE.  !: CFC flag  
    106    LOGICAL, PUBLIC, PARAMETER ::   lk_kriest     = .FALSE.  !: Kriest flag  
     121   LOGICAL, PUBLIC, PARAMETER ::   lk_pisces     = .FALSE.  !: PISCES flag  
     122   LOGICAL, PUBLIC, PARAMETER ::   lk_p4z        = .FALSE.  !: p4z flag  
    107123   INTEGER, PUBLIC, PARAMETER ::   jp_pisces     =  0       !: No CFC tracers 
    108124   INTEGER, PUBLIC, PARAMETER ::   jp_pisces_2d  =  0       !: No CFC additional 2d output arrays  
    … …  
    112128 
    113129   ! Starting/ending PISCES do-loop indices (N.B. no PISCES : jpl_pcs < jpf_pcs the do-loop are never done) 
    114    INTEGER, PUBLIC, PARAMETER ::   jp_pcs0     = jp_lp + 1                  !: First index of PISCES tracers 
    115    INTEGER, PUBLIC, PARAMETER ::   jp_pcs1     = jp_lp + jp_pisces          !: Last  index of PISCES tracers 
    116    INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_2d  = jp_lp_2d + 1               !: First index of 2D diag 
    117    INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_2d  = jp_lp_2d + jp_pisces_2d    !: Last  index of 2D diag 
    118    INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_3d  = jp_lp_3d + 1               !: First index of 3D diag 
    119    INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_3d  = jp_lp_3d + jp_pisces_3d    !: Last  index of 3d diag 
    120    INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_trd = jp_lp_trd + 1              !: First index of bio diag 
    121    INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_trd = jp_lp_trd + jp_pisces_trd  !: Last  index of bio diag 
     130   INTEGER, PUBLIC, PARAMETER ::   jp_pcs0     = 1                  !: First index of PISCES tracers 
     131   INTEGER, PUBLIC, PARAMETER ::   jp_pcs1     = jp_pisces          !: Last  index of PISCES tracers 
     132   INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_2d  = 1               !: First index of 2D diag 
     133   INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_2d  = jp_pisces_2d    !: Last  index of 2D diag 
     134   INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_3d  = 1               !: First index of 3D diag 
     135   INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_3d  = jp_pisces_3d    !: Last  index of 3d diag 
     136   INTEGER, PUBLIC, PARAMETER ::   jp_pcs0_trd = 1              !: First index of bio diag 
     137   INTEGER, PUBLIC, PARAMETER ::   jp_pcs1_trd = jp_pisces_trd  !: Last  index of bio diag 
    122138 
    123139 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r3294 r3680  
    77   !!             3.2  !  2009-04 (C. Ethe & NEMO team) style 
    88   !!---------------------------------------------------------------------- 
    9 #if defined key_pisces 
     9#if defined key_pisces || defined key_pisces_reduced  
    1010   !!---------------------------------------------------------------------- 
    1111   !!   'key_pisces'                                         PISCES model 
    … …  
    1919   INTEGER ::   numnatp 
    2020 
     21   !!*  Biological fluxes for light : variables shared by pisces & lobster 
     22   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  neln  !: number of T-levels + 1 in the euphotic layer 
     23   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  heup  !: euphotic layer depth 
     24   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  etot  !: par (photosynthetic available radiation) 
     25   ! 
     26   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  xksi  !:  LOBSTER : zooplakton closure 
     27   !                                                       !:  PISCES  : silicon dependant half saturation 
     28 
     29#if defined key_pisces  
    2130   !!*  Time variables 
    2231   INTEGER  ::   nrdttrc           !: ??? 
    … …  
    2736 
    2837   !!*  Biological parameters  
     38   INTEGER  ::   niter1max, niter2max   !: Maximum number of iterations for sinking 
    2939   REAL(wp) ::   rno3              !: ??? 
    3040   REAL(wp) ::   o2ut              !: ??? 
    … …  
    3747   REAL(wp) ::   ferat3            !: ??? 
    3848 
    39    !!* Damping  
    40    LOGICAL  ::   ln_pisdmp         !: relaxation or not of nutrients to a mean value 
    41    INTEGER  ::   nn_pisdmp         !: frequency of relaxation or not of nutrients to a mean value 
    42    LOGICAL  ::   ln_pisclo         !: Restoring or not of nutrients to initial value 
    43                                    !: on close seas 
     49   !!*  diagnostic parameters  
     50   REAL(wp) ::  tpp                !: total primary production 
     51   REAL(wp) ::  t_oce_co2_exp      !: total carbon export 
     52   REAL(wp) ::  t_oce_co2_flx      !: Total ocean carbon flux 
     53   REAL(wp) ::  t_atm_co2_flx      !: global mean of atmospheric pco2 
    4454 
    45    !!*  Biological fluxes for light 
    46    INTEGER , ALLOCATABLE, SAVE,   DIMENSION(:,:)  ::  neln       !: number of T-levels + 1 in the euphotic layer 
    47    REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:)  ::  heup       !: euphotic layer depth 
     55   !!* restoring 
     56   LOGICAL  ::  ln_pisdmp          !: restoring or not of nutrients to a mean value 
     57   INTEGER  ::  nn_pisdmp          !: frequency of relaxation or not of nutrients to a mean value 
     58   LOGICAL  ::  ln_pisclo          !: Restoring or not of nutrients to initial value on closed seas 
     59 
     60   !!* Mass conservation 
     61   LOGICAL  ::  ln_check_mass      !: Flag to check mass conservation 
    4862 
    4963   !!*  Biological fluxes for primary production 
    50    REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:)  ::   xksi       !: ??? 
    5164   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:)  ::   xksimax    !: ??? 
    5265   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanono3   !: ??? 
    … …  
    6174   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdfe    !: ??? 
    6275   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimsi     !: ??? 
     76   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   biron      !: bioavailable fraction of iron 
    6377 
    6478 
    … …  
    6781   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   nitrfac    !: ?? 
    6882   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xlimbac    !: ?? 
     83   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xlimbacl   !: ?? 
    6984   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xdiss      !: ?? 
    70     REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   prodcal    !: Calcite production 
    71     REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   grazing    !: Total zooplankton grazing 
     85   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   prodcal    !: Calcite production 
    7286 
    7387   !!* Variable for chemistry of the CO2 cycle 
    … …  
    96110#endif 
    97111 
     112#endif 
    98113   !!---------------------------------------------------------------------- 
    99114   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    … …  
    111126      !!---------------------------------------------------------------------- 
    112127      ierr(:) = 0 
    113       !*  Biological fluxes for light 
    114       ALLOCATE( neln(jpi,jpj), heup(jpi,jpj),                  STAT=ierr(1) ) 
     128      !*  Biological fluxes for light : shared variables for pisces & lobster 
     129      ALLOCATE( etot(jpi,jpj,jpk), neln(jpi,jpj), heup(jpi,jpj), xksi(jpi,jpj), STAT=ierr(1) ) 
    115130      ! 
     131#if defined key_pisces 
    116132      !*  Biological fluxes for primary production 
    117       ALLOCATE( xksimax(jpi,jpj)     , xksi(jpi,jpj)        ,       & 
     133      ALLOCATE( xksimax(jpi,jpj)     , biron   (jpi,jpj,jpk),       & 
    118134         &      xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk),       & 
    119135         &      xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk),       & 
    … …  
    121137         &      xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk),       & 
    122138         &      xlimsi  (jpi,jpj,jpk), concdfe (jpi,jpj,jpk),       & 
    123          &      concnfe (jpi,jpj,jpk),                          STAT=ierr(2) )  
     139         &      concnfe (jpi,jpj,jpk),                           STAT=ierr(2) )  
    124140         ! 
    125141      !*  SMS for the organic matter 
    126142      ALLOCATE( xfracal (jpi,jpj,jpk), nitrfac(jpi,jpj,jpk),       & 
    127          &      prodcal(jpi,jpj,jpk) , grazing(jpi,jpj,jpk),       & 
    128          &      xlimbac (jpi,jpj,jpk), xdiss  (jpi,jpj,jpk),   STAT=ierr(3) )   
    129          ! 
     143         &      xlimbac (jpi,jpj,jpk), xdiss  (jpi,jpj,jpk),       &  
     144         &      xlimbacl(jpi,jpj,jpk), prodcal(jpi,jpj,jpk),     STAT=ierr(3) ) 
     145 
    130146      !* Variable for chemistry of the CO2 cycle 
    131147      ALLOCATE( akb3(jpi,jpj,jpk)    , ak13  (jpi,jpj,jpk) ,       & 
    132148         &      ak23(jpi,jpj,jpk)    , aksp  (jpi,jpj,jpk) ,       & 
    133149         &      akw3(jpi,jpj,jpk)    , borat (jpi,jpj,jpk) ,       & 
    134          &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,   STAT=ierr(4) ) 
     150         &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,     STAT=ierr(4) ) 
    135151         ! 
    136152      !* Temperature dependancy of SMS terms 
    137       ALLOCATE( tgfunc(jpi,jpj,jpk)  , tgfunc2(jpi,jpj,jpk) ,   STAT=ierr(5) ) 
     153      ALLOCATE( tgfunc(jpi,jpj,jpk)  , tgfunc2(jpi,jpj,jpk) ,    STAT=ierr(5) ) 
    138154         ! 
    139155      !* Array used to indicate negative tracer values   
    140       ALLOCATE( xnegtr(jpi,jpj,jpk)  ,                          STAT=ierr(6) ) 
     156      ALLOCATE( xnegtr(jpi,jpj,jpk)  ,                           STAT=ierr(6) ) 
     157#endif 
    141158      ! 
    142159      sms_pisces_alloc = MAXVAL( ierr ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90

    r3295 r3680  
    99   !!             1.0  !  2005-03  (O. Aumont, A. El Moussaoui) F90 
    1010   !!             2.0  !  2007-12  (C. Ethe, G. Madec) from trcini.pisces.h90 
    11    !!---------------------------------------------------------------------- 
    12 #if defined key_pisces 
     11   !!             3.5  !  2012-05  (C. Ethe) Merge PISCES-LOBSTER 
     12   !!---------------------------------------------------------------------- 
     13#if defined key_pisces || defined key_pisces_reduced 
    1314   !!---------------------------------------------------------------------- 
    1415   !!   'key_pisces'                                       PISCES bio-model 
    … …  
    2021   USE trc             !  passive tracers common variables  
    2122   USE sms_pisces      !  PISCES Source Minus Sink variables 
    22    USE p4zche          !  Chemical model 
    23    USE p4zsink         !  vertical flux of particulate matter due to sinking 
    24    USE p4zopt          !  optical model 
    25    USE p4zrem          !  Remineralisation of organic matter 
    26    USE p4zflx          !  Gas exchange 
    27    USE p4zsed          !  Sedimentation 
    28    USE p4zlim          !  Co-limitations of differents nutrients 
    29    USE p4zprod         !  Growth rate of the 2 phyto groups 
    30    USE p4zmicro        !  Sources and sinks of microzooplankton 
    31    USE p4zmeso         !  Sources and sinks of mesozooplankton 
    32    USE p4zmort         !  Mortality terms for phytoplankton 
    33    USE p4zlys          !  Calcite saturation 
    34    USE p4zsed          !  Sedimentation 
    3523 
    3624   IMPLICIT NONE 
    … …  
    3927   PUBLIC   trc_ini_pisces   ! called by trcini.F90 module 
    4028 
    41    REAL(wp) :: sco2   =  2.312e-3_wp 
    42    REAL(wp) :: alka0  =  2.423e-3_wp 
    43    REAL(wp) :: oxyg0  =  177.6e-6_wp  
    44    REAL(wp) :: po4    =  2.174e-6_wp  
    45    REAL(wp) :: bioma0 =  1.000e-8_wp   
    46    REAL(wp) :: silic1 =  91.65e-6_wp   
    47    REAL(wp) :: no3    =  31.04e-6_wp * 7.625_wp 
    4829 
    4930#  include "top_substitute.h90" 
    … …  
    6142      !! ** Purpose :   Initialisation of the PISCES biochemical model 
    6243      !!---------------------------------------------------------------------- 
    63       ! 
    64       INTEGER  ::  ji, jj, jk 
     44 
     45      IF( lk_pisces ) THEN  ;   CALL p4z_ini   !  PISCES 
     46      ELSE                  ;   CALL p2z_ini   !  LOBSTER 
     47      ENDIF 
     48 
     49   END SUBROUTINE trc_ini_pisces 
     50 
     51   SUBROUTINE p4z_ini 
     52      !!---------------------------------------------------------------------- 
     53      !!                   ***  ROUTINE p4z_ini *** 
     54      !! 
     55      !! ** Purpose :   Initialisation of the PISCES biochemical model 
     56      !!---------------------------------------------------------------------- 
     57#if defined key_pisces  
     58      ! 
     59      USE p4zsms          ! Main P4Z routine 
     60      USE p4zche          !  Chemical model 
     61      USE p4zsink         !  vertical flux of particulate matter due to sinking 
     62      USE p4zopt          !  optical model 
     63      USE p4zsbc          !  Boundary conditions 
     64      USE p4zfechem       !  Iron chemistry 
     65      USE p4zrem          !  Remineralisation of organic matter 
     66      USE p4zflx          !  Gas exchange 
     67      USE p4zlim          !  Co-limitations of differents nutrients 
     68      USE p4zprod         !  Growth rate of the 2 phyto groups 
     69      USE p4zmicro        !  Sources and sinks of microzooplankton 
     70      USE p4zmeso         !  Sources and sinks of mesozooplankton 
     71      USE p4zmort         !  Mortality terms for phytoplankton 
     72      USE p4zlys          !  Calcite saturation 
     73      ! 
     74      REAL(wp), SAVE :: sco2   =  2.312e-3_wp 
     75      REAL(wp), SAVE :: alka0  =  2.423e-3_wp 
     76      REAL(wp), SAVE :: oxyg0  =  177.6e-6_wp  
     77      REAL(wp), SAVE :: po4    =  2.174e-6_wp  
     78      REAL(wp), SAVE :: bioma0 =  1.000e-8_wp   
     79      REAL(wp), SAVE :: silic1 =  91.65e-6_wp   
     80      REAL(wp), SAVE :: no3    =  31.04e-6_wp * 7.625_wp 
     81      ! 
     82      INTEGER  ::  ji, jj, jk, ierr 
    6583      REAL(wp) ::  zcaralk, zbicarb, zco3 
    6684      REAL(wp) ::  ztmas, ztmas1 
    6785      !!---------------------------------------------------------------------- 
     86 
    6887      IF(lwp) WRITE(numout,*) 
    69       IF(lwp) WRITE(numout,*) ' trc_ini_pisces :   PISCES biochemical model initialisation' 
     88      IF(lwp) WRITE(numout,*) ' p4z_ini :   PISCES biochemical model initialisation' 
    7089      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
    7190 
    72       CALL pisces_alloc()                          ! Allocate PISCES arrays 
    73  
     91                                                 ! Allocate PISCES arrays 
     92      ierr =         sms_pisces_alloc()           
     93      ierr = ierr +  p4z_che_alloc() 
     94      ierr = ierr +  p4z_sink_alloc() 
     95      ierr = ierr +  p4z_opt_alloc() 
     96      ierr = ierr +  p4z_prod_alloc() 
     97      ierr = ierr +  p4z_rem_alloc() 
     98      ierr = ierr +  p4z_flx_alloc() 
     99      ! 
     100      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     101      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'pisces_alloc: unable to allocate PISCES arrays' ) 
     102      ! 
     103 
     104      CALL p4z_sms_init       !  Maint routine 
    74105      !                                            ! Time-step 
    75106      rfact   = rdttrc(1)                          ! --------- 
    … …  
    132163         xksimax(:,:) = xksi(:,:) 
    133164 
    134       ENDIF 
    135  
    136       IF( .NOT. ln_rsttr ) THEN 
    137165         ! Initialization of chemical variables of the carbon cycle 
    138166         ! -------------------------------------------------------- 
    … …  
    159187      CALL p4z_lim_init       !  co-limitations by the various nutrients 
    160188      CALL p4z_prod_init      !  phytoplankton growth rate over the global ocean. 
     189      CALL p4z_sbc_init       !  boundary conditions 
     190      CALL p4z_fechem_init    !  Iron chemistry 
    161191      CALL p4z_rem_init       !  remineralisation 
    162192      CALL p4z_mort_init      !  phytoplankton mortality  
    163193      CALL p4z_micro_init     !  microzooplankton 
    164194      CALL p4z_meso_init      !  mesozooplankton 
    165       CALL p4z_sed_init       !  sedimentation  
    166195      CALL p4z_lys_init       !  calcite saturation 
    167196      CALL p4z_flx_init       !  gas exchange  
    … …  
    172201      IF(lwp) WRITE(numout,*) 'Initialization of PISCES tracers done' 
    173202      IF(lwp) WRITE(numout,*)  
    174       ! 
    175    END SUBROUTINE trc_ini_pisces 
    176  
    177  
    178    SUBROUTINE pisces_alloc 
    179       !!---------------------------------------------------------------------- 
    180       !!                     ***  ROUTINE pisces_alloc *** 
     203#endif 
     204      ! 
     205   END SUBROUTINE p4z_ini 
     206 
     207   SUBROUTINE p2z_ini 
     208      !!---------------------------------------------------------------------- 
     209      !!                   ***  ROUTINE p2z_ini *** 
    181210      !! 
    182       !! ** Purpose :   Allocate all the dynamic arrays of PISCES  
    183       !!---------------------------------------------------------------------- 
    184       ! 
    185       INTEGER :: ierr 
    186       !!---------------------------------------------------------------------- 
    187       ! 
    188       ierr =         sms_pisces_alloc()          ! Start of PISCES-related alloc routines... 
    189       ierr = ierr +  p4z_che_alloc() 
    190       ierr = ierr +  p4z_sink_alloc() 
    191       ierr = ierr +  p4z_opt_alloc() 
    192       ierr = ierr +  p4z_prod_alloc() 
    193       ierr = ierr +  p4z_rem_alloc() 
    194       ierr = ierr +  p4z_sed_alloc() 
    195       ierr = ierr +  p4z_flx_alloc() 
     211      !! ** Purpose :   Initialisation of the LOBSTER biochemical model 
     212      !!---------------------------------------------------------------------- 
     213#if defined key_pisces_reduced  
     214      ! 
     215      USE p2zopt 
     216      USE p2zexp 
     217      USE p2zbio 
     218      USE p2zsed 
     219      ! 
     220      INTEGER  ::  ji, jj, jk, ierr 
     221      !!---------------------------------------------------------------------- 
     222 
     223      IF(lwp) WRITE(numout,*) 
     224      IF(lwp) WRITE(numout,*) ' p2z_ini :   LOBSTER biochemical model initialisation' 
     225      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
     226 
     227      ierr =        sms_pisces_alloc()           
     228      ierr = ierr + p2z_exp_alloc() 
    196229      ! 
    197230      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    198       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'pisces_alloc: unable to allocate PISCES arrays' ) 
    199       ! 
    200    END SUBROUTINE pisces_alloc 
    201  
     231      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'p2z_ini: unable to allocate LOBSTER arrays' ) 
     232 
     233      ! LOBSTER initialisation for GYRE : init NO3=f(density) by asklod AS Kremeur 2005-07 
     234      ! ---------------------- 
     235      IF( .NOT. ln_rsttr ) THEN             ! in case of  no restart  
     236         trn(:,:,:,jpdet) = 0.1 * tmask(:,:,:) 
     237         trn(:,:,:,jpzoo) = 0.1 * tmask(:,:,:) 
     238         trn(:,:,:,jpnh4) = 0.1 * tmask(:,:,:) 
     239         trn(:,:,:,jpphy) = 0.1 * tmask(:,:,:) 
     240         trn(:,:,:,jpdom) = 1.0 * tmask(:,:,:) 
     241         WHERE( rhd(:,:,:) <= 24.5e-3 )  ;  trn(:,:,:,jpno3 ) = 2._wp * tmask(:,:,:) 
     242         ELSE WHERE                      ;  trn(:,:,:,jpno3) = ( 15.55 * ( rhd(:,:,:) * 1000. ) - 380.11 ) * tmask(:,:,:) 
     243         END WHERE                        
     244      ENDIF 
     245      !                       !  Namelist read 
     246      CALL p2z_opt_init       !  Optics parameters 
     247      CALL p2z_sed_init       !  sedimentation 
     248      CALL p2z_bio_init       !  biology 
     249      CALL p2z_exp_init       !  export  
     250      ! 
     251      IF(lwp) WRITE(numout,*)  
     252      IF(lwp) WRITE(numout,*) 'Initialization of LOBSTER tracers done' 
     253      IF(lwp) WRITE(numout,*)  
     254#endif 
     255      ! 
     256   END SUBROUTINE p2z_ini 
    202257#else 
    203258   !!---------------------------------------------------------------------- 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/trcnam_pisces.F90

    r3294 r3680  
    11MODULE trcnam_pisces 
    22   !!====================================================================== 
    3    !!                      ***  MODULE trcnam_lobster  *** 
     3   !!                      ***  MODULE trcnam_pisces  *** 
    44   !! TOP :   initialisation of some run parameters for PISCES bio-model 
    55   !!====================================================================== 
    … …  
    99   !!             2.0  !  2007-12  (C. Ethe, G. Madec) from trcnam.pisces.h90 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_pisces 
     11#if defined key_pisces || defined key_pisces_reduced 
    1212   !!---------------------------------------------------------------------- 
    1313   !!   'key_pisces'   :                                   PISCES bio-model 
    … …  
    1919   USE trc             ! TOP variables 
    2020   USE sms_pisces      ! sms trends 
     21   USE trdmod_trc_oce 
    2122   USE iom             ! I/O manager 
    2223 
    … …  
    4849      !! 
    4950      INTEGER :: jl, jn 
    50       TYPE(DIAG), DIMENSION(jp_pisces_2d) :: pisdia2d 
    51       TYPE(DIAG), DIMENSION(jp_pisces_3d) :: pisdia3d 
     51      TYPE(DIAG), DIMENSION(jp_pisces_2d)  :: pisdia2d 
     52      TYPE(DIAG), DIMENSION(jp_pisces_3d)  :: pisdia3d 
     53      TYPE(DIAG), DIMENSION(jp_pisces_trd) :: pisdiabio 
     54      CHARACTER(LEN=20)   ::   clname 
    5255      !! 
    53       NAMELIST/nampisbio/ nrdttrc, wsbio, xkmort, ferat3, wsbio2 
    54 #if defined key_kriest 
    55       NAMELIST/nampiskrp/ xkr_eta, xkr_zeta, xkr_mass_min, xkr_mass_max 
     56      NAMELIST/nampisdia/ pisdia3d, pisdia2d     ! additional diagnostics 
     57#if defined key_pisces_reduced 
     58      NAMELIST/nampisdbi/ pisdiabio 
    5659#endif 
    57       NAMELIST/nampisdia/ pisdia3d, pisdia2d     ! additional diagnostics 
    58       NAMELIST/nampisdmp/ ln_pisdmp, nn_pisdmp, ln_pisclo 
    5960 
    6061      !!---------------------------------------------------------------------- 
    6162 
    6263      IF(lwp) WRITE(numout,*) 
    63       IF(lwp) WRITE(numout,*) ' trc_nam_pisces : read PISCES namelists' 
     64      clname = 'namelist_pisces' 
     65#if defined key_pisces 
     66      IF(lwp) WRITE(numout,*) ' trc_nam_pisces : read PISCES namelist' 
     67#else 
     68      IF(lwp) WRITE(numout,*) ' trc_nam_pisces : read LOBSTER namelist' 
     69#endif 
    6470      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 
     71      CALL ctl_opn( numnatp, TRIM( clname ), 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 
    6572 
    66  
    67       !                               ! Open the namelist file 
    68       !                               ! ---------------------- 
    69       CALL ctl_opn( numnatp, 'namelist_pisces', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 
    70  
    71       REWIND( numnatp )                     
    72       READ  ( numnatp, nampisbio ) 
    73  
    74       IF(lwp) THEN                         ! control print 
    75          WRITE(numout,*) ' Namelist : nampisbio' 
    76          WRITE(numout,*) '    frequence pour la biologie                nrdttrc   =', nrdttrc 
    77          WRITE(numout,*) '    POC sinking speed                         wsbio     =', wsbio 
    78          WRITE(numout,*) '    half saturation constant for mortality    xkmort    =', xkmort 
    79          WRITE(numout,*) '    Fe/C in zooplankton                       ferat3    =', ferat3 
    80          WRITE(numout,*) '    Big particles sinking speed               wsbio2    =', wsbio2 
    81       ENDIF 
    82  
    83 #if defined key_kriest 
    84  
    85       !                               ! nampiskrp : kriest parameters 
    86       !                               ! ----------------------------- 
    87       xkr_eta      = 0.62         
    88       xkr_zeta     = 1.62         
    89       xkr_mass_min = 0.0002      
    90       xkr_mass_max = 1.       
    91  
    92       REWIND( numnatp )                     ! read natkriest 
    93       READ  ( numnatp, nampiskrp ) 
    94  
    95       IF(lwp) THEN 
    96          WRITE(numout,*) 
    97          WRITE(numout,*) ' Namelist : nampiskrp' 
    98          WRITE(numout,*) '    Sinking  exponent                        xkr_eta      = ', xkr_eta 
    99          WRITE(numout,*) '    N content exponent                       xkr_zeta     = ', xkr_zeta 
    100          WRITE(numout,*) '    Minimum mass for Aggregates              xkr_mass_min = ', xkr_mass_min 
    101          WRITE(numout,*) '    Maximum mass for Aggregates              xkr_mass_max = ', xkr_mass_max 
    102          WRITE(numout,*) 
    103      ENDIF 
    104  
    105  
    106      ! Computation of some variables 
    107      xkr_massp = 5.7E-6 * 7.6 * xkr_mass_min**xkr_zeta 
    108  
    109 #endif 
    11073      ! 
    11174      IF( .NOT.lk_iomput .AND. ln_diatrc ) THEN 
    … …  
    162125      ENDIF 
    163126 
    164       REWIND( numnatp ) 
    165       READ  ( numnatp, nampisdmp ) 
     127#if defined key_pisces_reduced 
    166128 
    167       IF(lwp) THEN                         ! control print 
    168          WRITE(numout,*) 
    169          WRITE(numout,*) ' Namelist : nampisdmp' 
    170          WRITE(numout,*) '    Relaxation of tracer to glodap mean value             ln_pisdmp      =', ln_pisdmp 
    171          WRITE(numout,*) '    Frequency of Relaxation                               nn_pisdmp      =', nn_pisdmp 
    172          WRITE(numout,*) '    Restoring of tracer to initial value  on closed seas  ln_pisclo      =', ln_pisclo 
    173          WRITE(numout,*) ' ' 
    174       ENDIF 
     129      IF( ( .NOT.lk_iomput .AND. ln_diabio ) .OR. lk_trdmld_trc ) THEN 
     130         ! 
     131         ! Namelist nampisdbi 
     132         ! ------------------- 
     133         DO jl = 1, jp_pisces_trd 
     134            IF(     jl <  10 ) THEN   ;   WRITE (pisdiabio(jl)%sname,'("BIO_",I1)') jl      ! short name 
     135            ELSEIF (jl < 100 ) THEN   ;   WRITE (pisdiabio(jl)%sname,'("BIO_",I2)') jl 
     136            ELSE                      ;   WRITE (pisdiabio(jl)%sname,'("BIO_",I3)') jl 
     137            ENDIF 
     138            WRITE(pisdiabio(jl)%lname,'("BIOLOGICAL TREND NUMBER ",I2)') jl                 ! long name 
     139            pisdiabio(jl)%units = 'mmoleN/m3/s '                                            ! units 
     140         END DO 
     141 
     142         REWIND( numnatp ) 
     143         READ  ( numnatp, nampisdbi ) 
     144 
     145         DO jl = 1, jp_pisces_trd 
     146            jn = jp_pcs0_trd + jl - 1 
     147            ctrbio(jl) = pisdiabio(jl)%sname 
     148            ctrbil(jl) = pisdiabio(jl)%lname 
     149            ctrbiu(jl) = pisdiabio(jl)%units 
     150         END DO 
     151 
     152         IF(lwp) THEN                   ! control print 
     153            WRITE(numout,*) 
     154            WRITE(numout,*) ' Namelist : nampisdbi' 
     155            DO jl = 1, jp_pisces_trd 
     156               jn = jp_pcs0_trd + jl - 1 
     157               WRITE(numout,*) '  biological trend No : ', jn, '    short name : ', ctrbio(jn), & 
     158                 &             '  long name  : ', ctrbio(jn), '   unit : ', ctrbio(jn) 
     159            END DO 
     160            WRITE(numout,*) ' ' 
     161         END IF 
     162         ! 
     163      END IF 
     164 
     165#endif 
    175166 
    176167   END SUBROUTINE trc_nam_pisces 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/trcsms_pisces.F90

    r3320 r3680  
    77   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
    88   !!---------------------------------------------------------------------- 
    9 #if defined key_pisces 
     9#if defined key_pisces || defined key_pisces_reduced 
    1010   !!---------------------------------------------------------------------- 
    1111   !!   'key_pisces'                                       PISCES bio-model 
    … …  
    1313   !!   trcsms_pisces        :  Time loop of passive tracers sms 
    1414   !!---------------------------------------------------------------------- 
    15    USE oce_trc         !  shared variables between ocean and passive tracers 
    16    USE trc             !  passive tracers common variables  
    17    USE sms_pisces      !  PISCES Source Minus Sink variables 
    18    USE p4zbio          !  Biological model 
    19    USE p4zche          !  Chemical model 
    20    USE p4zlys          !  Calcite saturation 
    21    USE p4zflx          !  Gas exchange 
    22    USE p4zsed          !  Sedimentation 
    23    USE p4zint          !  time interpolation 
    24    USE trdmod_oce      !  Ocean trends variables 
    25    USE trdmod_trc      !  TOP trends variables 
    26    USE sedmodel        !  Sediment model 
    27    USE prtctl_trc      !  print control for debugging 
     15   USE par_pisces 
     16   USE p4zsms 
     17   USE p2zsms 
    2818 
    2919   IMPLICIT NONE 
    … …  
    3121 
    3222   PUBLIC   trc_sms_pisces    ! called in trcsms.F90 
    33  
    34    LOGICAL ::  ln_check_mass = .false.       !: Flag to check mass conservation  
    35  
    36    INTEGER ::  numno3  !: logical unit for NO3 budget 
    37    INTEGER ::  numalk  !: logical unit for talk budget 
    38    INTEGER ::  numsil  !: logical unit for Si budget 
    39  
    4023   !!---------------------------------------------------------------------- 
    4124   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    … …  
    4629CONTAINS 
    4730 
     31      !!---------------------------------------------------------------------- 
     32      !!                   ***  ROUTINE trc_ini_pisces *** 
     33      !! 
     34      !! ** Purpose :   Initialisation of the PISCES biochemical model 
     35      !!---------------------------------------------------------------------- 
     36 
     37 
    4838   SUBROUTINE trc_sms_pisces( kt ) 
    4939      !!--------------------------------------------------------------------- 
    … …  
    5141      !! 
    5242      !! ** Purpose :   Managment of the call to Biological sources and sinks  
    53       !!              routines of PISCES bio-model 
    54       !! 
    55       !! ** Method  : - at each new day ... 
    56       !!              - several calls of bio and sed ??? 
    57       !!              - ... 
    58       !!--------------------------------------------------------------------- 
    59       ! 
    60       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
    61       !! 
    62       INTEGER ::   jnt, jn, jl 
    63       CHARACTER (len=25) :: charout 
    64       REAL(wp), POINTER, DIMENSION(:,:,:,:)  :: ztrdpis 
    65       !!--------------------------------------------------------------------- 
    66       ! 
    67       IF( nn_timing == 1 )  CALL timing_start('trc_sms_pisces') 
    68       ! 
    69       IF( ln_pisdmp .AND. MOD( kt - nn_dttrc, nn_pisdmp ) == 0 )   CALL trc_sms_pisces_dmp( kt )  ! Relaxation of some tracers 
    70                                                                    CALL trc_sms_pisces_mass_conserv( kt ) ! Mass conservation checking 
    71       IF( l_trdtrc )  THEN 
    72          CALL wrk_alloc( jpi, jpj, jpk, jp_pisces, ztrdpis )  
    73          DO jn = 1, jp_pisces 
    74             jl = jn + jp_pcs0 - 1 
    75             ztrdpis(:,:,:,jn) = trn(:,:,:,jl) 
    76          ENDDO 
    77       ENDIF 
    78  
    79       IF( ndayflxtr /= nday_year ) THEN      ! New days 
    80          ! 
    81          ndayflxtr = nday_year 
    82  
    83          IF(lwp) write(numout,*) 
    84          IF(lwp) write(numout,*) ' New chemical constants and various rates for biogeochemistry at new day : ', nday_year 
    85          IF(lwp) write(numout,*) '~~~~~~' 
    86  
    87          CALL p4z_che              ! computation of chemical constants 
    88          CALL p4z_int              ! computation of various rates for biogeochemistry 
    89          ! 
    90       ENDIF 
    91  
    92  
    93       DO jnt = 1, nrdttrc          ! Potential time splitting if requested 
    94          ! 
    95          CALL p4z_bio (kt, jnt)    ! Compute soft tissue production (POC) 
    96          CALL p4z_sed (kt, jnt)    ! compute soft tissue remineralisation 
    97          ! 
    98          DO jn = jp_pcs0, jp_pcs1 
    99             trb(:,:,:,jn) = trn(:,:,:,jn) 
    100          ENDDO 
    101          ! 
    102       END DO 
    103  
    104       IF( l_trdtrc )  THEN 
    105          DO jn = 1, jp_pisces 
    106             jl = jn + jp_pcs0 - 1 
    107             ztrdpis(:,:,:,jn) = ( ztrdpis(:,:,:,jn) - trn(:,:,:,jl) ) * rfact2r 
    108          ENDDO 
    109       ENDIF 
    110  
    111       CALL p4z_lys( kt )             ! Compute CaCO3 saturation 
    112       CALL p4z_flx( kt )             ! Compute surface fluxes 
    113  
    114       DO jn = jp_pcs0, jp_pcs1 
    115         CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. ) 
    116         CALL lbc_lnk( trb(:,:,:,jn), 'T', 1. ) 
    117         CALL lbc_lnk( tra(:,:,:,jn), 'T', 1. ) 
    118       END DO 
    119  
    120       IF( l_trdtrc ) THEN 
    121          DO jn = 1, jp_pisces 
    122             jl = jn + jp_pcs0 - 1 
    123              ztrdpis(:,:,:,jn) = ztrdpis(:,:,:,jn) + tra(:,:,:,jl) 
    124              CALL trd_mod_trc( ztrdpis(:,:,:,jn), jn, jptra_trd_sms, kt )   ! save trends 
    125           END DO 
    126           CALL wrk_dealloc( jpi, jpj, jpk, jp_pisces, ztrdpis )  
    127       END IF 
    128  
    129       IF( lk_sed ) THEN  
    130          ! 
    131          CALL sed_model( kt )     !  Main program of Sediment model 
    132          ! 
    133          DO jn = jp_pcs0, jp_pcs1 
    134            CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. ) 
    135          END DO 
    136          ! 
    137       ENDIF 
    138       ! 
    139       IF( nn_timing == 1 )  CALL timing_stop('trc_sms_pisces') 
    140       ! 
    141    END SUBROUTINE trc_sms_pisces 
    142  
    143    SUBROUTINE trc_sms_pisces_dmp( kt ) 
    144       !!---------------------------------------------------------------------- 
    145       !!                    ***  trc_sms_pisces_dmp  *** 
    146       !! 
    147       !! ** purpose  : Relaxation of some tracers 
    148       !!---------------------------------------------------------------------- 
    149       ! 
    150       INTEGER, INTENT( in )  ::     kt ! time step 
    151       ! 
    152       REAL(wp) ::  alkmean = 2426.     ! mean value of alkalinity ( Glodap ; for Goyet 2391. ) 
    153       REAL(wp) ::  po4mean = 2.165     ! mean value of phosphates 
    154       REAL(wp) ::  no3mean = 30.90     ! mean value of nitrate 
    155       REAL(wp) ::  silmean = 91.51     ! mean value of silicate 
    156       ! 
    157       REAL(wp) :: zarea, zalksum, zpo4sum, zno3sum, zsilsum 
    158       !!--------------------------------------------------------------------- 
    159  
    160  
    161       IF(lwp)  WRITE(numout,*) 
    162       IF(lwp)  WRITE(numout,*) ' trc_sms_pisces_dmp : Relaxation of nutrients at time-step kt = ', kt 
    163       IF(lwp)  WRITE(numout,*) 
    164  
    165       IF( cp_cfg == "orca" .AND. .NOT. lk_c1d ) THEN      ! ORCA condiguration (not 1D) ! 
    166          !                                                    ! --------------------------- ! 
    167          ! set total alkalinity, phosphate, nitrate & silicate 
    168          zarea          = 1._wp / glob_sum( cvol(:,:,:) ) * 1e6               
    169  
    170          zalksum = glob_sum( trn(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
    171          zpo4sum = glob_sum( trn(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea / 122. 
    172          zno3sum = glob_sum( trn(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea / 7.6 
    173          zsilsum = glob_sum( trn(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
    174   
    175          IF(lwp) WRITE(numout,*) '       TALK mean : ', zalksum 
    176          trn(:,:,:,jptal) = trn(:,:,:,jptal) * alkmean / zalksum 
    177  
    178          IF(lwp) WRITE(numout,*) '       PO4  mean : ', zpo4sum 
    179          trn(:,:,:,jppo4) = trn(:,:,:,jppo4) * po4mean / zpo4sum 
    180  
    181          IF(lwp) WRITE(numout,*) '       NO3  mean : ', zno3sum 
    182          trn(:,:,:,jpno3) = trn(:,:,:,jpno3) * no3mean / zno3sum 
    183  
    184          IF(lwp) WRITE(numout,*) '       SiO3 mean : ', zsilsum 
    185          trn(:,:,:,jpsil) = MIN( 400.e-6,trn(:,:,:,jpsil) * silmean / zsilsum ) 
    186          ! 
    187       ENDIF 
    188  
    189    END SUBROUTINE trc_sms_pisces_dmp 
    190  
    191    SUBROUTINE trc_sms_pisces_mass_conserv ( kt ) 
    192       !!---------------------------------------------------------------------- 
    193       !!                  ***  ROUTINE trc_sms_pisces_mass_conserv  *** 
    194       !! 
    195       !! ** Purpose :  Mass conservation check  
     43      !!                routines of PISCES or LOBSTER bio-model 
    19644      !! 
    19745      !!--------------------------------------------------------------------- 
    19846      ! 
    19947      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
    200       !! 
    201       REAL(wp) :: zalkbudget, zno3budget, zsilbudget 
     48      !!--------------------------------------------------------------------- 
    20249      ! 
    203       NAMELIST/nampismass/ ln_check_mass 
    204       !!--------------------------------------------------------------------- 
    205  
    206       IF( kt == nittrc000 ) THEN  
    207          REWIND( numnatp )        
    208          READ  ( numnatp, nampismass ) 
    209          IF(lwp) THEN                         ! control print 
    210             WRITE(numout,*) ' ' 
    211             WRITE(numout,*) ' Namelist parameter for mass conservation checking' 
    212             WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' 
    213             WRITE(numout,*) '    Flag to check mass conservation of NO3/Si/TALK ln_check_mass = ', ln_check_mass 
    214          ENDIF 
    215  
    216          IF( ln_check_mass .AND. lwp) THEN      !   Open budget file of NO3, ALK, Si 
    217             CALL ctl_opn( numno3, 'no3.budget' , 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
    218             CALL ctl_opn( numsil, 'sil.budget' , 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
    219             CALL ctl_opn( numalk, 'talk.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
    220          ENDIF 
     50      IF( lk_p4z ) THEN  ;   CALL p4z_sms( kt )   !  PISCES 
     51      ELSE               ;   CALL p2z_sms( kt )   !  LOBSTER 
    22152      ENDIF 
    222  
    223       IF( ln_check_mass ) THEN      !   Compute the budget of NO3, ALK, Si 
    224          zno3budget = glob_sum( (   trn(:,:,:,jpno3) + trn(:,:,:,jpnh4)  & 
    225             &                     + trn(:,:,:,jpphy) + trn(:,:,:,jpdia)  & 
    226             &                     + trn(:,:,:,jpzoo) + trn(:,:,:,jpmes)  & 
    227             &                     + trn(:,:,:,jppoc) + trn(:,:,:,jpgoc)  & 
    228             &                     + trn(:,:,:,jpdoc)                     ) * cvol(:,:,:)  )  
    229          !  
    230          zsilbudget = glob_sum( (   trn(:,:,:,jpsil) + trn(:,:,:,jpgsi)  & 
    231             &                     + trn(:,:,:,jpdsi)                     ) * cvol(:,:,:)  ) 
    232          !  
    233          zalkbudget = glob_sum( (   trn(:,:,:,jpno3) * rno3              & 
    234             &                     + trn(:,:,:,jptal)                     & 
    235             &                     + trn(:,:,:,jpcal) * 2.                ) * cvol(:,:,:)  ) 
    236  
    237          IF( lwp ) THEN 
    238             WRITE(numno3,9500) kt,  zno3budget / areatot 
    239             WRITE(numsil,9500) kt,  zsilbudget / areatot 
    240             WRITE(numalk,9500) kt,  zalkbudget / areatot 
    241          ENDIF 
    242        ENDIF 
    243  9500  FORMAT(i10,e18.10)      
    244        ! 
    245    END SUBROUTINE trc_sms_pisces_mass_conserv 
     53      ! 
     54   END SUBROUTINE trc_sms_pisces 
    24655 
    24756#else 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/PISCES/trcwri_pisces.F90

    r3295 r3680  
    66   !! History :   1.0  !  2009-05 (C. Ethe)  Original code 
    77   !!---------------------------------------------------------------------- 
    8 #if defined key_top && key_pisces && defined key_iomput 
     8#if defined key_top && defined key_iomput && ( defined key_pisces || defined key_pisces_reduced ) 
    99   !!---------------------------------------------------------------------- 
    10    !!   'key_pisces'                                           PISCES model 
     10   !!   'key_pisces or key_pisces_reduced'                     PISCES model 
    1111   !!---------------------------------------------------------------------- 
    1212   !! trc_wri_pisces   :  outputs of concentration fields 
    1313   !!---------------------------------------------------------------------- 
    1414   USE trc         ! passive tracers common variables  
     15   USE sms_pisces  ! PISCES variables 
    1516   USE iom         ! I/O manager 
    1617 
    … …  
    3536      ! write the tracer concentrations in the file 
    3637      ! --------------------------------------- 
    37       DO jn = 1, jptra 
    38          zrfact = 1.0e+6  
    39          IF( jn == jpno3 .OR. jn == jpnh4 ) zrfact = 1.0e+6 / 7.6 
    40          IF( jn == jppo4  )                 zrfact = 1.0e+6 / 122. 
     38#if defined key_pisces_reduced 
     39      DO jn = jp_pcs0, jp_pcs1 
    4140         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    4241         CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 
    4342      END DO 
     43#else 
     44      DO jn = jp_pcs0, jp_pcs1 
     45         zrfact = 1.0e+6  
     46         IF( jn == jpno3 .OR. jn == jpnh4 ) zrfact = rno3 * 1.0e+6  
     47         IF( jn == jppo4  )                 zrfact = po4r * 1.0e+6 
     48         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
     49         CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 
     50      END DO 
     51#endif 
    4452      ! 
    4553   END SUBROUTINE trc_wri_pisces 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90

    r3294 r3680  
    8282      IF( kt == nittrc000 )   CALL trc_adv_ctl          ! initialisation & control of options 
    8383 
    84 #if ! defined key_pisces 
    85       IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
    86          r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
    87       ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
    88          r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
     84      IF( ln_top_euler) THEN 
     85         r2dt(:) =  rdttrc(:)              ! = rdttrc (use Euler time stepping) 
     86      ELSE 
     87         IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
     88            r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
     89         ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
     90            r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
     91         ENDIF 
    8992      ENDIF 
    90 #else 
    91       r2dt(:) =  rdttrc(:)              ! = rdttrc (for PISCES use Euler time stepping) 
    92 #endif 
    9393 
    9494      !                                                   ! effective transport 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r3294 r3680  
    8181      NAMELIST/namtrc_rad/ ln_trcrad 
    8282#if defined key_trcdmp 
    83       NAMELIST/namtrc_dmp/ nn_hdmp_tr, nn_zdmp_tr, rn_surf_tr, & 
     83      NAMELIST/namtrc_dmp/ ln_trcdmp, nn_hdmp_tr, nn_zdmp_tr, rn_surf_tr, & 
    8484        &                  rn_bot_tr , rn_dep_tr , nn_file_tr 
    8585#endif 
    … …  
    156156         WRITE(numout,*) '~~~~~~~' 
    157157         WRITE(numout,*) '   Namelist namtrc_dmp : set damping parameter' 
     158         WRITE(numout,*) '      add a damping term or not      ln_trcdmp = ', ln_trcdmp 
    158159         WRITE(numout,*) '      tracer damping option          nn_hdmp_tr = ', nn_hdmp_tr 
    159160         WRITE(numout,*) '      mixed layer damping option     nn_zdmp_tr = ', nn_zdmp_tr, '(zoom: forced to 0)' 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r3294 r3680  
    3434   USE tranxt 
    3535# if defined key_agrif 
    36    USE agrif_top_update 
    3736   USE agrif_top_interp 
    3837# endif 
    … …  
    146145      ENDIF 
    147146 
    148 #if defined key_agrif 
    149       ! Update tracer at AGRIF zoom boundaries 
    150       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Trc( kt )      ! children only 
    151 #endif       
    152  
    153147      ! trends computation 
    154148      IF( l_trdtrc ) THEN                                      ! trends 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcrad.F90

    r3294 r3680  
    6363      IF( lk_cfc     )   CALL trc_rad_sms( kt, trb, trn, jp_cfc0 , jp_cfc1               )  ! CFC model 
    6464      IF( lk_c14b    )   CALL trc_rad_sms( kt, trb, trn, jp_c14b0, jp_c14b1              )  ! bomb C14 
    65       IF( lk_lobster )   CALL trc_rad_sms( kt, trb, trn, jp_lob0 , jp_lob1, cpreserv='Y' )  ! LOBSTER model 
    6665      IF( lk_pisces  )   CALL trc_rad_sms( kt, trb, trn, jp_pcs0 , jp_pcs1, cpreserv='Y' )  ! PISCES model 
    6766      IF( lk_my_trc  )   CALL trc_rad_sms( kt, trb, trn, jp_myt0 , jp_myt1               )  ! MY_TRC model 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r3625 r3680  
    5050      !!            tra = tra + emp * trn / e3t   for k=1 
    5151      !!         where emp, the surface freshwater budget (evaporation minus 
    52       !!         precipitation minus runoff) given in kg/m2/s is divided 
     52      !!         precipitation ) given in kg/m2/s is divided 
    5353      !!         by 1035 kg/m3 (density of ocean water) to obtain m/s. 
    5454      !! 
    … …  
    7979      ENDIF 
    8080 
     81      ! Coupling online : river runoff is added to the horizontal divergence (hdivn) in the subroutine sbc_rnf_div  
     82      ! one only consider the concentration/dilution effect due to evaporation minus precipitation + freezing/melting of sea-ice 
    8183 
    82       IF( lk_offline ) THEN          ! sfx in dynamical files contains sfx  - rnf 
    83          zsfx(:,:) = sfx(:,:)   
    84       ELSE                           ! Concentration dilution effect on tracer due to evaporation, precipitation, and river runoff 
    85          IF( lk_vvl ) THEN                      ! volume variable 
    86             zsfx(:,:) = sfx(:,:) - emp(:,:)    
    87 !!ch         zsfx(:,:) = 0. 
    88          ELSE                                   ! linear free surface 
    89             IF( ln_rnf ) THEN  ;  zsfx(:,:) = sfx(:,:) - rnf(:,:)   !  E-P-R 
    90             ELSE               ;  zsfx(:,:) = sfx(:,:) 
    91             ENDIF  
    92          ENDIF  
    93       ENDIF  
     84      IF( .NOT. lk_offline .AND. lk_vvl ) THEN  ! online coupling + volume variable 
     85         zemps(:,:) = sfx(:,:) - emp(:,:) 
     86      ELSE 
     87         zemps(:,:) = emp(:,:) 
     88      ENDIF 
    9489 
    9590      ! 0. initialization 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r3294 r3680  
    2929 
    3030#if defined key_agrif 
    31    USE agrif_top_sponge ! Momemtum and tracers sponges 
     31   USE agrif_top_sponge ! tracers sponges 
     32   USE agrif_top_update ! tracers updates 
    3233#endif 
    3334 
    … …  
    7677                                CALL trc_nxt( kstp )            ! tracer fields at next time step      
    7778         IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
     79 
     80#if defined key_agrif 
     81      IF( .NOT. Agrif_Root())   CALL Agrif_Update_Trc( kstp )   ! Update tracer at AGRIF zoom boundaries : children only 
     82#endif 
    7883         IF( ln_zps    )        CALL zps_hde( kstp, jptra, trn, gtru, gtrv )  ! Partial steps: now horizontal gradient of passive 
    7984                                                                ! tracers at the bottom ocean level 
    … …  
    98103   !!---------------------------------------------------------------------- 
    99104CONTAINS 
    100    SUBROUTINE trc_trp( kt )              ! Empty routine 
    101       INTEGER, INTENT(in) ::   kt 
    102       WRITE(*,*) 'trc_trp: You should not have seen this print! error?', kt 
     105   SUBROUTINE trc_trp( kstp )              ! Empty routine 
     106      INTEGER, INTENT(in) ::   kstp 
     107      WRITE(*,*) 'trc_trp: You should not have seen this print! error?', kstp 
    103108   END SUBROUTINE trc_trp 
    104109#endif 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trczdf.F90

    r3632 r3680  
    7373      IF( kt == nittrc000 )   CALL zdf_ctl          ! initialisation & control of options 
    7474 
    75 #if ! defined key_pisces 
    76       IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
    77          r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
    78       ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
    79          r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
     75      IF( ln_top_euler) THEN 
     76         r2dt(:) =  rdttrc(:)              ! = rdttrc (use Euler time stepping) 
     77      ELSE 
     78         IF( neuler == 0 .AND. kt == nittrc000 ) THEN     ! at nittrc000 
     79            r2dt(:) =  rdttrc(:)           ! = rdttrc (restarting with Euler time stepping) 
     80         ELSEIF( kt <= nittrc000 + 1 ) THEN          ! at nittrc000 or nittrc000+1 
     81            r2dt(:) = 2. * rdttrc(:)       ! = 2 rdttrc (leapfrog) 
     82         ENDIF 
    8083      ENDIF 
    81 #else 
    82       r2dt(:) =  rdttrc(:)              ! = rdttrc (for PISCES use Euler time stepping) 
    83 #endif 
    8484 
    8585      IF( l_trdtrc )  THEN 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trdmld_trc.F90

    r3320 r3680  
    3434   USE prtctl            ! print control 
    3535   USE sms_pisces        ! PISCES bio-model 
    36    USE sms_lobster       ! LOBSTER bio-model 
    3736   USE wrk_nemo          ! Memory allocation 
    3837 
    … …  
    5352   INTEGER ::   ndimtrd1                         
    5453   INTEGER, SAVE ::  ionce, icount 
    55 #if defined key_lobster 
     54#if defined key_pisces_reduced 
    5655   INTEGER ::   nidtrdbio, nh_tb 
    5756   INTEGER, SAVE ::  ioncebio, icountbio 
    … …  
    6261 
    6362   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::  ztmltrd2   ! 
    64 #if defined key_lobster 
     63#if defined key_pisces_reduced 
    6564   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  ztmltrdbio2  ! only needed for mean diagnostics in trd_mld_bio() 
    6665#endif 
    … …  
    8180      !!---------------------------------------------------------------------- 
    8281      ALLOCATE( ztmltrd2(jpi,jpj,jpltrd_trc,jptra) ,      & 
    83 #if defined key_lobster 
     82#if defined key_pisces_reduced 
    8483         &      ztmltrdbio2(jpi,jpj,jpdiabio)      ,      & 
    8584#endif 
    … …  
    133132         SELECT CASE ( nn_ctls_trc )                                ! choice of the control surface 
    134133            CASE ( -2  )   ;   STOP 'trdmld_trc : not ready '     !     -> isopycnal surface (see ???) 
    135 #if defined key_pisces || defined key_lobster 
     134#if defined key_pisces || defined key_pisces_reduced 
    136135            CASE ( -1  )   ;   nmld_trc(:,:) = neln(:,:)          !     -> euphotic layer with light criterion 
    137136#endif 
    … …  
    232231      INTEGER                         , INTENT(in) ::   ktrd          ! bio trend index 
    233232      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) ::   ptrc_trdmld   ! passive trc trend 
    234 #if defined key_lobster 
     233#if defined key_pisces_reduced 
    235234      ! 
    236235      INTEGER ::   ji, jj, jk, isum 
    … …  
    940939      !!---------------------------------------------------------------------- 
    941940      INTEGER, INTENT( in ) ::   kt                       ! ocean time-step index 
    942 #if defined key_lobster 
     941#if defined key_pisces_reduced 
    943942      INTEGER  ::  jl, it, itmod 
    944943      LOGICAL  :: llwarn  = .TRUE., lldebug = .TRUE. 
    … …  
    12171216      tmltrd_csum_ln_trc (:,:,:,:) = 0.e0   ;   rmld_sum_trc       (:,:)     = 0.e0 
    12181217 
    1219 #if defined key_lobster 
     1218#if defined key_pisces_reduced 
    12201219      nmoymltrdbio   = 0 
    12211220      tmltrd_sum_bio     (:,:,:) = 0.e0     ;   tmltrd_csum_ln_bio (:,:,:) = 0.e0 
    1222       DO jl = 1, jp_lobster_trd 
     1221      DO jl = 1, jp_pisces_trd 
    12231222          ctrd_bio(jl,1) = ctrbil(jl)   ! long name 
    12241223          ctrd_bio(jl,2) = ctrbio(jl)   ! short name 
    … …  
    12341233         tml_sumb_trc       (:,:,:)   = 0.e0   ;   tmltrd_csum_ub_trc (:,:,:,:) = 0.e0     ! mean 
    12351234         tmltrd_atf_sumb_trc(:,:,:)   = 0.e0   ;   tmltrd_rad_sumb_trc(:,:,:)   = 0.e0  
    1236 #if defined key_lobster 
     1235#if defined key_pisces_reduced 
    12371236         tmltrd_csum_ub_bio (:,:,:) = 0.e0 
    12381237#endif 
    … …  
    12421241      icount = 1   ;   ionce  = 1  ! open specifier    
    12431242 
    1244 #if defined key_lobster 
     1243#if defined key_pisces_reduced 
    12451244      icountbio = 1   ;   ioncebio  = 1  ! open specifier 
    12461245#endif 
    … …  
    13371336      END DO 
    13381337 
    1339 #if defined key_lobster 
     1338#if defined key_pisces_reduced 
    13401339          !-- Create a NetCDF file and enter the define mode 
    13411340          CALL dia_nam( clhstnam, nn_trd_trc, 'trdbio' ) 
    … …  
    13831382      END DO 
    13841383 
    1385 #if defined key_lobster 
    1386       DO jl = 1, jp_lobster_trd 
     1384#if defined key_pisces_reduced 
     1385      DO jl = 1, jp_pisces_trd 
    13871386         CALL histdef(nidtrdbio, TRIM("ML_"//ctrd_bio(jl,2)), TRIM(clmxl//" ML_"//ctrd_bio(jl,1))   ,            & 
    13881387             &    cltrcu, jpi, jpj, nh_tb, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) ! IOIPSL: time mean 
    … …  
    13951394      END DO 
    13961395 
    1397 #if defined key_lobster 
     1396#if defined key_pisces_reduced 
    13981397      !-- Leave IOIPSL/NetCDF define mode 
    13991398      CALL histend( nidtrdbio, snc4set ) 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trdmld_trc_rst.F90

    r2528 r3680  
    105105            END DO                                                     ! tracer loop 
    106106            !                                                          ! =========== 
    107 #if defined key_lobster 
    108             DO jl = 1, jp_lobster_trd 
     107#if defined key_pisces_reduced 
     108            DO jl = 1, jp_pisces_trd 
    109109               CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmltrd_csum_ub_bio'//ctrd_bio(jl,2), tmltrd_csum_ub_bio(:,:,jl) ) 
    110110            ENDDO 
    … …  
    190190         !                                                          ! =========== 
    191191 
    192 #if defined key_lobster 
    193          DO jl = 1, jp_lobster_trd 
     192#if defined key_pisces_reduced 
     193         DO jl = 1, jp_pisces_trd 
    194194            CALL iom_get( inum, jpdom_autoglo, 'tmltrd_csum_ub_bio'//ctrd_bio(jl,2), tmltrd_csum_ub_bio(:,:,jl) ) 
    195195         ENDDO 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trdmod_trc_oce.F90

    r3320 r3680  
    106106# endif 
    107107 
    108 # if defined key_lobster 
     108# if defined key_pisces_reduced 
    109109   CHARACTER(LEN=80) :: clname_bio, ctrd_bio(jpdiabio,2) 
    110110   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  & 
    … …  
    154154#endif 
    155155      ! 
    156 # if defined key_lobster 
     156# if defined key_pisces_reduced 
    157157      ALLOCATE( tmltrd_bio        (jpi,jpj,jpdiabio) ,     & 
    158158         &      tmltrd_sum_bio    (jpi,jpj,jpdiabio) ,     & 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r3625 r3680  
    5656 
    5757   !* model domain * 
    58    USE dom_oce , ONLY :   lzoom      => lzoom        !: zoom flag 
    59    USE dom_oce , ONLY :   lzoom_e    => lzoom_e      !: East  zoom type flag 
    60    USE dom_oce , ONLY :   lzoom_w    => lzoom_w      !: West  zoom type flag 
    61    USE dom_oce , ONLY :   lzoom_s    => lzoom_s      !: South zoom type flag 
    62    USE dom_oce , ONLY :   lzoom_n    => lzoom_n      !: North zoom type flag 
    63    USE dom_oce , ONLY :   lzoom_arct => lzoom_arct   !: ORCA    arctic zoom flag 
    64    USE dom_oce , ONLY :   lzoom_anta => lzoom_anta   !: ORCA antarctic zoom flag 
    65    USE dom_oce , ONLY :   nperio     =>   nperio     !: type of lateral boundary condition        
    66    USE dom_oce , ONLY :   nimpp      =>   nimpp      !: i index for mpp-subdomain left bottom 
    67    USE dom_oce , ONLY :   njmpp      =>   njmpp      !: j index for mpp-subdomain left bottom 
    68    USE dom_oce , ONLY :   nproc      =>   nproc      !: number for local processor 
    69    USE dom_oce , ONLY :   narea      =>   narea      !: number for local area 
    70    USE dom_oce , ONLY :   mig        =>   mig        !: local  ==> global  domain i-indice 
    71    USE dom_oce , ONLY :   mjg        =>   mjg        !: local  ==> global  domain i-indice 
    72    USE dom_oce , ONLY :   mi0        =>   mi0        !: global ==> local domain i-indice  
    73    USE dom_oce , ONLY :   mi1        =>   mi1        !: (mi0=1 and mi1=0 if the global indice is not in the local one) 
    74    USE dom_oce , ONLY :   mj0        =>   mj0        !: global ==> local domain j-indice  
    75    USE dom_oce , ONLY :   mj1        =>   mj1        !: (mj0=1 and mj1=0 if the global indice is not in the local one) 
    76    USE dom_oce , ONLY :   nidom      =>   nidom 
    77    USE dom_oce , ONLY :   nimppt     => nimppt     !:i-indexes for each processor 
    78    USE dom_oce , ONLY :   njmppt     => njmppt       !:j-indexes for each processor 
    79    USE dom_oce , ONLY :   ibonit     => ibonit       !:i-processor neighbour existence 
    80    USE dom_oce , ONLY :   ibonjt     => ibonjt       !:j- processor neighbour existence  
    81    USE dom_oce , ONLY :   nlci       => nlci         !:i- & j-dimensions of the local subdomain 
    82    USE dom_oce , ONLY :   nlcj       => nlcj         !: 
    83    USE dom_oce , ONLY :   nldi       => nldi         !:first and last indoor i- and j-indexes 
    84    USE dom_oce , ONLY :   nlei       => nlei         !: 
    85    USE dom_oce , ONLY :   nldj       => nldj         !: 
    86    USE dom_oce , ONLY :   nlej       => nlej         !: 
    87    USE dom_oce , ONLY :   nlcit      => nlcit        !:dimensions of every i-subdomain 
    88    USE dom_oce , ONLY :   nlcjt      => nlcjt        !:dimensions of every j-subdomain 
    89    USE dom_oce , ONLY :   nldit      => nldit        !:first indoor index for each i-domain  
    90    USE dom_oce , ONLY :   nleit      => nleit        !:last indoor index for each i-domain  
    91    USE dom_oce , ONLY :   nldjt      => nldjt        !:first indoor index for each j-domain  
    92    USE dom_oce , ONLY :   nlejt      => nlejt        !:last indoor index for each j-domain  
    93   
    94    !* horizontal mesh * 
    95    USE dom_oce , ONLY :   glamt      =>   glamt      !: longitude of t-point (degre)   
    96    USE dom_oce , ONLY :   glamu      =>   glamu      !: longitude of t-point (degre)   
    97    USE dom_oce , ONLY :   glamv      =>   glamv      !: longitude of t-point (degre)   
    98    USE dom_oce , ONLY :   glamf      =>   glamf      !: longitude of t-point (degre)   
    99    USE dom_oce , ONLY :   gphit      =>   gphit      !: latitude  of t-point (degre)    
    100    USE dom_oce , ONLY :   gphiu      =>   gphiu      !: latitude  of t-point (degre)    
    101    USE dom_oce , ONLY :   gphiv      =>   gphiv      !: latitude  of t-point (degre)    
    102    USE dom_oce , ONLY :   gphif      =>   gphif      !: latitude  of t-point (degre)    
    103    USE dom_oce , ONLY :   e1t        =>   e1t        !: horizontal scale factors at t-point (m)   
    104    USE dom_oce , ONLY :   e2t        =>   e2t        !: horizontal scale factors at t-point (m)    
    105    USE dom_oce , ONLY :   e1e2t      =>   e1e2t      !: cell surface at t-point (m2) 
    106    USE dom_oce , ONLY :   e1u        =>   e1u        !: horizontal scale factors at u-point (m) 
    107    USE dom_oce , ONLY :   e2u        =>   e2u        !: horizontal scale factors at u-point (m) 
    108    USE dom_oce , ONLY :   e1v        =>   e1v        !: horizontal scale factors at v-point (m) 
    109    USE dom_oce , ONLY :   e2v        =>   e2v        !: horizontal scale factors at v-point (m)   
    110  
    111    !* vertical mesh * 
    112    USE dom_oce , ONLY :   gdept_0    =>   gdept_0    !: reference depth of t-points (m) 
    113    USE dom_oce , ONLY :   e3t_0      =>   e3t_0      !: reference depth of t-points (m)   
    114    USE dom_oce , ONLY :   e3w_0      =>   e3w_0      !: reference depth of w-points (m) 
    115    USE dom_oce , ONLY :   gdepw_0    =>   gdepw_0    !: reference depth of w-points (m) 
    116 # if ! defined key_zco 
    117    USE dom_oce , ONLY :   gdep3w     =>  gdep3w      !: ??? 
    118    USE dom_oce , ONLY :   gdept      =>  gdept       !: depth of t-points (m) 
    119    USE dom_oce , ONLY :   gdepw      =>  gdepw       !: depth of t-points (m) 
    120    USE dom_oce , ONLY :   e3t        =>  e3t         !: vertical scale factors at t- 
    121    USE dom_oce , ONLY :   e3u        =>  e3u         !: vertical scale factors at u- 
    122    USE dom_oce , ONLY :   e3v        =>  e3v         !: vertical scale factors v- 
    123    USE dom_oce , ONLY :   e3w        =>  e3w         !: w-points (m) 
    124    USE dom_oce , ONLY :   e3f        =>  e3f         !: f-points (m) 
    125    USE dom_oce , ONLY :   e3uw       =>  e3uw        !: uw-points (m) 
    126    USE dom_oce , ONLY :   e3vw       =>  e3vw        !: vw-points (m) 
    127 # endif 
    128    USE dom_oce , ONLY :   ln_zps     =>  ln_zps      !: partial steps flag 
    129    USE dom_oce , ONLY :   ln_sco     =>  ln_sco      !: s-coordinate flag 
    130    USE dom_oce , ONLY :   ln_zco     =>  ln_zco      !: z-coordinate flag 
    131    USE dom_oce , ONLY :   hbatt      =>  hbatt       !: ocean depth at the vertical of  t-point (m) 
    132    USE dom_oce , ONLY :   hbatu      =>  hbatu       !: ocean depth at the vertical of  u-point (m) 
    133    USE dom_oce , ONLY :   hbatv      =>  hbatv       !: ocean depth at the vertical of w-point (m) 
    134    USE dom_oce , ONLY :   gsigt      =>  gsigt       !: model level depth coefficient at T-levels 
    135    USE dom_oce , ONLY :   gsigw      =>  gsigw       !: model level depth coefficient at W-levels 
    136    USE dom_oce , ONLY :   gsi3w      =>  gsi3w       !: model level depth coef at w-levels (defined as the sum of e3w) 
    137    USE dom_oce , ONLY :   esigt      =>  esigt       !: vertical scale factor coef. at t-levels 
    138    USE dom_oce , ONLY :   esigw      =>  esigw       !: vertical scale factor coef. at w-levels 
    139    USE dom_oce , ONLY :   lk_vvl     =>  lk_vvl      !: variable grid flag 
    140 # if defined key_vvl 
    141    USE dom_oce , ONLY :   gdep3w_1   =>  gdep3w_1    !: ??? 
    142    USE dom_oce , ONLY :   gdept_1    =>  gdept_1     !: depth of t-points (m) 
    143    USE dom_oce , ONLY :   gdepw_1    =>  gdepw_1     !: depth of t-points (m) 
    144    USE dom_oce , ONLY :   e3t_1      =>  e3t_1       !: vertical scale factors at t- 
    145    USE dom_oce , ONLY :   e3u_1      =>  e3u_1       !: vertical scale factors at u- 
    146    USE dom_oce , ONLY :   e3v_1      =>  e3v_1       !: vertical scale factors v- 
    147    USE dom_oce , ONLY :   e3w_1      =>  e3w_1       !: w-points (m) 
    148    USE dom_oce , ONLY :   e3f_1      =>  e3f_1       !: f-points (m) 
    149    USE dom_oce , ONLY :   e3uw_1     =>  e3uw_1      !: uw-points (m) 
    150    USE dom_oce , ONLY :   e3vw_1     =>  e3vw_1      !: vw-points (m) 
    151 # endif 
    152    !* masks, bathymetry * 
    153    USE dom_oce , ONLY :   mbkt       =>   mbkt       !: vertical index of the bottom last T- ocean level 
    154    USE dom_oce , ONLY :   mbku       =>   mbku       !: vertical index of the bottom last U- ocean level 
    155    USE dom_oce , ONLY :   mbkv       =>   mbkv       !: vertical index of the bottom last V- ocean level 
    156    USE dom_oce , ONLY :   tmask_i    =>   tmask_i    !: Interior mask at t-points 
    157    USE dom_oce , ONLY :   tmask      =>   tmask      !: land/ocean mask at t-points 
    158    USE dom_oce , ONLY :   umask      =>   umask      !: land/ocean mask at u-points    
    159    USE dom_oce , ONLY :   vmask      =>   vmask      !: land/ocean mask at v-points  
    160    USE dom_oce , ONLY :   fmask      =>   fmask      !: land/ocean mask at f-points  
    161  
    162    !* time domain * 
    163    USE dom_oce , ONLY :   neuler     =>   neuler     !: restart euler forward option (0=Euler) 
    164    USE dom_oce , ONLY :   rdt        =>   rdt        !: time step for the dynamics  
    165    USE dom_oce , ONLY :   atfp       =>   atfp       !: asselin time filter parameter 
    166    USE dom_oce , ONLY :   atfp1      =>   atfp1      !: asselin time filter coeff. (atfp1= 1-2*atfp) 
    167    USE dom_oce , ONLY :   rdttra     =>   rdttra     !: vertical profile of tracer time step 
    168    !                                                 !: it is the accumulated duration of previous runs 
    169    !                                                 !: that may have been run with different time steps. 
    170    !* calendar variables * 
    171    USE dom_oce , ONLY :   nyear      =>   nyear      !: current year 
    172    USE dom_oce , ONLY :   nmonth     =>   nmonth     !: current month 
    173    USE dom_oce , ONLY :   nday       =>   nday       !: current day of the month 
    174    USE dom_oce , ONLY :   ndastp     =>   ndastp     !: time step date in yyyymmdd format 
    175    USE dom_oce , ONLY :   nday_year  =>   nday_year  !: current day counted from jan 1st of the current year 
    176    USE dom_oce , ONLY :   nsec_year  =>   nsec_year  !: current time step counted in second since 00h jan 1st of the current year 
    177    USE dom_oce , ONLY :   nsec_month =>   nsec_month !: current time step counted in second since 00h 1st day of the current month 
    178    USE dom_oce , ONLY :   nsec_day   =>   nsec_day   !: current time step counted in second since 00h of the current day 
    179    USE dom_oce , ONLY :   fjulday    =>   fjulday    !: julian day 
    180    USE dom_oce , ONLY :   adatrj     =>   adatrj     !: number of elapsed days since the begining of the whole simulation 
    181                                                      !: (cumulative duration of previous runs  
    182                                                      !: that may have used different time-step size) 
    183    USE dom_oce , ONLY :   nyear_len  =>   nyear_len  !: length in days of the previous/current year 
    184    USE dom_oce , ONLY :   nmonth_len =>   nmonth_len !: length in days of the months of the current year 
     58   USE dom_oce  
    18559 
    18660 
    … …  
    21791   USE oce , ONLY :   grv     =>    grv     !:  
    21892#endif 
    219  
    220    USE dom_oce , ONLY :   nn_cla    =>  nn_cla        !: flag (0/1) for cross land advection  
    22193 
    22294   !* surface fluxes * 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/par_trc.F90

    r2528 r3680  
    55   !!====================================================================== 
    66   !! History :    -   !  1996-01  (M. Levy)  original code 
    7    !!              -   !  1999-07  (M. Levy)  for LOBSTER1 or NPZD model 
    87   !!              -   !  2000-04  (O. Aumont, M.A. Foujols)  HAMOCC3 and P3ZD 
    98   !!             1.0  !  2004-03  (C. Ethe) Free form and module 
    … …  
    1211   USE par_kind          ! kind parameters 
    1312   ! 
    14    USE par_lobster   ! LOBSTER model 
    1513   USE par_pisces    ! PISCES  model 
    1614   USE par_c14b      ! C14 bomb tracer 
    … …  
    2220   ! Passive tracers : Total size 
    2321   ! ---------------               ! total number of passive tracers, of 2d and 3d output and trend arrays 
    24    INTEGER, PUBLIC,  PARAMETER ::   jptra    =  jp_lobster    + jp_pisces     + jp_cfc     + jp_c14b    + jp_my_trc 
    25    INTEGER, PUBLIC,  PARAMETER ::   jpdia2d  =  jp_lobster_2d + jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d + jp_my_trc_2d 
    26    INTEGER, PUBLIC,  PARAMETER ::   jpdia3d  =  jp_lobster_3d + jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d + jp_my_trc_3d 
     22   INTEGER, PUBLIC,  PARAMETER ::   jptra    =  jp_pisces     + jp_cfc     + jp_c14b    + jp_my_trc 
     23   INTEGER, PUBLIC,  PARAMETER ::   jpdia2d  =  jp_pisces_2d  + jp_cfc_2d  + jp_c14b_2d + jp_my_trc_2d 
     24   INTEGER, PUBLIC,  PARAMETER ::   jpdia3d  =  jp_pisces_3d  + jp_cfc_3d  + jp_c14b_3d + jp_my_trc_3d 
    2725   !                     ! total number of sms diagnostic arrays 
    28    INTEGER, PUBLIC,  PARAMETER ::   jpdiabio = jp_lobster_trd + jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_my_trc_trd 
     26   INTEGER, PUBLIC,  PARAMETER ::   jpdiabio = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_my_trc_trd 
    2927    
    3028   !  1D configuration ("key_c1d") 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90

    r3294 r3680  
    1717   USE par_trc          ! TOP parameters 
    1818   USE oce_trc          ! ocean space and time domain variables 
     19   USE prtctl           ! print control for OPA 
    1920 
    2021   IMPLICIT NONE 
    … …  
    296297   END SUBROUTINE prt_ctl_trc_init 
    297298 
    298  
    299    SUBROUTINE sub_dom 
    300       !!---------------------------------------------------------------------- 
    301       !!                  ***  ROUTINE sub_dom  *** 
    302       !!                     
    303       !! ** Purpose :   Lay out the global domain over processors.  
    304       !!                CAUTION:  
    305       !!                This part has been extracted from the mpp_init 
    306       !!                subroutine and names of variables/arrays have been  
    307       !!                slightly changed to avoid confusion but the computation 
    308       !!                is exactly the same. Any modification about indices of 
    309       !!                each sub-domain in the mppini.F90 module should be reported  
    310       !!                here. 
    311       !! 
    312       !! ** Method  :   Global domain is distributed in smaller local domains. 
    313       !!                Periodic condition is a function of the local domain position 
    314       !!                (global boundary or neighbouring domain) and of the global 
    315       !!                periodic 
    316       !!                Type :         jperio global periodic condition 
    317       !!                               nperio local  periodic condition 
    318       !! 
    319       !! ** Action  : - set domain parameters 
    320       !!                    nimpp     : longitudinal index  
    321       !!                    njmpp     : latitudinal  index 
    322       !!                    nperio    : lateral condition type  
    323       !!                    narea     : number for local area 
    324       !!                    nlcil      : first dimension 
    325       !!                    nlcjl      : second dimension 
    326       !!                    nbondil    : mark for "east-west local boundary" 
    327       !!                    nbondjl    : mark for "north-south local boundary" 
    328       !!---------------------------------------------------------------------- 
    329       INTEGER ::   ji, jj, js               ! dummy loop indices 
    330       INTEGER ::   ii, ij                   ! temporary integers 
    331       INTEGER ::   irestil, irestjl         !    "          " 
    332       INTEGER ::   ijpi  , ijpj, nlcil      ! temporary logical unit 
    333       INTEGER ::   nlcjl , nbondil, nbondjl 
    334       INTEGER ::   nrecil, nrecjl, nldil, nleil, nldjl, nlejl 
    335       REAL(wp) ::   zidom, zjdom            ! temporary scalars 
    336       INTEGER, POINTER, DIMENSION(:,:) ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! temporary workspace 
    337       !!---------------------------------------------------------------------- 
    338       ! 
    339       CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) 
    340       ! 
    341       ! Dimension arrays for subdomains 
    342       ! ------------------------------- 
    343       !  Computation of local domain sizes ilcitl() ilcjtl() 
    344       !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo 
    345       !  The subdomains are squares leeser than or equal to the global 
    346       !  dimensions divided by the number of processors minus the overlap 
    347       !  array (cf. par_oce.F90). 
    348  
    349       ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci 
    350       ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj 
    351  
    352       nrecil  = 2 * jpreci 
    353       nrecjl  = 2 * jprecj 
    354       irestil = MOD( jpiglo - nrecil , isplt ) 
    355       irestjl = MOD( jpjglo - nrecjl , jsplt ) 
    356  
    357       IF(  irestil == 0 )   irestil = isplt 
    358       DO jj = 1, jsplt 
    359          DO ji = 1, irestil 
    360             ilcitl(ji,jj) = ijpi 
    361          END DO 
    362          DO ji = irestil+1, isplt 
    363             ilcitl(ji,jj) = ijpi -1 
    364          END DO 
    365       END DO 
    366        
    367       IF( irestjl == 0 )   irestjl = jsplt 
    368       DO ji = 1, isplt 
    369          DO jj = 1, irestjl 
    370             ilcjtl(ji,jj) = ijpj 
    371          END DO 
    372          DO jj = irestjl+1, jsplt 
    373             ilcjtl(ji,jj) = ijpj -1 
    374          END DO 
    375       END DO 
    376        
    377       zidom = nrecil 
    378       DO ji = 1, isplt 
    379          zidom = zidom + ilcitl(ji,1) - nrecil 
    380       END DO 
    381        
    382       zjdom = nrecjl 
    383       DO jj = 1, jsplt 
    384          zjdom = zjdom + ilcjtl(1,jj) - nrecjl 
    385       END DO 
    386  
    387       ! Index arrays for subdomains 
    388       ! --------------------------- 
    389  
    390       iimpptl(:,:) = 1 
    391       ijmpptl(:,:) = 1 
    392        
    393       IF( isplt > 1 ) THEN 
    394          DO jj = 1, jsplt 
    395             DO ji = 2, isplt 
    396                iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil 
    397             END DO 
    398          END DO 
    399       ENDIF 
    400  
    401       IF( jsplt > 1 ) THEN 
    402          DO jj = 2, jsplt 
    403             DO ji = 1, isplt 
    404                ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl 
    405             END DO 
    406          END DO 
    407       ENDIF 
    408        
    409       ! Subdomain description 
    410       ! --------------------- 
    411  
    412       DO js = 1, ijsplt 
    413          ii = 1 + MOD( js-1, isplt ) 
    414          ij = 1 + (js-1) / isplt 
    415          nimpptl(js) = iimpptl(ii,ij) 
    416          njmpptl(js) = ijmpptl(ii,ij) 
    417          nlcitl (js) = ilcitl (ii,ij)      
    418          nlcil       = nlcitl (js)      
    419          nlcjtl (js) = ilcjtl (ii,ij)      
    420          nlcjl       = nlcjtl (js) 
    421          nbondjl = -1                                    ! general case 
    422          IF( js   >  isplt          )   nbondjl = 0      ! first row of processor 
    423          IF( js   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor 
    424          IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction 
    425          ibonjtl(js) = nbondjl 
    426           
    427          nbondil = 0                                     !  
    428          IF( MOD( js, isplt ) == 1 )   nbondil = -1      ! 
    429          IF( MOD( js, isplt ) == 0 )   nbondil =  1      ! 
    430          IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction 
    431          ibonitl(js) = nbondil 
    432           
    433          nldil =  1   + jpreci 
    434          nleil = nlcil - jpreci 
    435          IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1 
    436          IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil 
    437          nldjl =  1   + jprecj 
    438          nlejl = nlcjl - jprecj 
    439          IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1 
    440          IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl 
    441          nlditl(js) = nldil 
    442          nleitl(js) = nleil 
    443          nldjtl(js) = nldjl 
    444          nlejtl(js) = nlejl 
    445       END DO 
    446       ! 
    447       CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) 
    448       ! 
    449    END SUBROUTINE sub_dom 
    450   
    451299#else 
    452300   !!---------------------------------------------------------------------- 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trc.F90

    r3625 r3680  
    55   !!====================================================================== 
    66   !! History :   OPA  !  1996-01  (M. Levy)  Original code 
    7    !!              -   !  1999-07  (M. Levy)  for LOBSTER1 or NPZD model 
    87   !!              -   !  2000-04  (O. Aumont, M.A. Foujols)  HAMOCC3 and P3ZD 
    98   !!   NEMO      1.0  !  2004-03  (C. Ethe)  Free form and module 
    … …  
    2524   INTEGER, PUBLIC                                                 ::   numnat        !: logicla unit for the passive tracer NAMELIST 
    2625   INTEGER, PUBLIC                                                 ::   numstr        !: logical unit for tracer statistics 
     26   INTEGER, PUBLIC                                                 ::   numrtr        !: logical unit for trc restart (read ) 
     27   INTEGER, PUBLIC                                                 ::   numrtw        !: logical unit for trc restart ( write ) 
     28   LOGICAL, PUBLIC                                                 ::   ln_top_euler  !: boolean term for euler integration in the first timestep 
    2729 
    2830   !! passive tracers fields (before,now,after) 
    … …  
    6870   CHARACTER(len = 80), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ctrcln         !: trccer field long name 
    6971   CHARACTER(len = 20), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ctrcun         !: tracer unit 
    70    LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_ini     !: Initialisation from data input file 
    7172   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_wri     !: save the tracer or not 
    7273 
    … …  
    7677      CHARACTER(len = 20)  :: units    !: unit 
    7778   END TYPE DIAG 
     79 
     80   !! information for inputs 
     81   !! -------------------------------------------------- 
     82   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_ini     !: Initialisation from data input file 
     83   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_obc     !: Use open boundary condition data 
     84   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_sbc     !: Use surface boundary condition data 
     85   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_cbc     !: Use coastal boundary condition data 
    7886 
    7987   !! additional 2D/3D outputs namelist 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r3294 r3680  
    2121   USE trcnam          ! Namelist read 
    2222   USE trcini_cfc      ! CFC      initialisation 
    23    USE trcini_lobster  ! LOBSTER  initialisation 
    2423   USE trcini_pisces   ! PISCES   initialisation 
    2524   USE trcini_c14b     ! C14 bomb initialisation 
    … …  
    7069      CALL top_alloc()              ! allocate TOP arrays 
    7170 
    72       IF( ln_dm2dc .AND. ( lk_pisces .OR. lk_lobster ) )    & 
    73          &  CALL ctl_stop( ' The diurnal cycle is not compatible with PISCES or LOBSTER  ' ) 
     71      IF( ln_dm2dc .AND. lk_pisces )    & 
     72         &  CALL ctl_stop( ' The diurnal cycle is not compatible with PISCES ' ) 
    7473 
    7574      IF( nn_cla == 1 )   & 
    … …  
    101100      areatot = glob_sum( cvol(:,:,:) ) 
    102101 
    103       IF( lk_lobster )       CALL trc_ini_lobster      ! LOBSTER bio-model 
    104102      IF( lk_pisces  )       CALL trc_ini_pisces       ! PISCES  bio-model 
    105103      IF( lk_cfc     )       CALL trc_ini_cfc          ! CFC     tracers 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

    r3319 r3680  
    2121   USE trc               ! passive tracers common variables 
    2222   USE trcnam_trp        ! Transport namelist 
    23    USE trcnam_lobster    ! LOBSTER namelist 
    2423   USE trcnam_pisces     ! PISCES namelist 
    2524   USE trcnam_cfc        ! CFC SMS namelist 
    … …  
    5352      !! ** Method  : - read passive tracer namelist  
    5453      !!              - read namelist of each defined SMS model 
    55       !!                ( (LOBSTER, PISCES, CFC, MY_TRC ) 
     54      !!                ( (PISCES, CFC, MY_TRC ) 
    5655      !!--------------------------------------------------------------------- 
    5756      INTEGER ::  jn, ierr 
    … …  
    6059      !! 
    6160      NAMELIST/namtrc/ nn_dttrc, nn_writetrc, ln_rsttr, nn_rsttr, & 
    62          &             cn_trcrst_in, cn_trcrst_out, sn_tracer, ln_trcdta, ln_trcdmp 
     61         &             cn_trcrst_in, cn_trcrst_out, sn_tracer, ln_trcdta, ln_trcdmp, & 
     62         &             ln_top_euler 
    6363#if defined key_trdmld_trc  || defined key_trdtrc 
    6464      NAMELIST/namtrc_trd/ nn_trd_trc, nn_ctls_trc, rn_ucf_trc, & 
    … …  
    7979      nn_dttrc      = 1                 ! default values 
    8080      nn_writetrc   = 10  
     81      ln_top_euler  = .FALSE. 
    8182      ln_rsttr      = .FALSE. 
    8283      nn_rsttr      =  0 
    … …  
    120121         WRITE(numout,*) '   Read inputs data from file (y/n)             ln_trcdta     = ', ln_trcdta 
    121122         WRITE(numout,*) '   Damping of passive tracer (y/n)              ln_trcdmp     = ', ln_trcdmp 
     123         WRITE(numout,*) '   Use euler integration for TRC (y/n)          ln_top_euler  = ', ln_top_euler 
    122124         WRITE(numout,*) ' ' 
    123125         DO jn = 1, jptra 
    … …  
    234236      ! namelist of SMS 
    235237      ! ---------------       
    236       IF( lk_lobster ) THEN   ;   CALL trc_nam_lobster      ! LOBSTER bio-model 
    237       ELSE                    ;   IF(lwp) WRITE(numout,*) '          LOBSTER not used' 
    238       ENDIF 
    239  
    240238      IF( lk_pisces  ) THEN   ;   CALL trc_nam_pisces      ! PISCES  bio-model 
    241239      ELSE                    ;   IF(lwp) WRITE(numout,*) '          PISCES not used' 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcrst.F90

    r3294 r3680  
    2727   USE trcnam_trp 
    2828   USE iom 
    29    USE trcrst_cfc      ! CFC       
    30    USE trcrst_lobster  ! LOBSTER  restart 
    31    USE trcrst_pisces   ! PISCES   restart 
    32    USE trcrst_c14b     ! C14 bomb restart 
    33    USE trcrst_my_trc   ! MY_TRC   restart 
    3429   USE daymod 
    3530   IMPLICIT NONE 
    … …  
    4035   PUBLIC   trc_rst_wri       ! called by ??? 
    4136   PUBLIC   trc_rst_cal 
    42  
    43    INTEGER, PUBLIC ::   numrtr, numrtw   !: logical unit for trc restart (read and write) 
    4437 
    4538   !! * Substitutions 
    … …  
    115108         CALL iom_get( numrtr, jpdom_autoglo, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) ) 
    116109      END DO 
    117  
    118       IF( lk_lobster )   CALL trc_rst_read_lobster( numrtr )      ! LOBSTER bio-model 
    119       IF( lk_pisces  )   CALL trc_rst_read_pisces ( numrtr )      ! PISCES  bio-model 
    120       IF( lk_cfc     )   CALL trc_rst_read_cfc    ( numrtr )      ! CFC     tracers 
    121       IF( lk_c14b    )   CALL trc_rst_read_c14b   ( numrtr )      ! C14 bomb  tracer 
    122       IF( lk_my_trc  )   CALL trc_rst_read_my_trc ( numrtr )      ! MY_TRC  tracers 
    123  
    124       CALL iom_close( numrtr ) 
    125110      ! 
    126111   END SUBROUTINE trc_rst_read 
    … …  
    138123      !!---------------------------------------------------------------------- 
    139124      ! 
    140       CALL trc_rst_cal( kt, 'WRITE' )   ! calendar 
    141125      CALL iom_rstput( kt, nitrst, numrtw, 'rdttrc1', rdttrc(1) )   ! surface passive tracer time step 
    142126      ! prognostic variables  
    … …  
    149133         CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) ) 
    150134      END DO 
    151  
    152       IF( lk_lobster )   CALL trc_rst_wri_lobster( kt, nitrst, numrtw )      ! LOBSTER bio-model 
    153       IF( lk_pisces  )   CALL trc_rst_wri_pisces ( kt, nitrst, numrtw )      ! PISCES  bio-model 
    154       IF( lk_cfc     )   CALL trc_rst_wri_cfc    ( kt, nitrst, numrtw )      ! CFC     tracers 
    155       IF( lk_c14b    )   CALL trc_rst_wri_c14b   ( kt, nitrst, numrtw )      ! C14 bomb  tracer 
    156       IF( lk_my_trc  )   CALL trc_rst_wri_my_trc ( kt, nitrst, numrtw )      ! MY_TRC  tracers 
    157  
     135      ! 
    158136      IF( kt == nitrst ) THEN 
    159137          CALL trc_rst_stat            ! statistics 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcsms.F90

    r3294 r3680  
    1515   USE oce_trc            ! 
    1616   USE trc                ! 
    17    USE trcsms_lobster     ! LOBSTER bio-model 
    1817   USE trcsms_pisces      ! PISCES biogeo-model 
    1918   USE trcsms_cfc         ! CFC 11 & 12 
    … …  
    4948      IF( nn_timing == 1 )   CALL timing_start('trc_sms') 
    5049      ! 
    51       IF( lk_lobster )   CALL trc_sms_lobster( kt )    ! main program of LOBSTER 
    5250      IF( lk_pisces  )   CALL trc_sms_pisces ( kt )    ! main program of PISCES  
    5351      IF( lk_cfc     )   CALL trc_sms_cfc    ( kt )    ! surface fluxes of CFC 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r3319 r3680  
    7878         ! 
    7979                                   CALL trc_rst_opn  ( kt )       ! Open tracer restart file  
     80         IF( lrst_trc )            CALL trc_rst_cal  ( kt, 'WRITE' )   ! calendar 
    8081         IF( lk_iomput ) THEN  ;   CALL trc_wri      ( kt )       ! output of passive tracers with iom I/O manager 
    8182         ELSE                  ;   CALL trc_dia      ( kt )       ! output of passive tracers with old I/O manager 
    … …  
    8384                                   CALL trc_sms      ( kt )       ! tracers: sinks and sources 
    8485                                   CALL trc_trp      ( kt )       ! transport of passive tracers 
     86         IF( kt == nittrc000 )     CALL iom_close( numrtr )       ! close input tracer restart file 
    8587         IF( lrst_trc )            CALL trc_rst_wri  ( kt )       ! write tracer restart file 
    8688         IF( lk_trdmld_trc  )      CALL trd_mld_trc  ( kt )       ! trends: Mixed-layer 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcsub.F90

    r3625 r3680  
    2929   USE sbc_oce         ! surface boundary condition: ocean 
    3030   USE bdy_oce 
     31#if defined key_obc 
     32   USE obc_oce, ONLY: obctmsk 
     33#endif 
    3134#if defined key_agrif 
    3235   USE agrif_opa_update 

  • branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/TOP_SRC/trcwri.F90

    r3295 r3680  
    1818   USE dianam      ! Output file name 
    1919   USE trcwri_pisces 
     20   USE trcwri_cfc 
     21   USE trcwri_c14b 
     22   USE trcwri_my_trc 
    2023 
    2124   IMPLICIT NONE 
    … …  
    6972      ! write the tracer concentrations in the file 
    7073      ! --------------------------------------- 
    71       IF( lk_pisces )  THEN 
    72          CALL trc_wri_pisces 
    73       ELSE 
    74          DO jn = 1, jptra 
    75             cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    76             CALL iom_put( cltra, trn(:,:,:,jn) ) 
    77          END DO 
    78       ENDIF 
     74      IF( lk_pisces  )   CALL trc_wri_pisces     ! PISCES  
     75      IF( lk_cfc     )   CALL trc_wri_cfc        ! surface fluxes of CFC 
     76      IF( lk_c14b    )   CALL trc_wri_c14b       ! surface fluxes of C14 
     77      IF( lk_my_trc  )   CALL trc_wri_my_trc     ! MY_TRC  tracers 
    7978      ! 
    8079   END SUBROUTINE trc_wri_trc 
Note: See TracChangeset for help on using the changeset viewer.