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

Changeset 3646


Ignore:
Timestamp:
2012-11-24T14:47:12+01:00 (11 years ago)
Author:
vichi
Message:

Add the resulting merged branch from CMCC and INGV 2012 developments

Location:
branches/2012/dev_CMCC_INGV_2012/NEMOGCM
Files:
1 deleted
36 edited
9 copied

Legend:

Unmodified
Added
Removed

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/AMM12/EXP00/namelist

    r3309 r3646  
    144144                           !     =2 annual global mean of e-p-r set to zero 
    145145                           !     =3 global emp set to zero and spread out over erp area 
     146   ln_wave = .false.       !  Activate coupling with wave (either Stokes Drift or Drag coefficient, or both)  (T => fill namsbc_wave) 
    146147   ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave) 
     148   ln_sdw  = .false.       !  Computation of 3D stokes drift                (T => fill namsbc_wave) 
    147149/ 
    148150!----------------------------------------------------------------------- 
    … …  
    971973!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! 
    972974   sn_cdg      =  'cdg_wave' ,        1          , 'drag_coeff' , .true.   , .false. , 'daily'  ,''         , '' 
     975   sn_usd      =  'sdw_wave' ,        1          , 'u_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     976   sn_vsd      =  'sdw_wave' ,        1          , 'v_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     977   sn_wn       =  'sdw_wave' ,        1          , 'wave_num'   , .true.   , .false. , 'daily'  ,''         , '' 
    973978! 
    974979   cn_dir_cdg  = './'  !  root directory for the location of drag coefficient files 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/AMM12_PISCES/EXP00/namelist

    r3309 r3646  
    144144                           !     =2 annual global mean of e-p-r set to zero 
    145145                           !     =3 global emp set to zero and spread out over erp area 
     146   ln_wave = .false.       !  Activate coupling with wave (either Stokes Drift or Drag coefficient, or both)  (T => fill namsbc_wave) 
    146147   ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave) 
     148   ln_sdw  = .false.       !  Computation of 3D stokes drift                (T => fill namsbc_wave) 
    147149/ 
    148150!----------------------------------------------------------------------- 
    … …  
    972974!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! 
    973975   sn_cdg      =  'cdg_wave' ,        1          , 'drag_coeff' , .true.   , .false. , 'daily'  ,''         , '' 
     976   sn_usd      =  'sdw_wave' ,        1          , 'u_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     977   sn_vsd      =  'sdw_wave' ,        1          , 'v_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     978   sn_wn       =  'sdw_wave' ,        1          , 'wave_num'   , .true.   , .false. , 'daily'  ,''         , '' 
    974979! 
    975980   cn_dir_cdg  = './'  !  root directory for the location of drag coefficient files 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/GYRE/EXP00/namelist

    r3306 r3646  
    144144                           !     =2 annual global mean of e-p-r set to zero 
    145145                           !     =3 global emp set to zero and spread out over erp area 
     146   ln_wave = .false.       !  Activate coupling with wave (either Stokes Drift or Drag coefficient, or both)  (T => fill namsbc_wave) 
    146147   ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave) 
     148   ln_sdw  = .false.       !  Computation of 3D stokes drift                (T => fill namsbc_wave) 
    147149/ 
    148150!----------------------------------------------------------------------- 
    … …  
    963965!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! 
    964966   sn_cdg      =  'cdg_wave' ,        1          , 'drag_coeff' , .true.   , .false. , 'daily'  ,''         , '' 
     967   sn_usd      =  'sdw_wave' ,        1          , 'u_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     968   sn_vsd      =  'sdw_wave' ,        1          , 'v_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     969   sn_wn       =  'sdw_wave' ,        1          , 'wave_num'   , .true.   , .false. , 'daily'  ,''         , '' 
    965970! 
    966971   cn_dir_cdg  = './'  !  root directory for the location of drag coefficient files 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist

    r3306 r3646  
    144144                           !     =2 annual global mean of e-p-r set to zero 
    145145                           !     =3 global emp set to zero and spread out over erp area 
     146   ln_wave = .false.       !  Activate coupling with wave (either Stokes Drift or Drag coefficient, or both)  (T => fill namsbc_wave) 
    146147   ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave) 
     148   ln_sdw  = .false.       !  Computation of 3D stokes drift                (T => fill namsbc_wave) 
    147149/ 
    148150!----------------------------------------------------------------------- 
    … …  
    967969!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! 
    968970   sn_cdg      =  'cdg_wave' ,        1          , 'drag_coeff' , .true.   , .false. , 'daily'  ,''         , '' 
     971   sn_usd      =  'sdw_wave' ,        1          , 'u_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     972   sn_vsd      =  'sdw_wave' ,        1          , 'v_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     973   sn_wn       =  'sdw_wave' ,        1          , 'wave_num'   , .true.   , .false. , 'daily'  ,''         , '' 
    969974! 
    970975   cn_dir_cdg  = './'  !  root directory for the location of drag coefficient files 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist

    r3306 r3646  
    144144                           !     =2 annual global mean of e-p-r set to zero 
    145145                           !     =3 global emp set to zero and spread out over erp area 
    146    ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave ) 
     146   ln_wave = .false.       !  Activate coupling with wave (either Stokes Drift or Drag coefficient, or both)  (T => fill namsbc_wave) 
     147   ln_cdgw = .false.       !  Neutral drag coefficient read from wave model (T => fill namsbc_wave) 
     148   ln_sdw  = .false.       !  Computation of 3D stokes drift                (T => fill namsbc_wave) 
    147149/ 
    148150!----------------------------------------------------------------------- 
    … …  
    964966!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! 
    965967   sn_cdg      =  'cdg_wave' ,        1          , 'drag_coeff' , .true.   , .false. , 'daily'  ,''         , '' 
     968   sn_usd      =  'sdw_wave' ,        1          , 'u_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     969   sn_vsd      =  'sdw_wave' ,        1          , 'v_sd2d'     , .true.   , .false. , 'daily'  ,''         , '' 
     970   sn_wn       =  'sdw_wave' ,        1          , 'wave_num'   , .true.   , .false. , 'daily'  ,''         , '' 
    966971! 
    967972   cn_dir_cdg  = './'  !  root directory for the location of drag coefficient files 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/CONFIG/cfg.txt

    r3549 r3646  
    1 GYRE OPA_SRC 
    21GYRE_LOBSTER OPA_SRC TOP_SRC 
    32ORCA2_LIM3 OPA_SRC LIM_SRC_3 
    43AMM12 OPA_SRC 
     4ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC 
    55ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 
    66AMM12_PISCES OPA_SRC TOP_SRC 
    77ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 
    8 ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC 
     8GYRE OPA_SRC 
     9GYRE_BFM OPA_SRC TOP_SRC 
     10PELAGOS_OFF OPA_SRC OFF_SRC TOP_SRC 
     11PELAGOS OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 

  • branches/2012/dev_CMCC_INGV_2012/NEMOGCM/EXTERNAL/IOIPSL/tools/flio_rbld.f90

    r2281 r3646  
    678678              io_sl(v_d_ul(iv))=it 
    679679            ENDIF 
     680          ENDIF 
     681!-------- Initialize to zero variables data  
     682          ! approximate dimension 
     683          IF ( it == 1 .AND. l_cgd) THEN 
     684          ! Enter I*J I*J is larger thant total number of single files 
     685            if ( ((f_d_l(1)/(d_s_l(1,1)-3)) * (f_d_l(2)/(d_s_l(2,1)-3) )) .gt. d_n_t ) then  
     686              CALL ZeroFill (f_id_o, f_v_nm(iv), f_d_l, v_d_nb(iv), v_type(iv), v_d_i(1:v_d_nb(iv),iv)) 
     687            endif 
    680688          ENDIF 
    681689        ENDIF 
    … …  
    16211629END SUBROUTINE flrb_rg 
    16221630!=== 
     1631SUBROUTINE ZeroFill(f_id_o,f_v_nm,f_d_l,v_d_nb,v_type,v_d_i) 
     1632 
     1633  IMPLICIT NONE 
     1634! Character length 
     1635  INTEGER,PARAMETER :: chlen=256 
     1636 
     1637  INTEGER              :: v_d_nb, v_type ! variable # of dims, variable type, var Unlim dimension 
     1638  INTEGER              :: f_id_o         ! Output file ID 
     1639  INTEGER,DIMENSION(:) :: f_d_l, v_d_i    ! Global dimensions, variable dimensio ID 
     1640  CHARACTER(LEN=chlen) :: f_v_nm         ! Variable name 
     1641  INTEGER,DIMENSION(:),ALLOCATABLE :: dims 
     1642 
     1643  INTEGER(KIND=i_2) :: i2_0d 
     1644  INTEGER(KIND=i_2), ALLOCATABLE :: i2_1d(:), i2_2d(:,:), i2_3d(:,:,:), i2_4d(:,:,:,:), i2_5d(:,:,:,:,:) 
     1645  INTEGER(KIND=i_4) :: i4_0d 
     1646  INTEGER(KIND=i_4), ALLOCATABLE :: i4_1d(:), i4_2d(:,:), i4_3d(:,:,:), i4_4d(:,:,:,:), i4_5d(:,:,:,:,:) 
     1647  REAL(KIND=r_4) :: r4_0d 
     1648  REAL(KIND=r_4), ALLOCATABLE    :: r4_1d(:), r4_2d(:,:), r4_3d(:,:,:), r4_4d(:,:,:,:), r4_5d(:,:,:,:,:) 
     1649  REAL(KIND=r_8) :: r8_0d 
     1650  REAL(KIND=r_8), ALLOCATABLE    :: r8_1d(:), r8_2d(:,:), r8_3d(:,:,:), r8_4d(:,:,:,:), r8_5d(:,:,:,:,:) 
     1651   
     1652  ! write(*,*) ' Into my sub... TOM' 
     1653  ! write(*,*) f_id_o, TRIM(f_v_nm), v_d_nb , v_type 
     1654  write(*,*) 'Variable: ',TRIM(f_v_nm), ' intiliazed to zero' 
     1655  write(*,*) 
     1656 
     1657  ! define variable dimension 
     1658  ALLOCATE(dims(v_d_nb))  
     1659  dims=f_d_l(v_d_i) 
     1660  SELECT CASE(v_type)  
     1661    ! INTEGER 1 and 2  
     1662    CASE (flio_i1,flio_i2) 
     1663      SELECT CASE (v_d_nb) 
     1664       CASE(1) 
     1665         ALLOCATE(i2_1d(dims(1))) 
     1666         i2_1d=0 
     1667         CALL flioputv (f_id_o,TRIM(f_v_nm),i2_1d) 
     1668         DEALLOCATE(i2_1d) 
     1669       CASE(2) 
     1670         ALLOCATE(i2_2d(dims(1),dims(2))) 
     1671         i2_2d=0 
     1672         CALL flioputv (f_id_o,TRIM(f_v_nm),i2_2d)  
     1673         DEALLOCATE(i2_2d) 
     1674       CASE(3) 
     1675         ALLOCATE(i2_3d(dims(1),dims(2),dims(3))) 
     1676         i2_3d=0 
     1677         CALL flioputv (f_id_o,TRIM(f_v_nm),i2_3d) 
     1678         DEALLOCATE(i2_3d) 
     1679       CASE(4) 
     1680         ALLOCATE(i2_4d(dims(1),dims(2),dims(3),dims(4))) 
     1681         i2_4d=0 
     1682         CALL flioputv (f_id_o,TRIM(f_v_nm),i2_4d) 
     1683         DEALLOCATE(i2_4d) 
     1684       CASE(5) 
     1685         ALLOCATE(i2_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) 
     1686         i2_5d=0 
     1687         CALL flioputv (f_id_o,TRIM(f_v_nm),i2_5d) 
     1688         DEALLOCATE(i2_5d) 
     1689      END SELECT 
     1690    ! INTEGER 4 
     1691    CASE (flio_i4) 
     1692      SELECT CASE (v_d_nb) 
     1693       CASE(1) 
     1694         ALLOCATE(i4_1d(dims(1))) 
     1695         i4_1d=0 
     1696         CALL flioputv (f_id_o,TRIM(f_v_nm),i4_1d) 
     1697         DEALLOCATE(i4_1d) 
     1698       CASE(2) 
     1699         ALLOCATE(i4_2d(dims(1),dims(2))) 
     1700         i4_2d=0 
     1701         CALL flioputv (f_id_o,TRIM(f_v_nm),i4_2d) 
     1702         DEALLOCATE(i4_2d) 
     1703       CASE(3) 
     1704         ALLOCATE(i4_3d(dims(1),dims(2),dims(3))) 
     1705         i4_3d=0 
     1706         CALL flioputv (f_id_o,TRIM(f_v_nm),i4_3d) 
     1707         DEALLOCATE(i4_3d) 
     1708       CASE(4) 
     1709         ALLOCATE(i4_4d(dims(1),dims(2),dims(3),dims(4))) 
     1710         i4_4d=0 
     1711         CALL flioputv (f_id_o,TRIM(f_v_nm),i4_4d) 
     1712         DEALLOCATE(i4_4d) 
     1713       CASE(5) 
     1714         ALLOCATE(i4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) 
     1715         i4_5d=0 
     1716         CALL flioputv (f_id_o,TRIM(f_v_nm),i4_5d) 
     1717         DEALLOCATE(i4_5d) 
     1718      END SELECT 
     1719    ! FLOAT 4 
     1720    CASE (flio_r4) 
     1721      SELECT CASE (v_d_nb) 
     1722       CASE(1) 
     1723         ALLOCATE(r4_1d(dims(1))) 
     1724         r4_1d=0 
     1725         CALL flioputv (f_id_o,TRIM(f_v_nm),r4_1d)  
     1726         DEALLOCATE(r4_1d) 
     1727       CASE(2) 
     1728         ALLOCATE(r4_2d(dims(1),dims(2))) 
     1729         r4_2d=0 
     1730         CALL flioputv (f_id_o,TRIM(f_v_nm),r4_2d)  
     1731         DEALLOCATE(r4_2d) 
     1732       CASE(3) 
     1733         ALLOCATE(r4_3d(dims(1),dims(2),dims(3))) 
     1734         r4_3d=0 
     1735         CALL flioputv (f_id_o,TRIM(f_v_nm),r4_3d)  
     1736         DEALLOCATE(r4_3d) 
     1737       CASE(4) 
     1738         ALLOCATE(r4_4d(dims(1),dims(2),dims(3),dims(4))) 
     1739         r4_4d=0 
     1740         CALL flioputv (f_id_o,TRIM(f_v_nm),r4_4d) 
     1741         DEALLOCATE(r4_4d) 
     1742       CASE(5) 
     1743         ALLOCATE(r4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) 
     1744         r4_5d=0 
     1745         CALL flioputv (f_id_o,TRIM(f_v_nm),r4_5d) 
     1746         DEALLOCATE(r4_5d) 
     1747      END SELECT 
     1748    ! FLOAT 8 
     1749    CASE (flio_r8) 
     1750      SELECT CASE (v_d_nb) 
     1751       CASE(1) 
     1752         ALLOCATE(r8_1d(dims(1))) 
     1753         r8_1d=0 
     1754         CALL flioputv (f_id_o,TRIM(f_v_nm),r8_1d) 
     1755         DEALLOCATE(r8_1d) 
     1756       CASE(2) 
     1757         ALLOCATE(r8_2d(dims(1),dims(2))) 
     1758         r8_2d=0 
     1759         CALL flioputv (f_id_o,TRIM(f_v_nm),r8_2d)  
     1760         DEALLOCATE(r8_2d) 
     1761       CASE(3) 
     1762         ALLOCATE(r8_3d(dims(1),dims(2),dims(3))) 
     1763         r8_3d=0 
     1764         CALL flioputv (f_id_o,TRIM(f_v_nm),r8_3d) 
     1765         DEALLOCATE(r8_3d) 
     1766       CASE(4) 
     1767         ALLOCATE(r8_4d(dims(1),dims(2),dims(3),dims(4))) 
     1768         r8_4d=0 
     1769         CALL flioputv (f_id_o,TRIM(f_v_nm),r8_4d) 
     1770         DEALLOCATE(r8_4d) 
     1771       CASE(5) 
     1772         ALLOCATE(r8_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) 
     1773         r8_5d=0 
     1774         CALL flioputv (f_id_o,TRIM(f_v_nm),r8_5d) 
     1775         DEALLOCATE(r8_5d) 
     1776      END SELECT 
     1777  END SELECT 
     1778 
     1779  DEALLOCATE (dims) 
     1780 
     1781END SUBROUTINE 
     1782!=== 
    16231783!-------------------- 
    16241784END PROGRAM flio_rbld 

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r3294 r3646  
    433433      ! Open file for each variable to get his number of dimension 
    434434      DO ifpr = 1, jfld 
    435          CALL iom_open( slf_d(ifpr)%clname, inum ) 
     435         CALL iom_open( TRIM( cn_dir )//TRIM( slf_d(ifpr)%clname ), inum ) 
    436436         idv   = iom_varid( inum , slf_d(ifpr)%clvar )  ! id of the variable sdjf%clvar 
    437437         idimv = iom_file ( inum )%ndims(idv)             ! number of dimension for variable sdjf%clvar 

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90

    r3294 r3646  
    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  
    … …  
    5455            CYCLE 
    5556         CASE(jp_frs) 
    56             CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     57            CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    5758         CASE DEFAULT 
    5859            CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    … …  
    6263   END SUBROUTINE bdy_dyn3d 
    6364 
    64    SUBROUTINE bdy_dyn3d_frs( idx, dta, kt ) 
     65   SUBROUTINE bdy_dyn3d_frs( idx, dta, kt, ib_bdy ) 
    6566      !!---------------------------------------------------------------------- 
    6667      !!                  ***  SUBROUTINE bdy_dyn3d_frs  *** 
    … …  
    7677      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    7778      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     79      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    7880      !! 
    7981      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    103105         END DO 
    104106      END DO  
    105       CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )   ! Boundary points should be updated 
     107      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    106108      ! 
    107109      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 

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

    r3347 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r3424 r3646  
    1111   !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions 
    1212   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge 
     13   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Updates for the  
     14   !!                             optimization of BDY communications 
    1315   !!---------------------------------------------------------------------- 
    1416#if defined key_bdy 
    … …  
    7678      CHARACTER(LEN=80),DIMENSION(jpbgrd)  ::   clfile 
    7779      CHARACTER(LEN=1),DIMENSION(jpbgrd)   ::   cgrid 
     80      INTEGER :: com_east, com_west, com_south, com_north          ! Flags for boundaries sending 
     81      INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving 
     82      INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates 
     83 
    7884      !! 
    7985      NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file,             & 
    … …  
    543549      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1 
    544550 
     551      ALLOCATE( nbondi_bdy(nb_bdy)) 
     552      ALLOCATE( nbondj_bdy(nb_bdy)) 
     553      nbondi_bdy(:)=2 
     554      nbondj_bdy(:)=2 
     555      ALLOCATE( nbondi_bdy_b(nb_bdy)) 
     556      ALLOCATE( nbondj_bdy_b(nb_bdy)) 
     557      nbondi_bdy_b(:)=2 
     558      nbondj_bdy_b(:)=2 
     559 
     560      ! Work out dimensions of boundary data on each neighbour process 
     561      IF(nbondi .eq. 0) THEN 
     562         iw_b(1) = jpizoom + nimppt(nowe+1) 
     563         ie_b(1) = jpizoom + nimppt(nowe+1)+nlcit(nowe+1)-3 
     564         is_b(1) = jpjzoom + njmppt(nowe+1) 
     565         in_b(1) = jpjzoom + njmppt(nowe+1)+nlcjt(nowe+1)-3 
     566 
     567         iw_b(2) = jpizoom + nimppt(noea+1) 
     568         ie_b(2) = jpizoom + nimppt(noea+1)+nlcit(noea+1)-3 
     569         is_b(2) = jpjzoom + njmppt(noea+1) 
     570         in_b(2) = jpjzoom + njmppt(noea+1)+nlcjt(noea+1)-3 
     571      ELSEIF(nbondi .eq. 1) THEN 
     572         iw_b(1) = jpizoom + nimppt(nowe+1) 
     573         ie_b(1) = jpizoom + nimppt(nowe+1)+nlcit(nowe+1)-3 
     574         is_b(1) = jpjzoom + njmppt(nowe+1) 
     575         in_b(1) = jpjzoom + njmppt(nowe+1)+nlcjt(nowe+1)-3 
     576      ELSEIF(nbondi .eq. -1) THEN 
     577         iw_b(2) = jpizoom + nimppt(noea+1) 
     578         ie_b(2) = jpizoom + nimppt(noea+1)+nlcit(noea+1)-3 
     579         is_b(2) = jpjzoom + njmppt(noea+1) 
     580         in_b(2) = jpjzoom + njmppt(noea+1)+nlcjt(noea+1)-3 
     581      ENDIF 
     582 
     583      IF(nbondj .eq. 0) THEN 
     584         iw_b(3) = jpizoom + nimppt(noso+1) 
     585         ie_b(3) = jpizoom + nimppt(noso+1)+nlcit(noso+1)-3 
     586         is_b(3) = jpjzoom + njmppt(noso+1) 
     587         in_b(3) = jpjzoom + njmppt(noso+1)+nlcjt(noso+1)-3 
     588 
     589         iw_b(4) = jpizoom + nimppt(nono+1) 
     590         ie_b(4) = jpizoom + nimppt(nono+1)+nlcit(nono+1)-3 
     591         is_b(4) = jpjzoom + njmppt(nono+1) 
     592         in_b(4) = jpjzoom + njmppt(nono+1)+nlcjt(nono+1)-3 
     593      ELSEIF(nbondj .eq. 1) THEN 
     594         iw_b(3) = jpizoom + nimppt(noso+1) 
     595         ie_b(3) = jpizoom + nimppt(noso+1)+nlcit(noso+1)-3 
     596         is_b(3) = jpjzoom + njmppt(noso+1) 
     597         in_b(3) = jpjzoom + njmppt(noso+1)+nlcjt(noso+1)-3 
     598      ELSEIF(nbondj .eq. -1) THEN 
     599         iw_b(4) = jpizoom + nimppt(nono+1) 
     600         ie_b(4) = jpizoom + nimppt(nono+1)+nlcit(nono+1)-3 
     601         is_b(4) = jpjzoom + njmppt(nono+1) 
     602         in_b(4) = jpjzoom + njmppt(nono+1)+nlcjt(nono+1)-3 
     603      ENDIF 
     604 
    545605      DO ib_bdy = 1, nb_bdy 
    546606         DO igrd = 1, jpbgrd 
    … …  
    585645         ! ----------------------------------------------------------------- 
    586646 
     647         com_east = 0 
     648         com_west = 0 
     649         com_south = 0 
     650         com_north = 0 
     651 
     652         com_east_b = 0 
     653         com_west_b = 0 
     654         com_south_b = 0 
     655         com_north_b = 0 
    587656         DO igrd = 1, jpbgrd 
    588657            icount  = 0 
    … …  
    598667                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1 
    599668                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 
     669                     ! check if point has to be sent 
     670                     ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 
     671                     ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 
     672                     if((com_east .ne. 1) .and. (ii .eq. (nlci-1)) .and. (nbondi .le. 0)) then 
     673                        com_east = 1 
     674                     elseif((com_west .ne. 1) .and. (ii .eq. 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 
     675                        com_west = 1 
     676                     endif  
     677                     if((com_south .ne. 1) .and. (ij .eq. 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 
     678                        com_south = 1 
     679                     elseif((com_north .ne. 1) .and. (ij .eq. (nlcj-1)) .and. (nbondj .le. 0)) then 
     680                        com_north = 1 
     681                     endif  
    600682                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy) 
    601683                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 
    602684                  ENDIF 
     685                  ! check if point has to be received from a neighbour 
     686                  IF(nbondi .eq. 0) THEN 
     687                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
     688                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
     689                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     690                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
     691                       if((com_west_b .ne. 1) .and. (ii .eq. (nlcit(nowe+1)-1))) then 
     692                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
     693                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     694                            com_south = 1 
     695                          elseif((ij .eq. nlcjt(nowe+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     696                            com_north = 1 
     697                          endif 
     698                          com_west_b = 1 
     699                       endif  
     700                     ENDIF 
     701                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
     702                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
     703                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     704                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
     705                       if((com_east_b .ne. 1) .and. (ii .eq. 2)) then 
     706                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
     707                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     708                            com_south = 1 
     709                          elseif((ij .eq. nlcjt(noea+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     710                            com_north = 1 
     711                          endif 
     712                          com_east_b = 1 
     713                       endif  
     714                     ENDIF 
     715                  ELSEIF(nbondi .eq. 1) THEN 
     716                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
     717                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
     718                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     719                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
     720                       if((com_west_b .ne. 1) .and. (ii .eq. (nlcit(nowe+1)-1))) then 
     721                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
     722                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     723                            com_south = 1 
     724                          elseif((ij .eq. nlcjt(nowe+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     725                            com_north = 1 
     726                          endif 
     727                          com_west_b = 1 
     728                       endif  
     729                     ENDIF 
     730                  ELSEIF(nbondi .eq. -1) THEN 
     731                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
     732                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
     733                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     734                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
     735                       if((com_east_b .ne. 1) .and. (ii .eq. 2)) then 
     736                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
     737                          if((ij .eq. 2) .and. (nbondj .eq. 0 .or. nbondj .eq. 1)) then 
     738                            com_south = 1 
     739                          elseif((ij .eq. nlcjt(noea+1)-1) .and. (nbondj .eq. 0 .or. nbondj .eq. -1)) then 
     740                            com_north = 1 
     741                          endif 
     742                          com_east_b = 1 
     743                       endif  
     744                     ENDIF 
     745                  ENDIF 
     746                  IF(nbondj .eq. 0) THEN 
     747                     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. & 
     748                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     749                       com_north_b = 1  
     750                     ENDIF 
     751                     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. & 
     752                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     753                       com_south_b = 1  
     754                     ENDIF 
     755                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
     756                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
     757                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     758                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
     759                       if((com_south_b .ne. 1) .and. (ij .eq. (nlcjt(noso+1)-1))) then 
     760                          com_south_b = 1 
     761                       endif  
     762                     ENDIF 
     763                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
     764                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
     765                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     766                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
     767                       if((com_north_b .ne. 1) .and. (ij .eq. 2)) then 
     768                          com_north_b = 1 
     769                       endif  
     770                     ENDIF 
     771                  ELSEIF(nbondj .eq. 1) THEN 
     772                     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. & 
     773                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     774                       com_south_b = 1  
     775                     ENDIF 
     776                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
     777                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
     778                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     779                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
     780                       if((com_south_b .ne. 1) .and. (ij .eq. (nlcjt(noso+1)-1))) then 
     781                          com_south_b = 1 
     782                       endif  
     783                     ENDIF 
     784                  ELSEIF(nbondj .eq. -1) THEN 
     785                     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. & 
     786                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
     787                       com_north_b = 1  
     788                     ENDIF 
     789                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
     790                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
     791                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
     792                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
     793                       if((com_north_b .ne. 1) .and. (ij .eq. 2)) then 
     794                          com_north_b = 1 
     795                       endif  
     796                     ENDIF 
     797                  ENDIF 
    603798               ENDDO 
    604799            ENDDO 
    605800         ENDDO  
     801         ! definition of the i- and j- direction local boundaries arrays 
     802         ! used for sending the boudaries 
     803         IF((com_east .eq. 1) .and. (com_west .eq. 1)) THEN 
     804            nbondi_bdy(ib_bdy) = 0 
     805         ELSEIF ((com_east .eq. 1) .and. (com_west .eq. 0)) THEN 
     806            nbondi_bdy(ib_bdy) = -1 
     807         ELSEIF ((com_east .eq. 0) .and. (com_west .eq. 1)) THEN 
     808            nbondi_bdy(ib_bdy) = 1 
     809         ENDIF 
     810 
     811         IF((com_north .eq. 1) .and. (com_south .eq. 1)) THEN 
     812            nbondj_bdy(ib_bdy) = 0 
     813         ELSEIF ((com_north .eq. 1) .and. (com_south .eq. 0)) THEN 
     814            nbondj_bdy(ib_bdy) = -1 
     815         ELSEIF ((com_north .eq. 0) .and. (com_south .eq. 1)) THEN 
     816            nbondj_bdy(ib_bdy) = 1 
     817         ENDIF 
     818 
     819         ! definition of the i- and j- direction local boundaries arrays 
     820         ! used for receiving the boudaries 
     821         IF((com_east_b .eq. 1) .and. (com_west_b .eq. 1)) THEN 
     822            nbondi_bdy_b(ib_bdy) = 0 
     823         ELSEIF ((com_east_b .eq. 1) .and. (com_west_b .eq. 0)) THEN 
     824            nbondi_bdy_b(ib_bdy) = -1 
     825         ELSEIF ((com_east_b .eq. 0) .and. (com_west_b .eq. 1)) THEN 
     826            nbondi_bdy_b(ib_bdy) = 1 
     827         ENDIF 
     828 
     829         IF((com_north_b .eq. 1) .and. (com_south_b .eq. 1)) THEN 
     830            nbondj_bdy_b(ib_bdy) = 0 
     831         ELSEIF ((com_north_b .eq. 1) .and. (com_south_b .eq. 0)) THEN 
     832            nbondj_bdy_b(ib_bdy) = -1 
     833         ELSEIF ((com_north_b .eq. 0) .and. (com_south_b .eq. 1)) THEN 
     834            nbondj_bdy_b(ib_bdy) = 1 
     835         ENDIF 
    606836 
    607837         ! Compute rim weights for FRS scheme 

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

    r3294 r3646  
    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 
    … …  
    5253            CYCLE 
    5354         CASE(jp_frs) 
    54             CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
     55            CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    5556         CASE DEFAULT 
    5657            CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
    … …  
    6061   END SUBROUTINE bdy_tra 
    6162 
    62    SUBROUTINE bdy_tra_frs( idx, dta, kt ) 
     63   SUBROUTINE bdy_tra_frs( idx, dta, kt, ib_bdy ) 
    6364      !!---------------------------------------------------------------------- 
    6465      !!                 ***  SUBROUTINE bdy_tra_frs  *** 
    … …  
    7172      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    7273      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
     74      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    7375      !!  
    7476      REAL(wp) ::   zwgt           ! boundary weight 
    … …  
    8991         END DO 
    9092      END DO  
    91       ! 
    92       CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. )   ; CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. )    ! Boundary points should be updated 
     93      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 
    9394      ! 
    9495      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 

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

    r3421 r3646  
    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 

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

    r2442 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r3435 r3646  
    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 
    … …  
    6871   PUBLIC   mppsize 
    6972   PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90 
     73   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
     74   PUBLIC   mpp_lnk_obc_2d, mpp_lnk_obc_3d 
    7075 
    7176   !! * Interfaces 
    … …  
    354359   END FUNCTION mynode 
    355360 
    356  
    357    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    358       !!---------------------------------------------------------------------- 
    359       !!                  ***  routine mpp_lnk_3d  *** 
     361   SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 
     362      !!---------------------------------------------------------------------- 
     363      !!                  ***  routine mpp_lnk_obc_3d  *** 
    360364      !! 
    361365      !! ** Purpose :   Message passing manadgement 
    362366      !! 
    363       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     367      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    364368      !!      between processors following neighboring subdomains. 
    365369      !!            domain parameters 
    … …  
    381385      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    382386      !                                                             ! =  1. , the sign is kept 
    383       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    384       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    385387      !! 
    386388      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    … …  
    391393      !!---------------------------------------------------------------------- 
    392394 
    393       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    394       ELSE                         ;   zland = 0.e0      ! zero by default 
    395       ENDIF 
     395      zland = 0.e0      ! zero by default 
    396396 
    397397      ! 1. standard boundary treatment 
    398398      ! ------------------------------ 
    399       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    400          ! 
    401          ! WARNING ptab is defined only between nld and nle 
    402          DO jk = 1, jpk 
    403             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    404                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
    405                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    406                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    407             END DO 
    408             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    409                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    410                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    411                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    412             END DO 
    413          END DO 
    414          ! 
    415       ELSE                              ! standard close or cyclic treatment  
    416          ! 
    417          !                                   ! East-West boundaries 
    418          !                                        !* Cyclic east-west 
    419          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    420             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    421             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    422          ELSE                                     !* closed 
    423             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    424                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    425          ENDIF 
    426          !                                   ! North-South boundaries (always closed) 
    427          IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    428                                       ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    429          ! 
     399      IF( nbondi == 2) THEN 
     400        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     401          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     402          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     403        ELSE 
     404          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     405          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     406        ENDIF 
     407      ELSEIF(nbondi == -1) THEN 
     408        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     409      ELSEIF(nbondi == 1) THEN 
     410        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     411      ENDIF                                     !* closed 
     412 
     413      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     414        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     415      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     416        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    430417      ENDIF 
    431418 
    … …  
    434421      ! we play with the neigbours AND the row number because of the periodicity  
    435422      ! 
     423      IF(nbondj .ne. 0) THEN 
    436424      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    437425      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    … …  
    472460            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    473461         END DO 
    474       CASE ( 0 )  
     462      CASE ( 0 ) 
    475463         DO jl = 1, jpreci 
    476464            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
    … …  
    482470         END DO 
    483471      END SELECT 
     472      ENDIF 
    484473 
    485474 
    … …  
    488477      ! always closed : we play only with the neigbours 
    489478      ! 
     479      IF(nbondi .ne. 0) THEN 
    490480      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    491481         ijhom = nlcj-nrecj 
    … …  
    525515            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    526516         END DO 
    527       CASE ( 0 )  
     517      CASE ( 0 ) 
    528518         DO jl = 1, jprecj 
    529519            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
    … …  
    535525         END DO 
    536526      END SELECT 
     527      ENDIF 
    537528 
    538529 
    … …  
    540531      ! ----------------------- 
    541532      ! 
    542       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     533      IF( npolj /= 0 ) THEN 
    543534         ! 
    544535         SELECT CASE ( jpni ) 
    … …  
    549540      ENDIF 
    550541      ! 
    551    END SUBROUTINE mpp_lnk_3d 
    552  
    553  
    554    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    555       !!---------------------------------------------------------------------- 
    556       !!                  ***  routine mpp_lnk_2d  *** 
     542   END SUBROUTINE mpp_lnk_obc_3d 
     543 
     544 
     545   SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 
     546      !!---------------------------------------------------------------------- 
     547      !!                  ***  routine mpp_lnk_obc_2d  *** 
    557548      !!                   
    558549      !! ** Purpose :   Message passing manadgement for 2d array 
    559550      !! 
    560       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     551      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries  
    561552      !!      between processors following neighboring subdomains. 
    562553      !!            domain parameters 
    … …  
    576567      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    577568      !                                                         ! =  1. , the sign is kept 
    578       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
    579       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    580569      !! 
    581570      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    … …  
    586575      !!---------------------------------------------------------------------- 
    587576 
    588       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    589       ELSE                         ;   zland = 0.e0      ! zero by default 
    590       ENDIF 
     577      zland = 0.e0      ! zero by default 
    591578 
    592579      ! 1. standard boundary treatment 
    593580      ! ------------------------------ 
    594581      ! 
    595       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    596          ! 
    597          ! WARNING pt2d is defined only between nld and nle 
    598          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    599             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
    600             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    601             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    602          END DO 
    603          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    604             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    605             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    606             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    607          END DO 
    608          ! 
    609       ELSE                              ! standard close or cyclic treatment  
    610          ! 
    611          !                                   ! East-West boundaries 
    612          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    613             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    614             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    615             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    616          ELSE                                     ! closed 
    617             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    618                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    619          ENDIF 
    620          !                                   ! North-South boundaries (always closed) 
    621             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    622                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    623          ! 
     582      IF( nbondi == 2) THEN 
     583        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     584          pt2d( 1 ,:) = pt2d(jpim1,:) 
     585          pt2d(jpi,:) = pt2d(  2  ,:) 
     586        ELSE 
     587          IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     588          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     589        ENDIF 
     590      ELSEIF(nbondi == -1) THEN 
     591        IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     592      ELSEIF(nbondi == 1) THEN 
     593        pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     594      ENDIF                                     !* closed 
     595 
     596      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     597        IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland       ! south except F-point 
     598      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     599        pt2d(:,nlcj-jprecj+1:jpj) = zland       ! north 
    624600      ENDIF 
    625601 
    … …  
    734710      ! ----------------------- 
    735711      ! 
     712      IF( npolj /= 0 ) THEN 
     713         ! 
     714         SELECT CASE ( jpni ) 
     715         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     716         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
     717         END SELECT 
     718         ! 
     719      ENDIF 
     720      ! 
     721   END SUBROUTINE mpp_lnk_obc_2d 
     722 
     723   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     724      !!---------------------------------------------------------------------- 
     725      !!                  ***  routine mpp_lnk_3d  *** 
     726      !! 
     727      !! ** Purpose :   Message passing manadgement 
     728      !! 
     729      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     730      !!      between processors following neighboring subdomains. 
     731      !!            domain parameters 
     732      !!                    nlci   : first dimension of the local subdomain 
     733      !!                    nlcj   : second dimension of the local subdomain 
     734      !!                    nbondi : mark for "east-west local boundary" 
     735      !!                    nbondj : mark for "north-south local boundary" 
     736      !!                    noea   : number for local neighboring processors  
     737      !!                    nowe   : number for local neighboring processors 
     738      !!                    noso   : number for local neighboring processors 
     739      !!                    nono   : number for local neighboring processors 
     740      !! 
     741      !! ** Action  :   ptab with update value at its periphery 
     742      !! 
     743      !!---------------------------------------------------------------------- 
     744      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     745      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     746      !                                                             ! = T , U , V , F , W points 
     747      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     748      !                                                             ! =  1. , the sign is kept 
     749      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     750      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     751      !! 
     752      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     753      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     754      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     755      REAL(wp) ::   zland 
     756      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     757      !!---------------------------------------------------------------------- 
     758 
     759      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     760      ELSE                         ;   zland = 0.e0      ! zero by default 
     761      ENDIF 
     762 
     763      ! 1. standard boundary treatment 
     764      ! ------------------------------ 
     765      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     766         ! 
     767         ! WARNING ptab is defined only between nld and nle 
     768         DO jk = 1, jpk 
     769            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     770               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
     771               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
     772               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     773            END DO 
     774            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     775               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
     776               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
     777               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
     778            END DO 
     779         END DO 
     780         ! 
     781      ELSE                              ! standard close or cyclic treatment  
     782         ! 
     783         !                                   ! East-West boundaries 
     784         !                                        !* Cyclic east-west 
     785         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     786            ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     787            ptab(jpi,:,:) = ptab(  2  ,:,:) 
     788         ELSE                                     !* closed 
     789            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     790                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     791         ENDIF 
     792         !                                   ! North-South boundaries (always closed) 
     793         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     794                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     795         ! 
     796      ENDIF 
     797 
     798      ! 2. East and west directions exchange 
     799      ! ------------------------------------ 
     800      ! we play with the neigbours AND the row number because of the periodicity  
     801      ! 
     802      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     803      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     804         iihom = nlci-nreci 
     805         DO jl = 1, jpreci 
     806            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     807            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     808         END DO 
     809      END SELECT   
     810      ! 
     811      !                           ! Migrations 
     812      imigr = jpreci * jpj * jpk 
     813      ! 
     814      SELECT CASE ( nbondi )  
     815      CASE ( -1 ) 
     816         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     817         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     818         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     819      CASE ( 0 ) 
     820         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     821         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     822         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     823         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     824         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     825         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     826      CASE ( 1 ) 
     827         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     828         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     829         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     830      END SELECT 
     831      ! 
     832      !                           ! Write Dirichlet lateral conditions 
     833      iihom = nlci-jpreci 
     834      ! 
     835      SELECT CASE ( nbondi ) 
     836      CASE ( -1 ) 
     837         DO jl = 1, jpreci 
     838            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     839         END DO 
     840      CASE ( 0 )  
     841         DO jl = 1, jpreci 
     842            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     843            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     844         END DO 
     845      CASE ( 1 ) 
     846         DO jl = 1, jpreci 
     847            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     848         END DO 
     849      END SELECT 
     850 
     851 
     852      ! 3. North and south directions 
     853      ! ----------------------------- 
     854      ! always closed : we play only with the neigbours 
     855      ! 
     856      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     857         ijhom = nlcj-nrecj 
     858         DO jl = 1, jprecj 
     859            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     860            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     861         END DO 
     862      ENDIF 
     863      ! 
     864      !                           ! Migrations 
     865      imigr = jprecj * jpi * jpk 
     866      ! 
     867      SELECT CASE ( nbondj )      
     868      CASE ( -1 ) 
     869         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     870         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     871         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     872      CASE ( 0 ) 
     873         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     874         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     875         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     876         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     877         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     878         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     879      CASE ( 1 )  
     880         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     881         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     882         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     883      END SELECT 
     884      ! 
     885      !                           ! Write Dirichlet lateral conditions 
     886      ijhom = nlcj-jprecj 
     887      ! 
     888      SELECT CASE ( nbondj ) 
     889      CASE ( -1 ) 
     890         DO jl = 1, jprecj 
     891            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     892         END DO 
     893      CASE ( 0 )  
     894         DO jl = 1, jprecj 
     895            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     896            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     897         END DO 
     898      CASE ( 1 ) 
     899         DO jl = 1, jprecj 
     900            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     901         END DO 
     902      END SELECT 
     903 
     904 
     905      ! 4. north fold treatment 
     906      ! ----------------------- 
     907      ! 
     908      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     909         ! 
     910         SELECT CASE ( jpni ) 
     911         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     912         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     913         END SELECT 
     914         ! 
     915      ENDIF 
     916      ! 
     917   END SUBROUTINE mpp_lnk_3d 
     918 
     919 
     920   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     921      !!---------------------------------------------------------------------- 
     922      !!                  ***  routine mpp_lnk_2d  *** 
     923      !!                   
     924      !! ** Purpose :   Message passing manadgement for 2d array 
     925      !! 
     926      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     927      !!      between processors following neighboring subdomains. 
     928      !!            domain parameters 
     929      !!                    nlci   : first dimension of the local subdomain 
     930      !!                    nlcj   : second dimension of the local subdomain 
     931      !!                    nbondi : mark for "east-west local boundary" 
     932      !!                    nbondj : mark for "north-south local boundary" 
     933      !!                    noea   : number for local neighboring processors  
     934      !!                    nowe   : number for local neighboring processors 
     935      !!                    noso   : number for local neighboring processors 
     936      !!                    nono   : number for local neighboring processors 
     937      !! 
     938      !!---------------------------------------------------------------------- 
     939      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
     940      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     941      !                                                         ! = T , U , V , F , W and I points 
     942      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     943      !                                                         ! =  1. , the sign is kept 
     944      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     945      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     946      !! 
     947      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     948      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     949      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     950      REAL(wp) ::   zland 
     951      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     952      !!---------------------------------------------------------------------- 
     953 
     954      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     955      ELSE                         ;   zland = 0.e0      ! zero by default 
     956      ENDIF 
     957 
     958      ! 1. standard boundary treatment 
     959      ! ------------------------------ 
     960      ! 
     961      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     962         ! 
     963         ! WARNING pt2d is defined only between nld and nle 
     964         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     965            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
     966            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
     967            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
     968         END DO 
     969         DO ji = nlci+1, jpi                 ! added column(s) (full) 
     970            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
     971            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
     972            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
     973         END DO 
     974         ! 
     975      ELSE                              ! standard close or cyclic treatment  
     976         ! 
     977         !                                   ! East-West boundaries 
     978         IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
     979            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     980            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
     981            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
     982         ELSE                                     ! closed 
     983            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
     984                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     985         ENDIF 
     986         !                                   ! North-South boundaries (always closed) 
     987            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
     988                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
     989         ! 
     990      ENDIF 
     991 
     992      ! 2. East and west directions exchange 
     993      ! ------------------------------------ 
     994      ! we play with the neigbours AND the row number because of the periodicity  
     995      ! 
     996      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     997      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     998         iihom = nlci-nreci 
     999         DO jl = 1, jpreci 
     1000            t2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     1001            t2we(:,jl,1) = pt2d(iihom +jl,:) 
     1002         END DO 
     1003      END SELECT 
     1004      ! 
     1005      !                           ! Migrations 
     1006      imigr = jpreci * jpj 
     1007      ! 
     1008      SELECT CASE ( nbondi ) 
     1009      CASE ( -1 ) 
     1010         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     1011         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1012         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1013      CASE ( 0 ) 
     1014         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1015         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     1016         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1017         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1018         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1019         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1020      CASE ( 1 ) 
     1021         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1022         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     1023         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1024      END SELECT 
     1025      ! 
     1026      !                           ! Write Dirichlet lateral conditions 
     1027      iihom = nlci - jpreci 
     1028      ! 
     1029      SELECT CASE ( nbondi ) 
     1030      CASE ( -1 ) 
     1031         DO jl = 1, jpreci 
     1032            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1033         END DO 
     1034      CASE ( 0 ) 
     1035         DO jl = 1, jpreci 
     1036            pt2d(jl      ,:) = t2we(:,jl,2) 
     1037            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
     1038         END DO 
     1039      CASE ( 1 ) 
     1040         DO jl = 1, jpreci 
     1041            pt2d(jl      ,:) = t2we(:,jl,2) 
     1042         END DO 
     1043      END SELECT 
     1044 
     1045 
     1046      ! 3. North and south directions 
     1047      ! ----------------------------- 
     1048      ! always closed : we play only with the neigbours 
     1049      ! 
     1050      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     1051         ijhom = nlcj-nrecj 
     1052         DO jl = 1, jprecj 
     1053            t2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     1054            t2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     1055         END DO 
     1056      ENDIF 
     1057      ! 
     1058      !                           ! Migrations 
     1059      imigr = jprecj * jpi 
     1060      ! 
     1061      SELECT CASE ( nbondj ) 
     1062      CASE ( -1 ) 
     1063         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     1064         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1065         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1066      CASE ( 0 ) 
     1067         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1068         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     1069         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1070         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1071         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1072         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1073      CASE ( 1 ) 
     1074         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1075         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     1076         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1077      END SELECT 
     1078      ! 
     1079      !                           ! Write Dirichlet lateral conditions 
     1080      ijhom = nlcj - jprecj 
     1081      ! 
     1082      SELECT CASE ( nbondj ) 
     1083      CASE ( -1 ) 
     1084         DO jl = 1, jprecj 
     1085            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1086         END DO 
     1087      CASE ( 0 ) 
     1088         DO jl = 1, jprecj 
     1089            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1090            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
     1091         END DO 
     1092      CASE ( 1 )  
     1093         DO jl = 1, jprecj 
     1094            pt2d(:,jl      ) = t2sn(:,jl,2) 
     1095         END DO 
     1096      END SELECT 
     1097 
     1098 
     1099      ! 4. north fold treatment 
     1100      ! ----------------------- 
     1101      ! 
    7361102      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    7371103         ! 
    … …  
    17812147      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend 
    17822148      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace 
     2149      LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 
    17832150      !!---------------------------------------------------------------------- 
    17842151 
    … …  
    18062173         CALL mppstop 
    18072174      ENDIF 
    1808        
     2175 
    18092176      ! Communication level by level 
    18102177      ! ---------------------------- 
    18112178!!gm Remark : this is very time consumming!!! 
    18122179      !                                         ! ------------------------ ! 
     2180            IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 
     2181            ! there is nothing to be migrated 
     2182               lmigr = .FALSE. 
     2183            ELSE 
     2184              lmigr = .TRUE. 
     2185            ENDIF 
     2186 
     2187      IF( lmigr ) THEN 
     2188 
    18132189      DO jk = 1, kk                             !   Loop over the levels   ! 
    18142190         !                                      ! ------------------------ ! 
    … …  
    18322208         ! --------------------------- 
    18332209         ! 
     2210       IF( ktype == 1 ) THEN 
     2211 
    18342212         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18352213            iihom = nlci-nreci 
    1836             DO jl = 1, jpreci 
    1837                t2ew(:,jl,1) = ztab(jpreci+jl,:) 
    1838                t2we(:,jl,1) = ztab(iihom +jl,:) 
    1839             END DO 
     2214            t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 
     2215            t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 
    18402216         ENDIF 
    18412217         ! 
    18422218         !                              ! Migrations 
    1843          imigr=jpreci*jpj 
     2219         imigr = jpreci 
    18442220         ! 
    18452221         IF( nbondi == -1 ) THEN 
    … …  
    18642240         ! 
    18652241         IF( nbondi == 0 .OR. nbondi == 1 ) THEN 
    1866             DO jl = 1, jpreci 
    1867                ztab(jl,:) = t2we(:,jl,2) 
    1868             END DO 
     2242            ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 
    18692243         ENDIF 
    18702244         IF( nbondi == -1 .OR. nbondi == 0 ) THEN 
    1871             DO jl = 1, jpreci 
    1872                ztab(iihom+jl,:) = t2ew(:,jl,2) 
    1873             END DO 
     2245            ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 
    18742246         ENDIF 
    1875  
     2247       ENDIF  ! (ktype == 1) 
    18762248 
    18772249         ! 2. North and south directions 
    18782250         ! ----------------------------- 
    18792251         ! 
     2252       IF(ktype == 2 ) THEN 
    18802253         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions 
    18812254            ijhom = nlcj-nrecj 
    1882             DO jl = 1, jprecj 
    1883                t2sn(:,jl,1) = ztab(:,ijhom +jl) 
    1884                t2ns(:,jl,1) = ztab(:,jprecj+jl) 
    1885             END DO 
     2255            t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 
     2256            t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 
    18862257         ENDIF 
    18872258         ! 
    18882259         !                              ! Migrations 
    1889          imigr = jprecj * jpi 
     2260         imigr = jprecj 
    18902261         ! 
    18912262         IF( nbondj == -1 ) THEN 
    … …  
    19092280         ijhom = nlcj - jprecj 
    19102281         IF( nbondj == 0 .OR. nbondj == 1 ) THEN 
    1911             DO jl = 1, jprecj 
    1912                ztab(:,jl) = t2sn(:,jl,2) 
    1913             END DO 
     2282            ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 
    19142283         ENDIF 
    19152284         IF( nbondj == 0 .OR. nbondj == -1 ) THEN 
    1916             DO jl = 1, jprecj 
    1917                ztab(:,ijhom+jl) = t2ns(:,jl,2) 
    1918             END DO 
     2285            ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 
    19192286         ENDIF 
     2287         ENDIF    ! (ktype == 2) 
    19202288         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 
    19212289            DO jj = ijpt0, ijpt1            ! north/south boundaries 
    19222290               DO ji = iipt0,ilpt1 
    1923                   ptab(ji,jk) = ztab(ji,jj)   
     2291                  ptab(ji,jk) = ztab(ji,jj) 
    19242292               END DO 
    19252293            END DO 
    … …  
    19272295            DO jj = ijpt0, ilpt1            ! east/west boundaries 
    19282296               DO ji = iipt0,iipt1 
    1929                   ptab(jj,jk) = ztab(ji,jj)  
     2297                  ptab(jj,jk) = ztab(ji,jj) 
    19302298               END DO 
    19312299            END DO 
    … …  
    19342302      END DO 
    19352303      ! 
     2304      ENDIF ! ( lmigr ) 
    19362305      CALL wrk_dealloc( jpi,jpj, ztab ) 
    19372306      ! 
    … …  
    25332902   END SUBROUTINE mpp_lbc_north_e 
    25342903 
     2904      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
     2905      !!---------------------------------------------------------------------- 
     2906      !!                  ***  routine mpp_lnk_bdy_3d  *** 
     2907      !! 
     2908      !! ** Purpose :   Message passing management 
     2909      !! 
     2910      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     2911      !!      between processors following neighboring subdomains. 
     2912      !!            domain parameters 
     2913      !!                    nlci   : first dimension of the local subdomain 
     2914      !!                    nlcj   : second dimension of the local subdomain 
     2915      !!                    nbondi_bdy : mark for "east-west local boundary" 
     2916      !!                    nbondj_bdy : mark for "north-south local boundary" 
     2917      !!                    noea   : number for local neighboring processors  
     2918      !!                    nowe   : number for local neighboring processors 
     2919      !!                    noso   : number for local neighboring processors 
     2920      !!                    nono   : number for local neighboring processors 
     2921      !! 
     2922      !! ** Action  :   ptab with update value at its periphery 
     2923      !! 
     2924      !!---------------------------------------------------------------------- 
     2925 
     2926      USE lbcnfd          ! north fold 
     2927 
     2928      INCLUDE 'mpif.h' 
     2929 
     2930      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     2931      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     2932      !                                                             ! = T , U , V , F , W points 
     2933      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     2934      !                                                             ! =  1. , the sign is kept 
     2935      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     2936      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     2937      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     2938      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     2939      REAL(wp) ::   zland 
     2940      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     2941      !!---------------------------------------------------------------------- 
     2942 
     2943      zland = 0.e0 
     2944 
     2945      ! 1. standard boundary treatment 
     2946      ! ------------------------------ 
     2947       
     2948      !                                   ! East-West boundaries 
     2949      !                                        !* Cyclic east-west 
     2950 
     2951      IF( nbondi == 2) THEN 
     2952        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     2953          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
     2954          ptab(jpi,:,:) = ptab(  2  ,:,:) 
     2955        ELSE 
     2956          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2957          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2958        ENDIF 
     2959      ELSEIF(nbondi == -1) THEN 
     2960        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
     2961      ELSEIF(nbondi == 1) THEN 
     2962        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     2963      ENDIF                                     !* closed 
     2964 
     2965      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     2966        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
     2967      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     2968        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     2969      ENDIF 
     2970       
     2971      ! 
     2972 
     2973      ! 2. East and west directions exchange 
     2974      ! ------------------------------------ 
     2975      ! we play with the neigbours AND the row number because of the periodicity  
     2976      ! 
     2977      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     2978      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     2979         iihom = nlci-nreci 
     2980         DO jl = 1, jpreci 
     2981            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     2982            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     2983         END DO 
     2984      END SELECT 
     2985      ! 
     2986      !                           ! Migrations 
     2987      imigr = jpreci * jpj * jpk 
     2988      ! 
     2989      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     2990      CASE ( -1 ) 
     2991         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     2992      CASE ( 0 ) 
     2993         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2994         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     2995      CASE ( 1 ) 
     2996         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     2997      END SELECT 
     2998      ! 
     2999      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3000      CASE ( -1 ) 
     3001         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3002      CASE ( 0 ) 
     3003         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     3004         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3005      CASE ( 1 ) 
     3006         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
     3007      END SELECT 
     3008      ! 
     3009      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3010      CASE ( -1 ) 
     3011         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3012      CASE ( 0 ) 
     3013         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3014         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3015      CASE ( 1 ) 
     3016         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3017      END SELECT 
     3018      ! 
     3019      !                           ! Write Dirichlet lateral conditions 
     3020      iihom = nlci-jpreci 
     3021      ! 
     3022      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3023      CASE ( -1 ) 
     3024         DO jl = 1, jpreci 
     3025            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3026         END DO 
     3027      CASE ( 0 ) 
     3028         DO jl = 1, jpreci 
     3029            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3030            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     3031         END DO 
     3032      CASE ( 1 ) 
     3033         DO jl = 1, jpreci 
     3034            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     3035         END DO 
     3036      END SELECT 
     3037 
     3038 
     3039      ! 3. North and south directions 
     3040      ! ----------------------------- 
     3041      ! always closed : we play only with the neigbours 
     3042      ! 
     3043      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3044         ijhom = nlcj-nrecj 
     3045         DO jl = 1, jprecj 
     3046            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     3047            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     3048         END DO 
     3049      ENDIF 
     3050      ! 
     3051      !                           ! Migrations 
     3052      imigr = jprecj * jpi * jpk 
     3053      ! 
     3054      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3055      CASE ( -1 ) 
     3056         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     3057      CASE ( 0 ) 
     3058         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3059         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     3060      CASE ( 1 ) 
     3061         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     3062      END SELECT 
     3063      ! 
     3064      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3065      CASE ( -1 ) 
     3066         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3067      CASE ( 0 ) 
     3068         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     3069         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3070      CASE ( 1 ) 
     3071         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     3072      END SELECT 
     3073      ! 
     3074      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3075      CASE ( -1 ) 
     3076         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3077      CASE ( 0 ) 
     3078         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3079         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3080      CASE ( 1 ) 
     3081         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3082      END SELECT 
     3083      ! 
     3084      !                           ! Write Dirichlet lateral conditions 
     3085      ijhom = nlcj-jprecj 
     3086      ! 
     3087      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3088      CASE ( -1 ) 
     3089         DO jl = 1, jprecj 
     3090            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3091         END DO 
     3092      CASE ( 0 ) 
     3093         DO jl = 1, jprecj 
     3094            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     3095            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     3096         END DO 
     3097      CASE ( 1 ) 
     3098         DO jl = 1, jprecj 
     3099            ptab(:,jl,:) = t3sn(:,jl,:,2) 
     3100         END DO 
     3101      END SELECT 
     3102 
     3103 
     3104      ! 4. north fold treatment 
     3105      ! ----------------------- 
     3106      ! 
     3107      IF( npolj /= 0) THEN 
     3108         ! 
     3109         SELECT CASE ( jpni ) 
     3110         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3111         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3112         END SELECT 
     3113         ! 
     3114      ENDIF 
     3115      ! 
     3116   END SUBROUTINE mpp_lnk_bdy_3d 
     3117 
     3118      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
     3119      !!---------------------------------------------------------------------- 
     3120      !!                  ***  routine mpp_lnk_bdy_2d  *** 
     3121      !! 
     3122      !! ** Purpose :   Message passing management 
     3123      !! 
     3124      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
     3125      !!      between processors following neighboring subdomains. 
     3126      !!            domain parameters 
     3127      !!                    nlci   : first dimension of the local subdomain 
     3128      !!                    nlcj   : second dimension of the local subdomain 
     3129      !!                    nbondi_bdy : mark for "east-west local boundary" 
     3130      !!                    nbondj_bdy : mark for "north-south local boundary" 
     3131      !!                    noea   : number for local neighboring processors  
     3132      !!                    nowe   : number for local neighboring processors 
     3133      !!                    noso   : number for local neighboring processors 
     3134      !!                    nono   : number for local neighboring processors 
     3135      !! 
     3136      !! ** Action  :   ptab with update value at its periphery 
     3137      !! 
     3138      !!---------------------------------------------------------------------- 
     3139 
     3140      USE lbcnfd          ! north fold 
     3141 
     3142      INCLUDE 'mpif.h' 
     3143 
     3144      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     3145      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     3146      !                                                             ! = T , U , V , F , W points 
     3147      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     3148      !                                                             ! =  1. , the sign is kept 
     3149      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
     3150      INTEGER  ::   ji, jj, jl             ! dummy loop indices 
     3151      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     3152      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     3153      REAL(wp) ::   zland 
     3154      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     3155      !!---------------------------------------------------------------------- 
     3156 
     3157      zland = 0.e0 
     3158 
     3159      ! 1. standard boundary treatment 
     3160      ! ------------------------------ 
     3161       
     3162      !                                   ! East-West boundaries 
     3163      !                                        !* Cyclic east-west 
     3164 
     3165      IF( nbondi == 2) THEN 
     3166        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
     3167          ptab( 1 ,:) = ptab(jpim1,:) 
     3168          ptab(jpi,:) = ptab(  2  ,:) 
     3169        ELSE 
     3170          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3171          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3172        ENDIF 
     3173      ELSEIF(nbondi == -1) THEN 
     3174        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
     3175      ELSEIF(nbondi == 1) THEN 
     3176        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
     3177      ENDIF                                     !* closed 
     3178 
     3179      IF (nbondj == 2 .OR. nbondj == -1) THEN 
     3180        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point 
     3181      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
     3182        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north 
     3183      ENDIF 
     3184       
     3185      ! 
     3186 
     3187      ! 2. East and west directions exchange 
     3188      ! ------------------------------------ 
     3189      ! we play with the neigbours AND the row number because of the periodicity  
     3190      ! 
     3191      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
     3192      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     3193         iihom = nlci-nreci 
     3194         DO jl = 1, jpreci 
     3195            t2ew(:,jl,1) = ptab(jpreci+jl,:) 
     3196            t2we(:,jl,1) = ptab(iihom +jl,:) 
     3197         END DO 
     3198      END SELECT 
     3199      ! 
     3200      !                           ! Migrations 
     3201      imigr = jpreci * jpj 
     3202      ! 
     3203      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3204      CASE ( -1 ) 
     3205         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     3206      CASE ( 0 ) 
     3207         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3208         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     3209      CASE ( 1 ) 
     3210         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     3211      END SELECT 
     3212      ! 
     3213      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3214      CASE ( -1 ) 
     3215         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3216      CASE ( 0 ) 
     3217         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     3218         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3219      CASE ( 1 ) 
     3220         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
     3221      END SELECT 
     3222      ! 
     3223      SELECT CASE ( nbondi_bdy(ib_bdy) ) 
     3224      CASE ( -1 ) 
     3225         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3226      CASE ( 0 ) 
     3227         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3228         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3229      CASE ( 1 ) 
     3230         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3231      END SELECT 
     3232      ! 
     3233      !                           ! Write Dirichlet lateral conditions 
     3234      iihom = nlci-jpreci 
     3235      ! 
     3236      SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
     3237      CASE ( -1 ) 
     3238         DO jl = 1, jpreci 
     3239            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3240         END DO 
     3241      CASE ( 0 ) 
     3242         DO jl = 1, jpreci 
     3243            ptab(jl      ,:) = t2we(:,jl,2) 
     3244            ptab(iihom+jl,:) = t2ew(:,jl,2) 
     3245         END DO 
     3246      CASE ( 1 ) 
     3247         DO jl = 1, jpreci 
     3248            ptab(jl      ,:) = t2we(:,jl,2) 
     3249         END DO 
     3250      END SELECT 
     3251 
     3252 
     3253      ! 3. North and south directions 
     3254      ! ----------------------------- 
     3255      ! always closed : we play only with the neigbours 
     3256      ! 
     3257      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     3258         ijhom = nlcj-nrecj 
     3259         DO jl = 1, jprecj 
     3260            t2sn(:,jl,1) = ptab(:,ijhom +jl) 
     3261            t2ns(:,jl,1) = ptab(:,jprecj+jl) 
     3262         END DO 
     3263      ENDIF 
     3264      ! 
     3265      !                           ! Migrations 
     3266      imigr = jprecj * jpi 
     3267      ! 
     3268      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3269      CASE ( -1 ) 
     3270         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     3271      CASE ( 0 ) 
     3272         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3273         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     3274      CASE ( 1 ) 
     3275         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     3276      END SELECT 
     3277      ! 
     3278      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3279      CASE ( -1 ) 
     3280         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3281      CASE ( 0 ) 
     3282         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     3283         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3284      CASE ( 1 ) 
     3285         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
     3286      END SELECT 
     3287      ! 
     3288      SELECT CASE ( nbondj_bdy(ib_bdy) ) 
     3289      CASE ( -1 ) 
     3290         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3291      CASE ( 0 ) 
     3292         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3293         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     3294      CASE ( 1 ) 
     3295         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     3296      END SELECT 
     3297      ! 
     3298      !                           ! Write Dirichlet lateral conditions 
     3299      ijhom = nlcj-jprecj 
     3300      ! 
     3301      SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
     3302      CASE ( -1 ) 
     3303         DO jl = 1, jprecj 
     3304            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3305         END DO 
     3306      CASE ( 0 ) 
     3307         DO jl = 1, jprecj 
     3308            ptab(:,jl      ) = t2sn(:,jl,2) 
     3309            ptab(:,ijhom+jl) = t2ns(:,jl,2) 
     3310         END DO 
     3311      CASE ( 1 ) 
     3312         DO jl = 1, jprecj 
     3313            ptab(:,jl) = t2sn(:,jl,2) 
     3314         END DO 
     3315      END SELECT 
     3316 
     3317 
     3318      ! 4. north fold treatment 
     3319      ! ----------------------- 
     3320      ! 
     3321      IF( npolj /= 0) THEN 
     3322         ! 
     3323         SELECT CASE ( jpni ) 
     3324         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     3325         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     3326         END SELECT 
     3327         ! 
     3328      ENDIF 
     3329      ! 
     3330   END SUBROUTINE mpp_lnk_bdy_2d 
    25353331 
    25363332   SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn_bt.F90

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r3294 r3646  
    831831         IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 
    832832         sdf(jf)%vcomp   = sdf_n(jf)%vcomp 
     833         sdf(jf)%rotn    = .FALSE. 
    833834      END DO 
    834835 

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

    r3294 r3646  
    4444   !                                             !:  = 1 global mean of e-p-r set to zero at each nn_fsbc time step 
    4545   !                                             !:  = 2 annual global mean of e-p-r set to zero 
    46    LOGICAL , PUBLIC ::   ln_cdgw     = .FALSE.   !: true if neutral drag coefficient read from wave model 
     46   LOGICAL , PUBLIC ::   ln_wave     = .FALSE.   !: true if some coupling with wave model 
     47   LOGICAL , PUBLIC ::   ln_cdgw     = .FALSE.   !: true if neutral drag coefficient from wave model 
     48   LOGICAL , PUBLIC ::   ln_sdw      = .FALSE.   !: true if 3d stokes drift from wave model 
    4749 
    4850   !!---------------------------------------------------------------------- 

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

    r3421 r3646  
    8383      !! 
    8484      NAMELIST/namsbc/ nn_fsbc   , ln_ana , ln_flx  , ln_blk_clio, ln_blk_core, ln_cpl,   & 
    85          &             ln_blk_mfs, ln_apr_dyn, nn_ice , ln_dm2dc, ln_rnf, ln_ssr     , nn_fwb, ln_cdgw 
     85         &             ln_blk_mfs, ln_apr_dyn, nn_ice , ln_dm2dc, ln_rnf, ln_ssr, nn_fwb, & 
     86         &             ln_wave, ln_cdgw, ln_sdw 
    8687      !!---------------------------------------------------------------------- 
    8788 
    … …  
    9293      ENDIF 
    9394 
     95      call flush(numout) 
    9496      REWIND( numnam )           ! Read Namelist namsbc 
    9597      READ  ( numnam, namsbc ) 
     98      call flush(numout) 
    9699 
    97100      !                          ! overwrite namelist parameter using CPP key information 
    … …  
    166169         &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
    167170 
    168        !drag coefficient read from wave model definable only with mfs bulk formulae and core  
    169        IF(ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) )              & 
    170           &   CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 
     171      IF ( ln_wave ) THEN 
     172      !Activated wave module but neither drag nor stokes drift activated 
     173         IF ( .NOT.(ln_cdgw .OR. ln_sdw) )   THEN 
     174            CALL ctl_warn( 'Ask for wave coupling but nor drag coefficient (ln_cdgw=F) neither stokes drift activated (ln_sdw=F)' ) 
     175      !drag coefficient read from wave model definable only with mfs bulk formulae and core  
     176         ELSEIF (ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) )       THEN        
     177             CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 
     178         ENDIF 
     179      ELSE 
     180      IF ( ln_cdgw .OR. ln_sdw  )                                         &  
     181         &   CALL ctl_stop('Not Activated Wave Module (ln_wave=F) but     & 
     182         & asked coupling with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ') 
     183      ENDIF  
    171184       
    172185      !                          ! Choice of the Surface Boudary Condition (set nsbc) 
    … …  
    249262      !                                                  ! averaged over nf_sbc time-step 
    250263 
    251       IF (ln_cdgw) CALL sbc_wave( kt ) 
     264      IF (ln_wave) CALL sbc_wave( kt ) 
    252265                                                   !==  sbc formulation  ==! 
    253266                                                             

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

    r3421 r3646  
    5858   REAL(wp) ::   r1_rau0   ! = 1 / rau0  
    5959 
    60    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    61    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    62    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
     60   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
     61   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
     62   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    6363  
    6464   !! * Substitutions   

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r3294 r3646  
    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) include the upstream where needed 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    1819   USE trdmod_oce      ! tracers trends  
    1920   USE trdtra      ! tracers trends  
     21   USE eosbn2          ! equation of state  
    2022   USE in_out_manager  ! I/O manager 
    2123   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    2224   USE trabbl          ! tracers: bottom boundary layer 
     25   USE sbcrnf          ! river runoffs 
    2326   USE lib_mpp         ! distribued memory computing 
    2427   USE lbclnk          ! ocean lateral boundary condition (or mpp link)  
    … …  
    2730   USE wrk_nemo        ! Memory Allocation 
    2831   USE timing          ! Timing 
     32   USE eosbn2          ! equation of state 
     33   USE sbcrnf          ! river runoffs 
    2934 
    3035   IMPLICIT NONE 
    … …  
    3540   LOGICAL  :: l_trd       ! flag to compute trends 
    3641 
     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) 
    3744   !! * Substitutions 
    3845#  include "domzgr_substitute.h90" 
    … …  
    7885      REAL(wp) ::   ztra, zbtr, zdt, zalpha   !   -      - 
    7986      REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 
     87      INTEGER  ::   ierr 
     88      REAL(wp) ::   zice                             ! temporary scalars 
     89      REAL(wp), POINTER, DIMENSION(:,:  ) :: ztfreez 
     90      REAL(wp), POINTER, DIMENSION(:,:,:) :: zind 
    8091      !!---------------------------------------------------------------------- 
    8192      ! 
    … …  
    8394      ! 
    8495      CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy ) 
     96      CALL wrk_alloc( jpi, jpj, ztfreez ) 
     97      CALL wrk_alloc( jpi, jpj, jpk, zind ) 
    8598      ! 
    8699 
    … …  
    89102         IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 
    90103         IF(lwp) WRITE(numout,*) '~~~~~~~' 
     104         IF(lwp) WRITE(numout,*) 
     105         ! 
     106         ! 
     107         IF (.not. ALLOCATED(upsmsk))THEN 
     108             ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
     109             IF( ierr /= 0 )   CALL ctl_stop('STOP', 'tra_adv_muscl: unable to allocate array') 
     110         ENDIF 
     111         ! 
     112         upsmsk(:,:) = 0._wp                             ! not upstream by default 
    91113         ! 
    92114         l_trd = .FALSE. 
    … …  
    94116      ENDIF 
    95117 
     118      ! 
     119      ! Upstream / centered scheme indicator 
     120      ! ------------------------------------ 
     121      ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 
     122      DO jk = 1, jpk 
     123         DO jj = 1, jpj 
     124            DO ji = 1, jpi 
     125               !                                        ! below ice covered area (if tn < "freezing"+0.1 ) 
     126               IF( tsn(ji,jj,jk,jp_tem) <= ztfreez(ji,jj) + 0.1_wp ) THEN   ;   zice = 1.e0 
     127               ELSE                                                         ;   zice = 0.e0 
     128               ENDIF 
     129               zind(ji,jj,jk) = MAX (   & 
     130                  rnfmsk(ji,jj) * rnfmsk_z(jk),      &  ! near runoff mouths (& closed sea outflows) 
     131                  upsmsk(ji,jj)               ,      &  ! some of some straits 
     132                  zice                               &  ! below ice covered area (if tn < "freezing"+0.1 ) 
     133                  &                  ) * tmask(ji,jj,jk) 
     134               zind(ji,jj,jk) = 1 - zind(ji,jj,jk) 
     135            END DO 
     136         END DO 
     137      END DO 
    96138      !                                                     ! =========== 
    97139      DO jn = 1, kjpt                                       ! tracer loop 
    … …  
    148190                  zalpha = 0.5 - z0u 
    149191                  zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 
    150                   zzwx = ptb(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 
    151                   zzwy = ptb(ji  ,jj,jk,jn) + zu * zslpx(ji  ,jj,jk) 
     192                  zzwx = ptb(ji+1,jj,jk,jn) + zind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk)) 
     193                  zzwy = ptb(ji  ,jj,jk,jn) + zind(ji,jj,jk) * (zu * zslpx(ji  ,jj,jk)) 
    152194                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    153195                  ! 
    … …  
    155197                  zalpha = 0.5 - z0v 
    156198                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 
    157                   zzwx = ptb(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 
    158                   zzwy = ptb(ji,jj  ,jk,jn) + zv * zslpy(ji,jj  ,jk)  
     199                  zzwx = ptb(ji,jj+1,jk,jn) + zind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk)) 
     200                  zzwy = ptb(ji,jj  ,jk,jn) + zind(ji,jj,jk) * (zv * zslpy(ji,jj  ,jk)) 
    159201                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    160202               END DO 
    … …  
    230272                  zalpha = 0.5 + z0w 
    231273                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr  
    232                   zzwx = ptb(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 
    233                   zzwy = ptb(ji,jj,jk  ,jn) + zw * zslpx(ji,jj,jk  ) 
     274                  zzwx = ptb(ji,jj,jk+1,jn) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1)) 
     275                  zzwy = ptb(ji,jj,jk  ,jn) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk  )) 
    234276                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    235277               END DO  
    … …  
    255297      ! 
    256298      CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy ) 
     299      CALL wrk_dealloc( jpi, jpj, ztfreez ) 
     300      CALL wrk_dealloc( jpi, jpj, jpk, zind ) 
    257301      ! 
    258302      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_muscl') 

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

    r2528 r3646  
    4242   !!--------------------------------------------------------------------- 
    4343   LOGICAL, PUBLIC, PARAMETER ::   lk_my_trc     = .TRUE.   !: PTS flag  
    44    INTEGER, PUBLIC, PARAMETER ::   jp_my_trc     =  2       !: number of PTS tracers 
     44   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc     =  1       !: number of PTS tracers 
    4545   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc_2d  =  0       !: additional 2d output arrays ('key_trc_diaadd') 
    4646   INTEGER, PUBLIC, PARAMETER ::   jp_my_trc_3d  =  0       !: additional 3d output arrays ('key_trc_diaadd') 
    … …  
    4949   ! assign an index in trc arrays for each PTS prognostic variables 
    5050   INTEGER, PUBLIC, PARAMETER ::   jpmyt1 = jp_lm + 1     !: 1st MY_TRC tracer 
    51    INTEGER, PUBLIC, PARAMETER ::   jpmyt2 = jp_lm + 2     !: 2nd MY_TRC tracer 
    5251 
    5352#else 

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/TOP_SRC/TRP/trczdf.F90

    r3425 r3646  
    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_CMCC_INGV_2012/NEMOGCM/NEMO/TOP_SRC/trc.F90

    r3294 r3646  
    2525   INTEGER, PUBLIC                                                 ::   numnat        !: logicla unit for the passive tracer NAMELIST 
    2626   INTEGER, PUBLIC                                                 ::   numstr        !: logical unit for tracer statistics 
     27   LOGICAL, PUBLIC                                                 ::   ln_top_euler  !: boolean term for euler integration in the first timestep 
    2728 
    2829   !! passive tracers fields (before,now,after) 
    … …  
    6869   CHARACTER(len = 80), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ctrcln         !: trccer field long name 
    6970   CHARACTER(len = 20), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ctrcun         !: tracer unit 
    70    LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_ini     !: Initialisation from data input file 
    7171   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_wri     !: save the tracer or not 
    7272 
    … …  
    7676      CHARACTER(len = 20)  :: units    !: unit 
    7777   END TYPE DIAG 
     78 
     79   !! information for inputs 
     80   !! -------------------------------------------------- 
     81   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_ini     !: Initialisation from data input file 
     82   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_obc     !: Use open boundary condition data 
     83   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_sbc     !: Use surface boundary condition data 
     84   LOGICAL            , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::  ln_trc_cbc     !: Use coastal boundary condition data 
    7885 
    7986   !! additional 2D/3D outputs namelist 

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

    r3319 r3646  
    6060      !! 
    6161      NAMELIST/namtrc/ nn_dttrc, nn_writetrc, ln_rsttr, nn_rsttr, & 
    62          &             cn_trcrst_in, cn_trcrst_out, sn_tracer, ln_trcdta, ln_trcdmp 
     62         &             cn_trcrst_in, cn_trcrst_out, sn_tracer, ln_trcdta, ln_trcdmp, & 
     63         &             ln_top_euler 
    6364#if defined key_trdmld_trc  || defined key_trdtrc 
    6465      NAMELIST/namtrc_trd/ nn_trd_trc, nn_ctls_trc, rn_ucf_trc, & 
    … …  
    7980      nn_dttrc      = 1                 ! default values 
    8081      nn_writetrc   = 10  
     82      ln_top_euler  = .FALSE. 
    8183      ln_rsttr      = .FALSE. 
    8284      nn_rsttr      =  0 
    … …  
    120122         WRITE(numout,*) '   Read inputs data from file (y/n)             ln_trcdta     = ', ln_trcdta 
    121123         WRITE(numout,*) '   Damping of passive tracer (y/n)              ln_trcdmp     = ', ln_trcdmp 
     124         WRITE(numout,*) '   Use euler integration for TRC (y/n)          ln_top_euler  = ', ln_top_euler 
    122125         WRITE(numout,*) ' ' 
    123126         DO jn = 1, jptra 

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

    r3294 r3646  
    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_CMCC_INGV_2012/NEMOGCM/SETTE/sette.sh

    r3555 r3646  
    440440    export TEST_NAME="SHORT" 
    441441    . prepare_exe_dir.sh 
    442     JOB_FILE=${EXE_DIR}/run_job.sh 
    443     NPROC=4 
    444     \rm $JOB_FILE 
     442#    JOB_FILE=${EXE_DIR}/run_job.sh 
     443#    NPROC=4 
     444#    \rm $JOB_FILE 
    445445    cd ${EXE_DIR} 
    446446    set_namelist namelist cn_exp \"OFFP_SHORT\" 
    … …  
    452452    set_namelist namelist jpnj 2 
    453453    set_namelist namelist jpnij 4 
    454     cp ../LONG/OFFP_LONG_00000020_restart*nc . 
     454#   cp ../LONG/OFFP_LONG_00000020_restart*nc . 
    455455    set_namelist namelist_top ln_diatrc .false. 
    456456    set_namelist namelist_top ln_rsttr .true. 
Note: See TracChangeset for help on using the changeset viewer.