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

Changeset 2888


Ignore:
Timestamp:
2011-10-06T11:26:33+02:00 (13 years ago)
Author:
davestorkey
Message:

Move changes into updated BDY module and restore old OBC code.
(Full merge to take place next year).

Location:
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC
Files:
16 added
4 deleted
21 edited

Legend:

Unmodified
Added
Removed

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r2797 r2888  
    1919   USE trabbc          ! bottom boundary condition 
    2020   USE obc_par         ! (for lk_obc) 
     21   USE bdy_par         ! (for lk_bdy) 
    2122 
    2223   IMPLICIT NONE 
    … …  
    204205      WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 
    205206      WRITE(numout,*) "~~~~~~~  output written in the 'heat_salt_volume_budgets.txt' ASCII file" 
    206       IF( lk_obc ) THEN 
     207      IF( lk_obc .or. lk_bdy ) THEN 
    207208         CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' )          
    208209      ENDIF 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r2865 r2888  
    3030   USE domvvl          ! variable volume 
    3131   USE obc_oce         ! ocean open boundary conditions 
    32    USE obcdta          ! ocean open boundary conditions 
    33    USE obcdyn          ! ocean open boundary conditions 
     32   USE obcdyn          ! open boundary condition for momentum (obc_dyn routine) 
     33   USE obcdyn_bt       ! 2D open boundary condition for momentum (obc_dyn_bt routine) 
    3434   USE obcvol          ! ocean open boundary condition (obc_vol routines) 
     35   USE bdy_oce         ! ocean open boundary conditions 
     36   USE bdydta          ! ocean open boundary conditions 
     37   USE bdydyn          ! ocean open boundary conditions 
     38   USE bdyvol          ! ocean open boundary condition (bdy_vol routines) 
    3539   USE in_out_manager  ! I/O manager 
    3640   USE lbclnk          ! lateral boundary condition (or mpp link) 
    … …  
    153157# if defined key_obc 
    154158      !                                !* OBC open boundaries 
    155       IF( lk_dynspg_exp ) CALL obc_dyn( kt ) 
    156       IF( lk_dynspg_ts )  CALL obc_dyn( kt, dyn3d_only=.true. ) 
    157  
    158 !!$!!gm ERROR - potential BUG: sshn should not be modified at this stage !!   ssh_nxt not alrady called 
    159 !!$         CALL lbc_lnk( sshn, 'T', 1. )         ! Boundary conditions on sshn 
    160 !!$         ! 
    161 !!$         IF( ln_vol_cst )   CALL obc_vol( kt ) 
    162 !!$         ! 
    163 !!$         IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshn, clinfo1=' ssh      : ', mask1=tmask ) 
     159      CALL obc_dyn( kt ) 
     160      ! 
     161      IF( .NOT. lk_dynspg_flt ) THEN 
     162         ! Flather boundary condition : - Update sea surface height on each open boundary 
     163         !                                       sshn   (= after ssh   ) for explicit case (lk_dynspg_exp=T) 
     164         !                                       sshn_b (= after ssha_b) for time-splitting case (lk_dynspg_ts=T) 
     165         !                              - Correct the barotropic velocities 
     166         CALL obc_dyn_bt( kt ) 
     167         ! 
     168!!gm ERROR - potential BUG: sshn should not be modified at this stage !!   ssh_nxt not alrady called 
     169         CALL lbc_lnk( sshn, 'T', 1. )         ! Boundary conditions on sshn 
     170         ! 
     171         IF( ln_vol_cst )   CALL obc_vol( kt ) 
     172         ! 
     173         IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshn, clinfo1=' ssh      : ', mask1=tmask ) 
     174      ENDIF 
     175      ! 
     176# elif defined key_bdy 
     177      !                                !* BDY open boundaries 
     178      IF( lk_dynspg_exp ) CALL bdy_dyn( kt ) 
     179      IF( lk_dynspg_ts )  CALL bdy_dyn( kt, dyn3d_only=.true. ) 
     180 
     181!!$   Do we need a call to bdy_vol here?? 
    164182      ! 
    165183# endif 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90

    r2797 r2888  
    2020   USE obc_oce         ! Lateral open boundary condition 
    2121   USE phycst          ! physical constants 
    22    USE obcdta          ! open boundary condition data     (obc_dta_bt routine) 
     22   USE obc_par         ! open boundary condition parameters 
     23   USE obcdta          ! open boundary condition data     (bdy_dta_bt routine) 
    2324   USE in_out_manager  ! I/O manager 
    2425   USE lib_mpp         ! distributed memory computing library 
    … …  
    7778 
    7879!!gm bug ??  Rachid we have to discuss of the call below. I don't understand why it is here and not in ssh_wzv 
    79       IF( lk_obc )   CALL obc_dta( kt, jit=0 )      ! OBC: read or estimate ssh and vertically integrated velocities 
     80      IF( lk_obc )   CALL obc_dta_bt( kt, 0 )      ! OBC: read or estimate ssh and vertically integrated velocities 
    8081!!gm 
    8182 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r2800 r2888  
    2626   USE sbc_oce         ! surface boundary condition: ocean 
    2727   USE obc_oce         ! Lateral open boundary condition 
     28   USE bdy_oce         ! Lateral open boundary condition 
    2829   USE sol_oce         ! ocean elliptic solver 
    2930   USE phycst          ! physical constants 
    … …  
    3435   USE solsor          ! Successive Over-relaxation solver 
    3536   USE obcdyn          ! ocean open boundary condition on dynamics 
    36    USE obcvol          ! ocean open boundary condition (obc_vol routines) 
     37   USE obcvol          ! ocean open boundary condition (obc_vol routine) 
     38   USE bdydyn          ! ocean open boundary condition on dynamics 
     39   USE bdyvol          ! ocean open boundary condition (bdy_vol routine) 
    3740   USE cla             ! cross land advection 
    3841   USE in_out_manager  ! I/O manager 
    … …  
    180183 
    181184#if defined key_obc 
    182       CALL obc_dyn( kt )      ! Update velocities on each open boundary 
    183       CALL obc_vol( kt )      ! Correction of the barotropic component velocity to control the volume of the system 
     185      CALL obc_dyn( kt )      ! Update velocities on each open boundary with the radiation algorithm 
     186      CALL obc_vol( kt )      ! Correction of the barotropic componant velocity to control the volume of the system 
     187#endif 
     188#if defined key_bdy 
     189      CALL bdy_dyn( kt )      ! Update velocities on each open boundary 
     190      CALL bdy_vol( kt )      ! Correction of the barotropic component velocity to control the volume of the system 
    184191#endif 
    185192#if defined key_agrif 
    … …  
    301308            spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj) 
    302309            spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj) 
     310#elif defined key_bdy 
     311            ! caution : grad D = 0 along open boundaries 
     312            spgu(ji,jj) = z2dt * ztdgu * bdyumask(ji,jj) 
     313            spgv(ji,jj) = z2dt * ztdgv * bdyvmask(ji,jj) 
    303314#else 
    304315            spgu(ji,jj) = z2dt * ztdgu 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r2865 r2888  
    2626   USE zdfbfr          ! bottom friction 
    2727   USE dynvor          ! vorticity term 
    28    USE obc_par         ! for lk_obc 
    2928   USE obc_oce         ! Lateral open boundary condition 
     29   USE obc_par         ! open boundary condition parameters 
    3030   USE obcdta          ! open boundary condition data      
    31    USE obcdyn2d        ! open boundary conditions on barotropic variables 
     31   USE obcfla          ! Flather open boundary condition   
     32   USE bdy_par         ! for lk_bdy 
     33   USE bdy_oce         ! Lateral open boundary condition 
     34   USE bdydta          ! open boundary condition data      
     35   USE bdydyn2d        ! open boundary conditions on barotropic variables 
    3236   USE lib_mpp         ! distributed memory computing library 
    3337   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    347351      zssh_sum(:,:) = sshn (:,:) 
    348352 
     353#if defined key_obc 
     354      ! set ssh corrections to 0 
     355      ! ssh corrections are applied to normal velocities (Flather's algorithm) and averaged over the barotropic loop 
     356      IF( lp_obc_east  )   sshfoe_b(:,:) = 0.e0 
     357      IF( lp_obc_west  )   sshfow_b(:,:) = 0.e0 
     358      IF( lp_obc_south )   sshfos_b(:,:) = 0.e0 
     359      IF( lp_obc_north )   sshfon_b(:,:) = 0.e0 
     360#endif 
     361 
    349362      !                                             ! ==================== ! 
    350363      DO jn = 1, icycle                             !  sub-time-step loop  ! (from NOW to AFTER+1) 
    … …  
    353366         IF( jn == 1 )   z2dt_e = rdt / nn_baro 
    354367 
    355          !                                                !* Update the forcing (OBC and tides) 
     368         !                                                !* Update the forcing (BDY and tides) 
    356369         !                                                !  ------------------ 
    357          IF( lk_obc )   CALL obc_dta ( kt, jit=jn, time_offset=+1 ) 
     370         IF( lk_obc )   CALL obc_dta_bt ( kt, jn   ) 
     371         IF( lk_bdy )   CALL bdy_dta ( kt, jit=jn, time_offset=+1 ) 
    358372 
    359373         !                                                !* after ssh_e 
    … …  
    369383         ! 
    370384#if defined key_obc 
    371          zhdiv(:,:) = zhdiv(:,:) * obctmask(:,:)               ! OBC mask 
     385         !                                                     ! OBC : zhdiv must be zero behind the open boundary 
     386!!  mpp remark: The zeroing of hdiv can probably be extended to 1->jpi/jpj for the correct row/column 
     387         IF( lp_obc_east  )   zhdiv(nie0p1:nie1p1,nje0  :nje1  ) = 0.e0      ! east 
     388         IF( lp_obc_west  )   zhdiv(niw0  :niw1  ,njw0  :njw1  ) = 0.e0      ! west 
     389         IF( lp_obc_north )   zhdiv(nin0  :nin1  ,njn0p1:njn1p1) = 0.e0      ! north 
     390         IF( lp_obc_south )   zhdiv(nis0  :nis1  ,njs0  :njs1  ) = 0.e0      ! south 
     391#endif 
     392#if defined key_bdy 
     393         zhdiv(:,:) = zhdiv(:,:) * bdytmask(:,:)               ! BDY mask 
    372394#endif 
    373395         ! 
    … …  
    466488         !                                                !* domain lateral boundary 
    467489         !                                                !  ----------------------- 
     490 
    468491                                                               ! OBC open boundaries 
    469 #if defined key_obc 
     492         IF( lk_obc               )   CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 
     493 
     494                                                               ! BDY open boundaries 
     495#if defined key_bdy 
    470496         pssh => sshn_e 
    471497         phur => hur_e 
    … …  
    474500         pv2d => va_e 
    475501 
    476          IF( lk_obc )   CALL obc_dyn2d( kt )  
     502         IF( lk_bdy )   CALL bdy_dyn2d( kt )  
    477503#endif 
    478504 
    … …  
    529555      !                                                    ! ==================== ! 
    530556 
     557#if defined key_obc 
     558      IF( lp_obc_east  )   sshfoe_b(:,:) = zcoef * sshfoe_b(:,:)     !!gm totally useless ????? 
     559      IF( lp_obc_west  )   sshfow_b(:,:) = zcoef * sshfow_b(:,:) 
     560      IF( lp_obc_north )   sshfon_b(:,:) = zcoef * sshfon_b(:,:) 
     561      IF( lp_obc_south )   sshfos_b(:,:) = zcoef * sshfos_b(:,:) 
     562#endif 
     563 
    531564      ! ----------------------------------------------------------------------------- 
    532565      ! Phase 3. update the general trend with the barotropic trend 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r2797 r2888  
    2626   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    2727   USE lib_mpp         ! MPP library 
     28   USE obc_par         ! open boundary cond. parameter 
    2829   USE obc_oce 
     30   USE bdy_oce 
    2931   USE diaar5, ONLY:   lk_diaar5 
    3032   USE iom 
    … …  
    173175#endif 
    174176#if defined key_obc 
    175       ssha(:,:) = ssha(:,:) * obctmask(:,:) 
     177      IF( Agrif_Root() ) THEN  
     178         ssha(:,:) = ssha(:,:) * obctmsk(:,:) 
     179         CALL lbc_lnk( ssha, 'T', 1. )                 ! absolutly compulsory !! (jmm) 
     180      ENDIF 
     181#endif 
     182#if defined key_bdy 
     183      ssha(:,:) = ssha(:,:) * bdytmask(:,:) 
    176184      CALL lbc_lnk( ssha, 'T', 1. )                 ! absolutly compulsory !! (jmm) 
    177185#endif 
    … …  
    209217            &                      - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) )    & 
    210218            &                         * tmask(:,:,jk) * z1_2dt 
    211 #if defined key_obc 
    212          wn(:,:,jk) = wn(:,:,jk) * obctmask(:,:) 
     219#if defined key_bdy 
     220         wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) 
    213221#endif 
    214222      END DO 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_oce.F90

    r2865 r2888  
    11MODULE obc_oce 
    2    !!====================================================================== 
     2   !!============================================================================== 
    33   !!                       ***  MODULE obc_oce   *** 
    4    !! Unstructured Open Boundary Cond. :   define related variables 
    5    !!====================================================================== 
    6    !! History :  1.0  !  2001-05  (J. Chanut, A. Sellar)  Original code 
    7    !!            3.0  !  2008-04  (NEMO team)  add in the reference version      
    8    !!            3.3  !  2010-09  (D. Storkey) add ice boundary conditions 
    9    !!            3.4  !  2011     (D. Storkey, J. Chanut) OBC-BDY merge 
    10    !!---------------------------------------------------------------------- 
    11 #if defined key_obc  
    12    !!---------------------------------------------------------------------- 
    13    !!   'key_obc'                      Unstructured Open Boundary Condition 
     4   !! Open Boundary Cond. :   define related variables 
     5   !!============================================================================== 
     6   !! history :  OPA  ! 1991-01 (CLIPPER)  Original code  
     7   !!   NEMO     1.0  ! 2002-02 (C. Talandier)  modules, F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_obc 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_obc' :                                 Open Boundary Condition 
    1412   !!---------------------------------------------------------------------- 
    1513   USE par_oce         ! ocean parameters 
    16    USE obc_par         ! Unstructured boundary parameters 
    17    USE lib_mpp         ! distributed memory computing 
     14   USE obc_par         ! open boundary condition parameters 
    1815 
    1916   IMPLICIT NONE 
    2017   PUBLIC 
    21  
    22    TYPE, PUBLIC ::   OBC_INDEX    !: Indices and weights which define the open boundary 
    23       INTEGER,          DIMENSION(jpbgrd) ::  nblen 
    24       INTEGER,          DIMENSION(jpbgrd) ::  nblenrim 
    25       INTEGER, POINTER, DIMENSION(:,:)   ::  nbi 
    26       INTEGER, POINTER, DIMENSION(:,:)   ::  nbj 
    27       INTEGER, POINTER, DIMENSION(:,:)   ::  nbr 
    28       INTEGER, POINTER, DIMENSION(:,:)   ::  nbmap 
    29       REAL   , POINTER, DIMENSION(:,:)   ::  nbw 
    30       REAL   , POINTER, DIMENSION(:)     ::  flagu 
    31       REAL   , POINTER, DIMENSION(:)     ::  flagv 
    32    END TYPE OBC_INDEX 
    33  
    34    TYPE, PUBLIC ::   OBC_DATA     !: Storage for external data 
    35       REAL, POINTER, DIMENSION(:)     ::  ssh 
    36       REAL, POINTER, DIMENSION(:)     ::  u2d 
    37       REAL, POINTER, DIMENSION(:)     ::  v2d 
    38       REAL, POINTER, DIMENSION(:,:)   ::  u3d 
    39       REAL, POINTER, DIMENSION(:,:)   ::  v3d 
    40       REAL, POINTER, DIMENSION(:,:)   ::  tem 
    41       REAL, POINTER, DIMENSION(:,:)   ::  sal 
    42 #if defined key_lim2 
    43       REAL, POINTER, DIMENSION(:)     ::  frld 
    44       REAL, POINTER, DIMENSION(:)     ::  hicif 
    45       REAL, POINTER, DIMENSION(:)     ::  hsnif 
    46 #endif 
    47    END TYPE OBC_DATA 
    48  
    49    !!---------------------------------------------------------------------- 
    50    !! Namelist variables 
    51    !!---------------------------------------------------------------------- 
    52    CHARACTER(len=80), DIMENSION(jp_obc) ::   cn_coords_file !: Name of obc coordinates file 
    53    CHARACTER(len=80)                    ::   cn_mask_file   !: Name of obc mask file 
     18    
     19   PUBLIC   obc_oce_alloc   ! called by obcini.F90 module 
     20 
     21   !!---------------------------------------------------------------------- 
     22   !! open boundary variables 
     23   !!---------------------------------------------------------------------- 
    5424   ! 
    55    LOGICAL, DIMENSION(jp_obc) ::   ln_coords_file           !: =T read obc coordinates from file;  
    56    !                                                        !: =F read obc coordinates from namelist 
    57    LOGICAL                    ::   ln_mask_file             !: =T read obcmask from file 
    58    LOGICAL                    ::   ln_vol                   !: =T volume correction              
    59    ! 
    60    INTEGER                    ::   nb_obc                   !: number of open boundary sets 
    61    INTEGER, DIMENSION(jp_obc) ::   nn_rimwidth              !: boundary rim width for Flow Relaxation Scheme 
    62    INTEGER                    ::   nn_volctl                !: = 0 the total volume will have the variability of the surface Flux E-P  
    63    !                                                        !  = 1 the volume will be constant during all the integration. 
    64    INTEGER, DIMENSION(jp_obc) ::   nn_dyn2d                 ! Choice of boundary condition for barotropic variables (U,V,SSH) 
    65    INTEGER, DIMENSION(jp_obc) ::   nn_dyn2d_dta           !: = 0 use the initial state as obc dta ;  
    66                                                             !: = 1 read it in a NetCDF file 
    67                                                             !: = 2 read tidal harmonic forcing from a NetCDF file 
    68                                                             !: = 3 read external data AND tidal harmonic forcing from NetCDF files 
    69    INTEGER, DIMENSION(jp_obc) ::   nn_dyn3d                 ! Choice of boundary condition for baroclinic velocities  
    70    INTEGER, DIMENSION(jp_obc) ::   nn_dyn3d_dta           !: = 0 use the initial state as obc dta ;  
    71                                                             !: = 1 read it in a NetCDF file 
    72    INTEGER, DIMENSION(jp_obc) ::   nn_tra                   ! Choice of boundary condition for active tracers (T and S) 
    73    INTEGER, DIMENSION(jp_obc) ::   nn_tra_dta             !: = 0 use the initial state as obc dta ;  
    74                                                             !: = 1 read it in a NetCDF file 
    75 #if defined key_lim2 
    76    INTEGER, DIMENSION(jp_obc) ::   nn_ice_lim2              ! Choice of boundary condition for sea ice variables  
    77    INTEGER, DIMENSION(jp_obc) ::   nn_ice_lim2_dta          !: = 0 use the initial state as obc dta ;  
    78                                                             !: = 1 read it in a NetCDF file 
    79 #endif 
    80    ! 
    81    INTEGER, DIMENSION(jp_obc) ::   nn_dmp2d_in              ! Damping timescale (days) for 2D solution for inward radiation or FRS  
    82    INTEGER, DIMENSION(jp_obc) ::   nn_dmp2d_out             ! Damping timescale (days) for 2D solution for outward radiation  
    83    INTEGER, DIMENSION(jp_obc) ::   nn_dmp3d_in              ! Damping timescale (days) for 3D solution for inward radiation or FRS  
    84    INTEGER, DIMENSION(jp_obc) ::   nn_dmp3d_out             ! Damping timescale (days) for 3D solution for outward radiation 
    85  
    86     
    87    !!---------------------------------------------------------------------- 
    88    !! Global variables 
    89    !!---------------------------------------------------------------------- 
    90    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   obctmask   !: Mask defining computational domain at T-points 
    91    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   obcumask   !: Mask defining computational domain at U-points 
    92    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   obcvmask   !: Mask defining computational domain at V-points 
    93  
    94    REAL(wp)                                    ::   obcsurftot !: Lateral surface of unstructured open boundary 
    95  
    96    REAL(wp), POINTER, DIMENSION(:,:)           ::   pssh       !:  
    97    REAL(wp), POINTER, DIMENSION(:,:)           ::   phur       !:  
    98    REAL(wp), POINTER, DIMENSION(:,:)           ::   phvr       !: Pointers for barotropic fields  
    99    REAL(wp), POINTER, DIMENSION(:,:)           ::   pu2d       !:  
    100    REAL(wp), POINTER, DIMENSION(:,:)           ::   pv2d       !:  
    101  
    102    !!---------------------------------------------------------------------- 
    103    !! open boundary data variables 
    104    !!---------------------------------------------------------------------- 
    105  
    106    INTEGER,  DIMENSION(jp_obc)                     ::   nn_dta            !: =0 => *all* data is set to initial conditions 
    107                                                                           !: =1 => some data to be read in from data files 
    108    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global        !: workspace for reading in global data arrays 
    109    TYPE(OBC_INDEX), DIMENSION(jp_obc), TARGET      ::   idx_obc           !: obc indices (local process) 
    110    TYPE(OBC_DATA) , DIMENSION(jp_obc)              ::   dta_obc           !: obc external data (local process) 
    111  
    112    !!---------------------------------------------------------------------- 
    113    !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     25   !                                            !!* Namelist namobc: open boundary condition * 
     26   INTEGER           ::   nn_obcdta   = 0        !:  = 0 use the initial state as obc data 
     27   !                                             !   = 1 read obc data in obcxxx.dta files 
     28   CHARACTER(len=20) ::   cn_obcdta   = 'annual' !: set to annual  if obc datafile hold 1 year of data 
     29   !                                             !  set to monthly if obc datafile hold 1 month of data 
     30   LOGICAL           ::   ln_obc_clim = .true.   !:  obc data files are climatological 
     31   LOGICAL           ::   ln_obc_fla  = .false.  !:  Flather open boundary condition not used 
     32   LOGICAL           ::   ln_vol_cst  = .true.   !:  Conservation of the whole volume 
     33   REAL(wp)          ::   rn_dpein    =  1.      !: damping time scale for inflow at East open boundary 
     34   REAL(wp)          ::   rn_dpwin    =  1.      !:    "                      "   at West open boundary 
     35   REAL(wp)          ::   rn_dpsin    =  1.      !:    "                      "   at South open boundary 
     36   REAL(wp)          ::   rn_dpnin    =  1.      !:    "                      "   at North open boundary 
     37   REAL(wp)          ::   rn_dpeob    = 15.      !: damping time scale for the climatology at East open boundary 
     38   REAL(wp)          ::   rn_dpwob    = 15.      !:    "                           "       at West open boundary 
     39   REAL(wp)          ::   rn_dpsob    = 15.      !:    "                           "       at South open boundary 
     40   REAL(wp)          ::   rn_dpnob    = 15.      !:    "                           "       at North open boundary 
     41   REAL(wp)          ::   rn_volemp   =  1.      !: = 0 the total volume will have the variability of the  
     42   !                                             !      surface Flux E-P else (volemp = 1) the volume will be constant 
     43   !                                             !  = 1 the volume will be constant during all the integration. 
     44 
     45   !                                  !!! OLD non-DOCTOR name of namelist variables 
     46   INTEGER  ::   nbobc                 !: number of open boundaries ( 1=< nbobc =< 4 )  
     47   INTEGER  ::   nobc_dta              !:  = 0 use the initial state as obc data 
     48   REAL(wp) ::   rdpein                !: damping time scale for inflow at East open boundary 
     49   REAL(wp) ::   rdpwin                !:    "                      "   at West open boundary 
     50   REAL(wp) ::   rdpsin                !:    "                      "   at South open boundary 
     51   REAL(wp) ::   rdpnin                !:    "                      "   at North open boundary 
     52   REAL(wp) ::   rdpeob                !: damping time scale for the climatology at East open boundary 
     53   REAL(wp) ::   rdpwob                !:    "                           "       at West open boundary 
     54   REAL(wp) ::   rdpsob                !:    "                           "       at South open boundary 
     55   REAL(wp) ::   rdpnob                !:    "                           "       at North open boundary 
     56   REAL(wp) ::   volemp                !: = 0 the total volume will have the variability of the  
     57   CHARACTER(len=20) :: cffile 
     58 
     59 
     60   !!General variables for open boundaries: 
     61   !!-------------------------------------- 
     62   LOGICAL ::   lfbceast, lfbcwest      !: logical flag for a fixed East and West open boundaries        
     63   LOGICAL ::   lfbcnorth, lfbcsouth    !: logical flag for a fixed North and South open boundaries        
     64   !                                    !  These logical flags are set to 'true' if damping time  
     65   !                                    !  scale are set to 0 in the namelist, for both inflow and outflow). 
     66 
     67   REAL(wp), PUBLIC ::   obcsurftot       !: Total lateral surface of open boundaries 
     68    
     69   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: &  !: 
     70      obctmsk,            &  !: mask array identical to tmask, execpt along OBC where it is set to 0 
     71      !                      !  it used to calculate the cumulate flux E-P in the obcvol.F90 routine 
     72      obcumask, obcvmask     !: u-, v- Force filtering mask for the open 
     73      !                      !  boundary condition on grad D 
     74 
     75   !!-------------------- 
     76   !! East open boundary: 
     77   !!-------------------- 
     78   INTEGER ::   nie0  , nie1      !: do loop index in mpp case for jpieob 
     79   INTEGER ::   nie0p1, nie1p1    !: do loop index in mpp case for jpieob+1 
     80   INTEGER ::   nie0m1, nie1m1    !: do loop index in mpp case for jpieob-1 
     81   INTEGER ::   nje0  , nje1      !: do loop index in mpp case for jpjed, jpjef 
     82   INTEGER ::   nje0p1, nje1m1    !: do loop index in mpp case for jpjedp1,jpjefm1 
     83   INTEGER ::   nje1m2, nje0m1    !: do loop index in mpp case for jpjefm1-1,jpjed 
     84 
     85   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::   &  !: 
     86      sshfoe,           & !: now climatology of the east boundary sea surface height 
     87      ubtfoe,vbtfoe       !: now climatology of the east boundary barotropic transport 
     88      
     89   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   &  !: 
     90      ufoe, vfoe,       & !: now climatology of the east boundary velocities  
     91      tfoe, sfoe,       & !: now climatology of the east boundary temperature and salinity 
     92      uclie               !: baroclinic componant of the zonal velocity after radiation  
     93      !                   ! in the obcdyn.F90 routine 
     94 
     95   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshfoe_b   !: east boundary ssh correction averaged over the barotropic loop 
     96      !                                            !  (if Flather's algoritm applied at open boundary) 
     97 
     98   !!------------------------------- 
     99   !! Arrays for radiative East OBC:  
     100   !!------------------------------- 
     101   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   uebnd, vebnd      !: baroclinic u & v component of the velocity over 3 rows  
     102      !                                                    !  and 3 time step (now, before, and before before) 
     103   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   tebnd, sebnd      !: East boundary temperature and salinity over 2 rows  
     104      !                                                    !  and 2 time step (now and before) 
     105   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   u_cxebnd, v_cxebnd    !: Zonal component of the phase speed ratio computed with  
     106      !                                                    !  radiation of u and v velocity (respectively) at the  
     107      !                                                    !  east open boundary (u_cxebnd = cx rdt ) 
     108   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   uemsk, vemsk, temsk   !: 2D mask for the East OB 
     109 
     110   ! Note that those arrays are optimized for mpp case  
     111   ! (hence the dimension jpj is the size of one processor subdomain) 
     112 
     113   !!-------------------- 
     114   !! West open boundary 
     115   !!-------------------- 
     116   INTEGER ::   niw0  , niw1       !: do loop index in mpp case for jpiwob 
     117   INTEGER ::   niw0p1, niw1p1     !: do loop index in mpp case for jpiwob+1 
     118   INTEGER ::   njw0  , njw1       !: do loop index in mpp case for jpjwd, jpjwf 
     119   INTEGER ::   njw0p1, njw1m1     !: do loop index in mpp case for jpjwdp1,jpjwfm1 
     120   INTEGER ::   njw1m2, njw0m1     !: do loop index in mpp case for jpjwfm2,jpjwd 
     121 
     122   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:) ::   &  !: 
     123      sshfow,           & !: now climatology of the west boundary sea surface height 
     124      ubtfow,vbtfow       !: now climatology of the west boundary barotropic transport 
     125 
     126   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   &  !: 
     127      ufow, vfow,       & !: now climatology of the west velocities  
     128      tfow, sfow,       & !: now climatology of the west temperature and salinity 
     129      ucliw               !: baroclinic componant of the zonal velocity after the radiation  
     130      !                   !  in the obcdyn.F90 routine 
     131 
     132   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshfow_b    !: west boundary ssh correction averaged over the barotropic loop 
     133      !                                          !  (if Flather's algoritm applied at open boundary) 
     134 
     135   !!------------------------------- 
     136   !! Arrays for radiative West OBC 
     137   !!------------------------------- 
     138   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   uwbnd, vwbnd     !: baroclinic u & v components of the velocity over 3 rows  
     139      !                                                   !  and 3 time step (now, before, and before before) 
     140   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   twbnd, swbnd     !: west boundary temperature and salinity over 2 rows and  
     141      !                                                   !  2 time step (now and before) 
     142   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   u_cxwbnd, v_cxwbnd   !: Zonal component of the phase speed ratio computed with  
     143      !                                                   !  radiation of zonal and meridional velocity (respectively)  
     144      !                                                   !  at the west open boundary (u_cxwbnd = cx rdt ) 
     145   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   uwmsk, vwmsk, twmsk  !: 2D mask for the West OB 
     146 
     147   ! Note that those arrays are optimized for mpp case  
     148   ! (hence the dimension jpj is the size of one processor subdomain) 
     149 
     150   !!--------------------- 
     151   !! North open boundary 
     152   !!--------------------- 
     153   INTEGER ::   nin0  , nin1       !: do loop index in mpp case for jpind, jpinf 
     154   INTEGER ::   nin0p1, nin1m1     !: do loop index in mpp case for jpindp1, jpinfm1 
     155   INTEGER ::   nin1m2, nin0m1     !: do loop index in mpp case for jpinfm1-1,jpind 
     156   INTEGER ::   njn0  , njn1       !: do loop index in mpp case for jpnob 
     157   INTEGER ::   njn0p1, njn1p1     !: do loop index in mpp case for jpnob+1 
     158   INTEGER ::   njn0m1, njn1m1     !: do loop index in mpp case for jpnob-1 
     159 
     160   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:) ::   &  !: 
     161      sshfon,           & !: now climatology of the north boundary sea surface height 
     162      ubtfon,vbtfon       !: now climatology of the north boundary barotropic transport 
     163 
     164   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   &    !: 
     165      ufon, vfon,       & !: now climatology of the north boundary velocities 
     166      tfon, sfon,       & !: now climatology of the north boundary temperature and salinity 
     167      vclin               !: baroclinic componant of the meridian velocity after the radiation 
     168      !                   !  in yhe obcdyn.F90 routine 
     169 
     170   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshfon_b      !: north boundary ssh correction averaged over the barotropic loop 
     171      !                                            !  (if Flather's algoritm applied at open boundary) 
     172 
     173   !!-------------------------------- 
     174   !! Arrays for radiative North OBC 
     175   !!-------------------------------- 
     176   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   unbnd, vnbnd      !: baroclinic u & v components of the velocity over 3 
     177      !                                                    !  rows and 3 time step (now, before, and before before) 
     178   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   tnbnd, snbnd      !: north boundary temperature and salinity over 
     179      !                                                    !  2 rows and 2 time step (now and before) 
     180   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   u_cynbnd, v_cynbnd    !: Meridional component of the phase speed ratio compu- 
     181      !                                                    !  ted with radiation of zonal and meridional velocity  
     182      !                                                    !  (respectively) at the north OB (u_cynbnd = cx rdt ) 
     183   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   unmsk, vnmsk, tnmsk   !: 2D mask for the North OB 
     184 
     185   ! Note that those arrays are optimized for mpp case  
     186   ! (hence the dimension jpj is the size of one processor subdomain) 
     187    
     188   !!--------------------- 
     189   !! South open boundary 
     190   !!--------------------- 
     191   INTEGER ::   nis0  , nis1       !: do loop index in mpp case for jpisd, jpisf 
     192   INTEGER ::   nis0p1, nis1m1     !: do loop index in mpp case for jpisdp1, jpisfm1 
     193   INTEGER ::   nis1m2, nis0m1     !: do loop index in mpp case for jpisfm1-1,jpisd 
     194   INTEGER ::   njs0  , njs1       !: do loop index in mpp case for jpsob 
     195   INTEGER ::   njs0p1, njs1p1     !: do loop index in mpp case for jpsob+1 
     196 
     197   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:) ::    &   !: 
     198      sshfos,           & !: now climatology of the south boundary sea surface height 
     199      ubtfos,vbtfos       !: now climatology of the south boundary barotropic transport 
     200 
     201   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::    &   !: 
     202      ufos, vfos,       & !: now climatology of the south boundary velocities  
     203      tfos, sfos,       & !: now climatology of the south boundary temperature and salinity 
     204      vclis               !: baroclinic componant of the meridian velocity after the radiation  
     205      !                   !  in the obcdyn.F90 routine 
     206 
     207   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshfos_b     !: south boundary ssh correction averaged over the barotropic loop 
     208      !                                           !  (if Flather's algoritm applied at open boundary) 
     209 
     210   !!-------------------------------- 
     211   !! Arrays for radiative South OBC   (computed by the forward time step in dynspg) 
     212   !!-------------------------------- 
     213   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   usbnd, vsbnd     !: baroclinic u & v components of the velocity over 3  
     214      !                                                   !  rows and 3 time step (now, before, and before before) 
     215   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   tsbnd, ssbnd     !: south boundary temperature and salinity over 
     216      !                                                   !  2 rows and 2 time step (now and before) 
     217   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   u_cysbnd, v_cysbnd   !: Meridional component of the phase speed ratio 
     218      !                                                   !  computed with radiation of zonal and meridional velocity  
     219      !                                                   !  (repsectively) at the south OB (u_cynbnd = cx rdt ) 
     220   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   usmsk, vsmsk, tsmsk  !: 2D mask for the South OB 
     221 
     222   !!---------------------------------------------------------------------- 
     223   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    114224   !! $Id$  
    115    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     225   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    116226   !!---------------------------------------------------------------------- 
    117227CONTAINS 
    118228 
    119    FUNCTION obc_oce_alloc() 
     229   INTEGER FUNCTION obc_oce_alloc() 
    120230      !!---------------------------------------------------------------------- 
    121       USE lib_mpp, ONLY: ctl_warn, mpp_sum 
    122       ! 
    123       INTEGER :: obc_oce_alloc 
     231      !!               ***  FUNCTION obc_oce_alloc  *** 
    124232      !!---------------------------------------------------------------------- 
    125       ! 
    126       ALLOCATE( obctmask(jpi,jpj) , obcumask(jpi,jpj), obcvmask(jpi,jpj),                    &   
    127          &      STAT=obc_oce_alloc ) 
    128          ! 
    129       IF( lk_mpp             )   CALL mpp_sum ( obc_oce_alloc ) 
    130       IF( obc_oce_alloc /= 0 )   CALL ctl_warn('obc_oce_alloc: failed to allocate arrays.') 
     233 
     234      ALLOCATE(                                                               & 
     235              !! East open boundary 
     236              obctmsk(jpi,jpj), obcumask(jpi,jpj), obcvmask(jpi,jpj),        & 
     237              sshfoe(jpjed:jpjef), ubtfoe(jpjed:jpjef), vbtfoe(jpjed:jpjef), & 
     238              ufoe(jpj,jpk), vfoe(jpj,jpk), tfoe(jpj,jpk), sfoe(jpj,jpk),    & 
     239              uclie(jpj,jpk), sshfoe_b(jpjed:jpjef,jpj),                     & 
     240              !! Arrays for radiative East OBC 
     241              uebnd(jpj,jpk,3,3), vebnd(jpj,jpk,3,3) ,                       & 
     242              tebnd(jpj,jpk,2,2), sebnd(jpj,jpk,2,2),                        & 
     243              u_cxebnd(jpj,jpk), v_cxebnd(jpj,jpk),                          & 
     244              uemsk(jpj,jpk), vemsk(jpj,jpk), temsk(jpj,jpk),                & 
     245              !! West open boundary 
     246              sshfow(jpjwd:jpjwf), ubtfow(jpjwd:jpjwf), vbtfow(jpjwd:jpjwf), & 
     247              ufow(jpj,jpk), vfow(jpj,jpk), tfow(jpj,jpk),                   & 
     248              sfow(jpj,jpk), ucliw(jpj,jpk), sshfow_b(jpjwd:jpjwf,jpj),      & 
     249              !! Arrays for radiative West OBC 
     250              uwbnd(jpj,jpk,3,3), vwbnd(jpj,jpk,3,3),                        & 
     251              twbnd(jpj,jpk,2,2), swbnd(jpj,jpk,2,2),                        & 
     252              u_cxwbnd(jpj,jpk), v_cxwbnd(jpj,jpk),                          & 
     253              uwmsk(jpj,jpk), vwmsk(jpj,jpk), twmsk(jpj,jpk),                & 
     254              !! North open boundary 
     255              sshfon(jpind:jpinf), ubtfon(jpind:jpinf), vbtfon(jpind:jpinf), & 
     256              ufon(jpi,jpk), vfon(jpi,jpk), tfon(jpi,jpk),                   & 
     257              sfon(jpi,jpk), vclin(jpi,jpk), sshfon_b(jpind:jpinf,jpj),      & 
     258              !! Arrays for radiative North OBC 
     259              unbnd(jpi,jpk,3,3), vnbnd(jpi,jpk,3,3),                        & 
     260              tnbnd(jpi,jpk,2,2), snbnd(jpi,jpk,2,2),                        & 
     261              u_cynbnd(jpi,jpk), v_cynbnd(jpi,jpk),                          & 
     262              unmsk(jpi,jpk), vnmsk(jpi,jpk), tnmsk (jpi,jpk),               & 
     263              !! South open boundary 
     264              sshfos(jpisd:jpisf), ubtfos(jpisd:jpisf), vbtfos(jpisd:jpisf), & 
     265              ufos(jpi,jpk), vfos(jpi,jpk), tfos(jpi,jpk),                   & 
     266              sfos(jpi,jpk), vclis(jpi,jpk),                                 & 
     267              sshfos_b(jpisd:jpisf,jpj),                                     & 
     268              !! Arrays for radiative South OBC  
     269              usbnd(jpi,jpk,3,3), vsbnd(jpi,jpk,3,3),                        & 
     270              tsbnd(jpi,jpk,2,2), ssbnd(jpi,jpk,2,2),                        & 
     271              u_cysbnd(jpi,jpk), v_cysbnd(jpi,jpk),                          & 
     272              usmsk(jpi,jpk), vsmsk(jpi,jpk), tsmsk(jpi,jpk),                & 
     273              !! 
     274              STAT=obc_oce_alloc ) 
    131275      ! 
    132276   END FUNCTION obc_oce_alloc 
    133  
     277    
    134278#else 
    135279   !!---------------------------------------------------------------------- 
    136    !!   Dummy module                NO Unstructured Open Boundary Condition 
    137    !!---------------------------------------------------------------------- 
    138    LOGICAL ::   ln_tides = .false.  !: =T apply tidal harmonic forcing along open boundaries 
     280   !!   Default option         Empty module                          No OBC 
     281   !!---------------------------------------------------------------------- 
    139282#endif 
    140283 
    141284   !!====================================================================== 
    142285END MODULE obc_oce 
    143  

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_par.F90

    r2797 r2888  
    11MODULE obc_par 
    2    !!====================================================================== 
    3    !!                      ***  MODULE obc_par   *** 
    4    !! Unstructured Open Boundary Cond. :   define related parameters 
    5    !!====================================================================== 
    6    !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code 
    7    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    8    !!            3.3  !  2010-09  (D. Storkey and E. O'Dea) update for Shelf configurations 
     2   !!============================================================================== 
     3   !!                  ***  MODULE obc_par   *** 
     4   !! Open Boundary Cond. :   define related parameters 
     5   !!============================================================================== 
     6   !! history :  OPA  ! 1991-01 (CLIPPER)  Original code  
     7   !!   NEMO     1.0  ! 2002-04   (C. Talandier)  modules 
     8   !!             -   ! 2004/06   (F. Durand) jptobc is defined as a parameter 
    99   !!---------------------------------------------------------------------- 
    10 #if defined   key_obc 
     10#if defined key_obc 
    1111   !!---------------------------------------------------------------------- 
    12    !!   'key_obc' :                    Unstructured Open Boundary Condition 
     12   !!   'key_obc' :                                Open Boundary Condition 
    1313   !!---------------------------------------------------------------------- 
     14   USE par_oce         ! ocean parameters 
    1415 
    1516   IMPLICIT NONE 
    1617   PUBLIC 
    1718 
    18    LOGICAL, PUBLIC, PARAMETER ::   lk_obc  = .TRUE.   !: Unstructured Ocean Boundary Condition flag 
    19    INTEGER, PUBLIC, PARAMETER ::   jp_obc  = 10       !: Maximum number of obc sets 
    20    INTEGER, PUBLIC, PARAMETER ::   jpbtime = 1000     !: Max number of time dumps per file 
    21    INTEGER, PUBLIC, PARAMETER ::   jpbgrd  = 3        !: Number of horizontal grid types used  (T, U, V) 
     19#if ! defined key_agrif 
     20   LOGICAL, PUBLIC, PARAMETER ::   lk_obc = .TRUE.     !: Ocean Boundary Condition flag 
     21#else 
     22   LOGICAL, PUBLIC            ::   lk_obc = .TRUE.     !: Ocean Boundary Condition flag 
     23#endif 
    2224 
    23    !! Flags for choice of schemes 
    24    INTEGER, PUBLIC, PARAMETER ::   jp_none         = 0        !: Flag for no open boundary condition 
    25    INTEGER, PUBLIC, PARAMETER ::   jp_frs          = 1        !: Flag for Flow Relaxation Scheme 
    26    INTEGER, PUBLIC, PARAMETER ::   jp_flather      = 2        !: Flag for Flather 
     25# if defined key_eel_r5 
     26   !!---------------------------------------------------------------------- 
     27   !!   'key_eel_r5' :                                 EEL R5 configuration 
     28   !!---------------------------------------------------------------------- 
     29#    include "obc_par_EEL_R5.h90" 
     30 
     31# elif defined key_pomme_r025 
     32   !!---------------------------------------------------------------------- 
     33   !!   'key_pomme_r025' :                         POMME R025 configuration 
     34   !!---------------------------------------------------------------------- 
     35#    include "obc_par_POMME_R025.h90" 
     36 
     37# else 
     38   !!--------------------------------------------------------------------- 
     39   !! open boundary parameter 
     40   !!--------------------------------------------------------------------- 
     41   INTEGER, PARAMETER ::   jptobc      =  2        !: time dimension of the BCS fields on input 
     42    
     43   !! * EAST open boundary 
     44   LOGICAL, PARAMETER ::   lp_obc_east = .FALSE.   !: to active or not the East open boundary 
     45   INTEGER   & 
     46#if !defined key_agrif 
     47     , PARAMETER   &  
     48#endif 
     49    ::     &  
     50      jpieob  = jpiglo-2,    &  !: i-localization of the East open boundary (must be ocean U-point) 
     51      jpjed   =        2,    &  !: j-starting indice of the East open boundary (must be land T-point) 
     52      jpjef   = jpjglo-1,    &  !: j-ending   indice of the East open boundary (must be land T-point) 
     53      jpjedp1 =  jpjed+1,    &  !: first ocean point         "                 " 
     54      jpjefm1 =  jpjef-1        !: last  ocean point         "                 " 
     55 
     56   !! * WEST open boundary 
     57   LOGICAL, PARAMETER ::   lp_obc_west = .FALSE.   !: to active or not the West open boundary 
     58   INTEGER   & 
     59#if !defined key_agrif 
     60     , PARAMETER   &  
     61#endif 
     62    ::     &  
     63      jpiwob  =          2,    &  !: i-localization of the West open boundary (must be ocean U-point) 
     64      jpjwd   =          2,    &  !: j-starting indice of the West open boundary (must be land T-point) 
     65      jpjwf   = jpjglo-1,    &  !: j-ending   indice of the West open boundary (must be land T-point) 
     66      jpjwdp1 =  jpjwd+1,    &  !: first ocean point         "                 " 
     67      jpjwfm1 =  jpjwf-1        !: last  ocean point         "                 " 
     68 
     69   !! * NORTH open boundary 
     70   LOGICAL, PARAMETER ::   lp_obc_north = .FALSE.   !: to active or not the North open boundary 
     71     INTEGER   & 
     72#if !defined key_agrif 
     73     , PARAMETER   &  
     74#endif 
     75    ::     &  
     76      jpjnob  = jpjglo-2,    &  !: j-localization of the North open boundary (must be ocean V-point) 
     77      jpind   =        2,    &  !: i-starting indice of the North open boundary (must be land T-point) 
     78      jpinf   = jpiglo-1,    &  !: i-ending   indice of the North open boundary (must be land T-point) 
     79      jpindp1 =  jpind+1,    &  !: first ocean point         "                 " 
     80      jpinfm1 =  jpinf-1        !: last  ocean point         "                 " 
     81 
     82   !! * SOUTH open boundary 
     83   LOGICAL, PARAMETER ::   lp_obc_south = .FALSE.   !: to active or not the South open boundary 
     84     INTEGER   & 
     85#if !defined key_agrif 
     86     , PARAMETER   &  
     87#endif 
     88    ::     &  
     89      jpjsob  =        2,    &  !: j-localization of the South open boundary (must be ocean V-point) 
     90      jpisd   =        2,    &  !: i-starting indice of the South open boundary (must be land T-point) 
     91      jpisf   = jpiglo-1,    &  !: i-ending   indice of the South open boundary (must be land T-point) 
     92      jpisdp1 =  jpisd+1,    &  !: first ocean point         "                 " 
     93      jpisfm1 =  jpisf-1        !: last  ocean point         "                 " 
     94    
     95   INTEGER, PARAMETER ::   jpnic = 2700   !: maximum number of isolated coastlines points  
     96 
     97# endif 
     98 
    2799#else 
    28100   !!---------------------------------------------------------------------- 
    29    !!   Default option :            NO Unstructured open boundary condition 
     101   !!   Default option :                         NO open boundary condition 
    30102   !!---------------------------------------------------------------------- 
    31    LOGICAL, PUBLIC, PARAMETER ::   lk_obc = .FALSE.   !: Unstructured Ocean Boundary Condition flag 
     103   LOGICAL, PUBLIC, PARAMETER ::   lk_obc = .FALSE.  !: Ocean Boundary Condition flag 
    32104#endif 
    33105 
    … …  
    35107   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    36108   !! $Id$  
    37    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     109   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    38110   !!====================================================================== 
    39111END MODULE obc_par 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcdta.F90

    r2865 r2888  
    11MODULE obcdta 
    2    !!====================================================================== 
    3    !!                       ***  MODULE obcdta  *** 
    4    !! Open boundary data : read the data for the unstructured open boundaries. 
    5    !!====================================================================== 
    6    !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code 
    7    !!             -   !  2007-01  (D. Storkey) Update to use IOM module 
    8    !!             -   !  2007-07  (D. Storkey) add obc_dta_fla 
    9    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    10    !!            3.3  !  2010-09  (E.O'Dea) modifications for Shelf configurations  
    11    !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions 
    12    !!            3.4  ???????????????? 
    13    !!---------------------------------------------------------------------- 
     2   !!============================================================================== 
     3   !!                            ***  MODULE obcdta  *** 
     4   !! Open boundary data : read the data for the open boundaries. 
     5   !!============================================================================== 
     6   !! History :  OPA  ! 1998-05 (J.M. Molines) Original code 
     7   !!            8.5  ! 2002-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     8   !!   NEMO     1.0  ! 2004-06 (F. Durand, A-M. Treguier) Netcdf BC files on input 
     9   !!            3.0  ! 2007-2008 (C. Langlais, P. Mathiot, J.M. Molines) high frequency boundaries data 
     10   !!------------------------------------------------------------------------------ 
    1411#if defined key_obc 
    15    !!---------------------------------------------------------------------- 
    16    !!   'key_obc'                     Open Boundary Conditions 
    17    !!---------------------------------------------------------------------- 
    18    !!    obc_dta        : read external data along open boundaries from file 
    19    !!    obc_dta_init   : initialise arrays etc for reading of external data 
    20    !!---------------------------------------------------------------------- 
    21    USE oce             ! ocean dynamics and tracers 
     12   !!------------------------------------------------------------------------------ 
     13   !!   'key_obc'         :                                Open Boundary Conditions 
     14   !!------------------------------------------------------------------------------ 
     15   !!   obc_dta           : read u, v, t, s data along each open boundary 
     16   !!------------------------------------------------------------------------------ 
     17   USE oce             ! ocean dynamics and tracers  
    2218   USE dom_oce         ! ocean space and time domain 
     19   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2320   USE phycst          ! physical constants 
    24    USE obc_oce         ! ocean open boundary conditions   
    25    USE obctides        ! tidal forcing at boundaries 
    26    USE fldread         ! read input fields 
    27    USE iom             ! IOM library 
     21   USE obc_par         ! ocean open boundary conditions 
     22   USE obc_oce         ! ocean open boundary conditions 
    2823   USE in_out_manager  ! I/O logical units 
    29 #if defined key_lim2 
    30    USE ice_2 
    31 #endif 
     24   USE lib_mpp         ! distributed memory computing 
     25   USE dynspg_oce      ! ocean: surface pressure gradient 
     26   USE ioipsl          ! now only for  ymds2ju function  
     27   USE iom             !  
    3228 
    3329   IMPLICIT NONE 
    3430   PRIVATE 
    3531 
    36    PUBLIC   obc_dta          ! routine called by step.F90 and dynspg_ts.F90 
    37    PUBLIC   obc_dta_init     ! routine called by nemogcm.F90 
    38  
    39    INTEGER, ALLOCATABLE, DIMENSION(:)   ::   nb_obc_fld        ! Number of fields to update for each boundary set. 
    40    INTEGER                              ::   nb_obc_fld_sum    ! Total number of fields to update for all boundary sets. 
    41  
    42    LOGICAL,           DIMENSION(jp_obc) ::   ln_full_vel_array ! =T => full velocities in 3D boundary conditions 
    43                                                                ! =F => baroclinic velocities in 3D boundary conditions 
    44  
    45    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET ::   bf        ! structure of input fields (file informations, fields read) 
    46  
    47    TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr   ! array of pointers to nbmap 
    48  
     32   PUBLIC   obc_dta         ! routine  called by step.F90 
     33   PUBLIC   obc_dta_bt      ! routine  called by dynspg_ts.F90 
     34   PUBLIC   obc_dta_alloc   ! function called by obcini.F90 
     35 
     36   REAL(wp),  DIMENSION(2)              ::   zjcnes_obc   !  
     37   REAL(wp),  DIMENSION(:), ALLOCATABLE ::   ztcobc 
     38   REAL(wp) :: rdt_obc 
     39   REAL(wp) :: zjcnes 
     40   INTEGER :: imm0, iyy0, idd0, iyy, imm, idd 
     41   INTEGER :: nt_a=2, nt_b=1, itobc, ndate0_cnes, nday_year0 
     42   INTEGER ::  itobce, itobcw, itobcs, itobcn, itobc_b  ! number of time steps in OBC files 
     43 
     44   INTEGER ::   ntobc        ! where we are in the obc file 
     45   INTEGER ::   ntobc_b      ! first record used 
     46   INTEGER ::   ntobc_a      ! second record used 
     47 
     48   CHARACTER (len=40) ::   cl_obc_eTS, cl_obc_eU   ! name of data files 
     49   CHARACTER (len=40) ::   cl_obc_wTS, cl_obc_wU   !   -       - 
     50   CHARACTER (len=40) ::   cl_obc_nTS, cl_obc_nV   !   -       - 
     51   CHARACTER (len=40) ::   cl_obc_sTS, cl_obc_sV   !   -       - 
     52 
     53   ! bt arrays for interpolating time dependent data on the boundaries 
     54   INTEGER ::   nt_m=0, ntobc_m 
     55   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtedta, vbtedta, sshedta    ! East 
     56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtwdta, vbtwdta, sshwdta    ! West 
     57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtndta, vbtndta, sshndta    ! North 
     58   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtsdta, vbtsdta, sshsdta    ! South 
     59   ! arrays used for interpolating time dependent data on the boundaries 
     60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uedta, vedta, tedta, sedta    ! East 
     61   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uwdta, vwdta, twdta, swdta    ! West 
     62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: undta, vndta, tndta, sndta    ! North 
     63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: usdta, vsdta, tsdta, ssdta    ! South 
     64 
     65   ! Masks set to .TRUE. after successful allocation below 
     66   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltemsk, luemsk, lvemsk  ! boolean msks 
     67   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltwmsk, luwmsk, lvwmsk  ! used for outliers 
     68   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltnmsk, lunmsk, lvnmsk  ! checks 
     69   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltsmsk, lusmsk, lvsmsk 
     70 
     71   !! * Substitutions 
     72#  include "obc_vectopt_loop_substitute.h90" 
    4973#  include "domzgr_substitute.h90" 
    5074   !!---------------------------------------------------------------------- 
    5175   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    52    !! $Id$  
    53    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     76   !! $Id$ 
     77   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5478   !!---------------------------------------------------------------------- 
    5579CONTAINS 
    5680 
    57       SUBROUTINE obc_dta( kt, jit, time_offset ) 
    58       !!---------------------------------------------------------------------- 
    59       !!                   ***  SUBROUTINE obc_dta  *** 
     81   INTEGER FUNCTION obc_dta_alloc() 
     82      !!------------------------------------------------------------------- 
     83      !!                     ***  ROUTINE obc_dta_alloc  *** 
     84      !!------------------------------------------------------------------- 
     85      INTEGER :: ierr(2) 
     86      !!------------------------------------------------------------------- 
     87# if defined key_dynspg_ts 
     88      ALLOCATE(   &     ! time-splitting : 0:jptobc 
     89         ! bt arrays for interpolating time dependent data on the boundaries 
     90         &      ubtedta  (jpj,0:jptobc) , vbtedta  (jpj,0:jptobc) , sshedta  (jpj,0:jptobc) ,    & 
     91         &      ubtwdta  (jpj,0:jptobc) , vbtwdta  (jpj,0:jptobc) , sshwdta  (jpj,0:jptobc) ,    & 
     92         &      ubtndta  (jpi,0:jptobc) , vbtndta  (jpi,0:jptobc) , sshndta  (jpi,0:jptobc) ,    & 
     93         &      ubtsdta  (jpi,0:jptobc) , vbtsdta  (jpi,0:jptobc) , sshsdta  (jpi,0:jptobc) ,    & 
     94         ! arrays used for interpolating time dependent data on the boundaries 
     95         &      uedta(jpj,jpk,0:jptobc) , vedta(jpj,jpk,0:jptobc)                           ,     & 
     96         &      tedta(jpj,jpk,0:jptobc) , sedta(jpj,jpk,0:jptobc)                           ,     & 
     97         &      uwdta(jpj,jpk,0:jptobc) , vwdta(jpj,jpk,0:jptobc)                           ,     & 
     98         &      twdta(jpj,jpk,0:jptobc) , swdta(jpj,jpk,0:jptobc)                           ,     & 
     99         &      undta(jpi,jpk,0:jptobc) , vndta(jpi,jpk,0:jptobc)                           ,     & 
     100         &      tndta(jpi,jpk,0:jptobc) , sndta(jpi,jpk,0:jptobc)                           ,     & 
     101         &      usdta(jpi,jpk,0:jptobc) , vsdta(jpi,jpk,0:jptobc)                           ,     & 
     102         &      tsdta(jpi,jpk,0:jptobc) , ssdta(jpi,jpk,0:jptobc)                           , STAT=ierr(1) ) 
     103# else 
     104      ALLOCATE(   &     ! no time splitting : 1:jptobc 
     105         ! bt arrays for interpolating time dependent data on the boundaries 
     106         &      ubtedta  (jpj,jptobc) , vbtedta  (jpj,jptobc) , sshedta  (jpj,jptobc)  ,     & 
     107         &      ubtwdta  (jpj,jptobc) , vbtwdta  (jpj,jptobc) , sshwdta  (jpj,jptobc)  ,     & 
     108         &      ubtndta  (jpi,jptobc) , vbtndta  (jpi,jptobc) , sshndta  (jpi,jptobc)  ,     & 
     109         &      ubtsdta  (jpi,jptobc) , vbtsdta  (jpi,jptobc) , sshsdta  (jpi,jptobc)  ,     & 
     110         ! arrays used for interpolating time dependent data on the boundaries 
     111         &      uedta(jpj,jpk,jptobc) , vedta(jpj,jpk,jptobc)                          ,     & 
     112         &      tedta(jpj,jpk,jptobc) , sedta(jpj,jpk,jptobc)                          ,     & 
     113         &      uwdta(jpj,jpk,jptobc) , vwdta(jpj,jpk,jptobc)                          ,     & 
     114         &      twdta(jpj,jpk,jptobc) , swdta(jpj,jpk,jptobc)                          ,     & 
     115         &      undta(jpi,jpk,jptobc) , vndta(jpi,jpk,jptobc)                          ,     & 
     116         &      tndta(jpi,jpk,jptobc) , sndta(jpi,jpk,jptobc)                          ,     & 
     117         &      usdta(jpi,jpk,jptobc) , vsdta(jpi,jpk,jptobc)                          ,     & 
     118         &      tsdta(jpi,jpk,jptobc) , ssdta(jpi,jpk,jptobc)                          , STAT=ierr(1) ) 
     119# endif 
     120 
     121      ALLOCATE( ltemsk(jpj,jpk) , luemsk(jpj,jpk) , lvemsk(jpj,jpk) ,     & 
     122         &      ltwmsk(jpj,jpk) , luwmsk(jpj,jpk) , lvwmsk(jpj,jpk) ,     & 
     123         &      ltnmsk(jpj,jpk) , lunmsk(jpj,jpk) , lvnmsk(jpj,jpk) ,     & 
     124         &      ltsmsk(jpj,jpk) , lusmsk(jpj,jpk) , lvsmsk(jpj,jpk) , STAT=ierr(2) ) 
     125 
     126      obc_dta_alloc = MAXVAL( ierr ) 
     127      IF( lk_mpp )   CALL mpp_sum( obc_dta_alloc ) 
     128 
     129      IF( obc_dta_alloc == 0 )  THEN         ! Initialise mask values following successful allocation 
     130         !      east            !          west            !          north           !          south           ! 
     131         ltemsk(:,:) = .TRUE.   ;   ltwmsk(:,:) = .TRUE.   ;   ltnmsk(:,:) = .TRUE.   ;   ltsmsk(:,:) = .TRUE. 
     132         luemsk(:,:) = .TRUE.   ;   luwmsk(:,:) = .TRUE.   ;   lunmsk(:,:) = .TRUE.   ;   lusmsk(:,:) = .TRUE. 
     133         lvemsk(:,:) = .TRUE.   ;   lvwmsk(:,:) = .TRUE.   ;   lvnmsk(:,:) = .TRUE.   ;   lvsmsk(:,:) = .TRUE. 
     134      END IF 
     135      ! 
     136   END FUNCTION obc_dta_alloc 
     137 
     138 
     139   SUBROUTINE obc_dta( kt ) 
     140      !!--------------------------------------------------------------------------- 
     141      !!                      ***  SUBROUTINE obc_dta  *** 
    60142      !!                     
    61       !! ** Purpose :   Update external data for open boundary conditions 
    62       !! 
    63       !! ** Method  :   Use fldread.F90 
    64       !!                 
    65       !!---------------------------------------------------------------------- 
    66       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    67       USE wrk_nemo, ONLY: wrk_2d_22, wrk_2d_23   ! 2D workspace 
    68       !! 
    69       INTEGER, INTENT( in )           ::   kt    ! ocean time-step index  
    70       INTEGER, INTENT( in ), OPTIONAL ::   jit   ! subcycle time-step index (for timesplitting option) 
    71       INTEGER, INTENT( in ), OPTIONAL ::   time_offset  ! time offset in units of timesteps. NB. if jit 
    72                                                         ! is present then units = subcycle timesteps. 
    73                                                         ! time_offset = 0 => get data at "now" time level 
    74                                                         ! time_offset = -1 => get data at "before" time level 
    75                                                         ! time_offset = +1 => get data at "after" time level 
    76                                                         ! etc. 
    77       !! 
    78       INTEGER     ::  ib_obc, jfld, jstart, jend, ib, ii, ij, ik, igrd  ! local indices 
    79       INTEGER,          DIMENSION(jpbgrd) ::   ilen1  
    80       INTEGER, POINTER, DIMENSION(:)      ::   nblen, nblenrim  ! short cuts 
     143      !! ** Purpose :   Find the climatological  boundary arrays for the specified date,  
     144      !!                The boundary arrays are netcdf files. Three possible cases:  
     145      !!                - one time frame only in the file (time dimension = 1). 
     146      !!                in that case the boundary data does not change in time. 
     147      !!                - many time frames. In that case,  if we have 12 frames 
     148      !!                we assume monthly fields.  
     149      !!                Else, we assume that time_counter is in seconds  
     150      !!                since the beginning of either the current year or a reference 
     151      !!                year given in the namelist. 
     152      !!                (no check is done so far but one would have to check the "unit" 
     153      !!                 attribute of variable time_counter). 
    81154      !! 
    82155      !!--------------------------------------------------------------------------- 
    83  
    84       IF(wrk_in_use(2, 22,23) ) THEN 
    85          CALL ctl_stop('obc_dta: ERROR: requested workspace arrays are unavailable.')   ;   RETURN 
     156      INTEGER, INTENT( in ) ::   kt          ! ocean time-step index 
     157      ! 
     158      INTEGER, SAVE :: immfile, iyyfile                     ! 
     159      INTEGER :: nt              !  record indices (incrementation) 
     160      REAL(wp) ::   zsec, zxy, znum, zden ! time interpolation weight 
     161      !!--------------------------------------------------------------------------- 
     162 
     163      ! 0.  initialisation : 
     164      ! -------------------- 
     165      IF ( kt == nit000  )  CALL obc_dta_ini ( kt ) 
     166      IF ( nobc_dta == 0 )  RETURN   ! already done in obc_dta_ini 
     167      IF ( itobc == 1    )  RETURN   ! case of only one time frame in file done in obc_dta_ini 
     168 
     169      ! in the following code, we assume that obc data are read from files, with more than 1 time frame in it 
     170 
     171      iyyfile=iyy ; immfile = 00  ! set component of the current file name 
     172      IF ( cffile /= 'annual') immfile = imm   !  
     173      IF ( ln_obc_clim       ) iyyfile = 0000  ! assume that climatological files are labeled y0000 
     174 
     175      ! 1. Synchronize time of run with time of data files 
     176      !--------------------------------------------------- 
     177      ! nday_year is the day number in the current year ( 1 for 01/01 ) 
     178      zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 
     179      IF (ln_obc_clim)  THEN  
     180         zjcnes = nday_year - 1  + zsec/rday 
     181      ELSE 
     182         zjcnes = zjcnes + rdt/rday 
     183      ENDIF 
     184 
     185      ! look for 'before' record number in the current file 
     186      ntobc = nrecbef ()  ! this function return the record number for 'before', relative to zjcnes 
     187 
     188      IF (MOD(kt-1,10)==0) THEN 
     189         IF (lwp) WRITE(numout,*) 'kt= ',kt,' zjcnes =', zjcnes,' ndastp =',ndastp, 'mm =',imm  
    86190      END IF 
    87191 
    88       ! Initialise data arrays once for all from initial conditions where required 
    89       !--------------------------------------------------------------------------- 
    90       IF( kt .eq. nit000 .and. .not. PRESENT(jit) ) THEN 
    91  
    92          ! Calculate depth-mean currents 
    93          !----------------------------- 
    94          pu2d => wrk_2d_22 
    95          pu2d => wrk_2d_23 
    96  
    97          pu2d(:,:) = 0.e0 
    98          pv2d(:,:) = 0.e0 
    99  
    100          DO ik = 1, jpkm1   !! Vertically integrated momentum trends 
    101              pu2d(:,:) = pu2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik) 
    102              pv2d(:,:) = pv2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik) 
     192      ! 2. read a new data if necessary  
     193      !-------------------------------- 
     194      IF ( ntobc /= ntobc_b ) THEN 
     195         ! we need to read the 'after' record 
     196         ! swap working index: 
     197# if defined key_dynspg_ts 
     198         nt=nt_m ; nt_m=nt_b ; nt_b=nt 
     199# endif 
     200         nt=nt_b ; nt_b=nt_a ; nt_a=nt 
     201         ntobc_b = ntobc 
     202 
     203         ! new record number : 
     204         ntobc_a = ntobc_a + 1  
     205 
     206         ! all tricky things related to record number, changing files etc... are managed by obc_read 
     207 
     208         CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile ) 
     209 
     210         ! update zjcnes_obc 
     211# if defined key_dynspg_ts 
     212         ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 
     213         zjcnes_obc(nt_m)= ztcobc(ntobc_m) 
     214# endif 
     215         zjcnes_obc(nt_b)= ztcobc(ntobc_b) 
     216         zjcnes_obc(nt_a)= ztcobc(ntobc_a) 
     217      ENDIF 
     218 
     219      ! 3.   interpolation at each time step 
     220      ! ------------------------------------ 
     221      IF( ln_obc_clim) THEN 
     222         znum= MOD(zjcnes           - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) ) 
     223         IF( znum < 0 ) znum = znum + REAL(nyear_len(1),wp) 
     224         zden= MOD(zjcnes_obc(nt_a) - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) )  
     225         IF( zden < 0 ) zden = zden + REAL(nyear_len(1),wp) 
     226      ELSE 
     227         znum= zjcnes           - zjcnes_obc(nt_b) 
     228         zden= zjcnes_obc(nt_a) - zjcnes_obc(nt_b) 
     229      ENDIF 
     230      zxy = znum / zden 
     231 
     232      IF( lp_obc_east ) THEN 
     233         !  fills sfoe, tfoe, ufoe ,vfoe 
     234         sfoe(:,:) = zxy * sedta (:,:,nt_a) + (1. - zxy)*sedta(:,:,nt_b) 
     235         tfoe(:,:) = zxy * tedta (:,:,nt_a) + (1. - zxy)*tedta(:,:,nt_b) 
     236         ufoe(:,:) = zxy * uedta (:,:,nt_a) + (1. - zxy)*uedta(:,:,nt_b) 
     237         vfoe(:,:) = zxy * vedta (:,:,nt_a) + (1. - zxy)*vedta(:,:,nt_b) 
     238      ENDIF 
     239 
     240      IF( lp_obc_west) THEN 
     241         !  fills sfow, tfow, ufow ,vfow 
     242         sfow(:,:) = zxy * swdta (:,:,nt_a) + (1. - zxy)*swdta(:,:,nt_b) 
     243         tfow(:,:) = zxy * twdta (:,:,nt_a) + (1. - zxy)*twdta(:,:,nt_b) 
     244         ufow(:,:) = zxy * uwdta (:,:,nt_a) + (1. - zxy)*uwdta(:,:,nt_b) 
     245         vfow(:,:) = zxy * vwdta (:,:,nt_a) + (1. - zxy)*vwdta(:,:,nt_b) 
     246      ENDIF 
     247 
     248      IF( lp_obc_north) THEN 
     249         !  fills sfon, tfon, ufon ,vfon 
     250         sfon(:,:) = zxy * sndta (:,:,nt_a) + (1. - zxy)*sndta(:,:,nt_b) 
     251         tfon(:,:) = zxy * tndta (:,:,nt_a) + (1. - zxy)*tndta(:,:,nt_b) 
     252         ufon(:,:) = zxy * undta (:,:,nt_a) + (1. - zxy)*undta(:,:,nt_b) 
     253         vfon(:,:) = zxy * vndta (:,:,nt_a) + (1. - zxy)*vndta(:,:,nt_b) 
     254      ENDIF 
     255 
     256      IF( lp_obc_south) THEN 
     257         !  fills sfos, tfos, ufos ,vfos 
     258         sfos(:,:) = zxy * ssdta (:,:,nt_a) + (1. - zxy)*ssdta(:,:,nt_b) 
     259         tfos(:,:) = zxy * tsdta (:,:,nt_a) + (1. - zxy)*tsdta(:,:,nt_b) 
     260         ufos(:,:) = zxy * usdta (:,:,nt_a) + (1. - zxy)*usdta(:,:,nt_b) 
     261         vfos(:,:) = zxy * vsdta (:,:,nt_a) + (1. - zxy)*vsdta(:,:,nt_b) 
     262      ENDIF 
     263   END SUBROUTINE obc_dta 
     264 
     265 
     266   SUBROUTINE obc_dta_ini( kt ) 
     267      !!----------------------------------------------------------------------------- 
     268      !!                       ***  SUBROUTINE obc_dta_ini  *** 
     269      !! 
     270      !! ** Purpose :   When obc_dta first call, realize some data initialization 
     271      !!---------------------------------------------------------------------------- 
     272      INTEGER, INTENT(in)  :: kt      ! ocean time-step index 
     273      ! 
     274      INTEGER ::   ji, jj   ! dummy loop indices 
     275      INTEGER, SAVE :: immfile, iyyfile                     ! 
     276 
     277      ! variables for the julian day calculation 
     278      INTEGER :: iyear, imonth, iday 
     279      REAL(wp) :: zsec , zjulian, zjuliancnes    
     280 
     281      IF(lwp) WRITE(numout,*) 
     282      IF(lwp) WRITE(numout,*)  'obc_dta : find boundary data' 
     283      IF(lwp) WRITE(numout,*)  '~~~~~~~' 
     284      IF (lwp) THEN 
     285         IF ( nobc_dta == 0 ) THEN  
     286            WRITE(numout,*)  '          OBC data taken from initial conditions.' 
     287         ELSE       
     288            WRITE(numout,*)  '          OBC data taken from netcdf files.' 
     289         ENDIF 
     290      ENDIF 
     291      nday_year0 = nday_year  ! to remember the day when kt=nit000 
     292 
     293      sedta(:,:,:) = 0.e0 ; tedta(:,:,:) = 0.e0 ; uedta(:,:,:) = 0.e0 ; vedta(:,:,:) = 0.e0 ! East 
     294      swdta(:,:,:) = 0.e0 ; twdta(:,:,:) = 0.e0 ; uwdta(:,:,:) = 0.e0 ; vwdta(:,:,:) = 0.e0 ! West 
     295      sndta(:,:,:) = 0.e0 ; tndta(:,:,:) = 0.e0 ; undta(:,:,:) = 0.e0 ; vndta(:,:,:) = 0.e0 ! North 
     296      ssdta(:,:,:) = 0.e0 ; tsdta(:,:,:) = 0.e0 ; usdta(:,:,:) = 0.e0 ; vsdta(:,:,:) = 0.e0 ! South 
     297 
     298      sfoe(:,:) = 0.e0  ; tfoe(:,:) = 0.e0 ; ufoe(:,:) = 0.e0 ; vfoe(:,:) = 0.e0   ! East 
     299      sfow(:,:) = 0.e0  ; tfow(:,:) = 0.e0 ; ufow(:,:) = 0.e0 ; vfow(:,:) = 0.e0   ! West 
     300      sfon(:,:) = 0.e0  ; tfon(:,:) = 0.e0 ; ufon(:,:) = 0.e0 ; vfon(:,:) = 0.e0   ! North 
     301      sfos(:,:) = 0.e0  ; tfos(:,:) = 0.e0 ; ufos(:,:) = 0.e0 ; vfos(:,:) = 0.e0   ! South 
     302 
     303      IF (nobc_dta == 0 ) THEN   ! boundary data are the initial data of this run (set only at nit000) 
     304         IF (lp_obc_east) THEN  ! East 
     305            DO ji = nie0 , nie1     
     306               sfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * sn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 
     307               tfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * tn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 
     308               ufoe(nje0:nje1,:) = uemsk(nje0:nje1,:) * un (ji   , nje0:nje1 , :) * umask(ji,  nje0:nje1 , :) 
     309               vfoe(nje0:nje1,:) = vemsk(nje0:nje1,:) * vn (ji+1 , nje0:nje1 , :) * vmask(ji+1,nje0:nje1 , :) 
     310            END DO 
     311         ENDIF 
     312 
     313         IF (lp_obc_west) THEN  ! West 
     314            DO ji = niw0 , niw1     
     315               sfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * sn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 
     316               tfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * tn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 
     317               ufow(njw0:njw1,:) = uwmsk(njw0:njw1,:) * un (ji , njw0:njw1 , :) * umask(ji , njw0:njw1 , :) 
     318               vfow(njw0:njw1,:) = vwmsk(njw0:njw1,:) * vn (ji , njw0:njw1 , :) * vmask(ji , njw0:njw1 , :) 
     319            END DO 
     320         ENDIF 
     321 
     322         IF (lp_obc_north) THEN ! North 
     323            DO jj = njn0 , njn1 
     324               sfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * sn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 
     325               tfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * tn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 
     326               ufon(nin0:nin1,:) = unmsk(nin0:nin1,:) * un (nin0:nin1 , jj+1 , :) * umask(nin0:nin1 , jj+1 , :) 
     327               vfon(nin0:nin1,:) = vnmsk(nin0:nin1,:) * vn (nin0:nin1 , jj   , :) * vmask(nin0:nin1 , jj   , :) 
     328            END DO 
     329         ENDIF 
     330 
     331         IF (lp_obc_south) THEN ! South 
     332            DO jj = njs0 , njs1 
     333               sfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * sn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 
     334               tfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * tn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 
     335               ufos(nis0:nis1,:) = usmsk(nis0:nis1,:) * un (nis0:nis1 , jj , :) * umask(nis0:nis1 , jj , :) 
     336               vfos(nis0:nis1,:) = vsmsk(nis0:nis1,:) * vn (nis0:nis1 , jj , :) * vmask(nis0:nis1 , jj , :) 
     337            END DO 
     338         ENDIF 
     339         RETURN  ! exit the routine all is done 
     340      ENDIF  ! nobc_dta = 0  
     341 
     342!!!! In the following OBC data are read from files. 
     343      ! all logical-mask are initialzed to true when declared 
     344      WHERE ( temsk == 0 ) ltemsk=.FALSE.  
     345      WHERE ( uemsk == 0 ) luemsk=.FALSE.  
     346      WHERE ( vemsk == 0 ) lvemsk=.FALSE.  
     347 
     348      WHERE ( twmsk == 0 ) ltwmsk=.FALSE.  
     349      WHERE ( uwmsk == 0 ) luwmsk=.FALSE.  
     350      WHERE ( vwmsk == 0 ) lvwmsk=.FALSE.  
     351 
     352      WHERE ( tnmsk == 0 ) ltnmsk=.FALSE.  
     353      WHERE ( unmsk == 0 ) lunmsk=.FALSE.  
     354      WHERE ( vnmsk == 0 ) lvnmsk=.FALSE.  
     355 
     356      WHERE ( tsmsk == 0 ) ltsmsk=.FALSE.  
     357      WHERE ( usmsk == 0 ) lusmsk=.FALSE.  
     358      WHERE ( vsmsk == 0 ) lvsmsk=.FALSE.  
     359 
     360      iyear=1950;  imonth=01; iday=01;  zsec=0.  
     361      ! zjuliancnes : julian day corresonding  to  01/01/1950 
     362      CALL ymds2ju(iyear, imonth, iday,zsec , zjuliancnes) 
     363 
     364      !current year and curent month  
     365      iyy=INT(ndastp/10000) ; imm=INT((ndastp -iyy*10000)/100) ; idd=(ndastp-iyy*10000-imm*100) 
     366      IF (iyy <  1900)  iyy = iyy+1900  ! always assume that years are on 4 digits. 
     367      CALL ymds2ju(iyy, imm, idd ,zsec , zjulian) 
     368      ndate0_cnes = zjulian - zjuliancnes   ! jcnes day when call to obc_dta_ini 
     369 
     370      iyyfile=iyy ; immfile=0  ! set component of the current file name 
     371      IF ( cffile /= 'annual') immfile=imm 
     372      IF ( ln_obc_clim) iyyfile = 0  ! assume that climatological files are labeled y0000 
     373 
     374      CALL obc_dta_chktime ( iyyfile, immfile ) 
     375 
     376      IF ( itobc == 1 ) THEN  
     377         ! in this case we will provide boundary data only once. 
     378         nt_a=1 ; ntobc_a=1 
     379         CALL obc_read (nit000, nt_a, ntobc_a, iyyfile, immfile)  
     380         IF( lp_obc_east ) THEN 
     381            !  fills sfoe, tfoe, ufoe ,vfoe 
     382            sfoe(:,:) =  sedta (:,:,1) ; tfoe(:,:) =  tedta (:,:,1) 
     383            ufoe(:,:) =  uedta (:,:,1) ; vfoe(:,:) =  vedta (:,:,1) 
     384         ENDIF 
     385 
     386         IF( lp_obc_west) THEN 
     387            !  fills sfow, tfow, ufow ,vfow 
     388            sfow(:,:) =  swdta (:,:,1) ; tfow(:,:) =  twdta (:,:,1) 
     389            ufow(:,:) =  uwdta (:,:,1) ; vfow(:,:) =  vwdta (:,:,1) 
     390         ENDIF 
     391 
     392         IF( lp_obc_north) THEN 
     393            !  fills sfon, tfon, ufon ,vfon 
     394            sfon(:,:) =  sndta (:,:,1) ; tfon(:,:) =  tndta (:,:,1) 
     395            ufon(:,:) =  undta (:,:,1) ; vfon(:,:) =  vndta (:,:,1) 
     396         ENDIF 
     397 
     398         IF( lp_obc_south) THEN 
     399            !  fills sfos, tfos, ufos ,vfos 
     400            sfos(:,:) =  ssdta (:,:,1) ; tfos(:,:) =  tsdta (:,:,1) 
     401            ufos(:,:) =  usdta (:,:,1) ; vfos(:,:) =  vsdta (:,:,1) 
     402         ENDIF 
     403         RETURN  ! we go out of obc_dta_ini -------------------------------------->>>>> 
     404      ENDIF 
     405 
     406      ! nday_year is the day number in the current year ( 1 for 01/01 ) 
     407      ! we suppose that we always start from the begining of a day 
     408      !    zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 
     409      zsec=0.e0  ! here, kt=nit000, nday_year = ndat_year0  
     410 
     411      IF (ln_obc_clim)  THEN  
     412         zjcnes = nday_year - 1  + zsec/rday  ! for clim file time is in days in a year 
     413      ELSE 
     414         zjcnes = ndate0_cnes + (nday_year - nday_year0 ) + zsec/rday 
     415      ENDIF 
     416 
     417      ! look for 'before' record number in the current file 
     418      ntobc = nrecbef () 
     419 
     420      IF (lwp) WRITE(numout,*) 'obc files frequency :',cffile 
     421      IF (lwp) WRITE(numout,*) ' zjcnes0 =',zjcnes,' ndastp0 =',ndastp 
     422      IF (lwp) WRITE(numout,*) ' annee0 ',iyy,' month0 ', imm,' day0 ', idd 
     423      IF (lwp) WRITE(numout,*) 'first file open :',cl_obc_nTS 
     424 
     425      ! record initialisation 
     426      !-------------------- 
     427      nt_b = 1 ; nt_a = 2 
     428 
     429      ntobc_a = ntobc + 1 
     430      ntobc_b = ntobc 
     431 
     432      CALL obc_read (kt, nt_b, ntobc_b, iyyfile, immfile)  ! read 'before' fields 
     433      CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile)  ! read 'after' fields 
     434 
     435      ! additional frame in case of time-splitting 
     436# if defined key_dynspg_ts 
     437      nt_m = 0 
     438      ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 
     439      zjcnes_obc(nt_m)= ztcobc(ntobc_m) ! FDbug has not checked that this is correct!! 
     440      IF (ln_rstart) THEN 
     441         CALL obc_read (kt, nt_m, ntobc_m, iyyfile, immfile)  ! read 'after' fields 
     442      ENDIF 
     443# endif 
     444 
     445      zjcnes_obc(nt_b)= ztcobc(ntobc_b) 
     446      zjcnes_obc(nt_a)= ztcobc(ntobc_a) 
     447      !  
     448   END SUBROUTINE obc_dta_ini 
     449 
     450 
     451   SUBROUTINE obc_dta_chktime (kyyfile, kmmfile) 
     452      ! 
     453      ! check the number of time steps in the files and read ztcobc  
     454      ! 
     455      ! * Arguments 
     456      INTEGER, INTENT(in) :: kyyfile, kmmfile 
     457      ! * local variables 
     458      INTEGER :: istop       ! error control 
     459      INTEGER :: ji          ! dummy loop index 
     460 
     461      INTEGER ::  idvar, id_e, id_w, id_n, id_s       ! file identifiers 
     462      INTEGER, DIMENSION(1)  :: itmp 
     463      CHARACTER(LEN=25) :: cl_vname 
     464 
     465      ntobc_a = 0; itobce =0 ; itobcw = 0; itobcn = 0; itobcs = 0 
     466      ! build file name 
     467      IF(ln_obc_clim) THEN   ! revert to old convention for climatological OBC forcing 
     468         cl_obc_eTS='obceast_TS.nc' 
     469         cl_obc_wTS='obcwest_TS.nc' 
     470         cl_obc_nTS='obcnorth_TS.nc' 
     471         cl_obc_sTS='obcsouth_TS.nc' 
     472      ELSE                   ! convention for climatological OBC 
     473         WRITE(cl_obc_eTS ,'("obc_east_TS_y",i4.4,"m",i2.2,".nc")'  ) kyyfile,kmmfile 
     474         WRITE(cl_obc_wTS ,'("obc_west_TS_y",i4.4,"m",i2.2,".nc")'  ) kyyfile,kmmfile 
     475         WRITE(cl_obc_nTS ,'("obc_north_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 
     476         WRITE(cl_obc_sTS ,'("obc_south_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 
     477      ENDIF 
     478 
     479      cl_vname = 'time_counter' 
     480      IF ( lp_obc_east ) THEN 
     481         CALL iom_open ( cl_obc_eTS , id_e ) 
     482         idvar = iom_varid( id_e, cl_vname, kdimsz = itmp ); itobce=itmp(1) 
     483      ENDIF 
     484      IF ( lp_obc_west ) THEN 
     485         CALL iom_open ( cl_obc_wTS , id_w ) 
     486         idvar = iom_varid( id_w, cl_vname, kdimsz = itmp ) ; itobcw=itmp(1) 
     487      ENDIF 
     488      IF ( lp_obc_north ) THEN 
     489         CALL iom_open ( cl_obc_nTS , id_n ) 
     490         idvar = iom_varid( id_n, cl_vname, kdimsz = itmp ) ; itobcn=itmp(1) 
     491      ENDIF 
     492      IF ( lp_obc_south ) THEN 
     493         CALL iom_open ( cl_obc_sTS , id_s ) 
     494         idvar = iom_varid( id_s, cl_vname, kdimsz = itmp ) ; itobcs=itmp(1) 
     495      ENDIF 
     496 
     497      itobc = MAX( itobce, itobcw, itobcn, itobcs ) 
     498      istop = 0 
     499      IF ( lp_obc_east  .AND. itobce /= itobc ) istop = istop+1  
     500      IF ( lp_obc_west  .AND. itobcw /= itobc ) istop = istop+1       
     501      IF ( lp_obc_north .AND. itobcn /= itobc ) istop = istop+1 
     502      IF ( lp_obc_south .AND. itobcs /= itobc ) istop = istop+1  
     503      nstop = nstop + istop 
     504 
     505      IF ( istop /=  0 )  THEN 
     506         WRITE(ctmp1,*) ' east, west, north, south: ', itobce, itobcw, itobcn, itobcs 
     507         CALL ctl_stop( 'obcdta : all files must have the same number of time steps', ctmp1 ) 
     508      ENDIF 
     509 
     510      IF ( itobc == 1 ) THEN  
     511         IF (lwp) THEN 
     512            WRITE(numout,*) ' obcdta found one time step only in the OBC files' 
     513            IF (ln_obc_clim) THEN 
     514               ! OK no problem 
     515            ELSE 
     516               ln_obc_clim=.true. 
     517               WRITE(numout,*) ' we force ln_obc_clim to T' 
     518            ENDIF 
     519         ENDIF 
     520      ELSE 
     521         IF ( ALLOCATED(ztcobc) ) DEALLOCATE ( ztcobc ) 
     522         ALLOCATE (ztcobc(itobc)) 
     523         DO ji=1,1   ! use a dummy loop to read ztcobc only once 
     524            IF ( lp_obc_east ) THEN 
     525               CALL iom_gettime ( id_e, ztcobc, cl_vname ) ; CALL iom_close (id_e) ; EXIT 
     526            ENDIF 
     527            IF ( lp_obc_west ) THEN 
     528               CALL iom_gettime ( id_w, ztcobc, cl_vname ) ; CALL iom_close (id_w) ; EXIT 
     529            ENDIF 
     530            IF ( lp_obc_north ) THEN 
     531               CALL iom_gettime ( id_n, ztcobc, cl_vname ) ; CALL iom_close (id_n) ; EXIT 
     532            ENDIF 
     533            IF ( lp_obc_south ) THEN 
     534               CALL iom_gettime ( id_s, ztcobc, cl_vname ) ; CALL iom_close (id_s) ; EXIT 
     535            ENDIF 
    103536         END DO 
    104          pu2d(:,:) = pu2d(:,:) * hur(:,:) 
    105          pv2d(:,:) = pv2d(:,:) * hvr(:,:) 
    106           
    107          DO ib_obc = 1, nb_obc 
    108  
    109             nblen => idx_obc(ib_obc)%nblen 
    110             nblenrim => idx_obc(ib_obc)%nblenrim 
    111  
    112             IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .eq. 0 ) THEN  
    113                IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 
    114                   ilen1(:) = nblen(:) 
    115                ELSE 
    116                   ilen1(:) = nblenrim(:) 
    117                ENDIF 
    118                igrd = 1 
    119                DO ib = 1, ilen1(igrd) 
    120                   ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    121                   ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    122                   dta_obc(ib_obc)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1)          
    123                END DO  
    124                igrd = 2 
    125                DO ib = 1, ilen1(igrd) 
    126                   ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    127                   ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    128                   dta_obc(ib_obc)%u2d(ib) = pu2d(ii,ij) * umask(ii,ij,1)          
    129                END DO  
    130                igrd = 3 
    131                DO ib = 1, ilen1(igrd) 
    132                   ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    133                   ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    134                   dta_obc(ib_obc)%v2d(ib) = pv2d(ii,ij) * vmask(ii,ij,1)          
    135                END DO  
    136             ENDIF 
    137  
    138             IF( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 0 ) THEN  
    139                IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 
    140                   ilen1(:) = nblen(:) 
    141                ELSE 
    142                   ilen1(:) = nblenrim(:) 
    143                ENDIF 
    144                igrd = 2  
    145                DO ib = 1, ilen1(igrd) 
    146                   DO ik = 1, jpkm1 
    147                      ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    148                      ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    149                      dta_obc(ib_obc)%u3d(ib,ik) =  ( un(ii,ij,ik) - pu2d(ii,ij) ) * umask(ii,ij,ik)          
     537         rdt_obc = ztcobc(2)-ztcobc(1)  !  just an information, not used for any computation 
     538         IF (lwp) WRITE(numout,*) ' obcdta found', itobc,' time steps in the OBC files' 
     539         IF (lwp) WRITE(numout,*) ' time step of obc data :', rdt_obc,' days'             
     540      ENDIF 
     541      zjcnes = zjcnes - rdt/rday  ! trick : zcnes is always incremented by rdt/rday in obc_dta! 
     542   END SUBROUTINE obc_dta_chktime 
     543 
     544# if defined key_dynspg_ts || defined key_dynspg_exp 
     545   SUBROUTINE obc_dta_bt( kt, kbt ) 
     546      !!--------------------------------------------------------------------------- 
     547      !!                      ***  SUBROUTINE obc_dta  *** 
     548      !! 
     549      !! ** Purpose :   time interpolation of barotropic data for time-splitting scheme 
     550      !!                Data at the boundary must be in m2/s  
     551      !! 
     552      !! History :  9.0  !  05-11 (V. garnier) Original code 
     553      !!--------------------------------------------------------------------------- 
     554      INTEGER, INTENT( in ) ::   kt          ! ocean time-step index 
     555      INTEGER, INTENT( in ) ::   kbt         ! barotropic ocean time-step index 
     556      ! 
     557      INTEGER ::   ji, jj  ! dummy loop indices 
     558      INTEGER ::   i15 
     559      INTEGER ::   itobcm, itobcp 
     560      REAL(wp) ::  zxy 
     561      INTEGER ::   isrel           ! number of seconds since 1/1/1992 
     562      !!--------------------------------------------------------------------------- 
     563 
     564      ! 1.   First call: check time frames available in files. 
     565      ! ------------------------------------------------------- 
     566 
     567      IF( kt == nit000 ) THEN 
     568 
     569         ! 1.1  Barotropic tangential velocities set to zero 
     570         ! ------------------------------------------------- 
     571         IF( lp_obc_east  ) vbtfoe(:) = 0.e0 
     572         IF( lp_obc_west  ) vbtfow(:) = 0.e0 
     573         IF( lp_obc_south ) ubtfos(:) = 0.e0 
     574         IF( lp_obc_north ) ubtfon(:) = 0.e0 
     575 
     576         ! 1.2  Sea surface height and normal barotropic velocities set to zero 
     577         !                               or initial conditions if nobc_dta == 0 
     578         ! -------------------------------------------------------------------- 
     579 
     580         IF( lp_obc_east ) THEN 
     581            ! initialisation to zero 
     582            sshedta(:,:) = 0.e0 
     583            ubtedta(:,:) = 0.e0 
     584            vbtedta(:,:) = 0.e0 ! tangential component 
     585            !                                        ! ================== ! 
     586            IF( nobc_dta == 0 )   THEN               ! initial state used ! 
     587               !                                     ! ================== ! 
     588               !  Fills sedta, tedta, uedta (global arrays) 
     589               !  Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 
     590               DO ji = nie0, nie1 
     591                  DO jj = 1, jpj 
     592                     sshedta(jj,1) = sshn(ji+1,jj) * tmask(ji+1,jj,1) 
    150593                  END DO 
    151                END DO  
    152                igrd = 3  
    153                DO ib = 1, ilen1(igrd) 
    154                   DO ik = 1, jpkm1 
    155                      ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    156                      ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    157                      dta_obc(ib_obc)%v3d(ib,ik) =  ( vn(ii,ij,ik) - pv2d(ii,ij) ) * vmask(ii,ij,ik)          
    158                      END DO 
    159                END DO  
    160             ENDIF 
    161  
    162             IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 0 ) THEN  
    163                IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 
    164                   ilen1(:) = nblen(:) 
    165                ELSE 
    166                   ilen1(:) = nblenrim(:) 
    167                ENDIF 
    168                igrd = 1                       ! Everything is at T-points here 
    169                DO ib = 1, ilen1(igrd) 
    170                   DO ik = 1, jpkm1 
    171                      ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    172                      ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    173                      dta_obc(ib_obc)%tem(ib,ik) = tn(ii,ij,ik) * tmask(ii,ij,ik)          
    174                      dta_obc(ib_obc)%sal(ib,ik) = sn(ii,ij,ik) * tmask(ii,ij,ik)          
     594               END DO 
     595            ENDIF 
     596         ENDIF 
     597 
     598         IF( lp_obc_west) THEN 
     599            ! initialisation to zero 
     600            sshwdta(:,:) = 0.e0 
     601            ubtwdta(:,:) = 0.e0 
     602            vbtwdta(:,:) = 0.e0 ! tangential component 
     603            !                                        ! ================== ! 
     604            IF( nobc_dta == 0 )   THEN               ! initial state used ! 
     605               !                                     ! ================== ! 
     606               !  Fills swdta, twdta, uwdta (global arrays) 
     607               !  Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 
     608               DO ji = niw0, niw1 
     609                  DO jj = 1, jpj 
     610                     sshwdta(jj,1) = sshn(ji,jj) * tmask(ji,jj,1) 
    175611                  END DO 
    176                END DO  
    177             ENDIF 
    178  
    179 #if defined key_lim2 
    180             IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 0 ) THEN  
    181                IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 
    182                   ilen1(:) = nblen(:) 
    183                ELSE 
    184                   ilen1(:) = nblenrim(:) 
    185                ENDIF 
    186                igrd = 1                       ! Everything is at T-points here 
    187                DO ib = 1, ilen1(igrd) 
    188                   ii = idx_obc(ib_obc)%nbi(ib,igrd) 
    189                   ij = idx_obc(ib_obc)%nbj(ib,igrd) 
    190                   dta_obc(ib_obc)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1)          
    191                   dta_obc(ib_obc)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1)          
    192                   dta_obc(ib_obc)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1)          
    193                END DO  
    194             ENDIF 
    195 #endif 
    196  
    197          ENDDO ! ib_obc 
    198  
    199       ENDIF ! kt .eq. nit000 
    200  
    201       ! update external data from files 
    202       !-------------------------------- 
    203       
    204       jstart = 1 
    205       DO ib_obc = 1, nb_obc    
    206          IF( nn_dta(ib_obc) .eq. 1 ) THEN ! skip this bit if no external data required 
    207        
    208             IF( PRESENT(jit) ) THEN 
    209                ! Update barotropic boundary conditions only 
    210                ! jit is optional argument for fld_read and tide_update 
    211                IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 
    212                   IF( nn_dyn2d_dta(ib_obc) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    213                      dta_obc(ib_obc)%ssh(:) = 0.0 
    214                      dta_obc(ib_obc)%u2d(:) = 0.0 
    215                      dta_obc(ib_obc)%v2d(:) = 0.0 
    216                   ENDIF 
    217                   IF( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) THEN ! update external data 
    218                      jend = jstart + 2 
    219                      CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), jit=jit, time_offset=time_offset ) 
    220                   ENDIF 
    221                   IF( nn_dyn2d_dta(ib_obc) .ge. 2 ) THEN ! update tidal harmonic forcing 
    222                      CALL tide_update( kt=kt, idx=idx_obc(ib_obc), dta=dta_obc(ib_obc), td=tides(ib_obc), jit=jit, time_offset=time_offset ) 
    223                   ENDIF 
     612               END DO 
     613            ENDIF 
     614         ENDIF 
     615 
     616         IF( lp_obc_north) THEN 
     617            ! initialisation to zero 
     618            sshndta(:,:) = 0.e0 
     619            ubtndta(:,:) = 0.e0 ! tangential component 
     620            vbtndta(:,:) = 0.e0 
     621            !                                        ! ================== ! 
     622            IF( nobc_dta == 0 ) THEN                 ! initial state used ! 
     623               !                                     ! ================== ! 
     624               !  Fills sndta, tndta, vndta (global arrays) 
     625               !  Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 
     626               DO jj = njn0, njn1 
     627                  DO ji = 1, jpi 
     628                     sshndta(ji,1) = sshn(ji,jj+1) * tmask(ji,jj+1,1) 
     629                  END DO 
     630               END DO 
     631            ENDIF 
     632         ENDIF 
     633 
     634         IF( lp_obc_south) THEN 
     635            ! initialisation to zero 
     636            sshsdta(:,:) = 0.e0 
     637            ubtsdta(:,:) = 0.e0 ! tangential component 
     638            vbtsdta(:,:) = 0.e0 
     639            !                                        ! ================== ! 
     640            IF( nobc_dta == 0 )   THEN               ! initial state used ! 
     641               !                                     ! ================== ! 
     642               !  Fills ssdta, tsdta, vsdta (global arrays) 
     643               !  Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 
     644               DO jj = njs0, njs1 
     645                  DO ji = 1, jpi 
     646                     sshsdta(ji,1) = sshn(ji,jj) * tmask(ji,jj,1) 
     647                  END DO 
     648               END DO 
     649            ENDIF 
     650         ENDIF 
     651 
     652         IF( nobc_dta == 0 ) CALL obc_depth_average(1)   ! depth averaged velocity from the OBC depth-dependent frames 
     653 
     654      ENDIF        !       END kt == nit000 
     655 
     656      !!------------------------------------------------------------------------------------ 
     657      ! 2.      Initialize the time we are at. Does this every time the routine is called, 
     658      !         excepted when nobc_dta = 0 
     659      ! 
     660 
     661      ! 3.  Call at every time step : Linear interpolation of BCs to current time step 
     662      ! ---------------------------------------------------------------------- 
     663 
     664      IF( lk_dynspg_ts ) THEN 
     665         isrel = (kt-1)*rdt + kbt*(rdt/REAL(nn_baro,wp)) 
     666      ELSE IF( lk_dynspg_exp ) THEN 
     667         isrel=kt*rdt 
     668      ENDIF 
     669 
     670      itobcm = nt_b 
     671      itobcp = nt_a 
     672      IF( itobc == 1 .OR. nobc_dta == 0 ) THEN 
     673         zxy = 0.e0 
     674         itobcm = 1 
     675         itobcp = 1 
     676      ELSE IF( itobc == 12 ) THEN 
     677         i15   = nday / 16 
     678         zxy = FLOAT( nday + 15 - 30 * i15 ) / 30. 
     679      ELSE 
     680         zxy = (zjcnes_obc(nt_a)-FLOAT(isrel)) / (zjcnes_obc(nt_a)-zjcnes_obc(nt_b)) 
     681         IF( zxy < 0. ) THEN   ! case of extrapolation, switch to old time frames 
     682            itobcm = nt_m 
     683            itobcp = nt_b 
     684            zxy = (zjcnes_obc(nt_b)-FLOAT(isrel)) / (zjcnes_obc(nt_b)-zjcnes_obc(nt_m)) 
     685         ENDIF 
     686      ENDIF 
     687 
     688      IF( lp_obc_east ) THEN           !  fills sshfoe, ubtfoe (local to each processor) 
     689         DO jj = 1, jpj 
     690            sshfoe(jj) = zxy * sshedta(jj,itobcp) + (1.-zxy) * sshedta(jj,itobcm) 
     691            ubtfoe(jj) = zxy * ubtedta(jj,itobcp) + (1.-zxy) * ubtedta(jj,itobcm) 
     692            vbtfoe(jj) = zxy * vbtedta(jj,itobcp) + (1.-zxy) * vbtedta(jj,itobcm) 
     693         END DO 
     694      ENDIF 
     695 
     696      IF( lp_obc_west) THEN            !  fills sshfow, ubtfow (local to each processor) 
     697         DO jj = 1, jpj 
     698            sshfow(jj) = zxy * sshwdta(jj,itobcp) + (1.-zxy) * sshwdta(jj,itobcm) 
     699            ubtfow(jj) = zxy * ubtwdta(jj,itobcp) + (1.-zxy) * ubtwdta(jj,itobcm) 
     700            vbtfow(jj) = zxy * vbtwdta(jj,itobcp) + (1.-zxy) * vbtwdta(jj,itobcm) 
     701         END DO 
     702      ENDIF 
     703 
     704      IF( lp_obc_north) THEN           !  fills sshfon, vbtfon (local to each processor) 
     705         DO ji = 1, jpi 
     706            sshfon(ji) = zxy * sshndta(ji,itobcp) + (1.-zxy) * sshndta(ji,itobcm) 
     707            ubtfon(ji) = zxy * ubtndta(ji,itobcp) + (1.-zxy) * ubtndta(ji,itobcm) 
     708            vbtfon(ji) = zxy * vbtndta(ji,itobcp) + (1.-zxy) * vbtndta(ji,itobcm) 
     709         END DO 
     710      ENDIF 
     711 
     712      IF( lp_obc_south) THEN           !  fills sshfos, vbtfos (local to each processor) 
     713         DO ji = 1, jpi 
     714            sshfos(ji) = zxy * sshsdta(ji,itobcp) + (1.-zxy) * sshsdta(ji,itobcm) 
     715            ubtfos(ji) = zxy * ubtsdta(ji,itobcp) + (1.-zxy) * ubtsdta(ji,itobcm) 
     716            vbtfos(ji) = zxy * vbtsdta(ji,itobcp) + (1.-zxy) * vbtsdta(ji,itobcm) 
     717         END DO 
     718      ENDIF 
     719 
     720   END SUBROUTINE obc_dta_bt 
     721 
     722# else 
     723   !!----------------------------------------------------------------------------- 
     724   !!   Default option 
     725   !!----------------------------------------------------------------------------- 
     726   SUBROUTINE obc_dta_bt ( kt, kbt )       ! Empty routine 
     727      !! * Arguments 
     728      INTEGER,INTENT(in) :: kt 
     729      INTEGER, INTENT( in ) ::   kbt         ! barotropic ocean time-step index 
     730      WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kt 
     731      WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kbt 
     732   END SUBROUTINE obc_dta_bt 
     733# endif 
     734 
     735   SUBROUTINE obc_read (kt, nt_x, ntobc_x, iyy, imm) 
     736      !!------------------------------------------------------------------------- 
     737      !!                      ***  ROUTINE obc_read  *** 
     738      !! 
     739      !! ** Purpose :  Read the boundary data in files identified by iyy and imm 
     740      !!               According to the validated open boundaries, return the  
     741      !!               following arrays : 
     742      !!                sedta, tedta : East OBC salinity and temperature 
     743      !!                uedta, vedta :   "   "  u and v velocity component       
     744      !! 
     745      !!                swdta, twdta : West OBC salinity and temperature 
     746      !!                uwdta, vwdta :   "   "  u and v velocity component       
     747      !! 
     748      !!                sndta, tndta : North OBC salinity and temperature 
     749      !!                undta, vndta :   "   "  u and v velocity component       
     750      !! 
     751      !!                ssdta, tsdta : South OBC salinity and temperature 
     752      !!                usdta, vsdta :   "   "  u and v velocity component       
     753      !! 
     754      !! ** Method  :  These fields are read in the record ntobc_x of the files. 
     755      !!               The number of records is already known. If  ntobc_x is greater 
     756      !!               than the number of record, this routine will look for next file, 
     757      !!               updating the indices (case of inter-annual obcs) or loop at the 
     758      !!               begining in case of climatological file (ln_obc_clim = true ). 
     759      !! ------------------------------------------------------------------------- 
     760      !! History:     !  2005  ( P. Mathiot, C. Langlais ) Original code 
     761      !!              !  2008  ( J,M, Molines ) Use IOM and cleaning 
     762      !!-------------------------------------------------------------------------- 
     763 
     764      ! * Arguments 
     765      INTEGER, INTENT( in ) :: kt, nt_x 
     766      INTEGER, INTENT( inout ) :: ntobc_x , iyy, imm      ! yes ! inout ! 
     767 
     768      ! * Local variables 
     769      CHARACTER (len=40) :: &    ! file names 
     770         cl_obc_eTS   , cl_obc_eU,  cl_obc_eV,& 
     771         cl_obc_wTS   , cl_obc_wU,  cl_obc_wV,& 
     772         cl_obc_nTS   , cl_obc_nU,  cl_obc_nV,& 
     773         cl_obc_sTS   , cl_obc_sU,  cl_obc_sV 
     774 
     775      INTEGER :: ikprint 
     776      REAL(wp) :: zmin, zmax   ! control of boundary values 
     777 
     778      !IOM stuff 
     779      INTEGER :: id_e, id_w, id_n, id_s 
     780      INTEGER, DIMENSION(2) :: istart, icount 
     781 
     782      !-------------------------------------------------------------------------- 
     783      IF ( ntobc_x > itobc ) THEN 
     784         IF (ln_obc_clim) THEN  ! just loop on the same file 
     785            ntobc_x = 1  
     786         ELSE 
     787            ! need to change file : it is always for an 'after' data 
     788            IF ( cffile == 'annual' ) THEN ! go to next year file 
     789               iyy = iyy + 1 
     790            ELSE IF ( cffile =='monthly' ) THEN  ! go to next month file 
     791               imm = imm + 1  
     792               IF ( imm == 13 ) THEN  
     793                  imm = 1 ; iyy = iyy + 1 
    224794               ENDIF 
    225795            ELSE 
    226                IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    227                   dta_obc(ib_obc)%ssh(:) = 0.0 
    228                   dta_obc(ib_obc)%u2d(:) = 0.0 
    229                   dta_obc(ib_obc)%v2d(:) = 0.0 
    230                ENDIF 
    231                IF( nb_obc_fld(ib_obc) .gt. 0 ) THEN ! update external data 
    232                   jend = jstart + nb_obc_fld(ib_obc) - 1 
    233                   CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), time_offset=time_offset ) 
    234                ENDIF 
    235                IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .ge. 2 ) THEN ! update tidal harmonic forcing 
    236                   CALL tide_update( kt=kt, idx=idx_obc(ib_obc), dta=dta_obc(ib_obc), td=tides(ib_obc), time_offset=time_offset ) 
    237                ENDIF 
    238             ENDIF 
    239             jstart = jend+1 
    240  
    241             ! If full velocities in boundary data then split into barotropic and baroclinic data 
    242             ! (Note that we have already made sure that you can't use ln_full_vel = .true. at the same 
    243             ! time as the dynspg_ts option).  
    244  
    245             IF( ln_full_vel_array(ib_obc) .and.                                             &  
    246            &    ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 .or. nn_dyn3d_dta(ib_obc) .eq. 1 ) ) THEN  
    247  
    248                igrd = 2                      ! zonal velocity 
    249                dta_obc(ib_obc)%u2d(:) = 0.0 
    250                DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 
    251                   ii   = idx_obc(ib_obc)%nbi(ib,igrd) 
    252                   ij   = idx_obc(ib_obc)%nbj(ib,igrd) 
    253                   DO ik = 1, jpkm1 
    254                      dta_obc(ib_obc)%u2d(ib) = dta_obc(ib_obc)%u2d(ib) & 
    255               &                                + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta_obc(ib_obc)%u3d(ib,ik) 
    256                   END DO 
    257                   dta_obc(ib_obc)%u2d(ib) =  dta_obc(ib_obc)%u2d(ib) * hur(ii,ij) 
    258                   DO ik = 1, jpkm1 
    259                      dta_obc(ib_obc)%u3d(ib,ik) = dta_obc(ib_obc)%u3d(ib,ik) - dta_obc(ib_obc)%u2d(ib)  
     796               ctmp1='obcread : this type of obc file is not supported :( ' 
     797               ctmp2=TRIM(cffile) 
     798               CALL ctl_stop (ctmp1, ctmp2) 
     799               ! cffile should be either annual or monthly ... 
     800            ENDIF 
     801            ! as the file is changed, need to update itobc etc ... 
     802            CALL obc_dta_chktime (iyy,imm) 
     803            ntobc_x = nrecbef() + 1 ! remember : this case occur for an after data 
     804         ENDIF 
     805      ENDIF 
     806 
     807      IF( lp_obc_east ) THEN  
     808         ! ... Read datafile and set temperature, salinity and normal velocity 
     809         ! ... initialise the sedta, tedta, uedta arrays 
     810         IF(ln_obc_clim) THEN  ! revert to old convention for climatological OBC forcing 
     811            cl_obc_eTS='obceast_TS.nc' 
     812            cl_obc_eU ='obceast_U.nc' 
     813            cl_obc_eV ='obceast_V.nc' 
     814         ELSE                  ! convention for climatological OBC 
     815            WRITE(cl_obc_eTS ,'("obc_east_TS_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     816            WRITE(cl_obc_eU  ,'("obc_east_U_y"   ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     817            WRITE(cl_obc_eV  ,'("obc_east_V_y"   ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     818         ENDIF 
     819         ! JMM this may change depending on the obc data format ... 
     820         istart(:)=(/nje0+njmpp-1,1/) ; icount(:)=(/nje1-nje0 +1,jpk/) 
     821         IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_eTS) 
     822         IF (nje1 >= nje0 ) THEN 
     823            CALL iom_open ( cl_obc_eTS , id_e ) 
     824            CALL iom_get ( id_e, jpdom_unknown, 'votemper', tedta(nje0:nje1,:,nt_x), & 
     825               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     826            CALL iom_get ( id_e, jpdom_unknown, 'vosaline', sedta(nje0:nje1,:,nt_x), & 
     827               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     828# if defined key_dynspg_ts || defined key_dynspg_exp 
     829            CALL iom_get ( id_e, jpdom_unknown, 'vossurfh', sshedta(nje0:nje1,nt_x), & 
     830               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     831# endif 
     832            CALL iom_close (id_e) 
     833            ! 
     834            CALL iom_open ( cl_obc_eU , id_e ) 
     835            CALL iom_get  ( id_e, jpdom_unknown, 'vozocrtx', uedta(nje0:nje1,:,nt_x), & 
     836               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     837            CALL iom_close ( id_e ) 
     838            ! 
     839            CALL iom_open ( cl_obc_eV , id_e ) 
     840            CALL iom_get ( id_e, jpdom_unknown, 'vomecrty', vedta(nje0:nje1,:,nt_x), & 
     841               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     842            CALL iom_close ( id_e ) 
     843 
     844            ! mask the boundary values 
     845            tedta(:,:,nt_x) = tedta(:,:,nt_x)*temsk(:,:) ;  sedta(:,:,nt_x) = sedta(:,:,nt_x)*temsk(:,:) 
     846            uedta(:,:,nt_x) = uedta(:,:,nt_x)*uemsk(:,:) ;  vedta(:,:,nt_x) = vedta(:,:,nt_x)*vemsk(:,:) 
     847 
     848            ! check any outliers  
     849            zmin=MINVAL( sedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(sedta(:,:,nt_x), mask=ltemsk) 
     850            IF (  zmin < 5 .OR. zmax > 50)   THEN 
     851               CALL ctl_stop('Error in sedta',' routine obcdta') 
     852            ENDIF 
     853            zmin=MINVAL( tedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(tedta(:,:,nt_x), mask=ltemsk) 
     854            IF (  zmin < -10. .OR. zmax > 40)   THEN 
     855               CALL ctl_stop('Error in tedta',' routine obcdta') 
     856            ENDIF 
     857            zmin=MINVAL( uedta(:,:,nt_x), mask=luemsk ) ; zmax=MAXVAL(uedta(:,:,nt_x), mask=luemsk) 
     858            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     859               CALL ctl_stop('Error in uedta',' routine obcdta') 
     860            ENDIF 
     861            zmin=MINVAL( vedta(:,:,nt_x), mask=lvemsk ) ; zmax=MAXVAL(vedta(:,:,nt_x), mask=lvemsk) 
     862            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     863               CALL ctl_stop('Error in vedta',' routine obcdta') 
     864            ENDIF 
     865 
     866            !               Usually printout is done only once at kt = nit000, unless nprint (namelist) > 1       
     867            IF ( lwp .AND.  ( kt == nit000 .OR. nprint /= 0 )  ) THEN 
     868               WRITE(numout,*) 
     869               WRITE(numout,*) ' Read East OBC data records ', ntobc_x 
     870               ikprint = jpj/20 +1 
     871               WRITE(numout,*) ' Temperature  record 1 - printout every 3 level' 
     872               CALL prihre( tedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     873               WRITE(numout,*) 
     874               WRITE(numout,*) ' Salinity  record 1 - printout every 3 level' 
     875               CALL prihre( sedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     876               WRITE(numout,*) 
     877               WRITE(numout,*) ' Normal velocity U  record 1  - printout every 3 level' 
     878               CALL prihre( uedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     879               WRITE(numout,*) 
     880               WRITE(numout,*) ' Tangential velocity V  record 1  - printout every 3 level' 
     881               CALL prihre( vedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     882            ENDIF 
     883         ENDIF 
     884      ENDIF 
     885!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     886      IF ( lp_obc_west ) THEN 
     887         ! ... Read datafile and set temperature, salinity and normal velocity 
     888         ! ... initialise the swdta, twdta, uwdta arrays 
     889         IF (ln_obc_clim) THEN   ! revert to old convention for climatological OBC forcing 
     890            cl_obc_wTS='obcwest_TS.nc' 
     891            cl_obc_wU ='obcwest_U.nc' 
     892            cl_obc_wV ='obcwest_V.nc' 
     893         ELSE                    ! convention for climatological OBC 
     894            WRITE(cl_obc_wTS ,'("obc_west_TS_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     895            WRITE(cl_obc_wU  ,'("obc_west_U_y"   ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     896            WRITE(cl_obc_wV  ,'("obc_west_V_y"   ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     897         ENDIF 
     898         istart(:)=(/njw0+njmpp-1,1/) ; icount(:)=(/njw1-njw0 +1,jpk/) 
     899         IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_wTS) 
     900 
     901         IF ( njw1 >= njw0 ) THEN 
     902            CALL iom_open ( cl_obc_wTS , id_w ) 
     903            CALL iom_get ( id_w, jpdom_unknown, 'votemper', twdta(njw0:njw1,:,nt_x), &  
     904               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     905 
     906            CALL iom_get ( id_w, jpdom_unknown, 'vosaline', swdta(njw0:njw1,:,nt_x), & 
     907               &               ktime=ntobc_x , kstart=istart, kcount= icount) 
     908# if defined key_dynspg_ts || defined key_dynspg_exp 
     909            CALL iom_get ( id_w, jpdom_unknown, 'vossurfh', sshwdta(njw0:njw1,nt_x), & 
     910               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     911# endif 
     912            CALL iom_close (id_w) 
     913            ! 
     914            CALL iom_open ( cl_obc_wU , id_w ) 
     915            CALL iom_get  ( id_w, jpdom_unknown, 'vozocrtx', uwdta(njw0:njw1,:,nt_x),& 
     916               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     917            CALL iom_close ( id_w ) 
     918            ! 
     919            CALL iom_open ( cl_obc_wV , id_w ) 
     920            CALL iom_get ( id_w, jpdom_unknown, 'vomecrty', vwdta(njw0:njw1,:,nt_x), & 
     921               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     922            CALL iom_close ( id_w ) 
     923 
     924            ! mask the boundary values 
     925            twdta(:,:,nt_x) = twdta(:,:,nt_x)*twmsk(:,:) ;  swdta(:,:,nt_x) = swdta(:,:,nt_x)*twmsk(:,:) 
     926            uwdta(:,:,nt_x) = uwdta(:,:,nt_x)*uwmsk(:,:) ;  vwdta(:,:,nt_x) = vwdta(:,:,nt_x)*vwmsk(:,:) 
     927 
     928            ! check any outliers 
     929            zmin=MINVAL( swdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(swdta(:,:,nt_x), mask=ltwmsk) 
     930            IF (  zmin < 5 .OR. zmax > 50)   THEN 
     931               CALL ctl_stop('Error in swdta',' routine obcdta') 
     932            ENDIF 
     933            zmin=MINVAL( twdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(twdta(:,:,nt_x), mask=ltwmsk) 
     934            IF (  zmin < -10. .OR. zmax > 40)   THEN 
     935               CALL ctl_stop('Error in twdta',' routine obcdta') 
     936            ENDIF 
     937            zmin=MINVAL( uwdta(:,:,nt_x), mask=luwmsk ) ; zmax=MAXVAL(uwdta(:,:,nt_x), mask=luwmsk) 
     938            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     939               CALL ctl_stop('Error in uwdta',' routine obcdta') 
     940            ENDIF 
     941            zmin=MINVAL( vwdta(:,:,nt_x), mask=lvwmsk ) ; zmax=MAXVAL(vwdta(:,:,nt_x), mask=lvwmsk) 
     942            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     943               CALL ctl_stop('Error in vwdta',' routine obcdta') 
     944            ENDIF 
     945 
     946 
     947            IF ( lwp .AND.  ( kt == nit000 .OR. nprint /= 0 )  ) THEN 
     948               WRITE(numout,*) 
     949               WRITE(numout,*) ' Read West OBC data records ', ntobc_x 
     950               ikprint = jpj/20 +1 
     951               WRITE(numout,*) ' Temperature  record 1 - printout every 3 level' 
     952               CALL prihre( twdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     953               WRITE(numout,*) 
     954               WRITE(numout,*) ' Salinity  record 1 - printout every 3 level' 
     955               CALL prihre( swdta(:,:,nt_x),jpj,jpk, 1, jpj, ikprint,   jpk, 1, -3, 1., numout ) 
     956               WRITE(numout,*) 
     957               WRITE(numout,*) ' Normal velocity U  record 1  - printout every 3 level' 
     958               CALL prihre( uwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     959               WRITE(numout,*) 
     960               WRITE(numout,*) ' Tangential velocity V  record 1  - printout every 3 level' 
     961               CALL prihre( vwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 
     962            ENDIF 
     963         END IF 
     964      ENDIF 
     965!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     966      IF( lp_obc_north) THEN 
     967         IF(ln_obc_clim) THEN   ! revert to old convention for climatological OBC forcing 
     968            cl_obc_nTS='obcnorth_TS.nc' 
     969            cl_obc_nU ='obcnorth_U.nc' 
     970            cl_obc_nV ='obcnorth_V.nc' 
     971         ELSE                   ! convention for climatological OBC 
     972            WRITE(cl_obc_nTS ,'("obc_north_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     973            WRITE(cl_obc_nV  ,'("obc_north_V_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     974            WRITE(cl_obc_nU  ,'("obc_north_U_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     975         ENDIF 
     976         istart(:)=(/nin0+nimpp-1,1/) ; icount(:)=(/nin1-nin0 +1,jpk/) 
     977         IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_nTS) 
     978         IF ( nin1 >= nin0 ) THEN 
     979            CALL iom_open ( cl_obc_nTS , id_n ) 
     980            CALL iom_get ( id_n, jpdom_unknown, 'votemper', tndta(nin0:nin1,:,nt_x), & 
     981               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     982            CALL iom_get ( id_n, jpdom_unknown, 'vosaline', sndta(nin0:nin1,:,nt_x), & 
     983               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     984# if defined key_dynspg_ts || defined key_dynspg_exp 
     985            CALL iom_get ( id_n, jpdom_unknown, 'vossurfh', sshndta(nin0:nin1,nt_x), & 
     986               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     987# endif 
     988            CALL iom_close (id_n) 
     989            ! 
     990            CALL iom_open ( cl_obc_nU , id_n ) 
     991            CALL iom_get  ( id_n, jpdom_unknown, 'vozocrtx', undta(nin0:nin1,:,nt_x), & 
     992               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     993            CALL iom_close ( id_n ) 
     994            ! 
     995            CALL iom_open ( cl_obc_nV , id_n ) 
     996            CALL iom_get  ( id_n, jpdom_unknown, 'vomecrty', vndta(nin0:nin1,:,nt_x), & 
     997               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     998            CALL iom_close ( id_n ) 
     999 
     1000            ! mask the boundary values 
     1001            tndta(:,:,nt_x) = tndta(:,:,nt_x)*tnmsk(:,:) ;  sndta(:,:,nt_x) = sndta(:,:,nt_x)*tnmsk(:,:) 
     1002            undta(:,:,nt_x) = undta(:,:,nt_x)*unmsk(:,:) ;  vndta(:,:,nt_x) = vndta(:,:,nt_x)*vnmsk(:,:) 
     1003 
     1004            ! check any outliers 
     1005            zmin=MINVAL( sndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(sndta(:,:,nt_x), mask=ltnmsk) 
     1006            IF (  zmin < 5 .OR. zmax > 50)   THEN 
     1007               CALL ctl_stop('Error in sndta',' routine obcdta') 
     1008            ENDIF 
     1009            zmin=MINVAL( tndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(tndta(:,:,nt_x), mask=ltnmsk) 
     1010            IF (  zmin < -10. .OR. zmax > 40)   THEN 
     1011               CALL ctl_stop('Error in tndta',' routine obcdta') 
     1012            ENDIF 
     1013            zmin=MINVAL( undta(:,:,nt_x), mask=lunmsk ) ; zmax=MAXVAL(undta(:,:,nt_x), mask=lunmsk) 
     1014            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     1015               CALL ctl_stop('Error in undta',' routine obcdta') 
     1016            ENDIF 
     1017            zmin=MINVAL( vndta(:,:,nt_x), mask=lvnmsk ) ; zmax=MAXVAL(vndta(:,:,nt_x), mask=lvnmsk) 
     1018            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     1019               CALL ctl_stop('Error in vndta',' routine obcdta') 
     1020            ENDIF 
     1021 
     1022            IF ( lwp .AND.  ( kt == nit000 .OR. nprint /= 0 )  ) THEN 
     1023               WRITE(numout,*) 
     1024               WRITE(numout,*) ' Read North OBC data records ', ntobc_x 
     1025               ikprint = jpi/20 +1 
     1026               WRITE(numout,*) ' Temperature  record 1 - printout every 3 level' 
     1027               CALL prihre( tndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1028               WRITE(numout,*) 
     1029               WRITE(numout,*) ' Salinity  record 1 - printout every 3 level' 
     1030               CALL prihre( sndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1031               WRITE(numout,*) 
     1032               WRITE(numout,*) ' Normal velocity V  record 1  - printout every 3 level' 
     1033               CALL prihre( vndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1034               WRITE(numout,*) 
     1035               WRITE(numout,*) ' Tangential  velocity U  record 1  - printout every 3 level' 
     1036               CALL prihre( undta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1037            ENDIF 
     1038         ENDIF 
     1039      ENDIF 
     1040!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1041      IF( lp_obc_south) THEN  
     1042         IF(ln_obc_clim) THEN   ! revert to old convention for climatological OBC forcing 
     1043            cl_obc_sTS='obcsouth_TS.nc' 
     1044            cl_obc_sU ='obcsouth_U.nc' 
     1045            cl_obc_sV ='obcsouth_V.nc' 
     1046         ELSE                    ! convention for climatological OBC 
     1047            WRITE(cl_obc_sTS ,'("obc_south_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     1048            WRITE(cl_obc_sV  ,'("obc_south_V_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     1049            WRITE(cl_obc_sU  ,'("obc_south_U_y"  ,i4.4,"m",i2.2,".nc")' ) iyy,imm 
     1050         ENDIF 
     1051         istart(:)=(/nis0+nimpp-1,1/) ; icount(:)=(/nis1-nis0 +1,jpk/) 
     1052         IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_sTS) 
     1053         IF ( nis1 >= nis0 ) THEN  
     1054            CALL iom_open ( cl_obc_sTS , id_s ) 
     1055            CALL iom_get ( id_s, jpdom_unknown, 'votemper', tsdta(nis0:nis1,:,nt_x), & 
     1056               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     1057            CALL iom_get ( id_s, jpdom_unknown, 'vosaline', ssdta(nis0:nis1,:,nt_x), & 
     1058               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     1059# if defined key_dynspg_ts || defined key_dynspg_exp 
     1060            CALL iom_get ( id_s, jpdom_unknown, 'vossurfh', sshsdta(nis0:nis1,nt_x), & 
     1061               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     1062# endif 
     1063            CALL iom_close (id_s) 
     1064            ! 
     1065            CALL iom_open ( cl_obc_sU , id_s ) 
     1066            CALL iom_get  ( id_s, jpdom_unknown, 'vozocrtx', usdta(nis0:nis1,:,nt_x), & 
     1067               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     1068            CALL iom_close ( id_s ) 
     1069            ! 
     1070            CALL iom_open ( cl_obc_sV , id_s ) 
     1071            CALL iom_get  ( id_s, jpdom_unknown, 'vomecrty', vsdta(nis0:nis1,:,nt_x), & 
     1072               &               ktime=ntobc_x , kstart=istart, kcount= icount ) 
     1073            CALL iom_close ( id_s ) 
     1074 
     1075            ! mask the boundary values 
     1076            tsdta(:,:,nt_x) = tsdta(:,:,nt_x)*tsmsk(:,:) ;  ssdta(:,:,nt_x) = ssdta(:,:,nt_x)*tsmsk(:,:) 
     1077            usdta(:,:,nt_x) = usdta(:,:,nt_x)*usmsk(:,:) ;  vsdta(:,:,nt_x) = vsdta(:,:,nt_x)*vsmsk(:,:) 
     1078 
     1079            ! check any outliers 
     1080            zmin=MINVAL( ssdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(ssdta(:,:,nt_x), mask=ltsmsk) 
     1081            IF (  zmin < 5 .OR. zmax > 50)   THEN 
     1082               CALL ctl_stop('Error in ssdta',' routine obcdta') 
     1083            ENDIF 
     1084            zmin=MINVAL( tsdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(tsdta(:,:,nt_x), mask=ltsmsk) 
     1085            IF (  zmin < -10. .OR. zmax > 40)   THEN 
     1086               CALL ctl_stop('Error in tsdta',' routine obcdta') 
     1087            ENDIF 
     1088            zmin=MINVAL( usdta(:,:,nt_x), mask=lusmsk ) ; zmax=MAXVAL(usdta(:,:,nt_x), mask=lusmsk) 
     1089            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     1090               CALL ctl_stop('Error in usdta',' routine obcdta') 
     1091            ENDIF 
     1092            zmin=MINVAL( vsdta(:,:,nt_x), mask=lvsmsk ) ; zmax=MAXVAL(vsdta(:,:,nt_x), mask=lvsmsk) 
     1093            IF (  zmin < -5. .OR. zmax > 5.)   THEN 
     1094               CALL ctl_stop('Error in vsdta',' routine obcdta') 
     1095            ENDIF 
     1096 
     1097            IF ( lwp .AND.  ( kt == nit000 .OR. nprint /= 0 )  ) THEN 
     1098               WRITE(numout,*) 
     1099               WRITE(numout,*) ' Read South OBC data records ', ntobc_x 
     1100               ikprint = jpi/20 +1 
     1101               WRITE(numout,*) ' Temperature  record 1 - printout every 3 level' 
     1102               CALL prihre( tsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1103               WRITE(numout,*) 
     1104               WRITE(numout,*) ' Salinity  record 1 - printout every 3 level' 
     1105               CALL prihre( ssdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1106               WRITE(numout,*) 
     1107               WRITE(numout,*) ' Normal velocity V  record 1  - printout every 3 level' 
     1108               CALL prihre( vsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1109               WRITE(numout,*) 
     1110               WRITE(numout,*) ' Tangential velocity U  record 1  - printout every 3 level' 
     1111               CALL prihre( usdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 
     1112            ENDIF 
     1113         ENDIF 
     1114      ENDIF 
     1115 
     1116# if defined key_dynspg_ts || defined key_dynspg_exp 
     1117      CALL obc_depth_average(nt_x)   ! computation of depth-averaged velocity 
     1118# endif 
     1119 
     1120!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     1121   END SUBROUTINE obc_read 
     1122 
     1123 
     1124   INTEGER FUNCTION nrecbef() 
     1125      !!----------------------------------------------------------------------- 
     1126      !!                     ***    FUNCTION nrecbef   *** 
     1127      !! 
     1128      !!  Purpose : - provide the before record number in files, with respect to zjcnes 
     1129      !! 
     1130      !!    History : 2008-04 : ( J.M. Molines ) Original code 
     1131      !!----------------------------------------------------------------------- 
     1132 
     1133      INTEGER :: it , idum 
     1134 
     1135      idum = itobc 
     1136      DO it =1, itobc 
     1137         IF ( ztcobc(it) > zjcnes ) THEN ;  idum = it - 1 ; EXIT ;  ENDIF 
     1138         ENDDO 
     1139         ! idum can be 0 (climato, before first record) 
     1140         IF ( idum == 0 ) THEN 
     1141            IF ( ln_obc_clim ) THEN 
     1142               idum = itobc 
     1143            ELSE 
     1144               ctmp1='obc_dta: find ntobc == 0 for  non climatological file ' 
     1145               ctmp2='consider adding a first record in your data file ' 
     1146               CALL ctl_stop(ctmp1, ctmp2) 
     1147            ENDIF 
     1148         ENDIF 
     1149         ! idum can be itobc ( zjcnes > ztcobc (itobc) ) 
     1150         !  This is not a problem ... 
     1151         nrecbef = idum 
     1152 
     1153      END FUNCTION nrecbef 
     1154 
     1155 
     1156      SUBROUTINE obc_depth_average(nt_x) 
     1157         !!----------------------------------------------------------------------- 
     1158         !!                     ***    ROUTINE obc_depth_average   *** 
     1159         !! 
     1160         !!  Purpose : - compute the depth-averaged velocity from depth-dependent OBC frames 
     1161         !! 
     1162         !!    History : 2009-01 : ( Fred Dupont ) Original code 
     1163         !!----------------------------------------------------------------------- 
     1164 
     1165         ! * Arguments 
     1166         INTEGER, INTENT( in ) :: nt_x 
     1167 
     1168         ! * Local variables 
     1169         INTEGER :: ji, jj, jk 
     1170 
     1171 
     1172         IF( lp_obc_east ) THEN 
     1173            ! initialisation to zero 
     1174            ubtedta(:,nt_x) = 0.e0 
     1175            vbtedta(:,nt_x) = 0.e0 
     1176            DO ji = nie0, nie1 
     1177               DO jj = 1, jpj 
     1178                  DO jk = 1, jpkm1 
     1179                     ubtedta(jj,nt_x) = ubtedta(jj,nt_x) + uedta(jj,jk,nt_x)*fse3u(ji,jj,jk) 
     1180                     vbtedta(jj,nt_x) = vbtedta(jj,nt_x) + vedta(jj,jk,nt_x)*fse3v(ji+1,jj,jk) 
    2601181                  END DO 
    2611182               END DO 
    262  
    263                igrd = 3                      ! meridional velocity 
    264                dta_obc(ib_obc)%v2d(:) = 0.0 
    265                DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 
    266                   ii   = idx_obc(ib_obc)%nbi(ib,igrd) 
    267                   ij   = idx_obc(ib_obc)%nbj(ib,igrd) 
    268                   DO ik = 1, jpkm1 
    269                      dta_obc(ib_obc)%v2d(ib) = dta_obc(ib_obc)%v2d(ib) & 
    270               &                                + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta_obc(ib_obc)%v3d(ib,ik) 
    271                   END DO 
    272                   dta_obc(ib_obc)%v2d(ib) =  dta_obc(ib_obc)%v2d(ib) * hvr(ii,ij) 
    273                   DO ik = 1, jpkm1 
    274                      dta_obc(ib_obc)%v3d(ib,ik) = dta_obc(ib_obc)%v3d(ib,ik) - dta_obc(ib_obc)%v2d(ib)  
     1183            END DO 
     1184         ENDIF 
     1185 
     1186         IF( lp_obc_west) THEN 
     1187            ! initialisation to zero 
     1188            ubtwdta(:,nt_x) = 0.e0 
     1189            vbtwdta(:,nt_x) = 0.e0 
     1190            DO ji = niw0, niw1 
     1191               DO jj = 1, jpj 
     1192                  DO jk = 1, jpkm1 
     1193                     ubtwdta(jj,nt_x) = ubtwdta(jj,nt_x) + uwdta(jj,jk,nt_x)*fse3u(ji,jj,jk) 
     1194                     vbtwdta(jj,nt_x) = vbtwdta(jj,nt_x) + vwdta(jj,jk,nt_x)*fse3v(ji,jj,jk) 
    2751195                  END DO 
    2761196               END DO 
    277      
    278             ENDIF 
    279  
    280          END IF ! nn_dta(ib_obc) = 1 
    281       END DO  ! ib_obc 
    282  
    283       IF(wrk_not_released(2, 22,23) )    CALL ctl_stop('obc_dta: ERROR: failed to release workspace arrays.') 
    284  
     1197            END DO 
     1198         ENDIF 
     1199 
     1200         IF( lp_obc_north) THEN 
     1201            ! initialisation to zero 
     1202            ubtndta(:,nt_x) = 0.e0 
     1203            vbtndta(:,nt_x) = 0.e0 
     1204            DO jj = njn0, njn1 
     1205               DO ji = 1, jpi 
     1206                  DO jk = 1, jpkm1 
     1207                     ubtndta(ji,nt_x) = ubtndta(ji,nt_x) + undta(ji,jk,nt_x)*fse3u(ji,jj+1,jk) 
     1208                     vbtndta(ji,nt_x) = vbtndta(ji,nt_x) + vndta(ji,jk,nt_x)*fse3v(ji,jj,jk) 
     1209                  END DO 
     1210               END DO 
     1211            END DO 
     1212         ENDIF 
     1213 
     1214         IF( lp_obc_south) THEN 
     1215            ! initialisation to zero 
     1216            ubtsdta(:,nt_x) = 0.e0 
     1217            vbtsdta(:,nt_x) = 0.e0 
     1218            DO jj = njs0, njs1 
     1219               DO ji = nis0, nis1 
     1220                  DO jk = 1, jpkm1 
     1221                     ubtsdta(ji,nt_x) = ubtsdta(ji,nt_x) + usdta(ji,jk,nt_x)*fse3u(ji,jj,jk) 
     1222                     vbtsdta(ji,nt_x) = vbtsdta(ji,nt_x) + vsdta(ji,jk,nt_x)*fse3v(ji,jj,jk) 
     1223                  END DO 
     1224               END DO 
     1225            END DO 
     1226         ENDIF 
     1227 
     1228      END SUBROUTINE obc_depth_average 
     1229 
     1230#else 
     1231      !!------------------------------------------------------------------------------ 
     1232      !!   default option:           Dummy module          NO Open Boundary Conditions 
     1233      !!------------------------------------------------------------------------------ 
     1234   CONTAINS 
     1235      SUBROUTINE obc_dta( kt )             ! Dummy routine 
     1236         INTEGER, INTENT (in) :: kt 
     1237         WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt 
    2851238      END SUBROUTINE obc_dta 
    286  
    287  
    288       SUBROUTINE obc_dta_init 
    289       !!---------------------------------------------------------------------- 
    290       !!                   ***  SUBROUTINE obc_dta_init  *** 
    291       !!                     
    292       !! ** Purpose :   Initialise arrays for reading of external data  
    293       !!                for open boundary conditions 
    294       !! 
    295       !! ** Method  :   Use fldread.F90 
    296       !!                 
    297       !!---------------------------------------------------------------------- 
    298       USE dynspg_oce, ONLY: lk_dynspg_ts 
    299       !! 
    300       INTEGER     ::  ib_obc, jfld, jstart, jend, ierror  ! local indices 
    301       !! 
    302       CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    303       CHARACTER(len=100), DIMENSION(nb_obc)  ::   cn_dir_array  ! Root directory for location of data files 
    304       LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    305                                                                 ! =F => baroclinic velocities in 3D boundary data 
    306       INTEGER                                ::   ilen_global   ! Max length required for global obc dta arrays 
    307       INTEGER,              DIMENSION(jpbgrd) ::  ilen0         ! size of local arrays 
    308       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ilen1, ilen3  ! size of 1st and 3rd dimensions of local arrays 
    309       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iobc           ! obc set for a particular jfld 
    310       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   igrid         ! index for grid type (1,2,3 = T,U,V) 
    311       INTEGER, POINTER, DIMENSION(:)         ::   nblen, nblenrim  ! short cuts 
    312       TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   blf_i         !  array of namelist information structures 
    313       TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   !  
    314       TYPE(FLD_N) ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
    315 #if defined key_lim2 
    316       TYPE(FLD_N) ::   bn_frld, bn_hicif, bn_hsnif      ! 
    3171239#endif 
    318       NAMELIST/namobc_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    319 #if defined key_lim2 
    320       NAMELIST/namobc_dta/ bn_frld, bn_hicif, bn_hsnif 
    321 #endif 
    322       NAMELIST/namobc_dta/ ln_full_vel 
    323       !!--------------------------------------------------------------------------- 
    324  
    325       ! Set nn_dta 
    326       DO ib_obc = 1, nb_obc 
    327          nn_dta(ib_obc) = MAX(  nn_dyn2d_dta(ib_obc)       & 
    328                                ,nn_dyn3d_dta(ib_obc)       & 
    329                                ,nn_tra_dta(ib_obc)         & 
    330 #if defined key_ice_lim2 
    331                                ,nn_ice_lim2_dta(ib_obc)    & 
    332 #endif 
    333                               ) 
    334          IF(nn_dta(ib_obc) .gt. 1) nn_dta(ib_obc) = 1 
    335       END DO 
    336  
    337       ! Work out upper bound of how many fields there are to read in and allocate arrays 
    338       ! --------------------------------------------------------------------------- 
    339       ALLOCATE( nb_obc_fld(nb_obc) ) 
    340       nb_obc_fld(:) = 0 
    341       DO ib_obc = 1, nb_obc          
    342          IF( nn_dyn2d(ib_obc) .gt. 0 .and. ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) THEN 
    343             nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3 
    344          ENDIF 
    345          IF( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ) THEN 
    346             nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2 
    347          ENDIF 
    348          IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 1  ) THEN 
    349             nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2 
    350          ENDIF 
    351 #if defined key_lim2 
    352          IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 1  ) THEN 
    353             nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3 
    354          ENDIF 
    355 #endif                
    356       ENDDO             
    357  
    358       nb_obc_fld_sum = SUM( nb_obc_fld ) 
    359  
    360       ALLOCATE( bf(nb_obc_fld_sum), STAT=ierror ) 
    361       IF( ierror > 0 ) THEN    
    362          CALL ctl_stop( 'obc_dta: unable to allocate bf structure' )   ;   RETURN   
    363       ENDIF 
    364       ALLOCATE( blf_i(nb_obc_fld_sum), STAT=ierror ) 
    365       IF( ierror > 0 ) THEN    
    366          CALL ctl_stop( 'obc_dta: unable to allocate blf_i structure' )   ;   RETURN   
    367       ENDIF 
    368       ALLOCATE( nbmap_ptr(nb_obc_fld_sum), STAT=ierror ) 
    369       IF( ierror > 0 ) THEN    
    370          CALL ctl_stop( 'obc_dta: unable to allocate nbmap_ptr structure' )   ;   RETURN   
    371       ENDIF 
    372       ALLOCATE( ilen1(nb_obc_fld_sum), ilen3(nb_obc_fld_sum) )  
    373       ALLOCATE( iobc(nb_obc_fld_sum) )  
    374       ALLOCATE( igrid(nb_obc_fld_sum) )  
    375  
    376       ! Read namelists 
    377       ! -------------- 
    378       REWIND(numnam) 
    379       jfld = 0  
    380       DO ib_obc = 1, nb_obc          
    381          IF( nn_dta(ib_obc) .eq. 1 ) THEN 
    382             ! set file information 
    383             cn_dir = './'        ! directory in which the model is executed 
    384             ln_full_vel = .false. 
    385             ! ... default values (NB: frequency positive => hours, negative => months) 
    386             !                    !  file       ! frequency !  variable        ! time intep !  clim   ! 'yearly' or ! weights  ! rotation  ! 
    387             !                    !  name       !  (hours)  !   name           !   (T/F)    !  (T/F)  !  'monthly'  ! filename ! pairs     ! 
    388             bn_ssh     = FLD_N(  'obc_ssh'     ,    24     ,  'sossheig'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    389             bn_u2d     = FLD_N(  'obc_vel2d_u' ,    24     ,  'vobtcrtx'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    390             bn_v2d     = FLD_N(  'obc_vel2d_v' ,    24     ,  'vobtcrty'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    391             bn_u3d     = FLD_N(  'obc_vel3d_u' ,    24     ,  'vozocrtx'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    392             bn_v3d     = FLD_N(  'obc_vel3d_v' ,    24     ,  'vomecrty'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    393             bn_tem     = FLD_N(  'obc_tem'     ,    24     ,  'votemper'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    394             bn_sal     = FLD_N(  'obc_sal'     ,    24     ,  'vosaline'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    395 #if defined key_lim2 
    396             bn_frld    = FLD_N(  'obc_frld'    ,    24     ,  'ildsconc'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    397             bn_hicif   = FLD_N(  'obc_hicif'   ,    24     ,  'iicethic'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    398             bn_hsnif   = FLD_N(  'obc_hsnif'   ,    24     ,  'isnothic'    ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    399 #endif 
    400  
    401             ! Important NOT to rewind here. 
    402             READ( numnam, namobc_dta ) 
    403  
    404             cn_dir_array(ib_obc) = cn_dir 
    405             ln_full_vel_array(ib_obc) = ln_full_vel 
    406  
    407             IF( ln_full_vel_array(ib_obc) .and. lk_dynspg_ts )  THEN 
    408                CALL ctl_stop( 'obc_dta_init: ERROR, cannot specify full velocities in boundary data',& 
    409             &                  'with dynspg_ts option' )   ;   RETURN   
    410             ENDIF              
    411  
    412             nblen => idx_obc(ib_obc)%nblen 
    413             nblenrim => idx_obc(ib_obc)%nblenrim 
    414  
    415             ! Only read in necessary fields for this set. 
    416             ! Important that barotropic variables come first. 
    417             IF( nn_dyn2d(ib_obc) .gt. 0 .and. ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) THEN  
    418  
    419                IF( nn_dyn2d(ib_obc) .ne. jp_frs ) THEN 
    420                   jfld = jfld + 1 
    421                   blf_i(jfld) = bn_ssh 
    422                   iobc(jfld) = ib_obc 
    423                   igrid(jfld) = 1 
    424                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    425                   ilen3(jfld) = 1 
    426                ENDIF 
    427  
    428                IF( .not. ln_full_vel_array(ib_obc) ) THEN 
    429  
    430                   jfld = jfld + 1 
    431                   blf_i(jfld) = bn_u2d 
    432                   iobc(jfld) = ib_obc 
    433                   igrid(jfld) = 2 
    434                   IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 
    435                      ilen1(jfld) = nblen(igrid(jfld)) 
    436                   ELSE 
    437                      ilen1(jfld) = nblenrim(igrid(jfld)) 
    438                   ENDIF 
    439                   ilen3(jfld) = 1 
    440  
    441                   jfld = jfld + 1 
    442                   blf_i(jfld) = bn_v2d 
    443                   iobc(jfld) = ib_obc 
    444                   igrid(jfld) = 3 
    445                   IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 
    446                      ilen1(jfld) = nblen(igrid(jfld)) 
    447                   ELSE 
    448                      ilen1(jfld) = nblenrim(igrid(jfld)) 
    449                   ENDIF 
    450                   ilen3(jfld) = 1 
    451  
    452                ENDIF 
    453  
    454             ENDIF 
    455  
    456             ! baroclinic velocities 
    457             IF( ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ) .or. & 
    458            &      ( ln_full_vel_array(ib_obc) .and. nn_dyn2d(ib_obc) .gt. 0 .and.  & 
    459            &        ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) ) THEN 
    460  
    461                jfld = jfld + 1 
    462                blf_i(jfld) = bn_u3d 
    463                iobc(jfld) = ib_obc 
    464                igrid(jfld) = 2 
    465                IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 
    466                   ilen1(jfld) = nblen(igrid(jfld)) 
    467                ELSE 
    468                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    469                ENDIF 
    470                ilen3(jfld) = jpk 
    471  
    472                jfld = jfld + 1 
    473                blf_i(jfld) = bn_v3d 
    474                iobc(jfld) = ib_obc 
    475                igrid(jfld) = 3 
    476                IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 
    477                   ilen1(jfld) = nblen(igrid(jfld)) 
    478                ELSE 
    479                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    480                ENDIF 
    481                ilen3(jfld) = jpk 
    482  
    483             ENDIF 
    484  
    485             ! temperature and salinity 
    486             IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 1 ) THEN 
    487  
    488                jfld = jfld + 1 
    489                blf_i(jfld) = bn_tem 
    490                iobc(jfld) = ib_obc 
    491                igrid(jfld) = 1 
    492                IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 
    493                   ilen1(jfld) = nblen(igrid(jfld)) 
    494                ELSE 
    495                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    496                ENDIF 
    497                ilen3(jfld) = jpk 
    498  
    499                jfld = jfld + 1 
    500                blf_i(jfld) = bn_sal 
    501                iobc(jfld) = ib_obc 
    502                igrid(jfld) = 1 
    503                IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 
    504                   ilen1(jfld) = nblen(igrid(jfld)) 
    505                ELSE 
    506                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    507                ENDIF 
    508                ilen3(jfld) = jpk 
    509  
    510             ENDIF 
    511  
    512 #if defined key_lim2 
    513             ! sea ice 
    514             IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 1 ) THEN 
    515  
    516                jfld = jfld + 1 
    517                blf_i(jfld) = bn_frld 
    518                iobc(jfld) = ib_obc 
    519                igrid(jfld) = 1 
    520                IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 
    521                   ilen1(jfld) = nblen(igrid(jfld)) 
    522                ELSE 
    523                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    524                ENDIF 
    525                ilen3(jfld) = 1 
    526  
    527                jfld = jfld + 1 
    528                blf_i(jfld) = bn_hicif 
    529                iobc(jfld) = ib_obc 
    530                igrid(jfld) = 1 
    531                IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 
    532                   ilen1(jfld) = nblen(igrid(jfld)) 
    533                ELSE 
    534                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    535                ENDIF 
    536                ilen3(jfld) = 1 
    537  
    538                jfld = jfld + 1 
    539                blf_i(jfld) = bn_hsnif 
    540                iobc(jfld) = ib_obc 
    541                igrid(jfld) = 1 
    542                IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 
    543                   ilen1(jfld) = nblen(igrid(jfld)) 
    544                ELSE 
    545                   ilen1(jfld) = nblenrim(igrid(jfld)) 
    546                ENDIF 
    547                ilen3(jfld) = 1 
    548  
    549             ENDIF 
    550 #endif 
    551             ! Recalculate field counts 
    552             !------------------------- 
    553             nb_obc_fld_sum = 0 
    554             IF( ib_obc .eq. 1 ) THEN  
    555                nb_obc_fld(ib_obc) = jfld 
    556                nb_obc_fld_sum     = jfld               
    557             ELSE 
    558                nb_obc_fld(ib_obc) = jfld - nb_obc_fld_sum 
    559                nb_obc_fld_sum = nb_obc_fld_sum + nb_obc_fld(ib_obc) 
    560             ENDIF 
    561  
    562          ENDIF ! nn_dta .eq. 1 
    563       ENDDO ! ib_obc 
    564  
    565  
    566       DO jfld = 1, nb_obc_fld_sum 
    567          ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 
    568          IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 
    569          nbmap_ptr(jfld)%ptr => idx_obc(iobc(jfld))%nbmap(:,igrid(jfld)) 
    570       ENDDO 
    571  
    572       ! fill bf with blf_i and control print 
    573       !------------------------------------- 
    574       jstart = 1 
    575       DO ib_obc = 1, nb_obc 
    576          jend = jstart + nb_obc_fld(ib_obc) - 1 
    577          CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(ib_obc), 'obc_dta', 'open boundary conditions', 'namobc_dta' ) 
    578          jstart = jend + 1 
    579       ENDDO 
    580  
    581       ! Initialise local boundary data arrays 
    582       ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later 
    583       ! nn_xxx_dta=1 : point to "fnow" arrays 
    584       !------------------------------------- 
    585  
    586       jfld = 0 
    587       DO ib_obc=1, nb_obc 
    588  
    589          nblen => idx_obc(ib_obc)%nblen 
    590          nblenrim => idx_obc(ib_obc)%nblenrim 
    591  
    592          IF (nn_dyn2d(ib_obc) .gt. 0) THEN 
    593             IF( nn_dyn2d_dta(ib_obc) .eq. 0 .or. nn_dyn2d_dta(ib_obc) .eq. 2 .or. ln_full_vel_array(ib_obc) ) THEN 
    594                IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 
    595                   ilen0(1:3) = nblen(1:3) 
    596                ELSE 
    597                   ilen0(1:3) = nblenrim(1:3) 
    598                ENDIF 
    599                ALLOCATE( dta_obc(ib_obc)%ssh(ilen0(1)) ) 
    600                ALLOCATE( dta_obc(ib_obc)%u2d(ilen0(2)) ) 
    601                ALLOCATE( dta_obc(ib_obc)%v2d(ilen0(3)) ) 
    602             ELSE 
    603                IF( nn_dyn2d(ib_obc) .ne. jp_frs ) THEN 
    604                   jfld = jfld + 1 
    605                   dta_obc(ib_obc)%ssh => bf(jfld)%fnow(:,1,1) 
    606                ENDIF 
    607                jfld = jfld + 1 
    608                dta_obc(ib_obc)%u2d => bf(jfld)%fnow(:,1,1) 
    609                jfld = jfld + 1 
    610                dta_obc(ib_obc)%v2d => bf(jfld)%fnow(:,1,1) 
    611             ENDIF 
    612          ENDIF 
    613  
    614          IF ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 0 ) THEN 
    615             IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 
    616                ilen0(1:3) = nblen(1:3) 
    617             ELSE 
    618                ilen0(1:3) = nblenrim(1:3) 
    619             ENDIF 
    620             ALLOCATE( dta_obc(ib_obc)%u3d(ilen0(2),jpk) ) 
    621             ALLOCATE( dta_obc(ib_obc)%v3d(ilen0(3),jpk) ) 
    622          ENDIF 
    623          IF ( ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ).or. & 
    624            &  ( ln_full_vel_array(ib_obc) .and. nn_dyn2d(ib_obc) .gt. 0 .and.   & 
    625            &    ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) ) THEN 
    626             jfld = jfld + 1 
    627             dta_obc(ib_obc)%u3d => bf(jfld)%fnow(:,1,:) 
    628             jfld = jfld + 1 
    629             dta_obc(ib_obc)%v3d => bf(jfld)%fnow(:,1,:) 
    630          ENDIF 
    631  
    632          IF (nn_tra(ib_obc) .gt. 0) THEN 
    633             IF( nn_tra_dta(ib_obc) .eq. 0 ) THEN 
    634                IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 
    635                   ilen0(1:3) = nblen(1:3) 
    636                ELSE 
    637                   ilen0(1:3) = nblenrim(1:3) 
    638                ENDIF 
    639                ALLOCATE( dta_obc(ib_obc)%tem(ilen0(1),jpk) ) 
    640                ALLOCATE( dta_obc(ib_obc)%sal(ilen0(1),jpk) ) 
    641             ELSE 
    642                jfld = jfld + 1 
    643                dta_obc(ib_obc)%tem => bf(jfld)%fnow(:,1,:) 
    644                jfld = jfld + 1 
    645                dta_obc(ib_obc)%sal => bf(jfld)%fnow(:,1,:) 
    646             ENDIF 
    647          ENDIF 
    648  
    649 #if defined key_lim2 
    650          IF (nn_ice_lim2(ib_obc) .gt. 0) THEN 
    651             IF( nn_ice_lim2_dta(ib_obc) .eq. 0 ) THEN 
    652                IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 
    653                   ilen0(1:3) = nblen(1:3) 
    654                ELSE 
    655                   ilen0(1:3) = nblenrim(1:3) 
    656                ENDIF 
    657                ALLOCATE( dta_obc(ib_obc)%frld(ilen0(1)) ) 
    658                ALLOCATE( dta_obc(ib_obc)%hicif(ilen0(1)) ) 
    659                ALLOCATE( dta_obc(ib_obc)%hsnif(ilen0(1)) ) 
    660             ELSE 
    661                jfld = jfld + 1 
    662                dta_obc(ib_obc)%frld  => bf(jfld)%fnow(:,1,1) 
    663                jfld = jfld + 1 
    664                dta_obc(ib_obc)%hicif => bf(jfld)%fnow(:,1,1) 
    665                jfld = jfld + 1 
    666                dta_obc(ib_obc)%hsnif => bf(jfld)%fnow(:,1,1) 
    667             ENDIF 
    668          ENDIF 
    669 #endif 
    670  
    671       ENDDO ! ib_obc  
    672  
    673       END SUBROUTINE obc_dta_init 
    674  
    675 #else 
    676    !!---------------------------------------------------------------------- 
    677    !!   Dummy module                   NO Open Boundary Conditions 
    678    !!---------------------------------------------------------------------- 
    679 CONTAINS 
    680    SUBROUTINE obc_dta( kt, jit )              ! Empty routine 
    681       INTEGER, INTENT( in )           ::   kt     
    682       INTEGER, INTENT( in ), OPTIONAL ::   jit    
    683       WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt 
    684    END SUBROUTINE obc_dta 
    685    SUBROUTINE obc_dta_init()                  ! Empty routine 
    686       WRITE(*,*) 'obc_dta_init: You should not have seen this print! error?' 
    687    END SUBROUTINE obc_dta_init 
    688 #endif 
    689  
    6901240   !!============================================================================== 
    691 END MODULE obcdta 
     1241   END MODULE obcdta 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn.F90

    r2865 r2888  
    11MODULE obcdyn 
    2    !!====================================================================== 
     2#if defined key_obc 
     3   !!================================================================================= 
    34   !!                       ***  MODULE  obcdyn  *** 
    4    !! Unstructured Open Boundary Cond. :   Flow relaxation scheme on velocities 
    5    !!====================================================================== 
    6    !! History :  1.0  !  2005-02  (J. Chanut, A. Sellar)  Original code 
    7    !!             -   !  2007-07  (D. Storkey) Move Flather implementation to separate routine. 
    8    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    9    !!            3.2  !  2008-04  (R. Benshila) consider velocity instead of transport  
    10    !!            3.3  !  2010-09  (E.O'Dea) modifications for Shelf configurations  
    11    !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions 
    12    !!---------------------------------------------------------------------- 
    13 #if defined key_obc  
    14    !!---------------------------------------------------------------------- 
    15    !!   'key_obc' :                    Unstructured Open Boundary Condition 
    16    !!---------------------------------------------------------------------- 
    17    !!   obc_dyn3d        : apply open boundary conditions to baroclinic velocities 
    18    !!   obc_dyn3d_frs    : apply Flow Relaxation Scheme 
    19    !!---------------------------------------------------------------------- 
     5   !! Ocean dynamics:   Radiation of velocities on each open boundary 
     6   !!================================================================================= 
     7 
     8   !!--------------------------------------------------------------------------------- 
     9   !!   obc_dyn        : call the subroutine for each open boundary 
     10   !!   obc_dyn_east   : radiation of the east open boundary velocities 
     11   !!   obc_dyn_west   : radiation of the west open boundary velocities 
     12   !!   obc_dyn_north  : radiation of the north open boundary velocities 
     13   !!   obc_dyn_south  : radiation of the south open boundary velocities 
     14   !!---------------------------------------------------------------------------------- 
     15 
     16   !!---------------------------------------------------------------------------------- 
     17   !! * Modules used 
    2018   USE oce             ! ocean dynamics and tracers  
    2119   USE dom_oce         ! ocean space and time domain 
    22    USE dynspg_oce       
     20   USE phycst          ! physical constants 
    2321   USE obc_oce         ! ocean open boundary conditions 
    24    USE obcdyn2d        ! open boundary conditions for barotropic solution 
    25    USE obcdyn3d        ! open boundary conditions for baroclinic velocities 
    26    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    27    USE in_out_manager  ! 
     22   USE lbclnk          ! ??? 
     23   USE lib_mpp         ! ??? 
     24   USE in_out_manager  ! I/O manager 
     25   USE dynspg_oce 
    2826 
    2927   IMPLICIT NONE 
    3028   PRIVATE 
    3129 
    32    PUBLIC   obc_dyn     ! routine called in dynspg_flt (if lk_dynspg_flt) or  
    33                         ! dyn_nxt (if lk_dynspg_ts or lk_dynspg_exp) 
    34  
    35 #  include "domzgr_substitute.h90" 
    36    !!---------------------------------------------------------------------- 
    37    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    38    !! $Id: obcdyn.F90 2528 2010-12-27 17:33:53Z rblod $  
    39    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    40    !!---------------------------------------------------------------------- 
     30   !! * Accessibility 
     31   PUBLIC obc_dyn     ! routine called in dynspg_flt (free surface case) 
     32 
     33   !! * Module variables 
     34   INTEGER ::   ji, jj, jk     ! dummy loop indices 
     35 
     36   INTEGER ::      & ! ... boundary space indices  
     37      nib   = 1,   & ! nib   = boundary point 
     38      nibm  = 2,   & ! nibm  = 1st interior point 
     39      nibm2 = 3,   & ! nibm2 = 2nd interior point 
     40                     ! ... boundary time indices  
     41      nit   = 1,   & ! nit    = now 
     42      nitm  = 2,   & ! nitm   = before 
     43      nitm2 = 3      ! nitm2  = before-before 
     44 
     45   REAL(wp) ::   rtaue  , rtauw  , rtaun  , rtaus  ,  & 
     46                 rtauein, rtauwin, rtaunin, rtausin 
     47 
     48   !!--------------------------------------------------------------------------------- 
     49 
    4150CONTAINS 
    4251 
    43    SUBROUTINE obc_dyn( kt, dyn3d_only ) 
     52   SUBROUTINE obc_dyn ( kt ) 
     53      !!------------------------------------------------------------------------------ 
     54      !!                      SUBROUTINE obc_dyn 
     55      !!                     ******************** 
     56      !! ** Purpose : 
     57      !!      Compute  dynamics (u,v) at the open boundaries. 
     58      !!      if defined key_dynspg_flt:  
     59      !!                 this routine is called by dynspg_flt and updates 
     60      !!                 ua, va which are the actual velocities (not trends) 
     61      !! 
     62      !!      The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north,  
     63      !!      and/or lp_obc_south allow the user to determine which boundary is an 
     64      !!      open one (must be done in the param_obc.h90 file). 
     65      !! 
     66      !! ** Reference :  
     67      !!      Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 
     68      !! 
     69      !! History : 
     70      !!        !  95-03 (J.-M. Molines) Original, SPEM 
     71      !!        !  97-07 (G. Madec, J.-M. Molines) addition 
     72      !!   8.5  !  02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     73      !!   9.0  !  05-11  (V. Garnier) Surface pressure gradient organization 
    4474      !!---------------------------------------------------------------------- 
    45       !!                  ***  SUBROUTINE obc_dyn  *** 
     75      !! * Arguments 
     76      INTEGER, INTENT( in ) ::   kt 
     77 
     78      !!---------------------------------------------------------------------- 
     79      !!  OPA 9.0 , LOCEAN-IPSL (2005)  
     80      !! $Id: obcdyn.F90 1528 2009-07-23 14:38:47Z rblod $  
     81      !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 
     82      !!---------------------------------------------------------------------- 
     83 
     84      ! 0. Local constant initialization 
     85      ! -------------------------------- 
     86 
     87      IF( kt == nit000 .OR. ln_rstart) THEN 
     88         ! ... Boundary restoring coefficient 
     89         rtaue = 2. * rdt / rdpeob 
     90         rtauw = 2. * rdt / rdpwob 
     91         rtaun = 2. * rdt / rdpnob 
     92         rtaus = 2. * rdt / rdpsob 
     93         ! ... Boundary restoring coefficient for inflow ( all boundaries) 
     94         rtauein = 2. * rdt / rdpein  
     95         rtauwin = 2. * rdt / rdpwin 
     96         rtaunin = 2. * rdt / rdpnin 
     97         rtausin = 2. * rdt / rdpsin  
     98      END IF 
     99 
     100      IF( lp_obc_east  )   CALL obc_dyn_east ( kt ) 
     101      IF( lp_obc_west  )   CALL obc_dyn_west ( kt ) 
     102      IF( lp_obc_north )   CALL obc_dyn_north( kt ) 
     103      IF( lp_obc_south )   CALL obc_dyn_south( kt ) 
     104 
     105      IF( lk_mpp ) THEN 
     106         IF( kt >= nit000+3 .AND. ln_rstart ) THEN 
     107            CALL lbc_lnk( ub, 'U', -1. ) 
     108            CALL lbc_lnk( vb, 'V', -1. ) 
     109         END IF 
     110         CALL lbc_lnk( ua, 'U', -1. ) 
     111         CALL lbc_lnk( va, 'V', -1. ) 
     112      ENDIF 
     113 
     114   END SUBROUTINE obc_dyn 
     115 
     116 
     117   SUBROUTINE obc_dyn_east ( kt ) 
     118      !!------------------------------------------------------------------------------ 
     119      !!                  ***  SUBROUTINE obc_dyn_east  *** 
     120      !!               
     121      !! ** Purpose : 
     122      !!      Apply the radiation algorithm on east OBC velocities ua, va using the  
     123      !!      phase velocities calculated in obc_rad_east subroutine in obcrad.F90 module 
     124      !!      If the logical lfbceast is .TRUE., there is no radiation but only fixed OBC 
    46125      !! 
    47       !! ** Purpose : - Wrapper routine for obc_dyn2d and obc_dyn3d. 
     126      !!  History : 
     127      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     128      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     129      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     130      !!         ! 00-06 (J.-M. Molines)  
     131      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     132      !!    9.0  ! 05-11  (V. Garnier) Surface pressure gradient organization 
     133      !!------------------------------------------------------------------------------ 
     134      !! * Arguments 
     135      INTEGER, INTENT( in ) ::   kt 
     136 
     137      !! * Local declaration 
     138      REAL(wp) ::   z05cx, ztau, zin 
     139      !!------------------------------------------------------------------------------ 
     140 
     141      ! 1. First three time steps and more if lfbceast is .TRUE. 
     142      !    In that case open boundary conditions are FIXED. 
     143      ! -------------------------------------------------------- 
     144 
     145      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast .OR. lk_dynspg_exp ) THEN 
     146 
     147         ! 1.1 U zonal velocity     
     148         ! -------------------- 
     149         DO ji = nie0, nie1 
     150            DO jk = 1, jpkm1 
     151               DO jj = 1, jpj 
     152                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uemsk(jj,jk)) + & 
     153                                 uemsk(jj,jk)*ufoe(jj,jk) 
     154               END DO 
     155            END DO 
     156         END DO 
     157 
     158         ! 1.2 V meridional velocity 
     159         ! ------------------------- 
     160         DO ji = nie0+1, nie1+1 
     161            DO jk = 1, jpkm1 
     162               DO jj = 1, jpj 
     163                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vemsk(jj,jk)) + & 
     164                                 vfoe(jj,jk)*vemsk(jj,jk) 
     165               END DO 
     166            END DO 
     167         END DO 
     168 
     169      ELSE 
     170 
     171      ! 2. Beyond the fourth time step if lfbceast is .FALSE. 
     172      ! ----------------------------------------------------- 
     173  
     174         ! 2.1. u-component of the velocity 
     175         ! --------------------------------- 
     176         ! 
     177         !          nibm2      nibm      nib 
     178         !            |   nibm  |   nib   |/// 
     179         !            |    |    |    |    |/// 
     180         !  jj-line --f----v----f----v----f--- 
     181         !            |    |    |    |    |/// 
     182         !            |         |         |/// 
     183         !  jj-line   u    T    u    T    u/// 
     184         !            |         |         |/// 
     185         !            |    |    |    |    |/// 
     186         !          jpieob-2   jpieob-1   jpieob 
     187         !                 |         |         
     188         !              jpieob-1    jpieob     
     189         !   
     190         ! ... If free surface formulation: 
     191         ! ... radiative conditions on the total part + relaxation toward climatology 
     192         ! ... (jpjedp1, jpjefm1),jpieob 
     193         DO ji = nie0, nie1 
     194            DO jk = 1, jpkm1 
     195               DO jj = 1, jpj 
     196                  z05cx = u_cxebnd(jj,jk) 
     197                  z05cx = z05cx / e1t(ji,jj) 
     198                  z05cx = min( z05cx, 1. ) 
     199         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     200         !           > 0, outflow zin=1, ztau=rtaue 
     201                  zin = sign( 1., z05cx ) 
     202                  zin = 0.5*( zin + abs(zin) ) 
     203         ! ... for inflow rtauein is used for relaxation coefficient else rtaue 
     204                  ztau = (1.-zin ) * rtauein  + zin * rtaue 
     205                  z05cx = z05cx * zin 
     206         ! ... update ua with radiative or climatological velocity 
     207                  ua(ji,jj,jk) = ua(ji,jj,jk) * ( 1. - uemsk(jj,jk) ) +          & 
     208                                 uemsk(jj,jk) * (  ( 1. - z05cx - ztau )         & 
     209                                 * uebnd(jj,jk,nib ,nitm) + 2.*z05cx               & 
     210                                 * uebnd(jj,jk,nibm,nit ) + ztau * ufoe (jj,jk) )  & 
     211                                 / (1. + z05cx) 
     212               END DO 
     213            END DO 
     214         END DO 
     215 
     216         ! 2.2 v-component of the velocity 
     217         ! ------------------------------- 
     218         ! 
     219         !          nibm2       nibm     nib 
     220         !            |   nibm  |   nib///|/// 
     221         !            |    |    |    |////|/// 
     222         !  jj-line --v----f----v----f----v--- 
     223         !            |    |    |    |////|/// 
     224         !            |    |    |    |////|/// 
     225         !            | jpieob-1 |  jpieob /|/// 
     226         !            |         |         |    
     227         !         jpieob-1    jpieob     jpieob+1 
     228         ! 
     229         ! ... radiative condition 
     230         ! ... (jpjedp1, jpjefm1), jpieob+1 
     231         DO ji = nie0+1, nie1+1 
     232            DO jk = 1, jpkm1 
     233               DO jj = 1, jpj 
     234                  z05cx = v_cxebnd(jj,jk)  
     235                  z05cx = z05cx / e1f(ji-1,jj) 
     236                  z05cx = min( z05cx, 1. ) 
     237         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     238         !           > 0, outflow zin=1, ztau=rtaue 
     239                  zin = sign( 1., z05cx ) 
     240                  zin = 0.5*( zin + abs(zin) ) 
     241         ! ... for inflow rtauein is used for relaxation coefficient else rtaue 
     242                  ztau = (1.-zin ) * rtauein  + zin * rtaue 
     243                  z05cx = z05cx * zin 
     244         ! ... update va with radiative or climatological velocity 
     245                  va(ji,jj,jk) = va(ji,jj,jk) * (1. - vemsk(jj,jk) ) +          & 
     246                                 vemsk(jj,jk) * ( ( 1. - z05cx - ztau )         & 
     247                                 * vebnd(jj,jk,nib ,nitm) + 2.*z05cx              & 
     248                                 * vebnd(jj,jk,nibm,nit ) + ztau * vfoe(jj,jk) )  & 
     249                                 / (1. + z05cx) 
     250               END DO 
     251            END DO 
     252         END DO 
     253 
     254      END IF 
     255 
     256   END SUBROUTINE obc_dyn_east 
     257 
     258 
     259   SUBROUTINE obc_dyn_west ( kt ) 
     260      !!------------------------------------------------------------------------------ 
     261      !!                  ***  SUBROUTINE obc_dyn_west  *** 
     262      !!                   
     263      !! ** Purpose : 
     264      !!      Apply the radiation algorithm on west OBC velocities ua, va using the  
     265      !!      phase velocities calculated in obc_rad_west subroutine in obcrad.F90 module 
     266      !!      If the logical lfbcwest is .TRUE., there is no radiation but only fixed OBC 
    48267      !! 
    49       !!---------------------------------------------------------------------- 
    50       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    51       USE wrk_nemo, ONLY: wrk_2d_7, wrk_2d_8      ! 2D workspace 
     268      !!  History : 
     269      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     270      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     271      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     272      !!         ! 00-06 (J.-M. Molines)  
     273      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     274      !!    9.0  ! 05-11  (V. Garnier) Surface pressure gradient organization 
     275      !!------------------------------------------------------------------------------ 
     276      !! * Arguments 
     277      INTEGER, INTENT( in ) ::   kt 
     278 
     279      !! * Local declaration 
     280      REAL(wp) ::   z05cx, ztau, zin 
     281      !!------------------------------------------------------------------------------ 
     282 
     283      ! 1. First three time steps and more if lfbcwest is .TRUE. 
     284      !    In that case open boundary conditions are FIXED. 
     285      ! -------------------------------------------------------- 
     286 
     287      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest .OR. lk_dynspg_exp ) THEN 
     288 
     289         ! 1.1 U zonal velocity 
     290         ! --------------------- 
     291         DO ji = niw0, niw1 
     292            DO jk = 1, jpkm1 
     293               DO jj = 1, jpj 
     294                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uwmsk(jj,jk)) + & 
     295                                 uwmsk(jj,jk)*ufow(jj,jk) 
     296               END DO 
     297            END DO 
     298         END DO 
     299 
     300         ! 1.2 V meridional velocity 
     301         ! ------------------------- 
     302         DO ji = niw0, niw1 
     303            DO jk = 1, jpkm1 
     304               DO jj = 1, jpj 
     305                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vwmsk(jj,jk)) + & 
     306                                 vfow(jj,jk)*vwmsk(jj,jk) 
     307               END DO 
     308            END DO 
     309         END DO 
     310 
     311      ELSE 
     312 
     313      ! 2. Beyond the fourth time step if lfbcwest is .FALSE. 
     314      ! ----------------------------------------------------- 
     315  
     316         ! 2.1. u-component of the velocity 
     317         ! --------------------------------- 
     318         ! 
     319         !        nib       nibm     nibm2 
     320         !      ///|   nib   |   nibm  | 
     321         !      ///|    |    |    |    | 
     322         !      ---f----v----f----v----f-- jj-line 
     323         !      ///|    |    |    |    | 
     324         !      ///|         |         | 
     325         !      ///u    T    u    T    u   jj-line 
     326         !      ///|         |         | 
     327         !      ///|    |    |    |    | 
     328         !       jpiwob    jpiwob+1    jpiwob+2 
     329         !              |         |         
     330         !            jpiwob+1    jpiwob+2      
     331         ! 
     332         ! ... If free surface formulation: 
     333         ! ... radiative conditions on the total part + relaxation toward climatology 
     334         ! ... (jpjwdp1, jpjwfm1), jpiwob 
     335         DO ji = niw0, niw1 
     336            DO jk = 1, jpkm1 
     337               DO jj = 1, jpj 
     338                  z05cx = u_cxwbnd(jj,jk) 
     339                  z05cx = z05cx / e1t(ji+1,jj) 
     340                  z05cx = max( z05cx, -1. ) 
     341         ! ... z05c  > 0, inflow  zin=0, ztau=1     
     342         !          =< 0, outflow zin=1, ztau=rtauw 
     343                  zin = sign( 1., -1. * z05cx ) 
     344                  zin = 0.5*( zin + abs(zin) ) 
     345                  ztau = (1.-zin )* rtauwin + zin * rtauw 
     346                  z05cx = z05cx * zin 
     347         ! ... update un with radiative or climatological velocity 
     348                  ua(ji,jj,jk) = ua(ji,jj,jk) * ( 1. - uwmsk(jj,jk) ) +          & 
     349                                 uwmsk(jj,jk) * ( ( 1. + z05cx - ztau )          & 
     350                                 * uwbnd(jj,jk,nib ,nitm) - 2.*z05cx               & 
     351                                 * uwbnd(jj,jk,nibm,nit ) + ztau  * ufow (jj,jk) ) & 
     352                                 / (1. - z05cx) 
     353               END DO 
     354            END DO 
     355         END DO 
     356 
     357         ! 2.2 v-component of the velocity 
     358         ! ------------------------------- 
     359         ! 
     360         !    nib       nibm     nibm2 
     361         !  ///|///nib   |   nibm  |  nibm2 
     362         !  ///|////|    |    |    |    |    | 
     363         !  ---v----f----v----f----v----f----v-- jj-line 
     364         !  ///|////|    |    |    |    |    | 
     365         !  ///|////|    |    |    |    |    | 
     366         ! jpiwob     jpiwob+1    jpiwob+2 
     367         !          |         |         |    
     368         !        jpiwob   jpiwob+1   jpiwob+2     
     369         ! 
     370         ! ... radiative condition plus Raymond-Kuo 
     371         ! ... (jpjwdp1, jpjwfm1),jpiwob 
     372         DO ji = niw0, niw1 
     373            DO jk = 1, jpkm1 
     374               DO jj = 1, jpj 
     375                  z05cx = v_cxwbnd(jj,jk)   
     376                  z05cx = z05cx / e1f(ji,jj) 
     377                  z05cx = max( z05cx, -1. ) 
     378         ! ... z05cx > 0, inflow  zin=0, ztau=1     
     379         !          =< 0, outflow zin=1, ztau=rtauw 
     380                  zin = sign( 1., -1. * z05cx ) 
     381                  zin = 0.5*( zin + abs(zin) ) 
     382                  ztau = (1.-zin )*rtauwin + zin * rtauw 
     383                  z05cx = z05cx * zin  
     384         ! ... update va with radiative or climatological velocity 
     385                  va(ji,jj,jk) = va(ji,jj,jk) * (1. - vwmsk(jj,jk) ) +          & 
     386                                 vwmsk(jj,jk) * ( ( 1. + z05cx - ztau )         & 
     387                                 * vwbnd(jj,jk,nib ,nitm) - 2.*z05cx              & 
     388                                 * vwbnd(jj,jk,nibm,nit ) + ztau * vfow (jj,jk) ) & 
     389                                 / (1. - z05cx) 
     390                END DO 
     391             END DO 
     392         END DO 
     393 
     394      END IF 
     395 
     396   END SUBROUTINE obc_dyn_west 
     397 
     398   SUBROUTINE obc_dyn_north ( kt ) 
     399      !!------------------------------------------------------------------------------ 
     400      !!                     SUBROUTINE obc_dyn_north 
     401      !!                    ************************* 
     402      !! ** Purpose : 
     403      !!      Apply the radiation algorithm on north OBC velocities ua, va using the  
     404      !!      phase velocities calculated in obc_rad_north subroutine in obcrad.F90 module 
     405      !!      If the logical lfbcnorth is .TRUE., there is no radiation but only fixed OBC 
    52406      !! 
    53       INTEGER, INTENT( in )           :: kt               ! Main time step counter 
    54       LOGICAL, INTENT( in ), OPTIONAL :: dyn3d_only       ! T => only update baroclinic velocities 
     407      !!  History : 
     408      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     409      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     410      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     411      !!         ! 00-06 (J.-M. Molines)  
     412      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     413      !!    9.0  ! 05-11  (V. Garnier) Surface pressure gradient organization 
     414      !!------------------------------------------------------------------------------ 
     415      !! * Arguments 
     416      INTEGER, INTENT( in ) ::   kt 
     417 
     418      !! * Local declaration 
     419      REAL(wp) ::   z05cx, ztau, zin 
     420      !!------------------------------------------------------------------------------ 
     421 
     422      ! 1. First three time steps and more if lfbcnorth is .TRUE. 
     423      !    In that case open boundary conditions are FIXED. 
     424      ! --------------------------------------------------------- 
     425  
     426      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcnorth  .OR. lk_dynspg_exp ) THEN 
     427 
     428         ! 1.1 U zonal velocity 
     429         ! -------------------- 
     430         DO jj = njn0+1, njn1+1 
     431            DO jk = 1, jpkm1 
     432               DO ji = 1, jpi 
     433                  ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-unmsk(ji,jk)) + & 
     434                                ufon(ji,jk)*unmsk(ji,jk) 
     435               END DO 
     436            END DO 
     437         END DO 
     438 
     439         ! 1.2 V meridional velocity 
     440         ! ------------------------- 
     441         DO jj = njn0, njn1 
     442            DO jk = 1, jpkm1 
     443               DO ji = 1, jpi 
     444                  va(ji,jj,jk)= va(ji,jj,jk) * (1.-vnmsk(ji,jk)) + & 
     445                                vfon(ji,jk)*vnmsk(ji,jk) 
     446               END DO 
     447            END DO 
     448         END DO 
     449 
     450      ELSE 
     451 
     452      ! 2. Beyond the fourth time step if lfbcnorth is .FALSE. 
     453      ! ------------------------------------------------------ 
     454 
     455         ! 2.1. u-component of the velocity 
     456         ! -------------------------------- 
     457         ! 
     458         !            ji-row 
     459         !              | 
     460         !       nib ///u//////  jpjnob + 1 
     461         !         /////|////// 
     462         !     nib -----f-----   jpjnob 
     463         !              |     
     464         !      nibm--  u   ---- jpjnob 
     465         !              |         
     466         !    nibm -----f-----   jpjnob-1 
     467         !              |         
     468         !     nibm2--  u   ---- jpjnob-1 
     469         !              |         
     470         !   nibm2 -----f-----   jpjnob-2 
     471         !              | 
     472         ! 
     473         ! ... radiative condition 
     474         ! ... jpjnob+1,(jpindp1, jpinfm1) 
     475         DO jj = njn0+1, njn1+1 
     476            DO jk = 1, jpkm1 
     477               DO ji = 1, jpi 
     478                  z05cx= u_cynbnd(ji,jk)  
     479                  z05cx = z05cx / e2f(ji, jj-1) 
     480                  z05cx = min( z05cx, 1. ) 
     481         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     482         !           > 0, outflow zin=1, ztau=rtaun 
     483                  zin = sign( 1., z05cx ) 
     484                  zin = 0.5*( zin + abs(zin) ) 
     485         ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 
     486                  ztau = (1.-zin ) * rtaunin  + zin * rtaun 
     487         ! ... for u, when inflow, ufon is prescribed 
     488                  z05cx = z05cx * zin 
     489         ! ... update un with radiative or climatological velocity 
     490                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-unmsk(ji,jk)) +             & 
     491                                 unmsk(ji,jk) * ( ( 1. - z05cx - ztau )         & 
     492                                 * unbnd(ji,jk,nib ,nitm) + 2.*z05cx              & 
     493                                 * unbnd(ji,jk,nibm,nit ) + ztau * ufon (ji,jk) ) & 
     494                                 / (1. + z05cx) 
     495               END DO 
     496            END DO 
     497         END DO 
     498 
     499         ! 2.2 v-component of the velocity 
     500         ! ------------------------------- 
     501         ! 
     502         !                ji-row    ji-row 
     503         !              |         | 
     504         !         /////|///////////////// 
     505         !    nib  -----f----v----f----  jpjnob 
     506         !              |         | 
     507         !      nib  -  u -- T -- u ---- jpjnob 
     508         !              |         | 
     509         !   nibm  -----f----v----f----  jpjnob-1 
     510         !              |         | 
     511         !     nibm --  u -- T -- u ---  jpjnob-1 
     512         !              |         | 
     513         !   nibm2 -----f----v----f----  jpjnob-2 
     514         !              |         | 
     515         ! 
     516         ! ... Free surface formulation: 
     517         ! ... radiative conditions on the total part + relaxation toward climatology 
     518         ! ... jpjnob,(jpindp1, jpinfm1) 
     519         DO jj = njn0, njn1 
     520            DO jk = 1, jpkm1 
     521               DO ji = 1, jpi 
     522         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
     523                  z05cx = v_cynbnd(ji,jk) 
     524                  z05cx = z05cx / e2t(ji,jj) 
     525                  z05cx = min( z05cx, 1. ) 
     526         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     527         !           > 0, outflow zin=1, ztau=rtaun 
     528                  zin = sign( 1., z05cx ) 
     529                  zin = 0.5*( zin + abs(zin) ) 
     530         ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 
     531                  ztau = (1.-zin ) * rtaunin + zin * rtaun 
     532                  z05cx = z05cx * zin 
     533         ! ... update va with radiative or climatological velocity 
     534                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vnmsk(ji,jk)) +             & 
     535                                 vnmsk(ji,jk) * ( ( 1. - z05cx - ztau )         & 
     536                                 * vnbnd(ji,jk,nib ,nitm) + 2.*z05cx              & 
     537                                 * vnbnd(ji,jk,nibm,nit ) + ztau * vfon (ji,jk) ) & 
     538                                 / (1. + z05cx) 
     539               END DO 
     540            END DO 
     541         END DO 
     542      END IF 
     543 
     544   END SUBROUTINE obc_dyn_north 
     545 
     546   SUBROUTINE obc_dyn_south ( kt ) 
     547      !!------------------------------------------------------------------------------ 
     548      !!                     SUBROUTINE obc_dyn_south 
     549      !!                    ************************* 
     550      !! ** Purpose : 
     551      !!      Apply the radiation algorithm on south OBC velocities ua, va using the  
     552      !!      phase velocities calculated in obc_rad_south subroutine in obcrad.F90 module 
     553      !!      If the logical lfbcsouth is .TRUE., there is no radiation but only fixed OBC 
    55554      !! 
    56       INTEGER               :: jk,ii,ij,ib,igrd     ! Loop counter 
    57       LOGICAL               :: ll_dyn2d, ll_dyn3d   
    58       !! 
    59  
    60       IF(wrk_in_use(2, 7,8) ) THEN 
    61          CALL ctl_stop('obc_dyn: ERROR: requested workspace arrays are unavailable.')   ;   RETURN 
     555      !!  History : 
     556      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     557      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     558      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     559      !!         ! 00-06 (J.-M. Molines)  
     560      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     561      !!    9.0  ! 05-11  (V. Garnier) Surface pressure gradient organization 
     562      !!------------------------------------------------------------------------------ 
     563      !! * Arguments 
     564      INTEGER, INTENT( in ) ::   kt 
     565 
     566      !! * Local declaration 
     567      REAL(wp) ::   z05cx, ztau, zin 
     568 
     569      !!------------------------------------------------------------------------------ 
     570      !!  OPA 8.5, LODYC-IPSL (2002) 
     571      !!------------------------------------------------------------------------------ 
     572 
     573      ! 1. First three time steps and more if lfbcsouth is .TRUE. 
     574      !    In that case open boundary conditions are FIXED. 
     575      ! --------------------------------------------------------- 
     576 
     577      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcsouth  .OR. lk_dynspg_exp ) THEN 
     578 
     579         ! 1.1 U zonal velocity 
     580         ! -------------------- 
     581         DO jj = njs0, njs1 
     582            DO jk = 1, jpkm1 
     583               DO ji = 1, jpi 
     584                  ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-usmsk(ji,jk)) + & 
     585                                usmsk(ji,jk) * ufos(ji,jk) 
     586               END DO 
     587            END DO 
     588         END DO 
     589 
     590         ! 1.2 V meridional velocity 
     591         ! ------------------------- 
     592         DO jj = njs0, njs1 
     593            DO jk = 1, jpkm1 
     594               DO ji = 1, jpi 
     595                  va(ji,jj,jk)= va(ji,jj,jk) * (1.-vsmsk(ji,jk)) + & 
     596                                vsmsk(ji,jk) * vfos(ji,jk) 
     597               END DO 
     598            END DO 
     599         END DO 
     600 
     601      ELSE 
     602 
     603      ! 2. Beyond the fourth time step if lfbcsouth is .FALSE. 
     604      ! ------------------------------------------------------ 
     605 
     606         ! 2.1. u-component of the velocity 
     607         ! -------------------------------- 
     608         ! 
     609         !            ji-row 
     610         !              | 
     611         !   nibm2 -----f-----   jpjsob +2 
     612         !              |     
     613         !    nibm2 --  u   ---- jpjsob +2  
     614         !              |         
     615         !    nibm -----f-----   jpjsob +1 
     616         !              |         
     617         !    nibm  --  u   ---- jpjsob +1 
     618         !              |         
     619         !    nib  -----f-----   jpjsob 
     620         !         /////|////// 
     621         !    nib   ////u/////   jpjsob  
     622         ! 
     623         ! ... radiative condition plus Raymond-Kuo 
     624         ! ... jpjsob,(jpisdp1, jpisfm1) 
     625         DO jj = njs0, njs1 
     626            DO jk = 1, jpkm1 
     627               DO ji = 1, jpi 
     628                  z05cx= u_cysbnd(ji,jk)  
     629                  z05cx = z05cx / e2f(ji, jj) 
     630                  z05cx = max( z05cx, -1. ) 
     631         ! ... z05cx > 0, inflow  zin=0, ztau=1  
     632         !          =< 0, outflow zin=1, ztau=rtaus 
     633                  zin = sign( 1., -1. * z05cx ) 
     634                  zin = 0.5*( zin + abs(zin) ) 
     635                  ztau = (1.-zin ) * rtausin + zin * rtaus 
     636                  z05cx = z05cx * zin  
     637         ! ... update ua with radiative or climatological velocity 
     638                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-usmsk(ji,jk)) +              & 
     639                                 usmsk(ji,jk) * (  ( 1. + z05cx - ztau )         & 
     640                                 * usbnd(ji,jk,nib ,nitm) - 2.*z05cx               & 
     641                                 * usbnd(ji,jk,nibm,nit ) + ztau * ufos (ji,jk) )  & 
     642                                 / (1. - z05cx) 
     643               END DO 
     644            END DO 
     645         END DO 
     646 
     647         ! 2.2 v-component of the velocity 
     648         ! ------------------------------- 
     649         ! 
     650         !                ji-row    ji-row 
     651         !              |         | 
     652         !  nibm2  -----f----v----f----  jpjsob+2 
     653         !              |         | 
     654         !    nibm   -  u -- T -- u ---- jpjsob+2 
     655         !              |         | 
     656         !   nibm  -----f----v----f----  jpjsob+1  
     657         !              |         | 
     658         !   nib    --  u -- T -- u ---  jpjsob+1 
     659         !              |         | 
     660         !   nib   -----f----v----f----  jpjsob 
     661         !         ///////////////////// 
     662         ! 
     663         ! ... Free surface formulation: 
     664         ! ... radiative conditions on the total part + relaxation toward climatology 
     665         ! ... jpjsob,(jpisdp1,jpisfm1) 
     666         DO jj = njs0, njs1 
     667            DO jk = 1, jpkm1 
     668               DO ji = 1, jpi 
     669                  z05cx = v_cysbnd(ji,jk) 
     670                  z05cx = z05cx / e2t(ji,jj+1) 
     671                  z05cx = max( z05cx, -1. ) 
     672         ! ... z05c > 0, inflow  zin=0, ztau=1  
     673         !         =< 0, outflow zin=1, ztau=rtaus 
     674                  zin = sign( 1., -1. * z05cx ) 
     675                  zin = 0.5*( zin + abs(zin) ) 
     676                  ztau = (1.-zin )*rtausin + zin * rtaus 
     677                  z05cx = z05cx * zin 
     678         ! ... update va with radiative or climatological velocity 
     679                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vsmsk(ji,jk)) +             & 
     680                                 vsmsk(ji,jk) * ( ( 1. + z05cx - ztau )         & 
     681                                 * vsbnd(ji,jk,nib ,nitm) - 2.*z05cx              & 
     682                                 * vsbnd(ji,jk,nibm,nit ) + ztau * vfos (ji,jk) ) & 
     683                                 / (1. - z05cx) 
     684               END DO 
     685            END DO 
     686         END DO 
    62687      END IF 
    63688 
    64       ll_dyn2d = .true. 
    65       ll_dyn3d = .true. 
    66  
    67       IF( PRESENT(dyn3d_only) ) THEN 
    68          IF( dyn3d_only ) ll_dyn2d = .false. 
    69       ENDIF 
    70  
    71       !------------------------------------------------------- 
    72       ! Set pointers 
    73       !------------------------------------------------------- 
    74  
    75       pssh => sshn 
    76       phur => hur 
    77       phvr => hvr 
    78       pu2d => wrk_2d_7 
    79       pv2d => wrk_2d_8 
    80  
    81       !------------------------------------------------------- 
    82       ! Split velocities into barotropic and baroclinic parts 
    83       !------------------------------------------------------- 
    84  
    85       pu2d(:,:) = 0.e0 
    86       pv2d(:,:) = 0.e0 
    87       DO jk = 1, jpkm1   !! Vertically integrated momentum trends 
    88           pu2d(:,:) = pu2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 
    89           pv2d(:,:) = pv2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 
    90       END DO 
    91       pu2d(:,:) = pu2d(:,:) * phur(:,:) 
    92       pv2d(:,:) = pv2d(:,:) * phvr(:,:) 
    93       DO jk = 1 , jpkm1 
    94          ua(:,:,jk) = ua(:,:,jk) - pu2d(:,:) 
    95          va(:,:,jk) = va(:,:,jk) - pv2d(:,:) 
    96       END DO 
    97  
    98       !------------------------------------------------------- 
    99       ! Apply boundary conditions to barotropic and baroclinic 
    100       ! parts separately 
    101       !------------------------------------------------------- 
    102  
    103       IF( ll_dyn2d ) CALL obc_dyn2d( kt ) 
    104  
    105       IF( ll_dyn3d ) CALL obc_dyn3d( kt ) 
    106  
    107       !------------------------------------------------------- 
    108       ! Recombine velocities 
    109       !------------------------------------------------------- 
    110  
    111       DO jk = 1 , jpkm1 
    112          ua(:,:,jk) = ( ua(:,:,jk) + pu2d(:,:) ) * umask(:,:,jk) 
    113          va(:,:,jk) = ( va(:,:,jk) + pv2d(:,:) ) * vmask(:,:,jk) 
    114       END DO 
    115  
    116       IF(wrk_not_released(2, 7,8) )    CALL ctl_stop('obc_dyn: ERROR: failed to release workspace arrays.') 
    117  
    118    END SUBROUTINE obc_dyn 
    119  
     689   END SUBROUTINE obc_dyn_south 
    120690#else 
    121    !!---------------------------------------------------------------------- 
    122    !!   Dummy module                   NO Unstruct Open Boundary Conditions 
    123    !!---------------------------------------------------------------------- 
     691   !!================================================================================= 
     692   !!                       ***  MODULE  obcdyn  *** 
     693   !! Ocean dynamics:   Radiation of velocities on each open boundary 
     694   !!================================================================================= 
    124695CONTAINS 
    125    SUBROUTINE obc_dyn( kt )      ! Empty routine 
    126       WRITE(*,*) 'obc_dyn: You should not have seen this print! error?', kt 
     696 
     697   SUBROUTINE obc_dyn 
     698                              ! No open boundaries ==> empty routine 
    127699   END SUBROUTINE obc_dyn 
    128700#endif 
    129701 
    130    !!====================================================================== 
    131702END MODULE obcdyn 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90

    r2865 r2888  
    1 MODULE obcini 
     1 MODULE obcini 
    22   !!====================================================================== 
    33   !!                       ***  MODULE  obcini  *** 
    4    !! Unstructured open boundaries : initialisation 
     4   !! OBC initial state :  Open boundary initial state 
    55   !!====================================================================== 
    6    !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code 
    7    !!             -   !  2007-01  (D. Storkey) Update to use IOM module 
    8    !!             -   !  2007-01  (D. Storkey) Tidal forcing 
    9    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    10    !!            3.3  !  2010-09  (E.O'Dea) updates for Shelf configurations 
    11    !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions 
    12    !!            3.4  !  2011     (D. Storkey, J. Chanut) OBC-BDY merge 
    13    !!                 !  --- Renamed bdyini.F90 -> obcini.F90 --- 
     6   !! History :  8.0  !  97-07  (J.M. Molines, G. Madec)  Original code 
     7   !!   NEMO     1.0  !  02-11  (C. Talandier, A-M. Treguier) Free surface, F90 
     8   !!            2.0  !  05-11  (V. Garnier) Surface pressure gradient organization 
    149   !!---------------------------------------------------------------------- 
    1510#if defined key_obc 
    1611   !!---------------------------------------------------------------------- 
    17    !!   'key_obc'                     Unstructured Open Boundary Conditions 
     12   !!   'key_obc'                                 Open Boundary Conditions 
    1813   !!---------------------------------------------------------------------- 
    19    !!   obc_init       : Initialization of unstructured open boundaries 
     14   !!   obc_init       : initialization for the open boundary condition 
    2015   !!---------------------------------------------------------------------- 
    2116   USE oce             ! ocean dynamics and tracers variables 
    22    USE dom_oce         ! ocean space and time domain 
    23    USE obc_oce         ! unstructured open boundary conditions 
     17   USE dom_oce         ! ocean space and time domain variables 
     18   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     19   USE phycst          ! physical constants 
     20   USE obc_oce         ! open boundary condition: ocean 
     21   USE obcdta          ! open boundary condition: data 
    2422   USE in_out_manager  ! I/O units 
    25    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    26    USE lib_mpp         ! for mpp_sum   
    27    USE iom             ! I/O 
     23   USE lib_mpp         ! MPP library 
     24   USE dynspg_oce      ! flag lk_dynspg_flt 
    2825 
    2926   IMPLICIT NONE 
    … …  
    3229   PUBLIC   obc_init   ! routine called by opa.F90 
    3330 
     31   !! * Substitutions 
     32#  include "obc_vectopt_loop_substitute.h90" 
    3433   !!---------------------------------------------------------------------- 
    35    !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     34   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    3635   !! $Id$  
    3736   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4342      !!                 ***  ROUTINE obc_init  *** 
    4443      !!          
    45       !! ** Purpose :   Initialization of the dynamics and tracer fields with  
    46       !!              unstructured open boundaries. 
     44      !! ** Purpose :   Initialization of the dynamics and tracer fields at  
     45      !!              the open boundaries. 
    4746      !! 
    48       !! ** Method  :   Read initialization arrays (mask, indices) to identify  
    49       !!              an unstructured open boundary 
     47      !! ** Method  :   initialization of open boundary variables 
     48      !!      (u, v) over 3 time step and 3 rows 
     49      !!      (t, s) over 2 time step and 2 rows 
     50      !!      if ln_rstart = .FALSE. : no restart, fields set to zero 
     51      !!      if ln_rstart = .TRUE.  : restart, fields are read in a file  
     52      !!      if rdpxxx = 0 then lfbc is set true for this boundary. 
    5053      !! 
    51       !! ** Input   :  obc_init.nc, input file for unstructured open boundaries 
    52       !!----------------------------------------------------------------------       
    53       ! namelist variables 
    54       !------------------- 
    55       INTEGER, PARAMETER          :: jp_nseg = 100 
    56       INTEGER                     :: nobcsege, nobcsegw, nobcsegn, nobcsegs  
    57       INTEGER, DIMENSION(jp_nseg) :: jpieob, jpjedt, jpjeft 
    58       INTEGER, DIMENSION(jp_nseg) :: jpiwob, jpjwdt, jpjwft 
    59       INTEGER, DIMENSION(jp_nseg) :: jpjnob, jpindt, jpinft 
    60       INTEGER, DIMENSION(jp_nseg) :: jpjsob, jpisdt, jpisft 
    61  
    62       ! local variables 
    63       !------------------- 
    64       INTEGER  ::   ib_obc, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    65       INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    66       INTEGER  ::   iw, ie, is, in, inum, id_dummy         !   -       - 
    67       INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    68       INTEGER, POINTER  ::  nbi, nbj, nbr                  ! short cuts 
    69       REAL   , POINTER  ::  flagu, flagv                   !    -   - 
    70       REAL(wp) ::   zefl, zwfl, znfl, zsfl                 ! local scalars 
    71       INTEGER, DIMENSION (2)                ::   kdimsz 
    72       INTEGER, DIMENSION(jpbgrd,jp_obc)       ::   nblendta         ! Length of index arrays  
    73       INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbidta, nbjdta   ! Index arrays: i and j indices of obc dta 
    74       INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbrdta           ! Discrete distance from rim points 
    75       REAL(wp), DIMENSION(jpidta,jpjdta)    ::   zmask            ! global domain mask 
    76       CHARACTER(LEN=80),DIMENSION(jpbgrd)  ::   clfile 
    77       CHARACTER(LEN=1),DIMENSION(jpbgrd)   ::   cgrid 
     54      !! ** Input   :   restart.obc file, restart file for open boundaries  
     55      !!---------------------------------------------------------------------- 
     56      USE obcrst,   ONLY :   obc_rst_read   ! Make obc_rst_read routine available 
    7857      !! 
    79       NAMELIST/namobc/ nb_obc, ln_coords_file, cn_coords_file,             & 
    80          &             ln_mask_file, cn_mask_file, nn_dyn2d, nn_dyn2d_dta, & 
    81          &             nn_dyn3d, nn_dyn3d_dta, nn_tra, nn_tra_dta,         &   
    82 #if defined key_lim2 
    83          &             nn_ice_lim2, nn_ice_lim2_dta,                       & 
    84 #endif 
    85          &             ln_vol, nn_volctl,                                  & 
    86          &             nn_rimwidth, nn_dmp2d_in, nn_dmp2d_out,             & 
    87          &             nn_dmp3d_in, nn_dmp3d_out 
     58      INTEGER  ::   ji, jj, istop , inumfbc 
     59      INTEGER, DIMENSION(4) ::   icorner 
     60      REAL(wp), DIMENSION(2) ::   ztestmask 
    8861      !! 
    89       NAMELIST/namobc_index/ nobcsege, jpieob, jpjedt, jpjeft,             & 
    90                              nobcsegw, jpiwob, jpjwdt, jpjwft,             & 
    91                              nobcsegn, jpjnob, jpindt, jpinft,             & 
    92                              nobcsegs, jpjsob, jpisdt, jpisft 
    93  
     62      NAMELIST/namobc/ rn_dpein, rn_dpwin, rn_dpnin, rn_dpsin,       & 
     63         &             rn_dpeob, rn_dpwob, rn_dpnob, rn_dpsob,       & 
     64         &             rn_volemp, nn_obcdta, cn_obcdta,    & 
     65         &             ln_obc_clim, ln_vol_cst, ln_obc_fla 
    9466      !!---------------------------------------------------------------------- 
    9567 
    96       IF( obc_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'obc_init : unable to allocate oce arrays' ) 
     68      REWIND( numnam )              ! Namelist namobc : open boundaries 
     69      READ  ( numnam, namobc ) 
     70 
     71      ! convert DOCTOR namelist name into the OLD names 
     72      nobc_dta = nn_obcdta 
     73      cffile   = cn_obcdta 
     74      rdpein   = rn_dpein 
     75      rdpwin   = rn_dpwin 
     76      rdpsin   = rn_dpsin 
     77      rdpnin   = rn_dpnin 
     78      rdpeob   = rn_dpeob 
     79      rdpwob   = rn_dpwob 
     80      rdpsob   = rn_dpsob 
     81      rdpnob   = rn_dpnob 
     82      volemp   = rn_volemp 
     83 
     84      !                              ! allocate obc arrays 
     85      IF( obc_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_oce arrays' ) 
     86      IF( obc_dta_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_dta arrays' ) 
     87 
     88      ! By security we set rdpxin and rdpxob respectively to 1. and 15. if the corresponding OBC is not activated 
     89      IF( .NOT.lp_obc_east  ) THEN   ;   rdpein = 1.   ;   rdpeob = 15.   ;   END IF 
     90      IF( .NOT.lp_obc_west  ) THEN   ;   rdpwin = 1.   ;   rdpwob = 15.   ;   END IF 
     91      IF( .NOT.lp_obc_north ) THEN   ;   rdpnin = 1.   ;   rdpnob = 15.   ;   END IF 
     92      IF( .NOT.lp_obc_south ) THEN   ;   rdpsin = 1.   ;   rdpsob = 15.   ;   END IF 
     93 
     94      ! number of open boudaries and open boundary indicators 
     95      nbobc = 0 
     96      IF( lp_obc_east  )   nbobc = nbobc + 1 
     97      IF( lp_obc_west  )   nbobc = nbobc + 1 
     98      IF( lp_obc_north )   nbobc = nbobc + 1 
     99      IF( lp_obc_south )   nbobc = nbobc + 1 
    97100 
    98101      IF(lwp) WRITE(numout,*) 
    99102      IF(lwp) WRITE(numout,*) 'obc_init : initialization of open boundaries' 
    100103      IF(lwp) WRITE(numout,*) '~~~~~~~~' 
    101       ! 
    102  
    103       IF( jperio /= 0 )   CALL ctl_stop( 'Cyclic or symmetric,',   & 
    104          &                               ' and general open boundary condition are not compatible' ) 
    105  
    106       cgrid= (/'t','u','v'/) 
    107  
    108       ! ----------------------------------------- 
    109       ! Initialise and read namelist parameters 
    110       ! ----------------------------------------- 
    111  
    112       nb_obc            = 0 
    113       ln_coords_file(:) = .false. 
    114       cn_coords_file(:) = '' 
    115       ln_mask_file      = .false. 
    116       cn_mask_file(:)   = '' 
    117       nn_dyn2d(:)       = 0 
    118       nn_dyn2d_dta(:)   = -1  ! uninitialised flag 
    119       nn_dyn3d(:)       = 0 
    120       nn_dyn3d_dta(:)   = -1  ! uninitialised flag 
    121       nn_tra(:)         = 0 
    122       nn_tra_dta(:)     = -1  ! uninitialised flag 
    123 #if defined key_lim2 
    124       nn_ice_lim2(:)    = 0 
    125       nn_ice_lim2_dta(:)= -1  ! uninitialised flag 
    126 #endif 
    127       ln_vol            = .false. 
    128       nn_volctl         = -1  ! uninitialised flag 
    129       nn_rimwidth(:)    = -1  ! uninitialised flag 
    130       nn_dmp2d_in(:)    = -1  ! uninitialised flag 
    131       nn_dmp2d_out(:)   = -1  ! uninitialised flag 
    132       nn_dmp3d_in(:)    = -1  ! uninitialised flag 
    133       nn_dmp3d_out(:)   = -1  ! uninitialised flag 
    134  
    135       REWIND( numnam )                     
    136       READ  ( numnam, namobc ) 
    137  
    138       ! ----------------------------------------- 
    139       ! Check and write out namelist parameters 
    140       ! ----------------------------------------- 
    141  
    142       !                                   ! control prints 
    143       IF(lwp) WRITE(numout,*) '         namobc' 
    144  
    145       IF( nb_obc .eq. 0 ) THEN  
    146         IF(lwp) WRITE(numout,*) 'nb_obc = 0, NO OPEN BOUNDARIES APPLIED.' 
     104      IF(lwp) WRITE(numout,*) '   Number of open boundaries    nbobc = ', nbobc 
     105      IF(lwp) WRITE(numout,*) 
     106 
     107      ! control prints 
     108      IF(lwp) WRITE(numout,*) '   Namelist namobc' 
     109      IF(lwp) WRITE(numout,*) '      data in file (=1) or initial state used (=0)   nn_obcdta   = ', nn_obcdta 
     110      IF(lwp) WRITE(numout,*) '      climatology (true) or not                      ln_obc_clim = ', ln_obc_clim 
     111      IF(lwp) WRITE(numout,*) '      vol_cst (true) or not:                         ln_vol_cst  = ', ln_vol_cst 
     112      IF(lwp) WRITE(numout,*) ' ' 
     113      IF(lwp) WRITE(numout,*) '   WARNING                                                  ' 
     114      IF(lwp) WRITE(numout,*) '      Flather"s algorithm is applied with explicit free surface scheme                 ' 
     115      IF(lwp) WRITE(numout,*) '      or with free surface time-splitting scheme                                       ' 
     116      IF(lwp) WRITE(numout,*) '      Nor radiation neither relaxation is allowed with explicit free surface scheme:   ' 
     117      IF(lwp) WRITE(numout,*) '      Radiation and/or relaxation is allowed with free surface time-splitting scheme ' 
     118      IF(lwp) WRITE(numout,*) '      depending of the choice of rdpXin = rdpXob  = 0. for open boundaries             ' 
     119      IF(lwp) WRITE(numout,*) 
     120      IF(lwp) WRITE(numout,*) '      For the filtered free surface case,                                              ' 
     121      IF(lwp) WRITE(numout,*) '      radiation, relaxation or presciption of data can be applied                      ' 
     122      IF(lwp) WRITE(numout,*) 
     123 
     124      IF( lwp.AND.lp_obc_east ) THEN 
     125         WRITE(numout,*) '      East open boundary :' 
     126         WRITE(numout,*) '         i index                    jpieob   = ', jpieob 
     127         WRITE(numout,*) '         damping time scale (days)  rn_dpeob = ', rn_dpeob 
     128         WRITE(numout,*) '         damping time scale (days)  rn_dpein = ', rn_dpein 
     129      ENDIF 
     130 
     131      IF( lwp.AND.lp_obc_west ) THEN 
     132         WRITE(numout,*) '      West open boundary :' 
     133         WRITE(numout,*) '         i index                    jpiwob   = ', jpiwob 
     134         WRITE(numout,*) '         damping time scale (days)  rn_dpwob = ', rn_dpwob 
     135         WRITE(numout,*) '         damping time scale (days)  rn_dpwin = ', rn_dpwin 
     136      ENDIF 
     137 
     138      IF( lwp.AND.lp_obc_north ) THEN 
     139         WRITE(numout,*) '      North open boundary :' 
     140         WRITE(numout,*) '         j index                    jpjnob   = ', jpjnob 
     141         WRITE(numout,*) '         damping time scale (days)  rn_dpnob = ', rn_dpnob 
     142         WRITE(numout,*) '         damping time scale (days)  rn_dpnin = ', rn_dpnin 
     143      ENDIF 
     144 
     145      IF( lwp.AND.lp_obc_south ) THEN 
     146         WRITE(numout,*) '      South open boundary :' 
     147         WRITE(numout,*) '         j index                    jpjsob   = ', jpjsob 
     148         WRITE(numout,*) '         damping time scale (days)  rn_dpsob = ', rn_dpsob 
     149         WRITE(numout,*) '         damping time scale (days)  rn_dpsin = ', rn_dpsin 
     150         WRITE(numout,*) 
     151      ENDIF 
     152 
     153      IF( nbobc >= 2 .AND. jperio /= 0 )   & 
     154         &   CALL ctl_stop( ' Cyclic or symmetric, and open boundary condition are not compatible' ) 
     155 
     156      ! 1. Initialisation of constants  
     157      ! ------------------------------ 
     158      ! ...                          convert rdp$ob in seconds 
     159      ! Fixed Bdy flag              inbound                outbound 
     160      lfbceast  = .FALSE.   ;   rdpein = rdpein * rday    ;   rdpeob = rdpeob * rday 
     161      lfbcwest  = .FALSE.   ;   rdpwin = rdpwin * rday    ;   rdpwob = rdpwob * rday 
     162      lfbcnorth = .FALSE.   ;   rdpnin = rdpnin * rday    ;   rdpnob = rdpnob * rday 
     163      lfbcsouth = .FALSE.   ;   rdpsin = rdpsin * rday    ;   rdpsob = rdpsob * rday 
     164      inumfbc = 0 
     165      ! ... look for Fixed Boundaries (rdp = 0 ) 
     166      ! ... When specified, lbcxxx flags are set to TRUE and rdpxxx are set to 
     167      ! ...  a small arbitrary value, (to avoid division by zero further on).  
     168      ! ...  rdpxxx is not used anymore. 
     169      IF( lp_obc_east )  THEN 
     170         IF( (rdpein+rdpeob) == 0 )  THEN 
     171            lfbceast = .TRUE.   ;   rdpein = 1e-3   ;   rdpeob = 1e-3 
     172            inumfbc = inumfbc+1 
     173         ELSEIF ( (rdpein*rdpeob) == 0 )  THEN 
     174            CALL ctl_stop( 'obc_init : rn_dpein & rn_dpeob must be both zero or non zero' ) 
     175         END IF 
     176      END IF 
     177 
     178      IF( lp_obc_west )  THEN 
     179         IF( (rdpwin + rdpwob) == 0 )  THEN 
     180            lfbcwest = .TRUE.     ;     rdpwin = 1e-3     ;     rdpwob = 1e-3 
     181            inumfbc = inumfbc+1 
     182         ELSEIF ( (rdpwin*rdpwob) == 0 )  THEN 
     183            CALL ctl_stop( 'obc_init : rn_dpwin & rn_dpwob must be both zero or non zero' ) 
     184         END IF 
     185      END IF 
     186      IF( lp_obc_north )  THEN 
     187         IF( (rdpnin + rdpnob) == 0 )  THEN 
     188            lfbcnorth = .TRUE.     ;     rdpnin = 1e-3     ;     rdpnob = 1e-3 
     189            inumfbc = inumfbc+1 
     190         ELSEIF ( (rdpnin*rdpnob) == 0 )  THEN 
     191            CALL ctl_stop( 'obc_init : rn_dpnin & rn_dpnob must be both zero or non zero' ) 
     192         END IF 
     193      END IF 
     194      IF( lp_obc_south )  THEN 
     195         IF( (rdpsin + rdpsob) == 0 )  THEN 
     196            lfbcsouth = .TRUE.   ;   rdpsin = 1e-3   ;   rdpsob = 1e-3 
     197            inumfbc = inumfbc+1 
     198         ELSEIF ( (rdpsin*rdpsob) == 0 )  THEN 
     199            CALL ctl_stop( 'obc_init : rn_dpsin & rn_dpsob must be both zero or non zero' ) 
     200         END IF 
     201      END IF 
     202 
     203      ! 2.  Clever mpp indices for loops on the open boundaries.  
     204      !     The loops will be performed only on the processors  
     205      !     that contain a given open boundary. 
     206      ! -------------------------------------------------------- 
     207 
     208      IF( lp_obc_east ) THEN 
     209         ! ...   mpp initialization 
     210         nie0   = max( 1, min(jpieob   - nimpp+1, jpi     ) ) 
     211         nie1   = max( 0, min(jpieob   - nimpp+1, jpi - 1 ) ) 
     212         nie0p1 = max( 1, min(jpieob+1 - nimpp+1, jpi     ) ) 
     213         nie1p1 = max( 0, min(jpieob+1 - nimpp+1, jpi - 1 ) ) 
     214         nie0m1 = max( 1, min(jpieob-1 - nimpp+1, jpi     ) ) 
     215         nie1m1 = max( 0, min(jpieob-1 - nimpp+1, jpi - 1 ) ) 
     216         nje0   = max( 2, min(jpjed    - njmpp+1, jpj     ) ) 
     217         nje1   = max( 0, min(jpjef    - njmpp+1, jpj - 1 ) ) 
     218         nje0p1 = max( 1, min(jpjedp1  - njmpp+1, jpj     ) ) 
     219         nje0m1 = max( 1, min(jpjed    - njmpp+1, jpj     ) ) 
     220         nje1m1 = max( 0, min(jpjefm1  - njmpp+1, jpj - 1 ) ) 
     221         nje1m2 = max( 0, min(jpjefm1-1- njmpp+1, jpj - 1 ) ) 
     222         IF(lwp) THEN 
     223            IF( lfbceast ) THEN 
     224               WRITE(numout,*)'     ' 
     225               WRITE(numout,*)'         Specified East Open Boundary' 
     226            ELSE 
     227               WRITE(numout,*)'     ' 
     228               WRITE(numout,*)'         Radiative East Open Boundary' 
     229            END IF 
     230         END IF 
     231      END IF 
     232 
     233      IF( lp_obc_west ) THEN 
     234         ! ...   mpp initialization 
     235         niw0   = max( 1, min(jpiwob   - nimpp+1, jpi     ) ) 
     236         niw1   = max( 0, min(jpiwob   - nimpp+1, jpi - 1 ) ) 
     237         niw0p1 = max( 1, min(jpiwob+1 - nimpp+1, jpi     ) ) 
     238         niw1p1 = max( 0, min(jpiwob+1 - nimpp+1, jpi - 1 ) ) 
     239         njw0   = max( 2, min(jpjwd    - njmpp+1, jpj     ) ) 
     240         njw1   = max( 0, min(jpjwf    - njmpp+1, jpj - 1 ) ) 
     241         njw0p1 = max( 1, min(jpjwdp1  - njmpp+1, jpj     ) ) 
     242         njw0m1 = max( 1, min(jpjwd    - njmpp+1, jpj     ) ) 
     243         njw1m1 = max( 0, min(jpjwfm1  - njmpp+1, jpj - 1 ) ) 
     244         njw1m2 = max( 0, min(jpjwfm1-1- njmpp+1, jpj - 1 ) ) 
     245         IF(lwp) THEN 
     246            IF( lfbcwest ) THEN 
     247               WRITE(numout,*)'     ' 
     248               WRITE(numout,*)'         Specified West Open Boundary' 
     249            ELSE 
     250               WRITE(numout,*)'     ' 
     251               WRITE(numout,*)'         Radiative West Open Boundary' 
     252            END IF 
     253         END IF 
     254      END IF 
     255  
     256      IF( lp_obc_north ) THEN 
     257         ! ...   mpp initialization 
     258         nin0   = max( 2, min(jpind    - nimpp+1, jpi     ) ) 
     259         nin1   = max( 0, min(jpinf    - nimpp+1, jpi - 1 ) ) 
     260         nin0p1 = max( 1, min(jpindp1  - nimpp+1, jpi     ) ) 
     261         nin0m1 = max( 1, min(jpind    - nimpp+1, jpi     ) ) 
     262         nin1m1 = max( 0, min(jpinfm1  - nimpp+1, jpi - 1 ) ) 
     263         nin1m2 = max( 0, min(jpinfm1-1- nimpp+1, jpi - 1 ) ) 
     264         njn0   = max( 1, min(jpjnob   - njmpp+1, jpj     ) ) 
     265         njn1   = max( 0, min(jpjnob   - njmpp+1, jpj - 1 ) ) 
     266         njn0p1 = max( 1, min(jpjnob+1 - njmpp+1, jpj     ) ) 
     267         njn1p1 = max( 0, min(jpjnob+1 - njmpp+1, jpj - 1 ) ) 
     268         njn0m1 = max( 1, min(jpjnob-1 - njmpp+1, jpj     ) ) 
     269         njn1m1 = max( 0, min(jpjnob-1 - njmpp+1, jpj - 1 ) ) 
     270         IF(lwp) THEN 
     271            IF( lfbcnorth ) THEN 
     272               WRITE(numout,*)'     ' 
     273               WRITE(numout,*)'         Specified North Open Boundary' 
     274            ELSE 
     275               WRITE(numout,*)'     ' 
     276               WRITE(numout,*)'         Radiative North Open Boundary' 
     277            END IF 
     278         END IF 
     279      END IF 
     280 
     281      IF( lp_obc_south ) THEN 
     282         ! ...   mpp initialization 
     283         nis0   = max( 2, min(jpisd    - nimpp+1, jpi     ) ) 
     284         nis1   = max( 0, min(jpisf    - nimpp+1, jpi - 1 ) ) 
     285         nis0p1 = max( 1, min(jpisdp1  - nimpp+1, jpi     ) ) 
     286         nis0m1 = max( 1, min(jpisd    - nimpp+1, jpi     ) ) 
     287         nis1m1 = max( 0, min(jpisfm1  - nimpp+1, jpi - 1 ) ) 
     288         nis1m2 = max( 0, min(jpisfm1-1- nimpp+1, jpi - 1 ) ) 
     289         njs0   = max( 1, min(jpjsob   - njmpp+1, jpj     ) ) 
     290         njs1   = max( 0, min(jpjsob   - njmpp+1, jpj - 1 ) ) 
     291         njs0p1 = max( 1, min(jpjsob+1 - njmpp+1, jpj     ) ) 
     292         njs1p1 = max( 0, min(jpjsob+1 - njmpp+1, jpj - 1 ) ) 
     293         IF(lwp) THEN 
     294            IF( lfbcsouth ) THEN 
     295               WRITE(numout,*)'     ' 
     296               WRITE(numout,*)'         Specified South Open Boundary' 
     297            ELSE 
     298               WRITE(numout,*)'     ' 
     299               WRITE(numout,*)'         Radiative South Open Boundary' 
     300            END IF 
     301         END IF 
     302      END IF 
     303 
     304      ! 3. mask correction for OBCs 
     305      ! --------------------------- 
     306 
     307      IF( lp_obc_east ) THEN 
     308         !... (jpjed,jpjefm1),jpieob 
     309         bmask(nie0p1:nie1p1,nje0:nje1m1) = 0.e0 
     310 
     311         ! ... initilization to zero 
     312         uemsk(:,:) = 0.e0   ;   vemsk(:,:) = 0.e0   ;   temsk(:,:) = 0.e0 
     313 
     314         ! ... set 2D mask on East OBC,  Vopt 
     315         DO ji = fs_nie0, fs_nie1 
     316            DO jj = nje0, nje1 
     317               uemsk(jj,:) = umask(ji,  jj,:) * tmask_i(ji,jj)   * tmask_i(ji+1,jj) 
     318               vemsk(jj,:) = vmask(ji+1,jj,:) * tmask_i(ji+1,jj)  
     319               temsk(jj,:) = tmask(ji+1,jj,:) * tmask_i(ji+1,jj)  
     320            END DO 
     321         END DO 
     322 
     323      END IF 
     324 
     325      IF( lp_obc_west ) THEN 
     326         ! ... (jpjwd,jpjwfm1),jpiwob 
     327         bmask(niw0:niw1,njw0:njw1m1) = 0.e0 
     328 
     329         ! ... initilization to zero 
     330         uwmsk(:,:) = 0.e0   ;   vwmsk(:,:) = 0.e0   ;   twmsk(:,:) = 0.e0   
     331 
     332         ! ... set 2D mask on West OBC,  Vopt 
     333         DO ji = fs_niw0, fs_niw1 
     334            DO jj = njw0, njw1 
     335               uwmsk(jj,:) = umask(ji,jj,:) * tmask_i(ji,jj)   * tmask_i(ji+1,jj) 
     336               vwmsk(jj,:) = vmask(ji,jj,:) * tmask_i(ji,jj)   
     337               twmsk(jj,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 
     338            END DO 
     339         END DO 
     340 
     341      END IF 
     342 
     343      IF( lp_obc_north ) THEN 
     344         ! ... jpjnob,(jpind,jpisfm1) 
     345         bmask(nin0:nin1m1,njn0p1:njn1p1) = 0.e0 
     346 
     347         ! ... initilization to zero 
     348         unmsk(:,:) = 0.e0   ;   vnmsk(:,:) = 0.e0   ;   tnmsk(:,:) = 0.e0 
     349 
     350         ! ... set 2D mask on North OBC,  Vopt 
     351         DO jj = fs_njn0, fs_njn1 
     352            DO ji = nin0, nin1 
     353               unmsk(ji,:) = umask(ji,jj+1,:) * tmask_i(ji,jj+1)  
     354               vnmsk(ji,:) = vmask(ji,jj  ,:) * tmask_i(ji,jj)   * tmask_i(ji,jj+1) 
     355               tnmsk(ji,:) = tmask(ji,jj+1,:) * tmask_i(ji,jj+1) 
     356            END DO 
     357         END DO 
     358 
     359      END IF 
     360 
     361      IF( lp_obc_south ) THEN  
     362         ! ... jpjsob,(jpisd,jpisfm1) 
     363         bmask(nis0:nis1m1,njs0:njs1) = 0.e0 
     364 
     365         ! ... initilization to zero 
     366         usmsk(:,:) = 0.e0   ;   vsmsk(:,:) = 0.e0   ;   tsmsk(:,:) = 0.e0 
     367 
     368         ! ... set 2D mask on South OBC,  Vopt 
     369         DO jj = fs_njs0, fs_njs1  
     370            DO ji = nis0, nis1 
     371               usmsk(ji,:) = umask(ji,jj,:) * tmask_i(ji,jj)  
     372               vsmsk(ji,:) = vmask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1) 
     373               tsmsk(ji,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 
     374            END DO 
     375         END DO 
     376 
     377      END IF 
     378 
     379      ! ... Initialize obcumask and obcvmask for the Force filtering  
     380      !     boundary condition in dynspg_flt 
     381      obcumask(:,:) = umask(:,:,1) 
     382      obcvmask(:,:) = vmask(:,:,1) 
     383 
     384      ! ... Initialize obctmsk on overlap region and obcs. This mask 
     385      !     is used in obcvol.F90 to calculate cumulate flux E-P.  
     386      !     obc Tracer point are outside the domain ( U/V obc points) ==> masked by obctmsk 
     387      !     - no flux E-P on obcs and overlap region (jpreci = jprecj = 1) 
     388      obctmsk(:,:) = tmask_i(:,:)      
     389 
     390      IF( lp_obc_east ) THEN 
     391         ! ... East obc Force filtering mask for the grad D 
     392         obcumask(nie0  :nie1  ,nje0p1:nje1m1) = 0.e0 
     393         obcvmask(nie0p1:nie1p1,nje0p1:nje1m1) = 0.e0 
     394         ! ... set to 0 on East OBC 
     395         obctmsk(nie0p1:nie1p1,nje0:nje1) = 0.e0 
     396      END IF 
     397 
     398      IF( lp_obc_west ) THEN 
     399         ! ... West obc Force filtering mask for the grad D 
     400         obcumask(niw0:niw1,njw0:njw1) = 0.e0 
     401         obcvmask(niw0:niw1,njw0:njw1) = 0.e0 
     402         ! ... set to 0 on West OBC 
     403         obctmsk(niw0:niw1,njw0:njw1) = 0.e0 
     404      END IF 
     405 
     406      IF( lp_obc_north ) THEN 
     407         ! ... North obc Force filtering mask for the grad D 
     408         obcumask(nin0p1:nin1m1,njn0p1:njn1p1) = 0.e0 
     409         obcvmask(nin0p1:nin1m1,njn0  :njn1  ) = 0.e0 
     410         ! ... set to 0 on North OBC 
     411         obctmsk(nin0:nin1,njn0p1:njn1p1) = 0.e0 
     412      END IF 
     413 
     414      IF( lp_obc_south ) THEN 
     415         ! ... South obc Force filtering mask for the grad D 
     416         obcumask(nis0p1:nis1m1,njs0:njs1) = 0.e0 
     417         obcvmask(nis0p1:nis1m1,njs0:njs1) = 0.e0 
     418         ! ... set to 0 on South OBC 
     419         obctmsk(nis0:nis1,njs0:njs1) = 0.e0 
     420      END IF 
     421 
     422      ! 3.1 Total lateral surface  
     423      ! ------------------------- 
     424      obcsurftot = 0.e0 
     425 
     426      IF( lp_obc_east ) THEN ! ... East open boundary lateral surface 
     427         DO ji = nie0, nie1 
     428            DO jj = 1, jpj  
     429               obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uemsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     430            END DO 
     431         END DO 
     432      END IF 
     433 
     434      IF( lp_obc_west ) THEN ! ... West open boundary lateral surface 
     435         DO ji = niw0, niw1 
     436            DO jj = 1, jpj  
     437               obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uwmsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     438            END DO 
     439         END DO 
     440      END IF 
     441 
     442      IF( lp_obc_north ) THEN ! ... North open boundary lateral surface 
     443         DO jj = njn0, njn1 
     444            DO ji = 1, jpi 
     445               obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vnmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     446            END DO 
     447         END DO 
     448      END IF 
     449 
     450      IF( lp_obc_south ) THEN ! ... South open boundary lateral surface 
     451         DO jj = njs0, njs1 
     452            DO ji = 1, jpi 
     453               obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vsmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     454            END DO 
     455         END DO 
     456      END IF 
     457 
     458      IF( lk_mpp )   CALL mpp_sum( obcsurftot )   ! sum over the global domain 
     459 
     460      ! 5. Control print on mask  
     461      !    The extremities of the open boundaries must be in land 
     462      !    or else correspond to an "ocean corner" between two open boundaries.  
     463      !    corner 1 is southwest, 2 is south east, 3 is northeast, 4 is northwest.  
     464      ! -------------------------------------------------------------------------- 
     465 
     466      icorner(:)=0 
     467 
     468      ! ... control of the west boundary 
     469      IF( lp_obc_west ) THEN 
     470         IF( jpiwob < 2 .OR.  jpiwob >= jpiglo-2 ) THEN 
     471            WRITE(ctmp1,*) ' jpiwob exceed ', jpiglo-2, 'or less than 2' 
     472            CALL ctl_stop( ctmp1 ) 
     473         END IF 
     474         ztestmask(:)=0. 
     475         DO ji=niw0,niw1 
     476            IF( (njw0 + njmpp - 1) == jpjwd ) ztestmask(1)=ztestmask(1)+ tmask(ji,njw0,1) 
     477            IF( (njw1 + njmpp - 1) == jpjwf ) ztestmask(2)=ztestmask(2)+ tmask(ji,njw1,1) 
     478         END DO 
     479         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain 
     480 
     481         IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 
     482         IF( ztestmask(2) /= 0. ) icorner(4)=icorner(4)+1 
     483      END IF 
     484 
     485      ! ... control of the east boundary 
     486      IF( lp_obc_east ) THEN 
     487         IF( jpieob < 4 .OR.  jpieob >= jpiglo ) THEN 
     488            WRITE(ctmp1,*) ' jpieob exceed ', jpiglo, ' or less than 4' 
     489            CALL ctl_stop( ctmp1 ) 
     490         END IF 
     491         ztestmask(:)=0. 
     492         DO ji=nie0p1,nie1p1 
     493            IF( (nje0 + njmpp - 1) == jpjed ) ztestmask(1)=ztestmask(1)+ tmask(ji,nje0,1) 
     494            IF( (nje1 + njmpp - 1) == jpjef ) ztestmask(2)=ztestmask(2)+ tmask(ji,nje1,1) 
     495         END DO 
     496         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain 
     497 
     498        IF( ztestmask(1) /= 0. ) icorner(2)=icorner(2)+1 
     499        IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 
     500      END IF 
     501 
     502      ! ... control of the north boundary 
     503      IF( lp_obc_north ) THEN 
     504         IF( jpjnob < 4 .OR.  jpjnob >= jpjglo ) THEN 
     505            WRITE(ctmp1,*) 'jpjnob exceed ', jpjglo, ' or less than 4' 
     506            CALL ctl_stop( ctmp1 ) 
     507         END IF 
     508         ztestmask(:)=0. 
     509         DO jj=njn0p1,njn1p1 
     510            IF( (nin0 + nimpp - 1) == jpind ) ztestmask(1)=ztestmask(1)+ tmask(nin0,jj,1) 
     511            IF( (nin1 + nimpp - 1) == jpinf ) ztestmask(2)=ztestmask(2)+ tmask(nin1,jj,1) 
     512         END DO 
     513         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain 
     514 
     515         IF( ztestmask(1) /= 0. ) icorner(4)=icorner(4)+1 
     516         IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 
     517      END IF 
     518 
     519      ! ... control of the south boundary 
     520      IF( lp_obc_south ) THEN 
     521         IF( jpjsob < 2 .OR.  jpjsob >= jpjglo-2 ) THEN 
     522            WRITE(ctmp1,*) ' jpjsob exceed ', jpjglo-2, ' or less than 2' 
     523            CALL ctl_stop( ctmp1 ) 
     524         END IF 
     525         ztestmask(:)=0. 
     526         DO jj=njs0,njs1 
     527            IF( (nis0 + nimpp - 1) == jpisd ) ztestmask(1)=ztestmask(1)+ tmask(nis0,jj,1) 
     528            IF( (nis1 + nimpp - 1) == jpisf ) ztestmask(2)=ztestmask(2)+ tmask(nis1,jj,1) 
     529         END DO 
     530         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain 
     531 
     532         IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 
     533         IF( ztestmask(2) /= 0. ) icorner(2)=icorner(2)+1 
     534      END IF 
     535 
     536      IF( icorner(1) == 2 ) THEN 
     537         IF(lwp) WRITE(numout,*) 
     538         IF(lwp) WRITE(numout,*) ' South West ocean corner, two open boudaries' 
     539         IF(lwp) WRITE(numout,*) ' ========== ' 
     540         IF(lwp) WRITE(numout,*) 
     541         IF( jpisd /= jpiwob.OR.jpjsob /= jpjwd ) & 
     542              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 
     543 
     544      ELSE IF( icorner(1) == 1 ) THEN 
     545         CALL ctl_stop( ' Open boundaries do not fit at SW corner, we stop' ) 
     546      END IF  
     547 
     548      IF( icorner(2) == 2 ) THEN 
     549          IF(lwp) WRITE(numout,*) 
     550          IF(lwp) WRITE(numout,*) ' South East ocean corner, two open boudaries' 
     551          IF(lwp) WRITE(numout,*) ' ========== ' 
     552          IF(lwp) WRITE(numout,*) 
     553          IF( jpisf /= jpieob+1.OR.jpjsob /= jpjed ) & 
     554               &   CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 
     555      ELSE IF( icorner(2) == 1 ) THEN 
     556         CALL ctl_stop( ' Open boundaries do not fit at SE corner, we stop' ) 
     557      END IF  
     558 
     559      IF( icorner(3) == 2 ) THEN 
     560         IF(lwp) WRITE(numout,*) 
     561         IF(lwp) WRITE(numout,*) ' North East ocean corner, two open boudaries' 
     562         IF(lwp) WRITE(numout,*) ' ========== ' 
     563         IF(lwp) WRITE(numout,*) 
     564         IF( jpinf /= jpieob+1 .OR. jpjnob+1 /= jpjef ) & 
     565              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 
     566       ELSE IF( icorner(3) == 1 ) THEN 
     567          CALL ctl_stop( ' Open boundaries do not fit at NE corner, we stop' ) 
     568       END IF  
     569 
     570      IF( icorner(4) == 2 ) THEN 
     571         IF(lwp) WRITE(numout,*) 
     572         IF(lwp) WRITE(numout,*) ' North West ocean corner, two open boudaries' 
     573         IF(lwp) WRITE(numout,*) ' ========== ' 
     574         IF(lwp) WRITE(numout,*) 
     575         IF( jpind /= jpiwob.OR.jpjnob+1 /= jpjwf ) & 
     576              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 
     577       ELSE IF( icorner(4) == 1 ) THEN 
     578          CALL ctl_stop( ' Open boundaries do not fit at NW corner, we stop' ) 
     579       END IF  
     580 
     581      ! 6. Initialization of open boundary variables (u, v, t, s) 
     582      ! -------------------------------------------------------------- 
     583      !   only if at least one boundary is  radiative  
     584      IF ( inumfbc < nbobc .AND.  ln_rstart ) THEN 
     585         !  Restart from restart.obc 
     586         CALL obc_rst_read 
    147587      ELSE 
    148         IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ',nb_obc 
     588 
     589!         ! ... Initialization to zero of radiation arrays. 
     590!         !     Those have dimensions of local subdomains 
     591 
     592          uebnd(:,:,:,:) = 0.e0   ;   unbnd(:,:,:,:) = 0.e0 
     593          vebnd(:,:,:,:) = 0.e0   ;   vnbnd(:,:,:,:) = 0.e0 
     594          tebnd(:,:,:,:) = 0.e0   ;   tnbnd(:,:,:,:) = 0.e0 
     595          sebnd(:,:,:,:) = 0.e0   ;   snbnd(:,:,:,:) = 0.e0 
     596 
     597          uwbnd(:,:,:,:) = 0.e0   ;   usbnd(:,:,:,:) = 0.e0 
     598          vwbnd(:,:,:,:) = 0.e0   ;   vsbnd(:,:,:,:) = 0.e0 
     599          twbnd(:,:,:,:) = 0.e0   ;   tsbnd(:,:,:,:) = 0.e0 
     600          swbnd(:,:,:,:) = 0.e0   ;   ssbnd(:,:,:,:) = 0.e0 
     601 
     602      END IF 
     603 
     604      ! 7. Control print 
     605      ! ----------------------------------------------------------------- 
     606 
     607      ! ... control of the east boundary 
     608      IF( lp_obc_east ) THEN 
     609         istop = 0 
     610         IF( jpieob < 4 .OR.  jpieob >= jpiglo ) THEN 
     611            IF(lwp) WRITE(numout,cform_err) 
     612            IF(lwp) WRITE(numout,*) '            jpieob exceed ', jpim1, ' or less than 4' 
     613            istop = istop + 1 
     614         END IF 
     615 
     616         IF( lk_mpp ) THEN 
     617            ! ...  
     618            IF( nimpp > jpieob-5) THEN 
     619               IF(lwp) WRITE(numout,cform_err) 
     620               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the East OBC' 
     621               IF(lwp) WRITE(numout,*) '        nimpp must be < jpieob-5' 
     622               istop = istop + 1 
     623            ENDIF 
     624         ELSE 
     625 
     626            ! ... stop if  e r r o r (s)   detected 
     627            IF( istop /= 0 ) THEN 
     628               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 
     629               CALL ctl_stop( ctmp1 ) 
     630            ENDIF 
     631         ENDIF 
    149632      ENDIF 
    150633 
    151       DO ib_obc = 1,nb_obc 
    152         IF(lwp) WRITE(numout,*) ' '  
    153         IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_obc,'------'  
    154  
    155         IF( ln_coords_file(ib_obc) ) THEN 
    156            IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_obc)) 
    157         ELSE 
    158            IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.' 
    159         ENDIF 
    160         IF(lwp) WRITE(numout,*) 
    161  
    162         IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution:  ' 
    163         SELECT CASE( nn_dyn2d(ib_obc) )                   
    164           CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    165           CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    166           CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      Flather radiation condition' 
    167           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_dyn2d' ) 
    168         END SELECT 
    169         IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 
    170            SELECT CASE( nn_dyn2d_dta(ib_obc) )                   !  
    171               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for obc data'         
    172               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    173               CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      tidal harmonic forcing taken from file' 
    174               CASE( 3 )      ;   IF(lwp) WRITE(numout,*) '      boundary data AND tidal harmonic forcing taken from files' 
    175               CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 
    176            END SELECT 
    177         ENDIF 
    178         IF(lwp) WRITE(numout,*) 
    179  
    180         IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities:  ' 
    181         SELECT CASE( nn_dyn3d(ib_obc) )                   
    182           CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    183           CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    184           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_dyn3d' ) 
    185         END SELECT 
    186         IF( nn_dyn3d(ib_obc) .gt. 0 ) THEN 
    187            SELECT CASE( nn_dyn3d_dta(ib_obc) )                   !  
    188               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for obc data'         
    189               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    190               CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 
    191            END SELECT 
    192         ENDIF 
    193         IF(lwp) WRITE(numout,*) 
    194  
    195         IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity:  ' 
    196         SELECT CASE( nn_tra(ib_obc) )                   
    197           CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    198           CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    199           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_tra' ) 
    200         END SELECT 
    201         IF( nn_tra(ib_obc) .gt. 0 ) THEN 
    202            SELECT CASE( nn_tra_dta(ib_obc) )                   !  
    203               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for obc data'         
    204               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    205               CASE DEFAULT   ;   CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 
    206            END SELECT 
    207         ENDIF 
    208         IF(lwp) WRITE(numout,*) 
    209  
    210 #if defined key_lim2 
    211         IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
    212         SELECT CASE( nn_ice_lim2(ib_obc) )                   
    213           CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    214           CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    215           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_tra' ) 
    216         END SELECT 
    217         IF( nn_ice_lim2(ib_obc) .gt. 0 ) THEN  
    218            SELECT CASE( nn_ice_lim2_dta(ib_obc) )                   !  
    219               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for obc data'         
    220               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    221               CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim2_dta must be 0 or 1' ) 
    222            END SELECT 
    223         ENDIF 
    224         IF(lwp) WRITE(numout,*) 
    225 #endif 
    226  
    227         IF(lwp) WRITE(numout,*) 'Boundary rim width for the FRS scheme = ', nn_rimwidth(ib_obc) 
    228         IF(lwp) WRITE(numout,*) 
    229  
    230       ENDDO 
    231  
    232      IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
    233        IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 
    234        IF(lwp) WRITE(numout,*) 
    235        SELECT CASE ( nn_volctl ) 
    236          CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will be constant' 
    237          CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will vary according to the surface E-P flux' 
    238          CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 
    239        END SELECT 
    240        IF(lwp) WRITE(numout,*) 
    241      ELSE 
    242        IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 
    243        IF(lwp) WRITE(numout,*) 
    244      ENDIF 
    245  
    246       ! ------------------------------------------------- 
    247       ! Initialise indices arrays for open boundaries 
    248       ! ------------------------------------------------- 
    249  
    250       ! Work out global dimensions of boundary data 
    251       ! --------------------------------------------- 
    252       REWIND( numnam )                     
    253       DO ib_obc = 1, nb_obc 
    254  
    255          jpbdta = 1 
    256          IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Work out size of global arrays from namelist parameters 
    257   
    258             ! No REWIND here because may need to read more than one namobc_index namelist. 
    259             READ  ( numnam, namobc_index ) 
    260  
    261             ! Automatic boundary definition: if nobcsegX = -1 
    262             ! set boundary to whole side of model domain. 
    263             IF( nobcsege == -1 ) THEN 
    264                nobcsege = 1 
    265                jpieob(1) = jpiglo - 1 
    266                jpjedt(1) = 2 
    267                jpjeft(1) = jpjglo - 1 
     634      ! ... control of the west boundary 
     635      IF( lp_obc_west ) THEN 
     636         istop = 0 
     637         IF( jpiwob < 2 .OR.  jpiwob >= jpiglo ) THEN 
     638            IF(lwp) WRITE(numout,cform_err) 
     639            IF(lwp) WRITE(numout,*) '            jpiwob exceed ', jpim1, ' or less than 2' 
     640            istop = istop + 1 
     641         END IF 
     642 
     643         IF( lk_mpp ) THEN 
     644            IF( (nimpp < jpiwob+5) .AND. (nimpp > 1) ) THEN 
     645               IF(lwp) WRITE(numout,cform_err) 
     646               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the West OBC' 
     647               IF(lwp) WRITE(numout,*) '        nimpp must be > jpiwob-5 or =1' 
     648               istop = istop + 1 
    268649            ENDIF 
    269             IF( nobcsegw == -1 ) THEN 
    270                nobcsegw = 1 
    271                jpiwob(1) = 2 
    272                jpjwdt(1) = 2 
    273                jpjwft(1) = jpjglo - 1 
     650         ELSE 
     651    
     652            ! ... stop if  e r r o r (s)   detected 
     653            IF( istop /= 0 ) THEN 
     654               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 
     655               CALL ctl_stop( ctmp1 ) 
    274656            ENDIF 
    275             IF( nobcsegn == -1 ) THEN 
    276                nobcsegn = 1 
    277                jpjnob(1) = jpjglo - 1 
    278                jpindt(1) = 2 
    279                jpinft(1) = jpiglo - 1 
     657         ENDIF 
     658      ENDIF 
     659 
     660      ! control of the north boundary 
     661      IF( lp_obc_north ) THEN 
     662         istop = 0 
     663         IF( jpjnob < 4 .OR.  jpjnob >= jpjglo ) THEN 
     664            IF(lwp) WRITE(numout,cform_err) 
     665            IF(lwp) WRITE(numout,*) '          jpjnob exceed ', jpjm1,' or less than 4' 
     666            istop = istop + 1 
     667         END IF 
     668 
     669         IF( lk_mpp ) THEN 
     670            IF( njmpp > jpjnob-5) THEN 
     671               IF(lwp) WRITE(numout,cform_err) 
     672               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the North OBC' 
     673               IF(lwp) WRITE(numout,*) '        njmpp must be < jpjnob-5' 
     674               istop = istop + 1 
    280675            ENDIF 
    281             IF( nobcsegs == -1 ) THEN 
    282                nobcsegs = 1 
    283                jpjsob(1) = 2 
    284                jpisdt(1) = 2 
    285                jpisft(1) = jpiglo - 1 
     676         ELSE 
     677    
     678            ! ... stop if  e r r o r (s)   detected 
     679            IF( istop /= 0 ) THEN 
     680                WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 
     681               CALL ctl_stop( ctmp1 ) 
     682           ENDIF 
     683         ENDIF 
     684      ENDIF 
     685 
     686      ! control of the south boundary 
     687      IF( lp_obc_south ) THEN 
     688         istop = 0 
     689         IF( jpjsob < 2 .OR. jpjsob >= jpjglo ) THEN 
     690            IF(lwp) WRITE(numout,cform_err) 
     691            IF(lwp) WRITE(numout,*) '          jpjsob exceed ', jpjm1,' or less than 2' 
     692            istop = istop + 1 
     693         END IF 
     694 
     695         IF( lk_mpp ) THEN 
     696            IF( (njmpp < jpjsob+5) .AND. (njmpp > 1) ) THEN 
     697               IF(lwp) WRITE(numout,cform_err) 
     698               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the South OBC' 
     699               IF(lwp) WRITE(numout,*) '        njmpp must be > jpjsob+5 or =1' 
     700               istop = istop + 1 
    286701            ENDIF 
    287  
    288             nblendta(:,ib_obc) = 0 
    289             DO iseg = 1, nobcsege 
    290                igrd = 1 
    291                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg) + 1                
    292                igrd = 2 
    293                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg) + 1                
    294                igrd = 3 
    295                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg)                
    296             ENDDO 
    297             DO iseg = 1, nobcsegw 
    298                igrd = 1 
    299                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg) + 1                
    300                igrd = 2 
    301                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg) + 1                
    302                igrd = 3 
    303                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg)                
    304             ENDDO 
    305             DO iseg = 1, nobcsegn 
    306                igrd = 1 
    307                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg) + 1                
    308                igrd = 2 
    309                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg)                
    310                igrd = 3 
    311                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg) + 1 
    312             ENDDO 
    313             DO iseg = 1, nobcsegs 
    314                igrd = 1 
    315                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) + 1                
    316                igrd = 2 
    317                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) 
    318                igrd = 3 
    319                nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) + 1                
    320             ENDDO 
    321  
    322             nblendta(:,ib_obc) = nblendta(:,ib_obc) * nn_rimwidth(ib_obc) 
    323             jpbdta = MAXVAL(nblendta(:,ib_obc))                
    324  
    325  
    326          ELSE            ! Read size of arrays in boundary coordinates file. 
    327  
    328  
    329             CALL iom_open( cn_coords_file(ib_obc), inum ) 
    330             jpbdta = 1 
    331             DO igrd = 1, jpbgrd 
    332                id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz )   
    333                nblendta(igrd,ib_obc) = kdimsz(1) 
    334                jpbdta = MAX(jpbdta, kdimsz(1)) 
    335             ENDDO 
    336  
    337          ENDIF  
    338  
    339       ENDDO ! ib_obc 
    340  
    341       ! Allocate arrays 
    342       !--------------- 
    343       ALLOCATE( nbidta(jpbdta, jpbgrd, nb_obc), nbjdta(jpbdta, jpbgrd, nb_obc),    & 
    344          &      nbrdta(jpbdta, jpbgrd, nb_obc) ) 
    345  
    346       ALLOCATE( dta_global(jpbdta, 1, jpk) ) 
    347  
    348       ! Calculate global boundary index arrays or read in from file 
    349       !------------------------------------------------------------ 
    350       REWIND( numnam )                     
    351       DO ib_obc = 1, nb_obc 
    352  
    353          IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Calculate global index arrays from namelist parameters 
    354  
    355             ! No REWIND here because may need to read more than one namobc_index namelist. 
    356             READ  ( numnam, namobc_index ) 
    357  
    358             ! Automatic boundary definition: if nobcsegX = -1 
    359             ! set boundary to whole side of model domain. 
    360             IF( nobcsege == -1 ) THEN 
    361                nobcsege = 1 
    362                jpieob(1) = jpiglo - 1 
    363                jpjedt(1) = 2 
    364                jpjeft(1) = jpjglo - 1 
     702         ELSE 
     703    
     704            ! ... stop if  e r r o r (s)   detected 
     705            IF( istop /= 0 ) THEN 
     706               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 
     707               CALL ctl_stop( ctmp1 ) 
    365708            ENDIF 
    366             IF( nobcsegw == -1 ) THEN 
    367                nobcsegw = 1 
    368                jpiwob(1) = 2 
    369                jpjwdt(1) = 2 
    370                jpjwft(1) = jpjglo - 1 
    371             ENDIF 
    372             IF( nobcsegn == -1 ) THEN 
    373                nobcsegn = 1 
    374                jpjnob(1) = jpjglo - 1 
    375                jpindt(1) = 2 
    376                jpinft(1) = jpiglo - 1 
    377             ENDIF 
    378             IF( nobcsegs == -1 ) THEN 
    379                nobcsegs = 1 
    380                jpjsob(1) = 2 
    381                jpisdt(1) = 2 
    382                jpisft(1) = jpiglo - 1 
    383             ENDIF 
    384  
    385             ! ------------ T points ------------- 
    386             igrd = 1   
    387             icount = 0 
    388             DO ir = 1, nn_rimwidth(ib_obc) 
    389                ! east 
    390                DO iseg = 1, nobcsege 
    391                   DO ij = jpjedt(iseg), jpjeft(iseg) 
    392                      icount = icount + 1 
    393                      nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir + 1 
    394                      nbjdta(icount, igrd, ib_obc) = ij 
    395                      nbrdta(icount, igrd, ib_obc) = ir 
    396                   ENDDO 
    397                ENDDO 
    398                ! west 
    399                DO iseg = 1, nobcsegw 
    400                   DO ij = jpjwdt(iseg), jpjwft(iseg) 
    401                      icount = icount + 1 
    402                      nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 
    403                      nbjdta(icount, igrd, ib_obc) = ij 
    404                      nbrdta(icount, igrd, ib_obc) = ir 
    405                   ENDDO 
    406                ENDDO 
    407                ! north 
    408                DO iseg = 1, nobcsegn 
    409                   DO ii = jpindt(iseg), jpinft(iseg) 
    410                      icount = icount + 1 
    411                      nbidta(icount, igrd, ib_obc) = ii 
    412                      nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir + 1 
    413                      nbrdta(icount, igrd, ib_obc) = ir 
    414                   ENDDO 
    415                ENDDO 
    416                ! south 
    417                DO iseg = 1, nobcsegs 
    418                   DO ii = jpisdt(iseg), jpisft(iseg) 
    419                      icount = icount + 1 
    420                      nbidta(icount, igrd, ib_obc) = ii 
    421                      nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 
    422                      nbrdta(icount, igrd, ib_obc) = ir 
    423                   ENDDO 
    424                ENDDO 
    425             ENDDO 
    426  
    427             ! ------------ U points ------------- 
    428             igrd = 2   
    429             icount = 0 
    430             DO ir = 1, nn_rimwidth(ib_obc) 
    431                ! east 
    432                DO iseg = 1, nobcsege 
    433                   DO ij = jpjedt(iseg), jpjeft(iseg) 
    434                      icount = icount + 1 
    435                      nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir 
    436                      nbjdta(icount, igrd, ib_obc) = ij 
    437                      nbrdta(icount, igrd, ib_obc) = ir 
    438                   ENDDO 
    439                ENDDO 
    440                ! west 
    441                DO iseg = 1, nobcsegw 
    442                   DO ij = jpjwdt(iseg), jpjwft(iseg) 
    443                      icount = icount + 1 
    444                      nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 
    445                      nbjdta(icount, igrd, ib_obc) = ij 
    446                      nbrdta(icount, igrd, ib_obc) = ir 
    447                   ENDDO 
    448                ENDDO 
    449                ! north 
    450                DO iseg = 1, nobcsegn 
    451                   DO ii = jpindt(iseg), jpinft(iseg) - 1 
    452                      icount = icount + 1 
    453                      nbidta(icount, igrd, ib_obc) = ii 
    454                      nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir + 1 
    455                      nbrdta(icount, igrd, ib_obc) = ir 
    456                   ENDDO 
    457                ENDDO 
    458                ! south 
    459                DO iseg = 1, nobcsegs 
    460                   DO ii = jpisdt(iseg), jpisft(iseg) - 1 
    461                      icount = icount + 1 
    462                      nbidta(icount, igrd, ib_obc) = ii 
    463                      nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 
    464                      nbrdta(icount, igrd, ib_obc) = ir 
    465                   ENDDO 
    466                ENDDO 
    467             ENDDO 
    468  
    469             ! ------------ V points ------------- 
    470             igrd = 3   
    471             icount = 0 
    472             DO ir = 1, nn_rimwidth(ib_obc) 
    473                ! east 
    474                DO iseg = 1, nobcsege 
    475                   DO ij = jpjedt(iseg), jpjeft(iseg) - 1 
    476                      icount = icount + 1 
    477                      nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir + 1 
    478                      nbjdta(icount, igrd, ib_obc) = ij 
    479                      nbrdta(icount, igrd, ib_obc) = ir 
    480                   ENDDO 
    481                ENDDO 
    482                ! west 
    483                DO iseg = 1, nobcsegw 
    484                   DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 
    485                      icount = icount + 1 
    486                      nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 
    487                      nbjdta(icount, igrd, ib_obc) = ij 
    488                      nbrdta(icount, igrd, ib_obc) = ir 
    489                   ENDDO 
    490                ENDDO 
    491                ! north 
    492                DO iseg = 1, nobcsegn 
    493                   DO ii = jpindt(iseg), jpinft(iseg) 
    494                      icount = icount + 1 
    495                      nbidta(icount, igrd, ib_obc) = ii 
    496                      nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir 
    497                      nbrdta(icount, igrd, ib_obc) = ir 
    498                   ENDDO 
    499                ENDDO 
    500                ! south 
    501                DO iseg = 1, nobcsegs 
    502                   DO ii = jpisdt(iseg), jpisft(iseg) 
    503                      icount = icount + 1 
    504                      nbidta(icount, igrd, ib_obc) = ii 
    505                      nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 
    506                      nbrdta(icount, igrd, ib_obc) = ir 
    507                   ENDDO 
    508                ENDDO 
    509             ENDDO 
    510  
    511          ELSE            ! Read global index arrays from boundary coordinates file. 
    512  
    513             DO igrd = 1, jpbgrd 
    514                CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 
    515                DO ii = 1,nblendta(igrd,ib_obc) 
    516                   nbidta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 
    517                END DO 
    518                CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 
    519                DO ii = 1,nblendta(igrd,ib_obc) 
    520                   nbjdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 
    521                END DO 
    522                CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 
    523                DO ii = 1,nblendta(igrd,ib_obc) 
    524                   nbrdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 
    525                END DO 
    526  
    527                ibr_max = MAXVAL( nbrdta(:,igrd,ib_obc) ) 
    528                IF(lwp) WRITE(numout,*) 
    529                IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max 
    530                IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_obc) 
    531                IF (ibr_max < nn_rimwidth(ib_obc))   & 
    532                      CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_obc) ) 
    533  
    534             END DO 
    535             CALL iom_close( inum ) 
    536  
    537          ENDIF  
    538  
    539       ENDDO  
    540  
    541       ! Work out dimensions of boundary data on each processor 
    542       ! ------------------------------------------------------ 
    543       
    544       iw = mig(1) + 1            ! if monotasking and no zoom, iw=2 
    545       ie = mig(1) + nlci-1 - 1   ! if monotasking and no zoom, ie=jpim1 
    546       is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    547       in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1 
    548  
    549       DO ib_obc = 1, nb_obc 
    550          DO igrd = 1, jpbgrd 
    551             icount  = 0 
    552             icountr = 0 
    553             idx_obc(ib_obc)%nblen(igrd)    = 0 
    554             idx_obc(ib_obc)%nblenrim(igrd) = 0 
    555             DO ib = 1, nblendta(igrd,ib_obc) 
    556                ! check that data is in correct order in file 
    557                ibm1 = MAX(1,ib-1) 
    558                IF(lwp) THEN         ! Since all procs read global data only need to do this check on one proc... 
    559                   IF( nbrdta(ib,igrd,ib_obc) < nbrdta(ibm1,igrd,ib_obc) ) THEN 
    560                      CALL ctl_stop('obc_init : ERROR : boundary data in file must be defined in order of distance from edge nbr.', & 
    561                                    'A utility for re-ordering boundary coordinates and data files exists in CDFTOOLS') 
    562                   ENDIF     
    563                ENDIF 
    564                ! check if point is in local domain 
    565                IF(  nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND.   & 
    566                   & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in       ) THEN 
    567                   ! 
    568                   icount = icount  + 1 
    569                   ! 
    570                   IF( nbrdta(ib,igrd,ib_obc) == 1 )   icountr = icountr+1 
    571                ENDIF 
    572             ENDDO 
    573             idx_obc(ib_obc)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 
    574             idx_obc(ib_obc)%nblen   (igrd) = icount  !: length of boundary data on each proc         
    575          ENDDO  ! igrd 
    576  
    577          ! Allocate index arrays for this boundary set 
    578          !-------------------------------------------- 
    579          ilen1 = MAXVAL(idx_obc(ib_obc)%nblen(:)) 
    580          ALLOCATE( idx_obc(ib_obc)%nbi(ilen1,jpbgrd) ) 
    581          ALLOCATE( idx_obc(ib_obc)%nbj(ilen1,jpbgrd) ) 
    582          ALLOCATE( idx_obc(ib_obc)%nbr(ilen1,jpbgrd) ) 
    583          ALLOCATE( idx_obc(ib_obc)%nbmap(ilen1,jpbgrd) ) 
    584          ALLOCATE( idx_obc(ib_obc)%nbw(ilen1,jpbgrd) ) 
    585          ALLOCATE( idx_obc(ib_obc)%flagu(ilen1) ) 
    586          ALLOCATE( idx_obc(ib_obc)%flagv(ilen1) ) 
    587  
    588          ! Dispatch mapping indices and discrete distances on each processor 
    589          ! ----------------------------------------------------------------- 
    590  
    591          DO igrd = 1, jpbgrd 
    592             icount  = 0 
    593             ! Loop on rimwidth to ensure outermost points come first in the local arrays. 
    594             DO ir=1, nn_rimwidth(ib_obc) 
    595                DO ib = 1, nblendta(igrd,ib_obc) 
    596                   ! check if point is in local domain and equals ir 
    597                   IF(  nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND.   & 
    598                      & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in .AND.   & 
    599                      & nbrdta(ib,igrd,ib_obc) == ir  ) THEN 
    600                      ! 
    601                      icount = icount  + 1 
    602                      idx_obc(ib_obc)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_obc)- mig(1)+1 
    603                      idx_obc(ib_obc)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_obc)- mjg(1)+1 
    604                      idx_obc(ib_obc)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_obc) 
    605                      idx_obc(ib_obc)%nbmap(icount,igrd) = ib 
    606                   ENDIF 
    607                ENDDO 
    608             ENDDO 
    609          ENDDO  
    610  
    611          ! Compute rim weights for FRS scheme 
    612          ! ---------------------------------- 
    613          DO igrd = 1, jpbgrd 
    614             DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 
    615                nbr => idx_obc(ib_obc)%nbr(ib,igrd) 
    616                idx_obc(ib_obc)%nbw(ib,igrd) = 1.- TANH( FLOAT( nbr - 1 ) *0.5 )      ! tanh formulation 
    617 !              idx_obc(ib_obc)%nbw(ib,igrd) = (FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth))**2      ! quadratic 
    618 !              idx_obc(ib_obc)%nbw(ib,igrd) =  FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth)          ! linear 
    619             END DO 
    620          END DO  
    621  
    622       ENDDO 
    623  
    624       ! ------------------------------------------------------ 
    625       ! Initialise masks and find normal/tangential directions 
    626       ! ------------------------------------------------------ 
    627  
    628       ! Read global 2D mask at T-points: obctmask 
    629       ! ----------------------------------------- 
    630       ! obctmask = 1  on the computational domain AND on open boundaries 
    631       !          = 0  elsewhere    
    632   
    633       IF( cp_cfg == "eel" .AND. jp_cfg == 5 ) THEN          ! EEL configuration at 5km resolution 
    634          zmask(         :                ,:) = 0.e0 
    635          zmask(jpizoom+1:jpizoom+jpiglo-2,:) = 1.e0           
    636       ELSE IF( ln_mask_file ) THEN 
    637          CALL iom_open( cn_mask_file, inum ) 
    638          CALL iom_get ( inum, jpdom_data, 'obc_msk', zmask(:,:) ) 
    639          CALL iom_close( inum ) 
    640       ELSE 
    641          zmask(:,:) = 1.e0 
     709         ENDIF 
    642710      ENDIF 
    643  
    644       DO ij = 1, nlcj      ! Save mask over local domain       
    645          DO ii = 1, nlci 
    646             obctmask(ii,ij) = zmask( mig(ii), mjg(ij) ) 
    647          END DO 
    648       END DO 
    649  
    650       ! Derive mask on U and V grid from mask on T grid 
    651       obcumask(:,:) = 0.e0 
    652       obcvmask(:,:) = 0.e0 
    653       DO ij=1, jpjm1 
    654          DO ii=1, jpim1 
    655             obcumask(ii,ij)=obctmask(ii,ij)*obctmask(ii+1, ij ) 
    656             obcvmask(ii,ij)=obctmask(ii,ij)*obctmask(ii  ,ij+1)   
    657          END DO 
    658       END DO 
    659       CALL lbc_lnk( obcumask(:,:), 'U', 1. )   ;   CALL lbc_lnk( obcvmask(:,:), 'V', 1. )      ! Lateral boundary cond. 
    660  
    661  
    662       ! Mask corrections 
    663       ! ---------------- 
    664       DO ik = 1, jpkm1 
    665          DO ij = 1, jpj 
    666             DO ii = 1, jpi 
    667                tmask(ii,ij,ik) = tmask(ii,ij,ik) * obctmask(ii,ij) 
    668                umask(ii,ij,ik) = umask(ii,ij,ik) * obcumask(ii,ij) 
    669                vmask(ii,ij,ik) = vmask(ii,ij,ik) * obcvmask(ii,ij) 
    670                bmask(ii,ij)    = bmask(ii,ij)    * obctmask(ii,ij) 
    671             END DO       
    672          END DO 
    673       END DO 
    674  
    675       DO ik = 1, jpkm1 
    676          DO ij = 2, jpjm1 
    677             DO ii = 2, jpim1 
    678                fmask(ii,ij,ik) = fmask(ii,ij,ik) * obctmask(ii,ij  ) * obctmask(ii+1,ij  )   & 
    679                   &                              * obctmask(ii,ij+1) * obctmask(ii+1,ij+1) 
    680             END DO       
    681          END DO 
    682       END DO 
    683  
    684       tmask_i (:,:) = tmask(:,:,1) * tmask_i(:,:)              
    685       obctmask(:,:) = tmask(:,:,1) 
    686  
    687       ! obc masks and bmask are now set to zero on boundary points: 
    688       igrd = 1       ! In the free surface case, bmask is at T-points 
    689       DO ib_obc = 1, nb_obc 
    690         DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)      
    691           bmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 
    692         ENDDO 
    693       ENDDO 
    694       ! 
    695       igrd = 1 
    696       DO ib_obc = 1, nb_obc 
    697         DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)       
    698           obctmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 
    699         ENDDO 
    700       ENDDO 
    701       ! 
    702       igrd = 2 
    703       DO ib_obc = 1, nb_obc 
    704         DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 
    705           obcumask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 
    706         ENDDO 
    707       ENDDO 
    708       ! 
    709       igrd = 3 
    710       DO ib_obc = 1, nb_obc 
    711         DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 
    712           obcvmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 
    713         ENDDO 
    714       ENDDO 
    715  
    716       ! Lateral boundary conditions 
    717       CALL lbc_lnk( fmask        , 'F', 1. )   ;   CALL lbc_lnk( obctmask(:,:), 'T', 1. ) 
    718       CALL lbc_lnk( obcumask(:,:), 'U', 1. )   ;   CALL lbc_lnk( obcvmask(:,:), 'V', 1. ) 
    719  
    720       DO ib_obc = 1, nb_obc       ! Indices and directions of rim velocity components 
    721  
    722          idx_obc(ib_obc)%flagu(:) = 0.e0 
    723          idx_obc(ib_obc)%flagv(:) = 0.e0 
    724          icount = 0  
    725  
    726          !flagu = -1 : u component is normal to the dynamical boundary but its direction is outward 
    727          !flagu =  0 : u is tangential 
    728          !flagu =  1 : u is normal to the boundary and is direction is inward 
    729    
    730          igrd = 2      ! u-component  
    731          DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)   
    732             nbi => idx_obc(ib_obc)%nbi(ib,igrd) 
    733             nbj => idx_obc(ib_obc)%nbj(ib,igrd) 
    734             zefl = obctmask(nbi  ,nbj) 
    735             zwfl = obctmask(nbi+1,nbj) 
    736             IF( zefl + zwfl == 2 ) THEN 
    737                icount = icount + 1 
    738             ELSE 
    739                idx_obc(ib_obc)%flagu(ib)=-zefl+zwfl 
    740             ENDIF 
    741          END DO 
    742  
    743          !flagv = -1 : u component is normal to the dynamical boundary but its direction is outward 
    744          !flagv =  0 : u is tangential 
    745          !flagv =  1 : u is normal to the boundary and is direction is inward 
    746  
    747          igrd = 3      ! v-component 
    748          DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)   
    749             nbi => idx_obc(ib_obc)%nbi(ib,igrd) 
    750             nbj => idx_obc(ib_obc)%nbj(ib,igrd) 
    751             znfl = obctmask(nbi,nbj  ) 
    752             zsfl = obctmask(nbi,nbj+1) 
    753             IF( znfl + zsfl == 2 ) THEN 
    754                icount = icount + 1 
    755             ELSE 
    756                idx_obc(ib_obc)%flagv(ib) = -znfl + zsfl 
    757             END IF 
    758          END DO 
    759   
    760          IF( icount /= 0 ) THEN 
    761             IF(lwp) WRITE(numout,*) 
    762             IF(lwp) WRITE(numout,*) ' E R R O R : Some data velocity points,',   & 
    763                ' are not boundary points. Check nbi, nbj, indices for boundary set ',ib_obc 
    764             IF(lwp) WRITE(numout,*) ' ========== ' 
    765             IF(lwp) WRITE(numout,*) 
    766             nstop = nstop + 1 
    767          ENDIF  
    768      
    769       ENDDO 
    770  
    771       ! Compute total lateral surface for volume correction: 
    772       ! ---------------------------------------------------- 
    773       obcsurftot = 0.e0  
    774       IF( ln_vol ) THEN   
    775          igrd = 2      ! Lateral surface at U-points 
    776          DO ib_obc = 1, nb_obc 
    777             DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 
    778                nbi => idx_obc(ib_obc)%nbi(ib,igrd) 
    779                nbj => idx_obc(ib_obc)%nbi(ib,igrd) 
    780                flagu => idx_obc(ib_obc)%flagu(ib) 
    781                obcsurftot = obcsurftot + hu     (nbi  , nbj)                           & 
    782                   &                    * e2u    (nbi  , nbj) * ABS( flagu ) & 
    783                   &                    * tmask_i(nbi  , nbj)                           & 
    784                   &                    * tmask_i(nbi+1, nbj)                    
    785             ENDDO 
    786          ENDDO 
    787  
    788          igrd=3 ! Add lateral surface at V-points 
    789          DO ib_obc = 1, nb_obc 
    790             DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 
    791                nbi => idx_obc(ib_obc)%nbi(ib,igrd) 
    792                nbj => idx_obc(ib_obc)%nbi(ib,igrd) 
    793                flagv => idx_obc(ib_obc)%flagv(ib) 
    794                obcsurftot = obcsurftot + hv     (nbi, nbj  )                           & 
    795                   &                    * e1v    (nbi, nbj  ) * ABS( flagv ) & 
    796                   &                    * tmask_i(nbi, nbj  )                           & 
    797                   &                    * tmask_i(nbi, nbj+1) 
    798             ENDDO 
    799          ENDDO 
    800          ! 
    801          IF( lk_mpp )   CALL mpp_sum( obcsurftot )      ! sum over the global domain 
    802       END IF    
    803       ! 
    804       ! Tidy up 
    805       !-------- 
    806       DEALLOCATE(nbidta, nbjdta, nbrdta) 
    807711 
    808712   END SUBROUTINE obc_init 
    … …  
    810714#else 
    811715   !!--------------------------------------------------------------------------------- 
    812    !!   Dummy module                                   NO open boundaries 
     716   !!   Dummy module                                                NO open boundaries 
    813717   !!--------------------------------------------------------------------------------- 
    814718CONTAINS 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcrad.F90

    r2797 r2888  
    55   !!================================================================================= 
    66#if defined key_obc 
    7 !!$   !!--------------------------------------------------------------------------------- 
    8 !!$   !!   obc_rad        : call the subroutine for each open boundary 
    9 !!$   !!   obc_rad_east   : compute the east phase velocities 
    10 !!$   !!   obc_rad_west   : compute the west phase velocities 
    11 !!$   !!   obc_rad_north  : compute the north phase velocities 
    12 !!$   !!   obc_rad_south  : compute the south phase velocities 
    13 !!$   !!--------------------------------------------------------------------------------- 
    14 !!$   USE oce             ! ocean dynamics and tracers variables 
    15 !!$   USE dom_oce         ! ocean space and time domain variables 
    16 !!$   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    17 !!$   USE phycst          ! physical constants 
    18 !!$   USE obc_oce         ! ocean open boundary conditions 
    19 !!$   USE lib_mpp         ! for mppobc 
    20 !!$   USE in_out_manager  ! I/O units 
    21 !!$ 
    22 !!$   IMPLICIT NONE 
    23 !!$   PRIVATE 
    24 !!$ 
    25 !!$   PUBLIC   obc_rad    ! routine called by step.F90 
    26 !!$ 
    27 !!$   INTEGER ::   ji, jj, jk     ! dummy loop indices 
    28 !!$ 
    29 !!$   INTEGER ::      & ! ... boundary space indices  
    30 !!$      nib   = 1,   & ! nib   = boundary point 
    31 !!$      nibm  = 2,   & ! nibm  = 1st interior point 
    32 !!$      nibm2 = 3,   & ! nibm2 = 2nd interior point 
    33 !!$                     ! ... boundary time indices  
    34 !!$      nit   = 1,   & ! nit    = now 
    35 !!$      nitm  = 2,   & ! nitm   = before 
    36 !!$      nitm2 = 3      ! nitm2  = before-before 
    37 !!$ 
    38 !!$   !! * Substitutions 
    39 !!$#  include "obc_vectopt_loop_substitute.h90" 
    40 !!$   !!--------------------------------------------------------------------------------- 
    41 !!$   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    42 !!$   !! $Id$  
    43 !!$   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    44 !!$   !!--------------------------------------------------------------------------------- 
    45 !!$ 
    46 !!$CONTAINS 
    47 !!$ 
    48 !!$   SUBROUTINE obc_rad ( kt ) 
    49 !!$      !!------------------------------------------------------------------------------ 
    50 !!$      !!                     SUBROUTINE obc_rad 
    51 !!$      !!                    ******************** 
    52 !!$      !! ** Purpose : 
    53 !!$      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
    54 !!$      !!      boundaries and calculate those phase speeds if the open boundaries are  
    55 !!$      !!      not fixed. In case of fixed open boundaries does nothing. 
    56 !!$      !! 
    57 !!$      !!     The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 
    58 !!$      !!     and/or lp_obc_south allow the user to determine which boundary is an 
    59 !!$      !!     open one (must be done in the param_obc.h90 file). 
    60 !!$      !!  
    61 !!$      !! ** Reference :  
    62 !!$      !!     Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 
    63 !!$      !! 
    64 !!$      !!  History : 
    65 !!$      !!    8.5  !  02-10  (C. Talandier, A-M. Treguier) Free surface, F90 from the  
    66 !!$      !!                                                 J. Molines and G. Madec version 
    67 !!$      !!------------------------------------------------------------------------------ 
    68 !!$      INTEGER, INTENT( in ) ::   kt 
    69 !!$      !!---------------------------------------------------------------------- 
    70 !!$ 
    71 !!$      IF( lp_obc_east  .AND. .NOT.lfbceast  )   CALL obc_rad_east ( kt )   ! East open boundary 
    72 !!$ 
    73 !!$      IF( lp_obc_west  .AND. .NOT.lfbcwest  )   CALL obc_rad_west ( kt )   ! West open boundary 
    74 !!$ 
    75 !!$      IF( lp_obc_north .AND. .NOT.lfbcnorth )   CALL obc_rad_north( kt )   ! North open boundary 
    76 !!$ 
    77 !!$      IF( lp_obc_south .AND. .NOT.lfbcsouth )   CALL obc_rad_south( kt )   ! South open boundary 
    78 !!$ 
    79 !!$   END SUBROUTINE obc_rad 
    80 !!$ 
    81 !!$ 
    82 !!$   SUBROUTINE obc_rad_east ( kt ) 
    83 !!$      !!------------------------------------------------------------------------------ 
    84 !!$      !!                     ***  SUBROUTINE obc_rad_east  *** 
    85 !!$      !!                    
    86 !!$      !! ** Purpose : 
    87 !!$      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
    88 !!$      !!      east boundary and calculate those phase speeds if this OBC is not fixed. 
    89 !!$      !!      In case of fixed OBC, this subrountine is not called. 
    90 !!$      !! 
    91 !!$      !!  History : 
    92 !!$      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
    93 !!$      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
    94 !!$      !!         ! 97-12 (M. Imbard) Mpp adaptation 
    95 !!$      !!         ! 00-06 (J.-M. Molines)  
    96 !!$      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
    97 !!$      !!------------------------------------------------------------------------------ 
    98 !!$      !! * Arguments 
    99 !!$      INTEGER, INTENT( in ) ::   kt 
    100 !!$ 
    101 !!$      !! * Local declarations 
    102 !!$      INTEGER  ::   ij 
    103 !!$      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
    104 !!$      REAL(wp) ::   zucb, zucbm, zucbm2 
    105 !!$      !!------------------------------------------------------------------------------ 
    106 !!$ 
    107 !!$      ! 1. Swap arrays before calculating radiative velocities 
    108 !!$      ! ------------------------------------------------------ 
    109 !!$ 
    110 !!$      ! 1.1  zonal velocity  
    111 !!$      ! ------------------- 
    112 !!$ 
    113 !!$      IF( kt > nit000 .OR. ln_rstart ) THEN  
    114 !!$ 
    115 !!$         ! ... advance in time (time filter, array swap)  
    116 !!$         DO jk = 1, jpkm1 
    117 !!$            DO jj = 1, jpj 
    118 !!$               uebnd(jj,jk,nib  ,nitm2) = uebnd(jj,jk,nib  ,nitm)*uemsk(jj,jk) 
    119 !!$               uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk) 
    120 !!$               uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk) 
    121 !!$            END DO 
    122 !!$         END DO 
    123 !!$         ! ... fields nitm <== nit  plus time filter at the boundary  
    124 !!$         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
    125 !!$            DO jk = 1, jpkm1 
    126 !!$               DO jj = 1, jpj 
    127 !!$                  uebnd(jj,jk,nib  ,nitm) = uebnd(jj,jk,nib,  nit)*uemsk(jj,jk) 
    128 !!$                  uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk) 
    129 !!$                  uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk) 
    130 !!$         ! ... fields nit <== now (kt+1)  
    131 !!$         ! ... Total or baroclinic velocity at b, bm and bm2 
    132 !!$                  zucb   = un(ji,jj,jk) 
    133 !!$                  zucbm  = un(ji-1,jj,jk) 
    134 !!$                  zucbm2 = un(ji-2,jj,jk) 
    135 !!$                  uebnd(jj,jk,nib  ,nit) = zucb   *uemsk(jj,jk) 
    136 !!$                  uebnd(jj,jk,nibm ,nit) = zucbm  *uemsk(jj,jk)  
    137 !!$                  uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk)  
    138 !!$               END DO 
    139 !!$            END DO 
    140 !!$         END DO 
    141 !!$         IF( lk_mpp )   CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout ) 
    142 !!$ 
    143 !!$         ! ... extremeties nie0, nie1 
    144 !!$         ij = jpjed +1 - njmpp 
    145 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    146 !!$            DO jk = 1,jpkm1 
    147 !!$               uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm) 
    148 !!$            END DO 
    149 !!$         END IF 
    150 !!$         ij = jpjef +1 - njmpp 
    151 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    152 !!$            DO jk = 1,jpkm1 
    153 !!$               uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm) 
    154 !!$            END DO 
    155 !!$         END IF 
    156 !!$ 
    157 !!$         ! 1.2 tangential velocity 
    158 !!$         ! ----------------------- 
    159 !!$ 
    160 !!$         ! ... advance in time (time filter, array swap) 
    161 !!$         DO jk = 1, jpkm1 
    162 !!$            DO jj = 1, jpj 
    163 !!$         ! ... fields nitm2 <== nitm 
    164 !!$               vebnd(jj,jk,nib  ,nitm2) = vebnd(jj,jk,nib  ,nitm)*vemsk(jj,jk) 
    165 !!$               vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk) 
    166 !!$               vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk) 
    167 !!$            END DO 
    168 !!$         END DO 
    169 !!$ 
    170 !!$         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
    171 !!$            DO jk = 1, jpkm1 
    172 !!$               DO jj = 1, jpj 
    173 !!$                  vebnd(jj,jk,nib  ,nitm) = vebnd(jj,jk,nib,  nit)*vemsk(jj,jk) 
    174 !!$                  vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk) 
    175 !!$                  vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk) 
    176 !!$         ! ... fields nit <== now (kt+1) 
    177 !!$                  vebnd(jj,jk,nib  ,nit) = vn(ji  ,jj,jk)*vemsk(jj,jk) 
    178 !!$                  vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk) 
    179 !!$                  vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk) 
    180 !!$               END DO 
    181 !!$            END DO 
    182 !!$         END DO 
    183 !!$         IF( lk_mpp )   CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout ) 
    184 !!$ 
    185 !!$         !... extremeties nie0, nie1 
    186 !!$         ij = jpjed +1 - njmpp 
    187 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    188 !!$            DO jk = 1,jpkm1 
    189 !!$               vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm) 
    190 !!$            END DO  
    191 !!$         END IF  
    192 !!$         ij = jpjef +1 - njmpp  
    193 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
    194 !!$            DO jk = 1,jpkm1  
    195 !!$               vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm) 
    196 !!$            END DO  
    197 !!$         END IF  
    198 !!$ 
    199 !!$         ! 1.3 Temperature and salinity 
    200 !!$         ! ---------------------------- 
    201 !!$ 
    202 !!$         ! ... advance in time (time filter, array swap) 
    203 !!$         DO jk = 1, jpkm1 
    204 !!$            DO jj = 1, jpj 
    205 !!$         ! ... fields nitm <== nit  plus time filter at the boundary 
    206 !!$               tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk) 
    207 !!$               sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk) 
    208 !!$            END DO 
    209 !!$         END DO 
    210 !!$ 
    211 !!$         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
    212 !!$            DO jk = 1, jpkm1 
    213 !!$               DO jj = 1, jpj 
    214 !!$                  tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
    215 !!$                  sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
    216 !!$         ! ... fields nit <== now (kt+1) 
    217 !!$                  tebnd(jj,jk,nib  ,nit) = tn(ji  ,jj,jk)*temsk(jj,jk) 
    218 !!$                  tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk) 
    219 !!$                  sebnd(jj,jk,nib  ,nit) = sn(ji  ,jj,jk)*temsk(jj,jk) 
    220 !!$                  sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk) 
    221 !!$               END DO 
    222 !!$            END DO 
    223 !!$         END DO 
    224 !!$         IF( lk_mpp )   CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 
    225 !!$         IF( lk_mpp )   CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 
    226 !!$ 
    227 !!$         ! ... extremeties nie0, nie1 
    228 !!$         ij = jpjed +1 - njmpp 
    229 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    230 !!$            DO jk = 1,jpkm1 
    231 !!$               tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm) 
    232 !!$               sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm) 
    233 !!$            END DO 
    234 !!$         END IF 
    235 !!$         ij = jpjef +1 - njmpp 
    236 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    237 !!$            DO jk = 1,jpkm1 
    238 !!$               tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm) 
    239 !!$               sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm) 
    240 !!$            END DO 
    241 !!$         END IF 
    242 !!$ 
    243 !!$      END IF     ! End of array swap 
    244 !!$ 
    245 !!$      ! 2 - Calculation of radiation velocities 
    246 !!$      ! --------------------------------------- 
    247 !!$ 
    248 !!$      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
    249 !!$ 
    250 !!$         ! 2.1  Calculate the normal velocity U based on phase velocity u_cxebnd 
    251 !!$         ! --------------------------------------------------------------------- 
    252 !!$         ! 
    253 !!$         !          nibm2      nibm      nib 
    254 !!$         !            |  nibm   |   nib   |/// 
    255 !!$         !            |    |    |    |    |/// 
    256 !!$         !  jj-line --f----v----f----v----f--- 
    257 !!$         !            |    |    |    |    |/// 
    258 !!$         !            |         |         |/// 
    259 !!$         !  jj-line   u    T    u    T    u/// 
    260 !!$         !            |         |         |/// 
    261 !!$         !            |    |    |    |    |/// 
    262 !!$         !          jpieob-2   jpieob-1   jpieob 
    263 !!$         !                 |         |         
    264 !!$         !              jpieob-1    jpieob       
    265 !!$         ! 
    266 !!$         ! ... (jpjedp1, jpjefm1),jpieob 
    267 !!$         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
    268 !!$            DO jk = 1, jpkm1 
    269 !!$               DO jj = 2, jpjm1 
    270 !!$         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
    271 !!$                  z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) & 
    272 !!$                           - 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj) 
    273 !!$         ! ... 2* gradj(u) (u-point i=nibm, time nitm) 
    274 !!$                  z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj) 
    275 !!$         ! ... square of the norm of grad(u) 
    276 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    277 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    278 !!$                  zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit) 
    279 !!$         ! ... i-phase speed ratio (bounded by 1)                
    280 !!$                  IF( z4nor2 == 0. ) THEN 
    281 !!$                     z4nor2=.00001 
    282 !!$                  END IF 
    283 !!$                  z05cx = zdt * z2dx / z4nor2 
    284 !!$                  u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk) 
    285 !!$               END DO 
    286 !!$            END DO 
    287 !!$         END DO 
    288 !!$ 
    289 !!$         ! 2.2  Calculate the tangential velocity based on phase velocity v_cxebnd 
    290 !!$         ! ----------------------------------------------------------------------- 
    291 !!$         ! 
    292 !!$         !          nibm2      nibm      nib 
    293 !!$         !            |   nibm  |   nib///|/// 
    294 !!$         !            |    |    |    |////|/// 
    295 !!$         !  jj-line --v----f----v----f----v--- 
    296 !!$         !            |    |    |    |////|/// 
    297 !!$         !            |    |    |    |////|/// 
    298 !!$         !            | jpieob-1| jpieob /|/// 
    299 !!$         !            |         |         |    
    300 !!$         !         jpieob-1    jpieob     jpieob+1 
    301 !!$         ! 
    302 !!$         ! ... (jpjedp1, jpjefm1), jpieob+1 
    303 !!$         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
    304 !!$            DO jk = 1, jpkm1 
    305 !!$               DO jj = 2, jpjm1 
    306 !!$         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
    307 !!$                  z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) & 
    308 !!$                          - 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj) 
    309 !!$         ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 
    310 !!$                  z2dy = ( vebnd(jj+1,jk,nibm,nitm) -  vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj) 
    311 !!$         ! ... square of the norm of grad(v) 
    312 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    313 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    314 !!$                  zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit) 
    315 !!$         ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 
    316 !!$         !     velocity ratio no divided by e1f for the tracer radiation 
    317 !!$                  IF( z4nor2 == 0. ) THEN 
    318 !!$                     z4nor2=.000001 
    319 !!$                  END IF 
    320 !!$                  z05cx = zdt * z2dx / z4nor2 
    321 !!$                  v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk) 
    322 !!$               END DO 
    323 !!$            END DO 
    324 !!$         END DO 
    325 !!$         IF( lk_mpp )   CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout ) 
    326 !!$ 
    327 !!$         ! ... extremeties nie0, nie1 
    328 !!$         ij = jpjed +1 - njmpp 
    329 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    330 !!$            DO jk = 1,jpkm1 
    331 !!$               v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk) 
    332 !!$            END DO 
    333 !!$         END IF 
    334 !!$         ij = jpjef +1 - njmpp 
    335 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    336 !!$            DO jk = 1,jpkm1 
    337 !!$               v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk) 
    338 !!$            END DO 
    339 !!$         END IF 
    340 !!$ 
    341 !!$      END IF 
    342 !!$ 
    343 !!$   END SUBROUTINE obc_rad_east 
    344 !!$ 
    345 !!$ 
    346 !!$   SUBROUTINE obc_rad_west ( kt ) 
    347 !!$      !!------------------------------------------------------------------------------ 
    348 !!$      !!                  ***  SUBROUTINE obc_rad_west  *** 
    349 !!$      !!                     
    350 !!$      !! ** Purpose : 
    351 !!$      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
    352 !!$      !!      west boundary and calculate those phase speeds if this OBC is not fixed. 
    353 !!$      !!      In case of fixed OBC, this subrountine is not called. 
    354 !!$      !! 
    355 !!$      !!  History : 
    356 !!$      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
    357 !!$      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
    358 !!$      !!         ! 97-12 (M. Imbard) Mpp adaptation 
    359 !!$      !!         ! 00-06 (J.-M. Molines)  
    360 !!$      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
    361 !!$      !!------------------------------------------------------------------------------ 
    362 !!$      !! * Arguments 
    363 !!$      INTEGER, INTENT( in ) ::   kt 
    364 !!$ 
    365 !!$      !! * Local declarations 
    366 !!$      INTEGER ::   ij 
    367 !!$      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
    368 !!$      REAL(wp) ::   zucb, zucbm, zucbm2 
    369 !!$      !!------------------------------------------------------------------------------ 
    370 !!$ 
    371 !!$      ! 1. Swap arrays before calculating radiative velocities 
    372 !!$      ! ------------------------------------------------------ 
    373 !!$ 
    374 !!$      ! 1.1  zonal velocity  
    375 !!$      ! ------------------- 
    376 !!$ 
    377 !!$      IF( kt > nit000 .OR. ln_rstart ) THEN 
    378 !!$ 
    379 !!$         ! ... advance in time (time filter, array swap)  
    380 !!$         DO jk = 1, jpkm1 
    381 !!$            DO jj = 1, jpj  
    382 !!$               uwbnd(jj,jk,nib  ,nitm2) = uwbnd(jj,jk,nib  ,nitm)*uwmsk(jj,jk) 
    383 !!$               uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk) 
    384 !!$               uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk) 
    385 !!$            END DO 
    386 !!$         END DO 
    387 !!$ 
    388 !!$         ! ... fields nitm <== nit  plus time filter at the boundary  
    389 !!$         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    390 !!$            DO jk = 1, jpkm1 
    391 !!$               DO jj = 1, jpj 
    392 !!$                  uwbnd(jj,jk,nib  ,nitm) = uwbnd(jj,jk,nib  ,nit)*uwmsk(jj,jk) 
    393 !!$                  uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk) 
    394 !!$                  uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk) 
    395 !!$         ! ... total or baroclinic velocity at b, bm and bm2 
    396 !!$                  zucb   = un (ji,jj,jk) 
    397 !!$                  zucbm  = un (ji+1,jj,jk) 
    398 !!$                  zucbm2 = un (ji+2,jj,jk) 
    399 !!$ 
    400 !!$         ! ... fields nit <== now (kt+1)  
    401 !!$                  uwbnd(jj,jk,nib  ,nit) = zucb  *uwmsk(jj,jk) 
    402 !!$                  uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk) 
    403 !!$                  uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk) 
    404 !!$               END DO 
    405 !!$            END DO 
    406 !!$         END DO 
    407 !!$         IF( lk_mpp )   CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 
    408 !!$ 
    409 !!$         ! ... extremeties niw0, niw1 
    410 !!$         ij = jpjwd +1 - njmpp 
    411 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    412 !!$            DO jk = 1,jpkm1 
    413 !!$               uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm) 
    414 !!$            END DO 
    415 !!$         END IF 
    416 !!$         ij = jpjwf +1 - njmpp 
    417 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    418 !!$            DO jk = 1,jpkm1 
    419 !!$               uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm) 
    420 !!$            END DO 
    421 !!$         END IF 
    422 !!$ 
    423 !!$         ! 1.2 tangential velocity 
    424 !!$         ! ----------------------- 
    425 !!$ 
    426 !!$         ! ... advance in time (time filter, array swap) 
    427 !!$         DO jk = 1, jpkm1 
    428 !!$            DO jj = 1, jpj  
    429 !!$         ! ... fields nitm2 <== nitm 
    430 !!$                  vwbnd(jj,jk,nib  ,nitm2) = vwbnd(jj,jk,nib  ,nitm)*vwmsk(jj,jk) 
    431 !!$                  vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk) 
    432 !!$                  vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk) 
    433 !!$            END DO 
    434 !!$         END DO 
    435 !!$ 
    436 !!$         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    437 !!$            DO jk = 1, jpkm1 
    438 !!$               DO jj = 1, jpj 
    439 !!$                  vwbnd(jj,jk,nib  ,nitm) = vwbnd(jj,jk,nib,  nit)*vwmsk(jj,jk) 
    440 !!$                  vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk) 
    441 !!$                  vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk) 
    442 !!$         ! ... fields nit <== now (kt+1) 
    443 !!$                  vwbnd(jj,jk,nib  ,nit) = vn(ji  ,jj,jk)*vwmsk(jj,jk) 
    444 !!$                  vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk) 
    445 !!$                  vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk) 
    446 !!$               END DO 
    447 !!$            END DO 
    448 !!$         END DO 
    449 !!$         IF( lk_mpp )   CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 
    450 !!$ 
    451 !!$         ! ... extremeties niw0, niw1  
    452 !!$         ij = jpjwd +1 - njmpp  
    453 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
    454 !!$            DO jk = 1,jpkm1  
    455 !!$               vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm) 
    456 !!$            END DO  
    457 !!$         END IF 
    458 !!$         ij = jpjwf +1 - njmpp  
    459 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
    460 !!$            DO jk = 1,jpkm1  
    461 !!$               vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm) 
    462 !!$            END DO  
    463 !!$         END IF  
    464 !!$  
    465 !!$         ! 1.3 Temperature and salinity 
    466 !!$         ! ---------------------------- 
    467 !!$  
    468 !!$         ! ... advance in time (time filter, array swap) 
    469 !!$         DO jk = 1, jpkm1 
    470 !!$            DO jj = 1, jpj 
    471 !!$         ! ... fields nitm <== nit  plus time filter at the boundary 
    472 !!$               twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk) 
    473 !!$               swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk) 
    474 !!$            END DO 
    475 !!$         END DO 
    476 !!$  
    477 !!$         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    478 !!$            DO jk = 1, jpkm1 
    479 !!$               DO jj = 1, jpj 
    480 !!$                  twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
    481 !!$                  swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
    482 !!$         ! ... fields nit <== now (kt+1) 
    483 !!$                  twbnd(jj,jk,nib  ,nit) = tn(ji   ,jj,jk)*twmsk(jj,jk) 
    484 !!$                  twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk) 
    485 !!$                  swbnd(jj,jk,nib  ,nit) = sn(ji   ,jj,jk)*twmsk(jj,jk) 
    486 !!$                  swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk) 
    487 !!$               END DO 
    488 !!$            END DO 
    489 !!$         END DO 
    490 !!$         IF( lk_mpp )   CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 
    491 !!$         IF( lk_mpp )   CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 
    492 !!$ 
    493 !!$         ! ... extremeties niw0, niw1 
    494 !!$         ij = jpjwd +1 - njmpp 
    495 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    496 !!$            DO jk = 1,jpkm1 
    497 !!$               twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm) 
    498 !!$               swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm) 
    499 !!$            END DO 
    500 !!$         END IF 
    501 !!$         ij = jpjwf +1 - njmpp 
    502 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    503 !!$            DO jk = 1,jpkm1 
    504 !!$               twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm) 
    505 !!$               swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm) 
    506 !!$            END DO 
    507 !!$         END IF 
    508 !!$  
    509 !!$      END IF     ! End of array swap 
    510 !!$ 
    511 !!$      ! 2 - Calculation of radiation velocities 
    512 !!$      ! --------------------------------------- 
    513 !!$    
    514 !!$      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
    515 !!$   
    516 !!$         ! 2.1  Calculate the normal velocity U based on phase velocity u_cxwbnd 
    517 !!$         ! ---------------------------------------------------------------------- 
    518 !!$         ! 
    519 !!$         !          nib       nibm      nibm2 
    520 !!$         !        ///|   nib   |   nibm  | 
    521 !!$         !        ///|    |    |    |    | 
    522 !!$         !        ---f----v----f----v----f-- jj-line 
    523 !!$         !        ///|    |    |    |    | 
    524 !!$         !        ///|         |         | 
    525 !!$         !        ///u    T    u    T    u   jj-line 
    526 !!$         !        ///|         |         | 
    527 !!$         !        ///|    |    |    |    | 
    528 !!$         !         jpiwob    jpiwob+1    jpiwob+2 
    529 !!$         !                |         |         
    530 !!$         !              jpiwob+1    jpiwob+2      
    531 !!$         ! 
    532 !!$         ! ... If free surface formulation: 
    533 !!$         ! ... radiative conditions on the total part + relaxation toward climatology 
    534 !!$         ! ... (jpjwdp1, jpjwfm1), jpiwob 
    535 !!$         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    536 !!$            DO jk = 1, jpkm1 
    537 !!$               DO jj = 2, jpjm1 
    538 !!$         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
    539 !!$                  z2dx = ( - uwbnd(jj,jk,nibm ,nit) -  uwbnd(jj,jk,nibm ,nitm2) & 
    540 !!$                           + 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj) 
    541 !!$         ! ... 2* gradj(u) (u-point i=nibm, time nitm) 
    542 !!$                  z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj) 
    543 !!$         ! ... square of the norm of grad(u) 
    544 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    545 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    546 !!$                  zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit) 
    547 !!$         ! ... i-phase speed ratio (bounded by -1) 
    548 !!$                  IF( z4nor2 == 0. ) THEN 
    549 !!$                     z4nor2=0.00001 
    550 !!$                  END IF 
    551 !!$                  z05cx = zdt * z2dx / z4nor2 
    552 !!$                  u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk) 
    553 !!$               END DO 
    554 !!$            END DO 
    555 !!$         END DO 
    556 !!$ 
    557 !!$         ! 2.2  Calculate the tangential velocity based on phase velocity v_cxwbnd 
    558 !!$         ! ----------------------------------------------------------------------- 
    559 !!$         ! 
    560 !!$         !      nib       nibm     nibm2 
    561 !!$         !    ///|///nib   |   nibm  |  nibm2 
    562 !!$         !    ///|////|    |    |    |    |    | 
    563 !!$         !    ---v----f----v----f----v----f----v-- jj-line 
    564 !!$         !    ///|////|    |    |    |    |    | 
    565 !!$         !    ///|////|    |    |    |    |    | 
    566 !!$         !   jpiwob     jpiwob+1    jpiwob+2 
    567 !!$         !            |         |         |    
    568 !!$         !          jpiwob   jpiwob+1   jpiwob+2     
    569 !!$         ! 
    570 !!$         ! ... radiative condition plus Raymond-Kuo 
    571 !!$         ! ... (jpjwdp1, jpjwfm1),jpiwob 
    572 !!$         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    573 !!$            DO jk = 1, jpkm1 
    574 !!$               DO jj = 2, jpjm1 
    575 !!$         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
    576 !!$                  z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) & 
    577 !!$                           + 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj) 
    578 !!$         ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 
    579 !!$                  z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj) 
    580 !!$         ! ... square of the norm of grad(v) 
    581 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    582 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    583 !!$                  zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit) 
    584 !!$         ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 
    585 !!$         !     velocity ratio no divided by e1f for the tracer radiation 
    586 !!$                  IF( z4nor2 == 0) THEN 
    587 !!$                     z4nor2=0.000001 
    588 !!$                  endif 
    589 !!$                  z05cx = zdt * z2dx / z4nor2 
    590 !!$                  v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk) 
    591 !!$               END DO 
    592 !!$            END DO 
    593 !!$         END DO 
    594 !!$         IF( lk_mpp )   CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout ) 
    595 !!$ 
    596 !!$         ! ... extremeties niw0, niw1 
    597 !!$         ij = jpjwd +1 - njmpp 
    598 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    599 !!$            DO jk = 1,jpkm1 
    600 !!$               v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk) 
    601 !!$            END DO 
    602 !!$         END IF 
    603 !!$         ij = jpjwf +1 - njmpp 
    604 !!$         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
    605 !!$            DO jk = 1,jpkm1 
    606 !!$               v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk) 
    607 !!$            END DO 
    608 !!$         END IF 
    609 !!$ 
    610 !!$      END IF 
    611 !!$ 
    612 !!$   END SUBROUTINE obc_rad_west 
    613 !!$ 
    614 !!$ 
    615 !!$   SUBROUTINE obc_rad_north ( kt ) 
    616 !!$      !!------------------------------------------------------------------------------ 
    617 !!$      !!                  ***  SUBROUTINE obc_rad_north  *** 
    618 !!$      !!            
    619 !!$      !! ** Purpose : 
    620 !!$      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
    621 !!$      !!      north boundary and calculate those phase speeds if this OBC is not fixed. 
    622 !!$      !!      In case of fixed OBC, this subrountine is not called. 
    623 !!$      !! 
    624 !!$      !!  History : 
    625 !!$      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
    626 !!$      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
    627 !!$      !!         ! 97-12 (M. Imbard) Mpp adaptation 
    628 !!$      !!         ! 00-06 (J.-M. Molines)  
    629 !!$      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
    630 !!$      !!------------------------------------------------------------------------------ 
    631 !!$      !! * Arguments 
    632 !!$      INTEGER, INTENT( in ) ::   kt 
    633 !!$ 
    634 !!$      !! * Local declarations 
    635 !!$      INTEGER  ::   ii 
    636 !!$      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
    637 !!$      REAL(wp) ::   zvcb, zvcbm, zvcbm2 
    638 !!$      !!------------------------------------------------------------------------------ 
    639 !!$ 
    640 !!$      ! 1. Swap arrays before calculating radiative velocities 
    641 !!$      ! ------------------------------------------------------ 
    642 !!$ 
    643 !!$      ! 1.1  zonal velocity  
    644 !!$      ! ------------------- 
    645 !!$ 
    646 !!$      IF( kt > nit000 .OR. ln_rstart ) THEN  
    647 !!$ 
    648 !!$         ! ... advance in time (time filter, array swap) 
    649 !!$         DO jk = 1, jpkm1 
    650 !!$            DO ji = 1, jpi 
    651 !!$         ! ... fields nitm2 <== nitm 
    652 !!$               unbnd(ji,jk,nib  ,nitm2) = unbnd(ji,jk,nib  ,nitm)*unmsk(ji,jk) 
    653 !!$               unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk) 
    654 !!$               unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk) 
    655 !!$            END DO 
    656 !!$         END DO 
    657 !!$ 
    658 !!$         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
    659 !!$            DO jk = 1, jpkm1 
    660 !!$               DO ji = 1, jpi 
    661 !!$                  unbnd(ji,jk,nib  ,nitm) = unbnd(ji,jk,nib,  nit)*unmsk(ji,jk) 
    662 !!$                  unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk) 
    663 !!$                  unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk) 
    664 !!$         ! ... fields nit <== now (kt+1) 
    665 !!$                  unbnd(ji,jk,nib  ,nit) = un(ji,jj,  jk)*unmsk(ji,jk) 
    666 !!$                  unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk) 
    667 !!$                  unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk) 
    668 !!$               END DO 
    669 !!$            END DO 
    670 !!$         END DO 
    671 !!$         IF( lk_mpp )   CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout ) 
    672 !!$ 
    673 !!$         ! ... extremeties njn0,njn1  
    674 !!$         ii = jpind + 1 - nimpp  
    675 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN  
    676 !!$            DO jk = 1, jpkm1 
    677 !!$                unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm) 
    678 !!$            END DO 
    679 !!$         END IF  
    680 !!$         ii = jpinf + 1 - nimpp  
    681 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    682 !!$            DO jk = 1, jpkm1 
    683 !!$               unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm) 
    684 !!$            END DO 
    685 !!$         END IF 
    686 !!$  
    687 !!$         ! 1.2. normal velocity  
    688 !!$         ! -------------------- 
    689 !!$ 
    690 !!$         ! ... advance in time (time filter, array swap)  
    691 !!$         DO jk = 1, jpkm1 
    692 !!$            DO ji = 1, jpi 
    693 !!$         ! ... fields nitm2 <== nitm  
    694 !!$               vnbnd(ji,jk,nib  ,nitm2) = vnbnd(ji,jk,nib  ,nitm)*vnmsk(ji,jk) 
    695 !!$               vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk) 
    696 !!$               vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk) 
    697 !!$            END DO 
    698 !!$         END DO 
    699 !!$ 
    700 !!$         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
    701 !!$            DO jk = 1, jpkm1 
    702 !!$               DO ji = 1, jpi 
    703 !!$                  vnbnd(ji,jk,nib  ,nitm) = vnbnd(ji,jk,nib,  nit)*vnmsk(ji,jk) 
    704 !!$                  vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk) 
    705 !!$                  vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk) 
    706 !!$         ! ... fields nit <== now (kt+1) 
    707 !!$         ! ... total or baroclinic velocity at b, bm and bm2 
    708 !!$                  zvcb   = vn (ji,jj,jk) 
    709 !!$                  zvcbm  = vn (ji,jj-1,jk) 
    710 !!$                  zvcbm2 = vn (ji,jj-2,jk) 
    711 !!$         ! ... fields nit <== now (kt+1)  
    712 !!$                  vnbnd(ji,jk,nib  ,nit) = zvcb  *vnmsk(ji,jk) 
    713 !!$                  vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk) 
    714 !!$                  vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk) 
    715 !!$               END DO 
    716 !!$            END DO 
    717 !!$         END DO 
    718 !!$         IF( lk_mpp )   CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout ) 
    719 !!$ 
    720 !!$         ! ... extremeties njn0,njn1 
    721 !!$         ii = jpind + 1 - nimpp 
    722 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    723 !!$            DO jk = 1, jpkm1 
    724 !!$               vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm) 
    725 !!$            END DO 
    726 !!$         END IF 
    727 !!$         ii = jpinf + 1 - nimpp 
    728 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    729 !!$            DO jk = 1, jpkm1 
    730 !!$               vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm) 
    731 !!$            END DO 
    732 !!$         END IF 
    733 !!$ 
    734 !!$         ! 1.3 Temperature and salinity 
    735 !!$         ! ---------------------------- 
    736 !!$ 
    737 !!$         ! ... advance in time (time filter, array swap) 
    738 !!$         DO jk = 1, jpkm1 
    739 !!$            DO ji = 1, jpi 
    740 !!$         ! ... fields nitm <== nit  plus time filter at the boundary 
    741 !!$               tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 
    742 !!$               snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 
    743 !!$            END DO 
    744 !!$         END DO 
    745 !!$ 
    746 !!$         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
    747 !!$            DO jk = 1, jpkm1 
    748 !!$               DO ji = 1, jpi 
    749 !!$                  tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
    750 !!$                  snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
    751 !!$         ! ... fields nit <== now (kt+1) 
    752 !!$                  tnbnd(ji,jk,nib  ,nit) = tn(ji,jj,  jk)*tnmsk(ji,jk) 
    753 !!$                  tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk) 
    754 !!$                  snbnd(ji,jk,nib  ,nit) = sn(ji,jj,  jk)*tnmsk(ji,jk) 
    755 !!$                  snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk) 
    756 !!$               END DO 
    757 !!$            END DO 
    758 !!$         END DO 
    759 !!$         IF( lk_mpp )   CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 
    760 !!$         IF( lk_mpp )   CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 
    761 !!$ 
    762 !!$         ! ... extremeties  njn0,njn1 
    763 !!$         ii = jpind + 1 - nimpp 
    764 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    765 !!$            DO jk = 1, jpkm1 
    766 !!$               tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm) 
    767 !!$               snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm) 
    768 !!$            END DO 
    769 !!$         END IF 
    770 !!$         ii = jpinf + 1 - nimpp 
    771 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    772 !!$            DO jk = 1, jpkm1 
    773 !!$               tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm) 
    774 !!$               snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm) 
    775 !!$            END DO 
    776 !!$         END IF 
    777 !!$ 
    778 !!$      END IF     ! End of array swap 
    779 !!$ 
    780 !!$      ! 2 - Calculation of radiation velocities 
    781 !!$      ! --------------------------------------- 
    782 !!$ 
    783 !!$      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
    784 !!$ 
    785 !!$         ! 2.1  Calculate the normal velocity based on phase velocity u_cynbnd 
    786 !!$         ! ------------------------------------------------------------------- 
    787 !!$         ! 
    788 !!$         !           ji-row 
    789 !!$         !             | 
    790 !!$         !     nib -///u//////  jpjnob + 1 
    791 !!$         !        /////|////// 
    792 !!$         !   nib  -----f-----   jpjnob 
    793 !!$         !             |     
    794 !!$         !     nibm--  u   ---- jpjnob 
    795 !!$         !             |         
    796 !!$         !  nibm  -----f-----   jpjnob-1 
    797 !!$         !             |         
    798 !!$         !    nibm2--  u   ---- jpjnob-1 
    799 !!$         !             |         
    800 !!$         !  nibm2 -----f-----   jpjnob-2 
    801 !!$         !             | 
    802 !!$         ! ... radiative condition 
    803 !!$         ! ... jpjnob+1,(jpindp1, jpinfm1) 
    804 !!$         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
    805 !!$            DO jk = 1, jpkm1 
    806 !!$               DO ji = 2, jpim1 
    807 !!$         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
    808 !!$                  z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) & 
    809 !!$                        - 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2) 
    810 !!$         ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 
    811 !!$                  z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1) 
    812 !!$         ! ... square of the norm of grad(v) 
    813 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    814 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    815 !!$                  zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit) 
    816 !!$         ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 
    817 !!$         !     velocity ratio no divided by e1f for the tracer radiation 
    818 !!$                  IF( z4nor2 == 0.) THEN 
    819 !!$                     z4nor2=.000001 
    820 !!$                  END IF 
    821 !!$                  z05cx = zdt * z2dx / z4nor2 
    822 !!$                  u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk) 
    823 !!$               END DO 
    824 !!$            END DO 
    825 !!$         END DO 
    826 !!$         IF( lk_mpp )   CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout ) 
    827 !!$ 
    828 !!$         ! ... extremeties  njn0,njn1 
    829 !!$         ii = jpind + 1 - nimpp 
    830 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    831 !!$            DO jk = 1, jpkm1 
    832 !!$               u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk) 
    833 !!$            END DO 
    834 !!$         END IF 
    835 !!$         ii = jpinf + 1 - nimpp 
    836 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    837 !!$            DO jk = 1, jpkm1 
    838 !!$               u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk) 
    839 !!$            END DO 
    840 !!$         END IF 
    841 !!$ 
    842 !!$         ! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd  
    843 !!$         ! ------------------------------------------------------------------ 
    844 !!$         ! 
    845 !!$         !                ji-row  ji-row 
    846 !!$         !                     | 
    847 !!$         !        /////|///////////////// 
    848 !!$         !   nib  -----f----v----f----  jpjnob 
    849 !!$         !             |         | 
    850 !!$         !     nib  -  u -- T -- u ---- jpjnob 
    851 !!$         !             |         | 
    852 !!$         !  nibm  -----f----v----f----  jpjnob-1 
    853 !!$         !             |         | 
    854 !!$         !    nibm --  u -- T -- u ---  jpjnob-1 
    855 !!$         !             |         | 
    856 !!$         !  nibm2 -----f----v----f----  jpjnob-2 
    857 !!$         !             |         | 
    858 !!$         ! ... Free surface formulation: 
    859 !!$         ! ... radiative conditions on the total part + relaxation toward climatology  
    860 !!$         ! ... jpjnob,(jpindp1, jpinfm1) 
    861 !!$         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
    862 !!$            DO jk = 1, jpkm1 
    863 !!$               DO ji = 2, jpim1 
    864 !!$         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
    865 !!$                  ii = ji -1 + nimpp 
    866 !!$                  z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) & 
    867 !!$                          - 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1) 
    868 !!$         ! ... 2* gradi(v) (v-point i=nibm, time nitm) 
    869 !!$                  z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1) 
    870 !!$         ! ... square of the norm of grad(u) 
    871 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    872 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    873 !!$                  zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit) 
    874 !!$         ! ... j-phase speed ratio (bounded by 1) 
    875 !!$                  IF( z4nor2 == 0. ) THEN 
    876 !!$                     z4nor2=.00001 
    877 !!$                  END IF 
    878 !!$                  z05cx = zdt * z2dx / z4nor2 
    879 !!$                  v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk) 
    880 !!$               END DO 
    881 !!$            END DO 
    882 !!$         END DO 
    883 !!$ 
    884 !!$      END IF 
    885 !!$ 
    886 !!$   END SUBROUTINE obc_rad_north 
    887 !!$ 
    888 !!$ 
    889 !!$   SUBROUTINE obc_rad_south ( kt ) 
    890 !!$      !!------------------------------------------------------------------------------ 
    891 !!$      !!                  ***  SUBROUTINE obc_rad_south  *** 
    892 !!$      !!            
    893 !!$      !! ** Purpose : 
    894 !!$      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
    895 !!$      !!      south boundary and calculate those phase speeds if this OBC is not fixed. 
    896 !!$      !!      In case of fixed OBC, this subrountine is not called. 
    897 !!$      !! 
    898 !!$      !!  History : 
    899 !!$      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
    900 !!$      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
    901 !!$      !!         ! 97-12 (M. Imbard) Mpp adaptation 
    902 !!$      !!         ! 00-06 (J.-M. Molines)  
    903 !!$      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
    904 !!$      !!------------------------------------------------------------------------------ 
    905 !!$      !! * Arguments 
    906 !!$      INTEGER, INTENT( in ) ::   kt 
    907 !!$ 
    908 !!$      !! * Local declarations 
    909 !!$      INTEGER ::   ii 
    910 !!$      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
    911 !!$      REAL(wp) ::   zvcb, zvcbm, zvcbm2 
    912 !!$      !!------------------------------------------------------------------------------ 
    913 !!$ 
    914 !!$      ! 1. Swap arrays before calculating radiative velocities 
    915 !!$      ! ------------------------------------------------------ 
    916 !!$ 
    917 !!$      ! 1.1  zonal velocity  
    918 !!$      ! -------------------- 
    919 !!$   
    920 !!$      IF( kt > nit000 .OR. ln_rstart ) THEN  
    921 !!$ 
    922 !!$         ! ... advance in time (time filter, array swap) 
    923 !!$         DO jk = 1, jpkm1 
    924 !!$            DO ji = 1, jpi 
    925 !!$         ! ... fields nitm2 <== nitm 
    926 !!$                  usbnd(ji,jk,nib  ,nitm2) = usbnd(ji,jk,nib  ,nitm)*usmsk(ji,jk) 
    927 !!$                  usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk) 
    928 !!$                  usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk) 
    929 !!$            END DO 
    930 !!$         END DO 
    931 !!$  
    932 !!$         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
    933 !!$            DO jk = 1, jpkm1 
    934 !!$               DO ji = 1, jpi 
    935 !!$                  usbnd(ji,jk,nib  ,nitm) = usbnd(ji,jk,nib,  nit)*usmsk(ji,jk) 
    936 !!$                  usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk) 
    937 !!$                  usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk) 
    938 !!$         ! ... fields nit <== now (kt+1) 
    939 !!$                  usbnd(ji,jk,nib  ,nit) = un(ji,jj  ,jk)*usmsk(ji,jk) 
    940 !!$                  usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk) 
    941 !!$                  usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk) 
    942 !!$               END DO 
    943 !!$            END DO 
    944 !!$         END DO 
    945 !!$         IF( lk_mpp )   CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 
    946 !!$ 
    947 !!$         ! ... extremeties njs0,njs1 
    948 !!$         ii = jpisd + 1 - nimpp 
    949 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    950 !!$            DO jk = 1, jpkm1 
    951 !!$               usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm) 
    952 !!$            END DO 
    953 !!$         END IF 
    954 !!$         ii = jpisf + 1 - nimpp 
    955 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    956 !!$            DO jk = 1, jpkm1 
    957 !!$               usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm) 
    958 !!$            END DO 
    959 !!$         END IF 
    960 !!$  
    961 !!$         ! 1.2 normal velocity 
    962 !!$         ! ------------------- 
    963 !!$  
    964 !!$         !.. advance in time (time filter, array swap)  
    965 !!$         DO jk = 1, jpkm1 
    966 !!$            DO ji = 1, jpi 
    967 !!$         ! ... fields nitm2 <== nitm  
    968 !!$               vsbnd(ji,jk,nib  ,nitm2) = vsbnd(ji,jk,nib  ,nitm)*vsmsk(ji,jk) 
    969 !!$               vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk) 
    970 !!$            END DO 
    971 !!$         END DO 
    972 !!$ 
    973 !!$         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
    974 !!$            DO jk = 1, jpkm1 
    975 !!$               DO ji = 1, jpi 
    976 !!$                  vsbnd(ji,jk,nib  ,nitm) = vsbnd(ji,jk,nib,  nit)*vsmsk(ji,jk) 
    977 !!$                  vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk) 
    978 !!$                  vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk) 
    979 !!$         ! ... total or baroclinic velocity at b, bm and bm2 
    980 !!$                  zvcb   = vn (ji,jj,jk) 
    981 !!$                  zvcbm  = vn (ji,jj+1,jk) 
    982 !!$                  zvcbm2 = vn (ji,jj+2,jk) 
    983 !!$         ! ... fields nit <== now (kt+1)  
    984 !!$                  vsbnd(ji,jk,nib  ,nit) = zvcb   *vsmsk(ji,jk) 
    985 !!$                  vsbnd(ji,jk,nibm ,nit) = zvcbm  *vsmsk(ji,jk) 
    986 !!$                  vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk) 
    987 !!$               END DO 
    988 !!$            END DO 
    989 !!$         END DO 
    990 !!$         IF( lk_mpp )   CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 
    991 !!$ 
    992 !!$         ! ... extremeties njs0,njs1 
    993 !!$         ii = jpisd + 1 - nimpp 
    994 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    995 !!$            DO jk = 1, jpkm1 
    996 !!$               vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm) 
    997 !!$            END DO 
    998 !!$         END IF 
    999 !!$         ii = jpisf + 1 - nimpp 
    1000 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    1001 !!$            DO jk = 1, jpkm1 
    1002 !!$               vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm) 
    1003 !!$            END DO 
    1004 !!$         END IF 
    1005 !!$ 
    1006 !!$         ! 1.3 Temperature and salinity 
    1007 !!$         ! ---------------------------- 
    1008 !!$ 
    1009 !!$         ! ... advance in time (time filter, array swap) 
    1010 !!$         DO jk = 1, jpkm1 
    1011 !!$            DO ji = 1, jpi 
    1012 !!$         ! ... fields nitm <== nit  plus time filter at the boundary 
    1013 !!$               tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 
    1014 !!$               ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 
    1015 !!$            END DO 
    1016 !!$         END DO 
    1017 !!$ 
    1018 !!$         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
    1019 !!$            DO jk = 1, jpkm1 
    1020 !!$               DO ji = 1, jpi 
    1021 !!$                  tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
    1022 !!$                  ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
    1023 !!$         ! ... fields nit <== now (kt+1) 
    1024 !!$                  tsbnd(ji,jk,nib  ,nit) = tn(ji,jj   ,jk)*tsmsk(ji,jk) 
    1025 !!$                  tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk) 
    1026 !!$                  ssbnd(ji,jk,nib  ,nit) = sn(ji,jj   ,jk)*tsmsk(ji,jk) 
    1027 !!$                  ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk) 
    1028 !!$               END DO 
    1029 !!$            END DO 
    1030 !!$         END DO 
    1031 !!$         IF( lk_mpp )   CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 
    1032 !!$         IF( lk_mpp )   CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 
    1033 !!$ 
    1034 !!$         ! ... extremeties  njs0,njs1 
    1035 !!$         ii = jpisd + 1 - nimpp 
    1036 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    1037 !!$            DO jk = 1, jpkm1 
    1038 !!$               tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm) 
    1039 !!$               ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm) 
    1040 !!$            END DO 
    1041 !!$         END IF 
    1042 !!$         ii = jpisf + 1 - nimpp 
    1043 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    1044 !!$            DO jk = 1, jpkm1 
    1045 !!$               tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm) 
    1046 !!$               ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm) 
    1047 !!$            END DO 
    1048 !!$         END IF 
    1049 !!$ 
    1050 !!$      END IF     ! End of array swap 
    1051 !!$ 
    1052 !!$      ! 2 - Calculation of radiation velocities 
    1053 !!$      ! --------------------------------------- 
    1054 !!$ 
    1055 !!$      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
    1056 !!$ 
    1057 !!$         ! 2.1  Calculate the normal velocity based on phase velocity u_cysbnd 
    1058 !!$         ! ------------------------------------------------------------------- 
    1059 !!$         ! 
    1060 !!$         !          ji-row 
    1061 !!$         !            | 
    1062 !!$         ! nibm2 -----f-----   jpjsob +2 
    1063 !!$         !            |     
    1064 !!$         !  nibm2 --  u  ----- jpjsob +2  
    1065 !!$         !            |         
    1066 !!$         !  nibm -----f-----   jpjsob +1 
    1067 !!$         !            |         
    1068 !!$         !  nibm  --  u  ----- jpjsob +1 
    1069 !!$         !            |         
    1070 !!$         !  nib  -----f-----   jpjsob 
    1071 !!$         !       /////|////// 
    1072 !!$         !  nib   ////u/////   jpjsob  
    1073 !!$         ! 
    1074 !!$         ! ... radiative condition plus Raymond-Kuo 
    1075 !!$         ! ... jpjsob,(jpisdp1, jpisfm1) 
    1076 !!$         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
    1077 !!$            DO jk = 1, jpkm1 
    1078 !!$               DO ji = 2, jpim1 
    1079 !!$         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
    1080 !!$                  z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) & 
    1081 !!$                          + 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1) 
    1082 !!$         ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 
    1083 !!$                  z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1) 
    1084 !!$         ! ... square of the norm of grad(v) 
    1085 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    1086 !!$                  IF( z4nor2 == 0.) THEN 
    1087 !!$                     z4nor2 = 0.000001 
    1088 !!$                  END IF 
    1089 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    1090 !!$                  zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit) 
    1091 !!$         ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 
    1092 !!$         !     velocity ratio no divided by e1f for the tracer radiation 
    1093 !!$                  z05cx = zdt * z2dx / z4nor2 
    1094 !!$                  u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk) 
    1095 !!$               END DO 
    1096 !!$            END DO 
    1097 !!$         END DO 
    1098 !!$         IF( lk_mpp )   CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout ) 
    1099 !!$ 
    1100 !!$         ! ... extremeties  njs0,njs1 
    1101 !!$         ii = jpisd + 1 - nimpp 
    1102 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    1103 !!$            DO jk = 1, jpkm1 
    1104 !!$               u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk) 
    1105 !!$            END DO 
    1106 !!$         END IF 
    1107 !!$         ii = jpisf + 1 - nimpp 
    1108 !!$         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
    1109 !!$            DO jk = 1, jpkm1 
    1110 !!$               u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk) 
    1111 !!$            END DO 
    1112 !!$         END IF 
    1113 !!$ 
    1114 !!$         ! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd  
    1115 !!$         ! ------------------------------------------------------------------- 
    1116 !!$         ! 
    1117 !!$         !               ji-row  ji-row 
    1118 !!$         !            |         | 
    1119 !!$         ! nibm2 -----f----v----f----  jpjsob+2 
    1120 !!$         !            |         | 
    1121 !!$         !  nibm   -  u -- T -- u ---- jpjsob+2 
    1122 !!$         !            |         | 
    1123 !!$         ! nibm  -----f----v----f----  jpjsob+1  
    1124 !!$         !            |         | 
    1125 !!$         ! nib    --  u -- T -- u ---  jpjsob+1 
    1126 !!$         !            |         | 
    1127 !!$         ! nib   -----f----v----f----  jpjsob 
    1128 !!$         !       ///////////////////// 
    1129 !!$         ! 
    1130 !!$         ! ... Free surface formulation: 
    1131 !!$         ! ... radiative conditions on the total part + relaxation toward climatology 
    1132 !!$         ! ... jpjsob,(jpisdp1,jpisfm1) 
    1133 !!$         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
    1134 !!$            DO jk = 1, jpkm1 
    1135 !!$               DO ji = 2, jpim1 
    1136 !!$         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
    1137 !!$                  z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) & 
    1138 !!$                           + 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1) 
    1139 !!$         ! ... 2* gradi(v) (v-point i=nibm, time nitm) 
    1140 !!$                  z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1) 
    1141 !!$         ! ... square of the norm of grad(u) 
    1142 !!$                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
    1143 !!$                  IF( z4nor2 == 0.) THEN 
    1144 !!$                     z4nor2 = 0.000001 
    1145 !!$                  END IF 
    1146 !!$         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
    1147 !!$                  zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit) 
    1148 !!$         ! ... j-phase speed ratio (bounded by -1) 
    1149 !!$                  z05cx = zdt * z2dx / z4nor2 
    1150 !!$                  v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk) 
    1151 !!$               END DO 
    1152 !!$            END DO 
    1153 !!$         END DO 
    1154 !!$ 
    1155 !!$      ENDIF 
    1156 !!$  
    1157 !!$   END SUBROUTINE obc_rad_south 
    1158 !!$ 
    1159 !!$#else 
     7   !!--------------------------------------------------------------------------------- 
     8   !!   obc_rad        : call the subroutine for each open boundary 
     9   !!   obc_rad_east   : compute the east phase velocities 
     10   !!   obc_rad_west   : compute the west phase velocities 
     11   !!   obc_rad_north  : compute the north phase velocities 
     12   !!   obc_rad_south  : compute the south phase velocities 
     13   !!--------------------------------------------------------------------------------- 
     14   USE oce             ! ocean dynamics and tracers variables 
     15   USE dom_oce         ! ocean space and time domain variables 
     16   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     17   USE phycst          ! physical constants 
     18   USE obc_oce         ! ocean open boundary conditions 
     19   USE lib_mpp         ! for mppobc 
     20   USE in_out_manager  ! I/O units 
     21 
     22   IMPLICIT NONE 
     23   PRIVATE 
     24 
     25   PUBLIC   obc_rad    ! routine called by step.F90 
     26 
     27   INTEGER ::   ji, jj, jk     ! dummy loop indices 
     28 
     29   INTEGER ::      & ! ... boundary space indices  
     30      nib   = 1,   & ! nib   = boundary point 
     31      nibm  = 2,   & ! nibm  = 1st interior point 
     32      nibm2 = 3,   & ! nibm2 = 2nd interior point 
     33                     ! ... boundary time indices  
     34      nit   = 1,   & ! nit    = now 
     35      nitm  = 2,   & ! nitm   = before 
     36      nitm2 = 3      ! nitm2  = before-before 
     37 
     38   !! * Substitutions 
     39#  include "obc_vectopt_loop_substitute.h90" 
     40   !!--------------------------------------------------------------------------------- 
     41   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     42   !! $Id$  
     43   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     44   !!--------------------------------------------------------------------------------- 
     45 
     46CONTAINS 
     47 
     48   SUBROUTINE obc_rad ( kt ) 
     49      !!------------------------------------------------------------------------------ 
     50      !!                     SUBROUTINE obc_rad 
     51      !!                    ******************** 
     52      !! ** Purpose : 
     53      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
     54      !!      boundaries and calculate those phase speeds if the open boundaries are  
     55      !!      not fixed. In case of fixed open boundaries does nothing. 
     56      !! 
     57      !!     The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 
     58      !!     and/or lp_obc_south allow the user to determine which boundary is an 
     59      !!     open one (must be done in the param_obc.h90 file). 
     60      !!  
     61      !! ** Reference :  
     62      !!     Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 
     63      !! 
     64      !!  History : 
     65      !!    8.5  !  02-10  (C. Talandier, A-M. Treguier) Free surface, F90 from the  
     66      !!                                                 J. Molines and G. Madec version 
     67      !!------------------------------------------------------------------------------ 
     68      INTEGER, INTENT( in ) ::   kt 
     69      !!---------------------------------------------------------------------- 
     70 
     71      IF( lp_obc_east  .AND. .NOT.lfbceast  )   CALL obc_rad_east ( kt )   ! East open boundary 
     72 
     73      IF( lp_obc_west  .AND. .NOT.lfbcwest  )   CALL obc_rad_west ( kt )   ! West open boundary 
     74 
     75      IF( lp_obc_north .AND. .NOT.lfbcnorth )   CALL obc_rad_north( kt )   ! North open boundary 
     76 
     77      IF( lp_obc_south .AND. .NOT.lfbcsouth )   CALL obc_rad_south( kt )   ! South open boundary 
     78 
     79   END SUBROUTINE obc_rad 
     80 
     81 
     82   SUBROUTINE obc_rad_east ( kt ) 
     83      !!------------------------------------------------------------------------------ 
     84      !!                     ***  SUBROUTINE obc_rad_east  *** 
     85      !!                    
     86      !! ** Purpose : 
     87      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
     88      !!      east boundary and calculate those phase speeds if this OBC is not fixed. 
     89      !!      In case of fixed OBC, this subrountine is not called. 
     90      !! 
     91      !!  History : 
     92      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     93      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     94      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     95      !!         ! 00-06 (J.-M. Molines)  
     96      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     97      !!------------------------------------------------------------------------------ 
     98      !! * Arguments 
     99      INTEGER, INTENT( in ) ::   kt 
     100 
     101      !! * Local declarations 
     102      INTEGER  ::   ij 
     103      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
     104      REAL(wp) ::   zucb, zucbm, zucbm2 
     105      !!------------------------------------------------------------------------------ 
     106 
     107      ! 1. Swap arrays before calculating radiative velocities 
     108      ! ------------------------------------------------------ 
     109 
     110      ! 1.1  zonal velocity  
     111      ! ------------------- 
     112 
     113      IF( kt > nit000 .OR. ln_rstart ) THEN  
     114 
     115         ! ... advance in time (time filter, array swap)  
     116         DO jk = 1, jpkm1 
     117            DO jj = 1, jpj 
     118               uebnd(jj,jk,nib  ,nitm2) = uebnd(jj,jk,nib  ,nitm)*uemsk(jj,jk) 
     119               uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk) 
     120               uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk) 
     121            END DO 
     122         END DO 
     123         ! ... fields nitm <== nit  plus time filter at the boundary  
     124         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     125            DO jk = 1, jpkm1 
     126               DO jj = 1, jpj 
     127                  uebnd(jj,jk,nib  ,nitm) = uebnd(jj,jk,nib,  nit)*uemsk(jj,jk) 
     128                  uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk) 
     129                  uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk) 
     130         ! ... fields nit <== now (kt+1)  
     131         ! ... Total or baroclinic velocity at b, bm and bm2 
     132                  zucb   = un(ji,jj,jk) 
     133                  zucbm  = un(ji-1,jj,jk) 
     134                  zucbm2 = un(ji-2,jj,jk) 
     135                  uebnd(jj,jk,nib  ,nit) = zucb   *uemsk(jj,jk) 
     136                  uebnd(jj,jk,nibm ,nit) = zucbm  *uemsk(jj,jk)  
     137                  uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk)  
     138               END DO 
     139            END DO 
     140         END DO 
     141         IF( lk_mpp )   CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout ) 
     142 
     143         ! ... extremeties nie0, nie1 
     144         ij = jpjed +1 - njmpp 
     145         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     146            DO jk = 1,jpkm1 
     147               uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm) 
     148            END DO 
     149         END IF 
     150         ij = jpjef +1 - njmpp 
     151         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     152            DO jk = 1,jpkm1 
     153               uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm) 
     154            END DO 
     155         END IF 
     156 
     157         ! 1.2 tangential velocity 
     158         ! ----------------------- 
     159 
     160         ! ... advance in time (time filter, array swap) 
     161         DO jk = 1, jpkm1 
     162            DO jj = 1, jpj 
     163         ! ... fields nitm2 <== nitm 
     164               vebnd(jj,jk,nib  ,nitm2) = vebnd(jj,jk,nib  ,nitm)*vemsk(jj,jk) 
     165               vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk) 
     166               vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk) 
     167            END DO 
     168         END DO 
     169 
     170         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     171            DO jk = 1, jpkm1 
     172               DO jj = 1, jpj 
     173                  vebnd(jj,jk,nib  ,nitm) = vebnd(jj,jk,nib,  nit)*vemsk(jj,jk) 
     174                  vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk) 
     175                  vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk) 
     176         ! ... fields nit <== now (kt+1) 
     177                  vebnd(jj,jk,nib  ,nit) = vn(ji  ,jj,jk)*vemsk(jj,jk) 
     178                  vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk) 
     179                  vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk) 
     180               END DO 
     181            END DO 
     182         END DO 
     183         IF( lk_mpp )   CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout ) 
     184 
     185         !... extremeties nie0, nie1 
     186         ij = jpjed +1 - njmpp 
     187         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     188            DO jk = 1,jpkm1 
     189               vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm) 
     190            END DO  
     191         END IF  
     192         ij = jpjef +1 - njmpp  
     193         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
     194            DO jk = 1,jpkm1  
     195               vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm) 
     196            END DO  
     197         END IF  
     198 
     199         ! 1.3 Temperature and salinity 
     200         ! ---------------------------- 
     201 
     202         ! ... advance in time (time filter, array swap) 
     203         DO jk = 1, jpkm1 
     204            DO jj = 1, jpj 
     205         ! ... fields nitm <== nit  plus time filter at the boundary 
     206               tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk) 
     207               sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk) 
     208            END DO 
     209         END DO 
     210 
     211         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     212            DO jk = 1, jpkm1 
     213               DO jj = 1, jpj 
     214                  tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
     215                  sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
     216         ! ... fields nit <== now (kt+1) 
     217                  tebnd(jj,jk,nib  ,nit) = tn(ji  ,jj,jk)*temsk(jj,jk) 
     218                  tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk) 
     219                  sebnd(jj,jk,nib  ,nit) = sn(ji  ,jj,jk)*temsk(jj,jk) 
     220                  sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk) 
     221               END DO 
     222            END DO 
     223         END DO 
     224         IF( lk_mpp )   CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 
     225         IF( lk_mpp )   CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 
     226 
     227         ! ... extremeties nie0, nie1 
     228         ij = jpjed +1 - njmpp 
     229         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     230            DO jk = 1,jpkm1 
     231               tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm) 
     232               sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm) 
     233            END DO 
     234         END IF 
     235         ij = jpjef +1 - njmpp 
     236         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     237            DO jk = 1,jpkm1 
     238               tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm) 
     239               sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm) 
     240            END DO 
     241         END IF 
     242 
     243      END IF     ! End of array swap 
     244 
     245      ! 2 - Calculation of radiation velocities 
     246      ! --------------------------------------- 
     247 
     248      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
     249 
     250         ! 2.1  Calculate the normal velocity U based on phase velocity u_cxebnd 
     251         ! --------------------------------------------------------------------- 
     252         ! 
     253         !          nibm2      nibm      nib 
     254         !            |  nibm   |   nib   |/// 
     255         !            |    |    |    |    |/// 
     256         !  jj-line --f----v----f----v----f--- 
     257         !            |    |    |    |    |/// 
     258         !            |         |         |/// 
     259         !  jj-line   u    T    u    T    u/// 
     260         !            |         |         |/// 
     261         !            |    |    |    |    |/// 
     262         !          jpieob-2   jpieob-1   jpieob 
     263         !                 |         |         
     264         !              jpieob-1    jpieob       
     265         ! 
     266         ! ... (jpjedp1, jpjefm1),jpieob 
     267         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     268            DO jk = 1, jpkm1 
     269               DO jj = 2, jpjm1 
     270         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
     271                  z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) & 
     272                           - 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj) 
     273         ! ... 2* gradj(u) (u-point i=nibm, time nitm) 
     274                  z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj) 
     275         ! ... square of the norm of grad(u) 
     276                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     277         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     278                  zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit) 
     279         ! ... i-phase speed ratio (bounded by 1)                
     280                  IF( z4nor2 == 0. ) THEN 
     281                     z4nor2=.00001 
     282                  END IF 
     283                  z05cx = zdt * z2dx / z4nor2 
     284                  u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk) 
     285               END DO 
     286            END DO 
     287         END DO 
     288 
     289         ! 2.2  Calculate the tangential velocity based on phase velocity v_cxebnd 
     290         ! ----------------------------------------------------------------------- 
     291         ! 
     292         !          nibm2      nibm      nib 
     293         !            |   nibm  |   nib///|/// 
     294         !            |    |    |    |////|/// 
     295         !  jj-line --v----f----v----f----v--- 
     296         !            |    |    |    |////|/// 
     297         !            |    |    |    |////|/// 
     298         !            | jpieob-1| jpieob /|/// 
     299         !            |         |         |    
     300         !         jpieob-1    jpieob     jpieob+1 
     301         ! 
     302         ! ... (jpjedp1, jpjefm1), jpieob+1 
     303         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     304            DO jk = 1, jpkm1 
     305               DO jj = 2, jpjm1 
     306         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
     307                  z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) & 
     308                          - 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj) 
     309         ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 
     310                  z2dy = ( vebnd(jj+1,jk,nibm,nitm) -  vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj) 
     311         ! ... square of the norm of grad(v) 
     312                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     313         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     314                  zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit) 
     315         ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 
     316         !     velocity ratio no divided by e1f for the tracer radiation 
     317                  IF( z4nor2 == 0. ) THEN 
     318                     z4nor2=.000001 
     319                  END IF 
     320                  z05cx = zdt * z2dx / z4nor2 
     321                  v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk) 
     322               END DO 
     323            END DO 
     324         END DO 
     325         IF( lk_mpp )   CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout ) 
     326 
     327         ! ... extremeties nie0, nie1 
     328         ij = jpjed +1 - njmpp 
     329         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     330            DO jk = 1,jpkm1 
     331               v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk) 
     332            END DO 
     333         END IF 
     334         ij = jpjef +1 - njmpp 
     335         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     336            DO jk = 1,jpkm1 
     337               v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk) 
     338            END DO 
     339         END IF 
     340 
     341      END IF 
     342 
     343   END SUBROUTINE obc_rad_east 
     344 
     345 
     346   SUBROUTINE obc_rad_west ( kt ) 
     347      !!------------------------------------------------------------------------------ 
     348      !!                  ***  SUBROUTINE obc_rad_west  *** 
     349      !!                     
     350      !! ** Purpose : 
     351      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
     352      !!      west boundary and calculate those phase speeds if this OBC is not fixed. 
     353      !!      In case of fixed OBC, this subrountine is not called. 
     354      !! 
     355      !!  History : 
     356      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     357      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     358      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     359      !!         ! 00-06 (J.-M. Molines)  
     360      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     361      !!------------------------------------------------------------------------------ 
     362      !! * Arguments 
     363      INTEGER, INTENT( in ) ::   kt 
     364 
     365      !! * Local declarations 
     366      INTEGER ::   ij 
     367      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
     368      REAL(wp) ::   zucb, zucbm, zucbm2 
     369      !!------------------------------------------------------------------------------ 
     370 
     371      ! 1. Swap arrays before calculating radiative velocities 
     372      ! ------------------------------------------------------ 
     373 
     374      ! 1.1  zonal velocity  
     375      ! ------------------- 
     376 
     377      IF( kt > nit000 .OR. ln_rstart ) THEN 
     378 
     379         ! ... advance in time (time filter, array swap)  
     380         DO jk = 1, jpkm1 
     381            DO jj = 1, jpj  
     382               uwbnd(jj,jk,nib  ,nitm2) = uwbnd(jj,jk,nib  ,nitm)*uwmsk(jj,jk) 
     383               uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk) 
     384               uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk) 
     385            END DO 
     386         END DO 
     387 
     388         ! ... fields nitm <== nit  plus time filter at the boundary  
     389         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     390            DO jk = 1, jpkm1 
     391               DO jj = 1, jpj 
     392                  uwbnd(jj,jk,nib  ,nitm) = uwbnd(jj,jk,nib  ,nit)*uwmsk(jj,jk) 
     393                  uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk) 
     394                  uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk) 
     395         ! ... total or baroclinic velocity at b, bm and bm2 
     396                  zucb   = un (ji,jj,jk) 
     397                  zucbm  = un (ji+1,jj,jk) 
     398                  zucbm2 = un (ji+2,jj,jk) 
     399 
     400         ! ... fields nit <== now (kt+1)  
     401                  uwbnd(jj,jk,nib  ,nit) = zucb  *uwmsk(jj,jk) 
     402                  uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk) 
     403                  uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk) 
     404               END DO 
     405            END DO 
     406         END DO 
     407         IF( lk_mpp )   CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 
     408 
     409         ! ... extremeties niw0, niw1 
     410         ij = jpjwd +1 - njmpp 
     411         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     412            DO jk = 1,jpkm1 
     413               uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm) 
     414            END DO 
     415         END IF 
     416         ij = jpjwf +1 - njmpp 
     417         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     418            DO jk = 1,jpkm1 
     419               uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm) 
     420            END DO 
     421         END IF 
     422 
     423         ! 1.2 tangential velocity 
     424         ! ----------------------- 
     425 
     426         ! ... advance in time (time filter, array swap) 
     427         DO jk = 1, jpkm1 
     428            DO jj = 1, jpj  
     429         ! ... fields nitm2 <== nitm 
     430                  vwbnd(jj,jk,nib  ,nitm2) = vwbnd(jj,jk,nib  ,nitm)*vwmsk(jj,jk) 
     431                  vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk) 
     432                  vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk) 
     433            END DO 
     434         END DO 
     435 
     436         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     437            DO jk = 1, jpkm1 
     438               DO jj = 1, jpj 
     439                  vwbnd(jj,jk,nib  ,nitm) = vwbnd(jj,jk,nib,  nit)*vwmsk(jj,jk) 
     440                  vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk) 
     441                  vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk) 
     442         ! ... fields nit <== now (kt+1) 
     443                  vwbnd(jj,jk,nib  ,nit) = vn(ji  ,jj,jk)*vwmsk(jj,jk) 
     444                  vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk) 
     445                  vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk) 
     446               END DO 
     447            END DO 
     448         END DO 
     449         IF( lk_mpp )   CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 
     450 
     451         ! ... extremeties niw0, niw1  
     452         ij = jpjwd +1 - njmpp  
     453         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
     454            DO jk = 1,jpkm1  
     455               vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm) 
     456            END DO  
     457         END IF 
     458         ij = jpjwf +1 - njmpp  
     459         IF( ij >= 2 .AND. ij < jpjm1 ) THEN  
     460            DO jk = 1,jpkm1  
     461               vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm) 
     462            END DO  
     463         END IF  
     464  
     465         ! 1.3 Temperature and salinity 
     466         ! ---------------------------- 
     467  
     468         ! ... advance in time (time filter, array swap) 
     469         DO jk = 1, jpkm1 
     470            DO jj = 1, jpj 
     471         ! ... fields nitm <== nit  plus time filter at the boundary 
     472               twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk) 
     473               swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk) 
     474            END DO 
     475         END DO 
     476  
     477         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     478            DO jk = 1, jpkm1 
     479               DO jj = 1, jpj 
     480                  twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
     481                  swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
     482         ! ... fields nit <== now (kt+1) 
     483                  twbnd(jj,jk,nib  ,nit) = tn(ji   ,jj,jk)*twmsk(jj,jk) 
     484                  twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk) 
     485                  swbnd(jj,jk,nib  ,nit) = sn(ji   ,jj,jk)*twmsk(jj,jk) 
     486                  swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk) 
     487               END DO 
     488            END DO 
     489         END DO 
     490         IF( lk_mpp )   CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 
     491         IF( lk_mpp )   CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 
     492 
     493         ! ... extremeties niw0, niw1 
     494         ij = jpjwd +1 - njmpp 
     495         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     496            DO jk = 1,jpkm1 
     497               twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm) 
     498               swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm) 
     499            END DO 
     500         END IF 
     501         ij = jpjwf +1 - njmpp 
     502         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     503            DO jk = 1,jpkm1 
     504               twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm) 
     505               swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm) 
     506            END DO 
     507         END IF 
     508  
     509      END IF     ! End of array swap 
     510 
     511      ! 2 - Calculation of radiation velocities 
     512      ! --------------------------------------- 
     513    
     514      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
     515   
     516         ! 2.1  Calculate the normal velocity U based on phase velocity u_cxwbnd 
     517         ! ---------------------------------------------------------------------- 
     518         ! 
     519         !          nib       nibm      nibm2 
     520         !        ///|   nib   |   nibm  | 
     521         !        ///|    |    |    |    | 
     522         !        ---f----v----f----v----f-- jj-line 
     523         !        ///|    |    |    |    | 
     524         !        ///|         |         | 
     525         !        ///u    T    u    T    u   jj-line 
     526         !        ///|         |         | 
     527         !        ///|    |    |    |    | 
     528         !         jpiwob    jpiwob+1    jpiwob+2 
     529         !                |         |         
     530         !              jpiwob+1    jpiwob+2      
     531         ! 
     532         ! ... If free surface formulation: 
     533         ! ... radiative conditions on the total part + relaxation toward climatology 
     534         ! ... (jpjwdp1, jpjwfm1), jpiwob 
     535         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     536            DO jk = 1, jpkm1 
     537               DO jj = 2, jpjm1 
     538         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
     539                  z2dx = ( - uwbnd(jj,jk,nibm ,nit) -  uwbnd(jj,jk,nibm ,nitm2) & 
     540                           + 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj) 
     541         ! ... 2* gradj(u) (u-point i=nibm, time nitm) 
     542                  z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj) 
     543         ! ... square of the norm of grad(u) 
     544                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     545         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     546                  zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit) 
     547         ! ... i-phase speed ratio (bounded by -1) 
     548                  IF( z4nor2 == 0. ) THEN 
     549                     z4nor2=0.00001 
     550                  END IF 
     551                  z05cx = zdt * z2dx / z4nor2 
     552                  u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk) 
     553               END DO 
     554            END DO 
     555         END DO 
     556 
     557         ! 2.2  Calculate the tangential velocity based on phase velocity v_cxwbnd 
     558         ! ----------------------------------------------------------------------- 
     559         ! 
     560         !      nib       nibm     nibm2 
     561         !    ///|///nib   |   nibm  |  nibm2 
     562         !    ///|////|    |    |    |    |    | 
     563         !    ---v----f----v----f----v----f----v-- jj-line 
     564         !    ///|////|    |    |    |    |    | 
     565         !    ///|////|    |    |    |    |    | 
     566         !   jpiwob     jpiwob+1    jpiwob+2 
     567         !            |         |         |    
     568         !          jpiwob   jpiwob+1   jpiwob+2     
     569         ! 
     570         ! ... radiative condition plus Raymond-Kuo 
     571         ! ... (jpjwdp1, jpjwfm1),jpiwob 
     572         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     573            DO jk = 1, jpkm1 
     574               DO jj = 2, jpjm1 
     575         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
     576                  z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) & 
     577                           + 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj) 
     578         ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 
     579                  z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj) 
     580         ! ... square of the norm of grad(v) 
     581                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     582         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     583                  zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit) 
     584         ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 
     585         !     velocity ratio no divided by e1f for the tracer radiation 
     586                  IF( z4nor2 == 0) THEN 
     587                     z4nor2=0.000001 
     588                  endif 
     589                  z05cx = zdt * z2dx / z4nor2 
     590                  v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk) 
     591               END DO 
     592            END DO 
     593         END DO 
     594         IF( lk_mpp )   CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout ) 
     595 
     596         ! ... extremeties niw0, niw1 
     597         ij = jpjwd +1 - njmpp 
     598         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     599            DO jk = 1,jpkm1 
     600               v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk) 
     601            END DO 
     602         END IF 
     603         ij = jpjwf +1 - njmpp 
     604         IF( ij >= 2 .AND. ij < jpjm1 ) THEN 
     605            DO jk = 1,jpkm1 
     606               v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk) 
     607            END DO 
     608         END IF 
     609 
     610      END IF 
     611 
     612   END SUBROUTINE obc_rad_west 
     613 
     614 
     615   SUBROUTINE obc_rad_north ( kt ) 
     616      !!------------------------------------------------------------------------------ 
     617      !!                  ***  SUBROUTINE obc_rad_north  *** 
     618      !!            
     619      !! ** Purpose : 
     620      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
     621      !!      north boundary and calculate those phase speeds if this OBC is not fixed. 
     622      !!      In case of fixed OBC, this subrountine is not called. 
     623      !! 
     624      !!  History : 
     625      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     626      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     627      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     628      !!         ! 00-06 (J.-M. Molines)  
     629      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     630      !!------------------------------------------------------------------------------ 
     631      !! * Arguments 
     632      INTEGER, INTENT( in ) ::   kt 
     633 
     634      !! * Local declarations 
     635      INTEGER  ::   ii 
     636      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
     637      REAL(wp) ::   zvcb, zvcbm, zvcbm2 
     638      !!------------------------------------------------------------------------------ 
     639 
     640      ! 1. Swap arrays before calculating radiative velocities 
     641      ! ------------------------------------------------------ 
     642 
     643      ! 1.1  zonal velocity  
     644      ! ------------------- 
     645 
     646      IF( kt > nit000 .OR. ln_rstart ) THEN  
     647 
     648         ! ... advance in time (time filter, array swap) 
     649         DO jk = 1, jpkm1 
     650            DO ji = 1, jpi 
     651         ! ... fields nitm2 <== nitm 
     652               unbnd(ji,jk,nib  ,nitm2) = unbnd(ji,jk,nib  ,nitm)*unmsk(ji,jk) 
     653               unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk) 
     654               unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk) 
     655            END DO 
     656         END DO 
     657 
     658         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     659            DO jk = 1, jpkm1 
     660               DO ji = 1, jpi 
     661                  unbnd(ji,jk,nib  ,nitm) = unbnd(ji,jk,nib,  nit)*unmsk(ji,jk) 
     662                  unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk) 
     663                  unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk) 
     664         ! ... fields nit <== now (kt+1) 
     665                  unbnd(ji,jk,nib  ,nit) = un(ji,jj,  jk)*unmsk(ji,jk) 
     666                  unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk) 
     667                  unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk) 
     668               END DO 
     669            END DO 
     670         END DO 
     671         IF( lk_mpp )   CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout ) 
     672 
     673         ! ... extremeties njn0,njn1  
     674         ii = jpind + 1 - nimpp  
     675         IF( ii >= 2 .AND. ii < jpim1 ) THEN  
     676            DO jk = 1, jpkm1 
     677                unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm) 
     678            END DO 
     679         END IF  
     680         ii = jpinf + 1 - nimpp  
     681         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     682            DO jk = 1, jpkm1 
     683               unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm) 
     684            END DO 
     685         END IF 
     686  
     687         ! 1.2. normal velocity  
     688         ! -------------------- 
     689 
     690         ! ... advance in time (time filter, array swap)  
     691         DO jk = 1, jpkm1 
     692            DO ji = 1, jpi 
     693         ! ... fields nitm2 <== nitm  
     694               vnbnd(ji,jk,nib  ,nitm2) = vnbnd(ji,jk,nib  ,nitm)*vnmsk(ji,jk) 
     695               vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk) 
     696               vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk) 
     697            END DO 
     698         END DO 
     699 
     700         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
     701            DO jk = 1, jpkm1 
     702               DO ji = 1, jpi 
     703                  vnbnd(ji,jk,nib  ,nitm) = vnbnd(ji,jk,nib,  nit)*vnmsk(ji,jk) 
     704                  vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk) 
     705                  vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk) 
     706         ! ... fields nit <== now (kt+1) 
     707         ! ... total or baroclinic velocity at b, bm and bm2 
     708                  zvcb   = vn (ji,jj,jk) 
     709                  zvcbm  = vn (ji,jj-1,jk) 
     710                  zvcbm2 = vn (ji,jj-2,jk) 
     711         ! ... fields nit <== now (kt+1)  
     712                  vnbnd(ji,jk,nib  ,nit) = zvcb  *vnmsk(ji,jk) 
     713                  vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk) 
     714                  vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk) 
     715               END DO 
     716            END DO 
     717         END DO 
     718         IF( lk_mpp )   CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout ) 
     719 
     720         ! ... extremeties njn0,njn1 
     721         ii = jpind + 1 - nimpp 
     722         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     723            DO jk = 1, jpkm1 
     724               vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm) 
     725            END DO 
     726         END IF 
     727         ii = jpinf + 1 - nimpp 
     728         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     729            DO jk = 1, jpkm1 
     730               vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm) 
     731            END DO 
     732         END IF 
     733 
     734         ! 1.3 Temperature and salinity 
     735         ! ---------------------------- 
     736 
     737         ! ... advance in time (time filter, array swap) 
     738         DO jk = 1, jpkm1 
     739            DO ji = 1, jpi 
     740         ! ... fields nitm <== nit  plus time filter at the boundary 
     741               tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 
     742               snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 
     743            END DO 
     744         END DO 
     745 
     746         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     747            DO jk = 1, jpkm1 
     748               DO ji = 1, jpi 
     749                  tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
     750                  snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
     751         ! ... fields nit <== now (kt+1) 
     752                  tnbnd(ji,jk,nib  ,nit) = tn(ji,jj,  jk)*tnmsk(ji,jk) 
     753                  tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk) 
     754                  snbnd(ji,jk,nib  ,nit) = sn(ji,jj,  jk)*tnmsk(ji,jk) 
     755                  snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk) 
     756               END DO 
     757            END DO 
     758         END DO 
     759         IF( lk_mpp )   CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 
     760         IF( lk_mpp )   CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 
     761 
     762         ! ... extremeties  njn0,njn1 
     763         ii = jpind + 1 - nimpp 
     764         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     765            DO jk = 1, jpkm1 
     766               tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm) 
     767               snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm) 
     768            END DO 
     769         END IF 
     770         ii = jpinf + 1 - nimpp 
     771         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     772            DO jk = 1, jpkm1 
     773               tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm) 
     774               snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm) 
     775            END DO 
     776         END IF 
     777 
     778      END IF     ! End of array swap 
     779 
     780      ! 2 - Calculation of radiation velocities 
     781      ! --------------------------------------- 
     782 
     783      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
     784 
     785         ! 2.1  Calculate the normal velocity based on phase velocity u_cynbnd 
     786         ! ------------------------------------------------------------------- 
     787         ! 
     788         !           ji-row 
     789         !             | 
     790         !     nib -///u//////  jpjnob + 1 
     791         !        /////|////// 
     792         !   nib  -----f-----   jpjnob 
     793         !             |     
     794         !     nibm--  u   ---- jpjnob 
     795         !             |         
     796         !  nibm  -----f-----   jpjnob-1 
     797         !             |         
     798         !    nibm2--  u   ---- jpjnob-1 
     799         !             |         
     800         !  nibm2 -----f-----   jpjnob-2 
     801         !             | 
     802         ! ... radiative condition 
     803         ! ... jpjnob+1,(jpindp1, jpinfm1) 
     804         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     805            DO jk = 1, jpkm1 
     806               DO ji = 2, jpim1 
     807         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
     808                  z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) & 
     809                        - 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2) 
     810         ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 
     811                  z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1) 
     812         ! ... square of the norm of grad(v) 
     813                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     814         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     815                  zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit) 
     816         ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 
     817         !     velocity ratio no divided by e1f for the tracer radiation 
     818                  IF( z4nor2 == 0.) THEN 
     819                     z4nor2=.000001 
     820                  END IF 
     821                  z05cx = zdt * z2dx / z4nor2 
     822                  u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk) 
     823               END DO 
     824            END DO 
     825         END DO 
     826         IF( lk_mpp )   CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout ) 
     827 
     828         ! ... extremeties  njn0,njn1 
     829         ii = jpind + 1 - nimpp 
     830         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     831            DO jk = 1, jpkm1 
     832               u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk) 
     833            END DO 
     834         END IF 
     835         ii = jpinf + 1 - nimpp 
     836         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     837            DO jk = 1, jpkm1 
     838               u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk) 
     839            END DO 
     840         END IF 
     841 
     842         ! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd  
     843         ! ------------------------------------------------------------------ 
     844         ! 
     845         !                ji-row  ji-row 
     846         !                     | 
     847         !        /////|///////////////// 
     848         !   nib  -----f----v----f----  jpjnob 
     849         !             |         | 
     850         !     nib  -  u -- T -- u ---- jpjnob 
     851         !             |         | 
     852         !  nibm  -----f----v----f----  jpjnob-1 
     853         !             |         | 
     854         !    nibm --  u -- T -- u ---  jpjnob-1 
     855         !             |         | 
     856         !  nibm2 -----f----v----f----  jpjnob-2 
     857         !             |         | 
     858         ! ... Free surface formulation: 
     859         ! ... radiative conditions on the total part + relaxation toward climatology  
     860         ! ... jpjnob,(jpindp1, jpinfm1) 
     861         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
     862            DO jk = 1, jpkm1 
     863               DO ji = 2, jpim1 
     864         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
     865                  ii = ji -1 + nimpp 
     866                  z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) & 
     867                          - 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1) 
     868         ! ... 2* gradi(v) (v-point i=nibm, time nitm) 
     869                  z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1) 
     870         ! ... square of the norm of grad(u) 
     871                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     872         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     873                  zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit) 
     874         ! ... j-phase speed ratio (bounded by 1) 
     875                  IF( z4nor2 == 0. ) THEN 
     876                     z4nor2=.00001 
     877                  END IF 
     878                  z05cx = zdt * z2dx / z4nor2 
     879                  v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk) 
     880               END DO 
     881            END DO 
     882         END DO 
     883 
     884      END IF 
     885 
     886   END SUBROUTINE obc_rad_north 
     887 
     888 
     889   SUBROUTINE obc_rad_south ( kt ) 
     890      !!------------------------------------------------------------------------------ 
     891      !!                  ***  SUBROUTINE obc_rad_south  *** 
     892      !!            
     893      !! ** Purpose : 
     894      !!      Perform swap of arrays to calculate radiative phase speeds at the open  
     895      !!      south boundary and calculate those phase speeds if this OBC is not fixed. 
     896      !!      In case of fixed OBC, this subrountine is not called. 
     897      !! 
     898      !!  History : 
     899      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     900      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     901      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     902      !!         ! 00-06 (J.-M. Molines)  
     903      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 
     904      !!------------------------------------------------------------------------------ 
     905      !! * Arguments 
     906      INTEGER, INTENT( in ) ::   kt 
     907 
     908      !! * Local declarations 
     909      INTEGER ::   ii 
     910      REAL(wp) ::   z05cx, zdt, z4nor2, z2dx, z2dy 
     911      REAL(wp) ::   zvcb, zvcbm, zvcbm2 
     912      !!------------------------------------------------------------------------------ 
     913 
     914      ! 1. Swap arrays before calculating radiative velocities 
     915      ! ------------------------------------------------------ 
     916 
     917      ! 1.1  zonal velocity  
     918      ! -------------------- 
     919   
     920      IF( kt > nit000 .OR. ln_rstart ) THEN  
     921 
     922         ! ... advance in time (time filter, array swap) 
     923         DO jk = 1, jpkm1 
     924            DO ji = 1, jpi 
     925         ! ... fields nitm2 <== nitm 
     926                  usbnd(ji,jk,nib  ,nitm2) = usbnd(ji,jk,nib  ,nitm)*usmsk(ji,jk) 
     927                  usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk) 
     928                  usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk) 
     929            END DO 
     930         END DO 
     931  
     932         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     933            DO jk = 1, jpkm1 
     934               DO ji = 1, jpi 
     935                  usbnd(ji,jk,nib  ,nitm) = usbnd(ji,jk,nib,  nit)*usmsk(ji,jk) 
     936                  usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk) 
     937                  usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk) 
     938         ! ... fields nit <== now (kt+1) 
     939                  usbnd(ji,jk,nib  ,nit) = un(ji,jj  ,jk)*usmsk(ji,jk) 
     940                  usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk) 
     941                  usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk) 
     942               END DO 
     943            END DO 
     944         END DO 
     945         IF( lk_mpp )   CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 
     946 
     947         ! ... extremeties njs0,njs1 
     948         ii = jpisd + 1 - nimpp 
     949         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     950            DO jk = 1, jpkm1 
     951               usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm) 
     952            END DO 
     953         END IF 
     954         ii = jpisf + 1 - nimpp 
     955         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     956            DO jk = 1, jpkm1 
     957               usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm) 
     958            END DO 
     959         END IF 
     960  
     961         ! 1.2 normal velocity 
     962         ! ------------------- 
     963  
     964         !.. advance in time (time filter, array swap)  
     965         DO jk = 1, jpkm1 
     966            DO ji = 1, jpi 
     967         ! ... fields nitm2 <== nitm  
     968               vsbnd(ji,jk,nib  ,nitm2) = vsbnd(ji,jk,nib  ,nitm)*vsmsk(ji,jk) 
     969               vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk) 
     970            END DO 
     971         END DO 
     972 
     973         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     974            DO jk = 1, jpkm1 
     975               DO ji = 1, jpi 
     976                  vsbnd(ji,jk,nib  ,nitm) = vsbnd(ji,jk,nib,  nit)*vsmsk(ji,jk) 
     977                  vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk) 
     978                  vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk) 
     979         ! ... total or baroclinic velocity at b, bm and bm2 
     980                  zvcb   = vn (ji,jj,jk) 
     981                  zvcbm  = vn (ji,jj+1,jk) 
     982                  zvcbm2 = vn (ji,jj+2,jk) 
     983         ! ... fields nit <== now (kt+1)  
     984                  vsbnd(ji,jk,nib  ,nit) = zvcb   *vsmsk(ji,jk) 
     985                  vsbnd(ji,jk,nibm ,nit) = zvcbm  *vsmsk(ji,jk) 
     986                  vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk) 
     987               END DO 
     988            END DO 
     989         END DO 
     990         IF( lk_mpp )   CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 
     991 
     992         ! ... extremeties njs0,njs1 
     993         ii = jpisd + 1 - nimpp 
     994         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     995            DO jk = 1, jpkm1 
     996               vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm) 
     997            END DO 
     998         END IF 
     999         ii = jpisf + 1 - nimpp 
     1000         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     1001            DO jk = 1, jpkm1 
     1002               vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm) 
     1003            END DO 
     1004         END IF 
     1005 
     1006         ! 1.3 Temperature and salinity 
     1007         ! ---------------------------- 
     1008 
     1009         ! ... advance in time (time filter, array swap) 
     1010         DO jk = 1, jpkm1 
     1011            DO ji = 1, jpi 
     1012         ! ... fields nitm <== nit  plus time filter at the boundary 
     1013               tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 
     1014               ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 
     1015            END DO 
     1016         END DO 
     1017 
     1018         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1019            DO jk = 1, jpkm1 
     1020               DO ji = 1, jpi 
     1021                  tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
     1022                  ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
     1023         ! ... fields nit <== now (kt+1) 
     1024                  tsbnd(ji,jk,nib  ,nit) = tn(ji,jj   ,jk)*tsmsk(ji,jk) 
     1025                  tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk) 
     1026                  ssbnd(ji,jk,nib  ,nit) = sn(ji,jj   ,jk)*tsmsk(ji,jk) 
     1027                  ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk) 
     1028               END DO 
     1029            END DO 
     1030         END DO 
     1031         IF( lk_mpp )   CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 
     1032         IF( lk_mpp )   CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 
     1033 
     1034         ! ... extremeties  njs0,njs1 
     1035         ii = jpisd + 1 - nimpp 
     1036         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     1037            DO jk = 1, jpkm1 
     1038               tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm) 
     1039               ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm) 
     1040            END DO 
     1041         END IF 
     1042         ii = jpisf + 1 - nimpp 
     1043         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     1044            DO jk = 1, jpkm1 
     1045               tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm) 
     1046               ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm) 
     1047            END DO 
     1048         END IF 
     1049 
     1050      END IF     ! End of array swap 
     1051 
     1052      ! 2 - Calculation of radiation velocities 
     1053      ! --------------------------------------- 
     1054 
     1055      IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 
     1056 
     1057         ! 2.1  Calculate the normal velocity based on phase velocity u_cysbnd 
     1058         ! ------------------------------------------------------------------- 
     1059         ! 
     1060         !          ji-row 
     1061         !            | 
     1062         ! nibm2 -----f-----   jpjsob +2 
     1063         !            |     
     1064         !  nibm2 --  u  ----- jpjsob +2  
     1065         !            |         
     1066         !  nibm -----f-----   jpjsob +1 
     1067         !            |         
     1068         !  nibm  --  u  ----- jpjsob +1 
     1069         !            |         
     1070         !  nib  -----f-----   jpjsob 
     1071         !       /////|////// 
     1072         !  nib   ////u/////   jpjsob  
     1073         ! 
     1074         ! ... radiative condition plus Raymond-Kuo 
     1075         ! ... jpjsob,(jpisdp1, jpisfm1) 
     1076         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1077            DO jk = 1, jpkm1 
     1078               DO ji = 2, jpim1 
     1079         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
     1080                  z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) & 
     1081                          + 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1) 
     1082         ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 
     1083                  z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1) 
     1084         ! ... square of the norm of grad(v) 
     1085                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     1086                  IF( z4nor2 == 0.) THEN 
     1087                     z4nor2 = 0.000001 
     1088                  END IF 
     1089         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     1090                  zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit) 
     1091         ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 
     1092         !     velocity ratio no divided by e1f for the tracer radiation 
     1093                  z05cx = zdt * z2dx / z4nor2 
     1094                  u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk) 
     1095               END DO 
     1096            END DO 
     1097         END DO 
     1098         IF( lk_mpp )   CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout ) 
     1099 
     1100         ! ... extremeties  njs0,njs1 
     1101         ii = jpisd + 1 - nimpp 
     1102         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     1103            DO jk = 1, jpkm1 
     1104               u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk) 
     1105            END DO 
     1106         END IF 
     1107         ii = jpisf + 1 - nimpp 
     1108         IF( ii >= 2 .AND. ii < jpim1 ) THEN 
     1109            DO jk = 1, jpkm1 
     1110               u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk) 
     1111            END DO 
     1112         END IF 
     1113 
     1114         ! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd  
     1115         ! ------------------------------------------------------------------- 
     1116         ! 
     1117         !               ji-row  ji-row 
     1118         !            |         | 
     1119         ! nibm2 -----f----v----f----  jpjsob+2 
     1120         !            |         | 
     1121         !  nibm   -  u -- T -- u ---- jpjsob+2 
     1122         !            |         | 
     1123         ! nibm  -----f----v----f----  jpjsob+1  
     1124         !            |         | 
     1125         ! nib    --  u -- T -- u ---  jpjsob+1 
     1126         !            |         | 
     1127         ! nib   -----f----v----f----  jpjsob 
     1128         !       ///////////////////// 
     1129         ! 
     1130         ! ... Free surface formulation: 
     1131         ! ... radiative conditions on the total part + relaxation toward climatology 
     1132         ! ... jpjsob,(jpisdp1,jpisfm1) 
     1133         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     1134            DO jk = 1, jpkm1 
     1135               DO ji = 2, jpim1 
     1136         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
     1137                  z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) & 
     1138                           + 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1) 
     1139         ! ... 2* gradi(v) (v-point i=nibm, time nitm) 
     1140                  z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1) 
     1141         ! ... square of the norm of grad(u) 
     1142                  z4nor2 = z2dx * z2dx + z2dy * z2dy 
     1143                  IF( z4nor2 == 0.) THEN 
     1144                     z4nor2 = 0.000001 
     1145                  END IF 
     1146         ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 
     1147                  zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit) 
     1148         ! ... j-phase speed ratio (bounded by -1) 
     1149                  z05cx = zdt * z2dx / z4nor2 
     1150                  v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk) 
     1151               END DO 
     1152            END DO 
     1153         END DO 
     1154 
     1155      ENDIF 
     1156  
     1157   END SUBROUTINE obc_rad_south 
     1158 
     1159#else 
    11601160   !!================================================================================= 
    11611161   !!                       ***  MODULE  obcrad  *** 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90

    r2865 r2888  
    11MODULE obctra 
    2    !!====================================================================== 
     2   !!================================================================================= 
    33   !!                       ***  MODULE  obctra  *** 
    4    !! Ocean tracers:   Flow Relaxation Scheme of tracers on each open boundary 
    5    !!====================================================================== 
    6    !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code 
    7    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    8    !!---------------------------------------------------------------------- 
     4   !! Ocean tracers:   Radiation of tracers on each open boundary 
     5   !!================================================================================= 
    96#if defined key_obc 
    10    !!---------------------------------------------------------------------- 
    11    !!   'key_obc'                     Unstructured Open Boundary Conditions 
    12    !!---------------------------------------------------------------------- 
    13    !!   obc_tra            : Apply open boundary conditions to T and S 
    14    !!   obc_tra_frs        : Apply Flow Relaxation Scheme 
    15    !!---------------------------------------------------------------------- 
     7   !!--------------------------------------------------------------------------------- 
     8   !!   'key_obc'      :                                      Open Boundary Conditions 
     9   !!--------------------------------------------------------------------------------- 
     10   !!   obc_tra        : call the subroutine for each open boundary 
     11   !!   obc_tra_east   : radiation of the east open boundary tracers 
     12   !!   obc_tra_west   : radiation of the west open boundary tracers 
     13   !!   obc_tra_north  : radiation of the north open boundary tracers 
     14   !!   obc_tra_south  : radiation of the south open boundary tracers 
     15   !!---------------------------------------------------------------------------------- 
     16   !! * Modules used 
    1617   USE oce             ! ocean dynamics and tracers variables 
    1718   USE dom_oce         ! ocean space and time domain variables  
     19   USE phycst          ! physical constants 
    1820   USE obc_oce         ! ocean open boundary conditions 
    19    USE obcdta, ONLY:   bf 
    20    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     21   USE lib_mpp         ! ??? 
     22   USE lbclnk          ! ??? 
    2123   USE in_out_manager  ! I/O manager 
    2224 
    … …  
    2426   PRIVATE 
    2527 
    26    PUBLIC obc_tra      ! routine called in tranxt.F90  
    27  
    28    !!---------------------------------------------------------------------- 
     28   !! * Accessibility 
     29   PUBLIC obc_tra     ! routine called in tranxt.F90  
     30 
     31   !! * Module variables 
     32   INTEGER ::      & ! ... boundary space indices  
     33      nib   = 1,   & ! nib   = boundary point 
     34      nibm  = 2,   & ! nibm  = 1st interior point 
     35      nibm2 = 3,   & ! nibm2 = 2nd interior point 
     36                     ! ... boundary time indices  
     37      nit   = 1,   & ! nit    = now 
     38      nitm  = 2,   & ! nitm   = before 
     39      nitm2 = 3      ! nitm2  = before-before 
     40 
     41   REAL(wp) ::     & 
     42      rtaue  , rtauw  , rtaun  , rtaus  ,  &  ! Boundary restoring coefficient 
     43      rtauein, rtauwin, rtaunin, rtausin      ! Boundary restoring coefficient for inflow  
     44 
     45   !! * Substitutions 
     46#  include "obc_vectopt_loop_substitute.h90" 
     47   !!--------------------------------------------------------------------------------- 
    2948   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    3049   !! $Id$  
    3150   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    32    !!---------------------------------------------------------------------- 
     51   !!--------------------------------------------------------------------------------- 
     52 
    3353CONTAINS 
    3454 
    3555   SUBROUTINE obc_tra( kt ) 
     56      !!------------------------------------------------------------------------------- 
     57      !!                 ***  SUBROUTINE obc_tra  *** 
     58      !!                     
     59      !! ** Purpose :   Compute tracer fields (t,s) along the open boundaries. 
     60      !!      This routine is called by the tranxt.F routine and updates ta,sa 
     61      !!      which are the actual temperature and salinity fields. 
     62      !!        The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 
     63      !!      and/or lp_obc_south allow the user to determine which boundary is an 
     64      !!      open one (must be done in the param_obc.h90 file). 
     65      !! 
     66      !! Reference :  
     67      !!   Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 
     68      !! 
     69      !!  History : 
     70      !!        !  95-03 (J.-M. Molines) Original, SPEM 
     71      !!        !  97-07 (G. Madec, J.-M. Molines) addition 
     72      !!   8.5  !  02-10 (C. Talandier, A-M. Treguier) F90 
    3673      !!---------------------------------------------------------------------- 
    37       !!                  ***  SUBROUTINE obc_dyn3d  *** 
    38       !! 
    39       !! ** Purpose : - Apply open boundary conditions for baroclinic velocities 
    40       !! 
     74      !! * Arguments 
     75      INTEGER, INTENT( in ) ::   kt 
    4176      !!---------------------------------------------------------------------- 
    42       INTEGER, INTENT( in ) :: kt     ! Main time step counter 
    43       !! 
    44       INTEGER               :: ib_obc ! Loop index 
    45  
    46       DO ib_obc=1, nb_obc 
    47  
    48          SELECT CASE( nn_tra(ib_obc) ) 
    49          CASE(jp_none) 
    50             CYCLE 
    51          CASE(jp_frs) 
    52             CALL obc_tra_frs( idx_obc(ib_obc), dta_obc(ib_obc), kt ) 
    53          CASE DEFAULT 
    54             CALL ctl_stop( 'obc_tra : unrecognised option for open boundaries for T and S' ) 
    55          END SELECT 
    56       ENDDO 
     77 
     78      ! 0. Local constant initialization 
     79 
     80      IF( kt == nit000 .OR. ln_rstart) THEN 
     81         ! ... Boundary restoring coefficient 
     82         rtaue = 2. * rdt / rdpeob 
     83         rtauw = 2. * rdt / rdpwob 
     84         rtaun = 2. * rdt / rdpnob 
     85         rtaus = 2. * rdt / rdpsob 
     86         ! ... Boundary restoring coefficient for inflow ( all boundaries) 
     87         rtauein = 2. * rdt / rdpein  
     88         rtauwin = 2. * rdt / rdpwin 
     89         rtaunin = 2. * rdt / rdpnin 
     90         rtausin = 2. * rdt / rdpsin  
     91      END IF 
     92 
     93      IF( lp_obc_east  )   CALL obc_tra_east ( kt )    ! East open boundary 
     94 
     95      IF( lp_obc_west  )   CALL obc_tra_west ( kt )    ! West open boundary 
     96 
     97      IF( lp_obc_north )   CALL obc_tra_north( kt )    ! North open boundary 
     98 
     99      IF( lp_obc_south )   CALL obc_tra_south( kt )    ! South open boundary 
     100 
     101      IF( lk_mpp ) THEN                  !!bug ??? 
     102         IF( kt >= nit000+3 .AND. ln_rstart ) THEN 
     103            CALL lbc_lnk( tb, 'T', 1. ) 
     104            CALL lbc_lnk( sb, 'T', 1. ) 
     105         END IF 
     106         CALL lbc_lnk( ta, 'T', 1. ) 
     107         CALL lbc_lnk( sa, 'T', 1. ) 
     108      ENDIF 
    57109 
    58110   END SUBROUTINE obc_tra 
    59111 
    60    SUBROUTINE obc_tra_frs( idx, dta, kt ) 
    61       !!---------------------------------------------------------------------- 
    62       !!                 ***  SUBROUTINE obc_tra_frs  *** 
    63       !!                     
    64       !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries. 
    65       !!  
    66       !! Reference : Engedahl H., 1995, Tellus, 365-382. 
    67       !!---------------------------------------------------------------------- 
    68       INTEGER,         INTENT(in) ::   kt 
    69       TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    70       TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    71       !!  
    72       REAL(wp) ::   zwgt           ! boundary weight 
    73       INTEGER  ::   ib, ik, igrd   ! dummy loop indices 
    74       INTEGER  ::   ii, ij         ! 2D addresses 
    75       !!---------------------------------------------------------------------- 
    76       ! 
    77       ! 
    78       igrd = 1                       ! Everything is at T-points here 
    79       DO ib = 1, idx%nblen(igrd) 
    80          DO ik = 1, jpkm1 
    81             ii = idx%nbi(ib,igrd) 
    82             ij = idx%nbj(ib,igrd) 
    83             zwgt = idx%nbw(ib,igrd) 
    84             ta(ii,ij,ik) = ( ta(ii,ij,ik) + zwgt * ( dta%tem(ib,ik) - ta(ii,ij,ik) ) ) * tmask(ii,ij,ik)          
    85             sa(ii,ij,ik) = ( sa(ii,ij,ik) + zwgt * ( dta%sal(ib,ik) - sa(ii,ij,ik) ) ) * tmask(ii,ij,ik) 
    86          END DO 
    87       END DO  
    88       ! 
    89       CALL lbc_lnk( ta, 'T', 1. )   ; CALL lbc_lnk( sa, 'T', 1. )    ! Boundary points should be updated 
    90       ! 
    91       IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 
    92    ! 
    93    END SUBROUTINE obc_tra_frs 
    94     
     112 
     113   SUBROUTINE obc_tra_east ( kt ) 
     114      !!------------------------------------------------------------------------------ 
     115      !!                ***  SUBROUTINE obc_tra_east  *** 
     116      !!                   
     117      !! ** Purpose : 
     118      !!      Apply the radiation algorithm on east OBC tracers ta, sa using the  
     119      !!      phase velocities calculated in obc_rad_east subroutine in obcrad.F90 module 
     120      !!      If the logical lfbceast is .TRUE., there is no radiation but only fixed OBC 
     121      !! 
     122      !!  History : 
     123      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     124      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     125      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     126      !!         ! 00-06 (J.-M. Molines)  
     127      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) F90 
     128      !!------------------------------------------------------------------------------ 
     129      !! * Arguments 
     130      INTEGER, INTENT( in ) ::   kt 
     131 
     132      !! * Local declaration 
     133      INTEGER ::   ji, jj, jk      ! dummy loop indices 
     134      REAL(wp) ::   z05cx, ztau, zin 
     135      !!------------------------------------------------------------------------------ 
     136 
     137      ! 1. First three time steps and more if lfbceast is .TRUE. 
     138      !    In that case open boundary conditions are FIXED. 
     139      ! -------------------------------------------------------- 
     140 
     141      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast ) THEN 
     142         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     143            DO jk = 1, jpkm1 
     144               DO jj = 1, jpj 
     145                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 
     146                                 tfoe(jj,jk)*temsk(jj,jk) 
     147                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) + & 
     148                                 sfoe(jj,jk)*temsk(jj,jk) 
     149               END DO 
     150            END DO 
     151         END DO 
     152 
     153      ELSE 
     154 
     155      ! 2. Beyond the fourth time step if lfbceast is .FALSE. 
     156      ! ----------------------------------------------------- 
     157 
     158         ! Temperature and salinity radiation 
     159         ! ---------------------------------- 
     160         ! 
     161         !            nibm2      nibm      nib 
     162         !              |   nibm  |   nib///|/// 
     163         !              |    |    |    |////|/// 
     164         !  jj   line --v----f----v----f----v--- 
     165         !              |    |    |    |////|/// 
     166         !                   |         |///   // 
     167         !  jj   line   T    u    T    u/// T // 
     168         !                   |         |///   // 
     169         !              |    |    |    |////|/// 
     170         !  jj-1 line --v----f----v----f----v--- 
     171         !              |    |    |    |////|/// 
     172         !                jpieob-1    jpieob / /// 
     173         !              |         |         | 
     174         !           jpieob-1    jpieob     jpieob+1 
     175         ! 
     176         ! ... radiative conditions + relaxation toward a climatology 
     177         !     the phase velocity is taken as the phase velocity of the tangen- 
     178         !     tial velocity (here vn), which have been saved in (u_cxebnd,v_cxebnd) 
     179         ! ... (jpjedp1, jpjefm1), jpieob+1 
     180         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     181            DO jk = 1, jpkm1 
     182               DO jj = 2, jpjm1 
     183         ! ... i-phase speed ratio (from averaged of v_cxebnd) 
     184                  z05cx = ( 0.5 * ( v_cxebnd(jj,jk) + v_cxebnd(jj-1,jk) ) ) / e1t(ji-1,jj) 
     185                  z05cx = min( z05cx, 1. ) 
     186         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     187         !           > 0, outflow zin=1, ztau=rtaue 
     188                  zin = sign( 1., z05cx ) 
     189                  zin = 0.5*( zin + abs(zin) ) 
     190         ! ... for inflow rtauein is used for relaxation coefficient else rtaue 
     191                  ztau = (1.-zin ) * rtauein  + zin * rtaue 
     192                  z05cx = z05cx * zin 
     193         ! ... update ( ta, sa ) with radiative or climatological (t, s) 
     194                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) +           &  
     195                                 temsk(jj,jk) * ( ( 1. - z05cx - ztau )         & 
     196                                 * tebnd(jj,jk,nib ,nitm) + 2.*z05cx              & 
     197                                 * tebnd(jj,jk,nibm,nit ) + ztau * tfoe (jj,jk) ) & 
     198                                 / (1. + z05cx) 
     199                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) +           &  
     200                                 temsk(jj,jk) * ( ( 1. - z05cx - ztau )         & 
     201                                 * sebnd(jj,jk,nib ,nitm) + 2.*z05cx              & 
     202                                 * sebnd(jj,jk,nibm,nit ) + ztau * sfoe (jj,jk) ) & 
     203                                 / (1. + z05cx) 
     204               END DO 
     205            END DO 
     206         END DO 
     207 
     208      END IF 
     209 
     210   END SUBROUTINE obc_tra_east 
     211 
     212 
     213   SUBROUTINE obc_tra_west ( kt ) 
     214      !!------------------------------------------------------------------------------ 
     215      !!                 ***  SUBROUTINE obc_tra_west  *** 
     216      !!            
     217      !! ** Purpose : 
     218      !!      Apply the radiation algorithm on west OBC tracers ta, sa using the  
     219      !!      phase velocities calculated in obc_rad_west subroutine in obcrad.F90 module 
     220      !!      If the logical lfbcwest is .TRUE., there is no radiation but only fixed OBC 
     221      !! 
     222      !!  History : 
     223      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     224      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     225      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     226      !!         ! 00-06 (J.-M. Molines)  
     227      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) F90 
     228      !!------------------------------------------------------------------------------ 
     229      !! * Arguments 
     230      INTEGER, INTENT( in ) ::   kt 
     231 
     232      !! * Local declaration 
     233      INTEGER ::   ji, jj, jk      ! dummy loop indices 
     234      REAL(wp) ::   z05cx, ztau, zin 
     235      !!------------------------------------------------------------------------------ 
     236 
     237      ! 1. First three time steps and more if lfbcwest is .TRUE. 
     238      !    In that case open boundary conditions are FIXED. 
     239      ! -------------------------------------------------------- 
     240 
     241      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest ) THEN 
     242 
     243         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     244            DO jk = 1, jpkm1 
     245               DO jj = 1, jpj 
     246                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 
     247                                 tfow(jj,jk)*twmsk(jj,jk) 
     248                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 
     249                                 sfow(jj,jk)*twmsk(jj,jk) 
     250               END DO 
     251            END DO 
     252         END DO 
     253 
     254      ELSE 
     255 
     256      ! 2. Beyond the fourth time step if lfbcwest is .FALSE. 
     257      ! ----------------------------------------------------- 
     258           
     259         ! Temperature and salinity radiation 
     260         ! ---------------------------------- 
     261         ! 
     262         !          nib       nibm     nibm2 
     263         !     nib///|   nibm  |  nibm2  | 
     264         !   ///|////|    |    |    |    |    
     265         !   ---v----f----v----f----v----f-- jj   line 
     266         !   ///|////|    |    |    |    |    
     267         !   //   ///|         |         |    
     268         !   // T ///u    T    u    T    u   jj   line 
     269         !   //   ///|         |         |    
     270         !   ///|////|    |    |    |    |    
     271         !   ---v----f----v----f----v----f-- jj-1 line 
     272         !   ///|////|    |    |    |    |    
     273         !         jpiwob    jpiwob+1    jpiwob+2 
     274         !      |         |         |         
     275         !    jpiwob    jpiwob+1   jpiwob+2 
     276         ! 
     277         ! ... radiative conditions + relaxation toward a climatology 
     278         ! ... the phase velocity is taken as the phase velocity of the tangen- 
     279         ! ... tial velocity (here vn), which have been saved in (v_cxwbnd) 
     280         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     281            DO jk = 1, jpkm1 
     282               DO jj = 2, jpjm1 
     283         ! ... i-phase speed ratio (from averaged of v_cxwbnd) 
     284                  z05cx = (  0.5 * ( v_cxwbnd(jj,jk) + v_cxwbnd(jj-1,jk) ) ) / e1t(ji+1,jj) 
     285                  z05cx = max( z05cx, -1. ) 
     286         ! ... z05cx > 0, inflow  zin=0, ztau=1     
     287         !           < 0, outflow zin=1, ztau=rtauw 
     288                  zin = sign( 1., -1.* z05cx ) 
     289                  zin = 0.5*( zin + abs(zin) ) 
     290                  ztau = (1.-zin )*rtauwin + zin * rtauw 
     291                  z05cx = z05cx * zin 
     292         ! ... update (ta,sa) with radiative or climatological (t, s) 
     293                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) +           & 
     294                                 twmsk(jj,jk) * ( ( 1. + z05cx - ztau )         & 
     295                                 * twbnd(jj,jk,nib ,nitm) - 2.*z05cx              & 
     296                                 * twbnd(jj,jk,nibm,nit ) + ztau * tfow (jj,jk) ) & 
     297                                 / (1. - z05cx) 
     298                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) +           & 
     299                                 twmsk(jj,jk) * ( ( 1. + z05cx - ztau )         & 
     300                                 * swbnd(jj,jk,nib ,nitm) - 2.*z05cx              & 
     301                                 * swbnd(jj,jk,nibm,nit ) + ztau * sfow (jj,jk) ) & 
     302                                 / (1. - z05cx) 
     303               END DO 
     304            END DO 
     305         END DO 
     306 
     307      END IF 
     308 
     309   END SUBROUTINE obc_tra_west 
     310 
     311 
     312   SUBROUTINE obc_tra_north ( kt ) 
     313      !!------------------------------------------------------------------------------ 
     314      !!                 ***  SUBROUTINE obc_tra_north  *** 
     315      !! 
     316      !! ** Purpose : 
     317      !!      Apply the radiation algorithm on north OBC tracers ta, sa using the  
     318      !!      phase velocities calculated in obc_rad_north subroutine in obcrad.F90 module 
     319      !!      If the logical lfbcnorth is .TRUE., there is no radiation but only fixed OBC 
     320      !! 
     321      !!  History : 
     322      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     323      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     324      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     325      !!         ! 00-06 (J.-M. Molines)  
     326      !!    8.5  ! 02-10 (C. Talandier, A-M. Treguier) F90 
     327      !!------------------------------------------------------------------------------ 
     328      !! * Arguments 
     329      INTEGER, INTENT( in ) ::   kt 
     330 
     331      !! * Local declaration 
     332      INTEGER ::   ji, jj, jk      ! dummy loop indices 
     333      REAL(wp) ::   z05cx, ztau, zin 
     334      !!------------------------------------------------------------------------------ 
     335 
     336      ! 1. First three time steps and more if lfbcnorth is .TRUE. 
     337      !    In that case open boundary conditions are FIXED. 
     338      ! -------------------------------------------------------- 
     339 
     340      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcnorth ) THEN 
     341 
     342         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     343            DO jk = 1, jpkm1 
     344               DO ji = 1, jpi 
     345                  ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 
     346                                tnmsk(ji,jk) * tfon(ji,jk) 
     347                  sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 
     348                                tnmsk(ji,jk) * sfon(ji,jk) 
     349               END DO 
     350            END DO 
     351         END DO 
     352 
     353      ELSE 
     354 
     355      ! 2. Beyond the fourth time step if lfbcnorth is .FALSE. 
     356      ! ------------------------------------------------------- 
     357           
     358         ! Temperature and salinity radiation 
     359         ! ---------------------------------- 
     360         ! 
     361         !           ji-1   ji   ji   ji +1 
     362         !             | 
     363         !    nib //// u // T // u // T //   jpjnob + 1 
     364         !        /////|////////////////// 
     365         !    nib  ----f----v----f----v---   jpjnob 
     366         !             |         |        
     367         !      nibm-- u -- T -- u -- T --   jpjnob 
     368         !             |         |             
     369         !   nibm  ----f----v----f----v---  jpjnob-1 
     370         !             |         |       
     371         !     nibm2-- u -- T -- T -- T --  jpjnob-1 
     372         !             |         |     
     373         !   nibm2 ----f----v----f----v---  jpjnob-2 
     374         !             |         | 
     375         ! 
     376         ! ... radiative conditions + relaxation toward a climatology 
     377         ! ... the phase velocity is taken as the normal phase velocity of the tangen- 
     378         ! ... tial velocity (here un), which has been saved in (u_cynbnd) 
     379         ! ... jpjnob+1,(jpindp1, jpinfm1) 
     380         DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 
     381            DO jk = 1, jpkm1 
     382               DO ji = 2, jpim1 
     383         ! ... j-phase speed ratio (from averaged of vtnbnd) 
     384         !        (bounded by 1) 
     385                  z05cx = ( 0.5 * ( u_cynbnd(ji,jk) + u_cynbnd(ji-1,jk) ) ) / e2t(ji,jj-1) 
     386                  z05cx = min( z05cx, 1. ) 
     387         ! ... z05cx=< 0, inflow  zin=0, ztau=1     
     388         !           > 0, outflow zin=1, ztau=rtaun 
     389                  zin = sign( 1., z05cx ) 
     390                  zin = 0.5*( zin + abs(zin) ) 
     391         ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 
     392                  ztau = (1.-zin ) * rtaunin + zin * rtaun 
     393                  z05cx = z05cx * zin 
     394         ! ... update (ta,sa) with radiative or climatological (t, s) 
     395                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) +             & 
     396                                 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau )         & 
     397                                 * tnbnd(ji,jk,nib ,nitm) + 2.*z05cx              & 
     398                                 * tnbnd(ji,jk,nibm,nit ) + ztau * tfon (ji,jk) ) & 
     399                                 / (1. + z05cx) 
     400                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) +             & 
     401                                 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau )         & 
     402                                 * snbnd(ji,jk,nib ,nitm) + 2.*z05cx              & 
     403                                 * snbnd(ji,jk,nibm,nit ) + ztau * sfon (ji,jk) ) & 
     404                                 / (1. + z05cx) 
     405               END DO 
     406            END DO 
     407         END DO 
     408 
     409      END IF 
     410 
     411   END SUBROUTINE obc_tra_north 
     412 
     413 
     414   SUBROUTINE obc_tra_south ( kt ) 
     415      !!------------------------------------------------------------------------------ 
     416      !!                ***  SUBROUTINE obc_tra_south  *** 
     417      !!      
     418      !! ** Purpose : 
     419      !!      Apply the radiation algorithm on south OBC tracers ta, sa using the  
     420      !!      phase velocities calculated in obc_rad_south subroutine in obcrad.F90 module 
     421      !!      If the logical lfbcsouth is .TRUE., there is no radiation but only fixed OBC 
     422      !! 
     423      !!  History : 
     424      !!         ! 95-03 (J.-M. Molines) Original from SPEM 
     425      !!         ! 97-07 (G. Madec, J.-M. Molines) additions 
     426      !!         ! 97-12 (M. Imbard) Mpp adaptation 
     427      !!         ! 00-06 (J.-M. Molines)  
     428      !!    8.5  ! 02-10 (C. Talandier, A-M Treguier) F90 
     429      !!------------------------------------------------------------------------------ 
     430      !! * Arguments 
     431      INTEGER, INTENT( in ) ::   kt 
     432 
     433      !! * Local declaration 
     434      INTEGER ::   ji, jj, jk      ! dummy loop indices 
     435      REAL(wp) ::   z05cx, ztau, zin 
     436      !!------------------------------------------------------------------------------ 
     437 
     438      ! 1. First three time steps and more if lfbcsouth is .TRUE. 
     439      !    In that case open boundary conditions are FIXED. 
     440      ! -------------------------------------------------------- 
     441 
     442      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcsouth ) THEN 
     443 
     444         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     445            DO jk = 1, jpkm1 
     446               DO ji = 1, jpi 
     447                  ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 
     448                                tsmsk(ji,jk) * tfos(ji,jk) 
     449                  sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 
     450                                tsmsk(ji,jk) * sfos(ji,jk) 
     451               END DO 
     452            END DO 
     453         END DO 
     454 
     455      ELSE 
     456 
     457      ! 2. Beyond the fourth time step if lfbcsouth is .FALSE. 
     458      ! ------------------------------------------------------- 
     459           
     460         ! Temperature and salinity radiation 
     461         ! ---------------------------------- 
     462         ! 
     463         !           ji-1   ji   ji   ji +1 
     464         !             |         | 
     465         !   nibm2 ----f----v----f----v---   jpjsob+2 
     466         !             |         |        
     467         !   nibm2 --  u -- T -- u -- T --   jpjsob+2 
     468         !             |         |             
     469         !   nibm  ----f----v----f----v---   jpjsob+1 
     470         !             |         |       
     471         !    nibm --  u -- T -- T -- T --   jpjsob+1 
     472         !             |         |     
     473         !   nib  -----f----v----f----v---   jpjsob 
     474         !       //////|/////////|////////  
     475         !    nib //// u // T // u // T //   jpjsob  
     476         ! 
     477         !... radiative conditions + relaxation toward a climatology 
     478         !... the phase velocity is taken as the phase velocity of the tangen- 
     479         !... tial velocity (here un), which has been saved in (u_cysbnd) 
     480         !... jpjsob,(jpisdp1, jpisfm1) 
     481         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     482            DO jk = 1, jpkm1 
     483               DO ji = 2, jpim1 
     484         !... j-phase speed ratio (from averaged of u_cysbnd) 
     485         !       (bounded by 1) 
     486                  z05cx = ( 0.5 * ( u_cysbnd(ji,jk) + u_cysbnd(ji-1,jk) ) ) / e2t(ji,jj+1) 
     487                  z05cx = max( z05cx, -1. ) 
     488         !... z05cx > 0, inflow  zin=0, ztau=1 
     489         !          < 0, outflow zin=1, ztau=rtaus 
     490                  zin = sign( 1., -1.* z05cx ) 
     491                  zin = 0.5*( zin + abs(zin) ) 
     492                  ztau = (1.-zin ) * rtausin + zin * rtaus 
     493                  z05cx = z05cx * zin 
     494 
     495         !... update (ta,sa) with radiative or climatological (t, s) 
     496                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) +             & 
     497                                 tsmsk(ji,jk) * ( ( 1. + z05cx - ztau )         & 
     498                                 * tsbnd(ji,jk,nib ,nitm) - 2.*z05cx              & 
     499                                 * tsbnd(ji,jk,nibm,nit ) + ztau * tfos (ji,jk) ) & 
     500                                 / (1. - z05cx) 
     501                  sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) +             & 
     502                                 tsmsk(ji,jk) * (  ( 1. + z05cx - ztau )        & 
     503                                 * ssbnd(ji,jk,nib ,nitm) - 2.*z05cx              & 
     504                                 * ssbnd(ji,jk,nibm,nit ) + ztau * sfos (ji,jk) ) & 
     505                                 / (1. - z05cx) 
     506               END DO 
     507            END DO 
     508         END DO 
     509 
     510      END IF    
     511 
     512   END SUBROUTINE obc_tra_south 
     513 
    95514#else 
    96    !!---------------------------------------------------------------------- 
    97    !!   Dummy module                   NO Unstruct Open Boundary Conditions 
    98    !!---------------------------------------------------------------------- 
     515   !!--------------------------------------------------------------------------------- 
     516   !!   Default option                                                    Empty module 
     517   !!--------------------------------------------------------------------------------- 
    99518CONTAINS 
    100    SUBROUTINE obc_tra(kt)      ! Empty routine 
    101       WRITE(*,*) 'obc_tra: You should not have seen this print! error?', kt 
     519   SUBROUTINE obc_tra      ! Empty routine 
    102520   END SUBROUTINE obc_tra 
    103521#endif 
    104522 
    105    !!====================================================================== 
     523   !!================================================================================= 
    106524END MODULE obctra 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcvol.F90

    r2865 r2888  
    11MODULE obcvol 
    2    !!====================================================================== 
     2   !!================================================================================= 
    33   !!                       ***  MODULE  obcvol  *** 
    4    !! Ocean dynamic :  Volume constraint when unstructured boundary  
    5    !!                  and Free surface are used 
    6    !!====================================================================== 
    7    !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code 
    8    !!             -   !  2006-01  (J. Chanut) Bug correction 
    9    !!            3.0  !  2008-04  (NEMO team)  add in the reference version 
    10    !!---------------------------------------------------------------------- 
    11 #if   defined key_obc   &&   defined key_dynspg_flt 
    12    !!---------------------------------------------------------------------- 
    13    !!   'key_obc'            AND      unstructured open boundary conditions 
    14    !!   'key_dynspg_flt'                              filtered free surface 
    15    !!---------------------------------------------------------------------- 
     4   !! Ocean dynamic :  Volume constraint when OBC and Free surface are used 
     5   !!================================================================================= 
     6#if   defined key_obc   &&   ! defined key_vvl 
     7   !!--------------------------------------------------------------------------------- 
     8   !!   'key_obc'               and   NOT                 open boundary conditions 
     9   !!   'key_vvl'                                         constant volume free surface 
     10   !!--------------------------------------------------------------------------------- 
     11   !! * Modules used 
    1612   USE oce             ! ocean dynamics and tracers  
    1713   USE dom_oce         ! ocean space and time domain  
     14   USE sbc_oce         ! ocean surface boundary conditions 
    1815   USE phycst          ! physical constants 
    1916   USE obc_oce         ! ocean open boundary conditions 
    2017   USE lib_mpp         ! for mppsum 
    2118   USE in_out_manager  ! I/O manager 
    22    USE sbc_oce         ! ocean surface boundary conditions 
    2319 
    2420   IMPLICIT NONE 
    2521   PRIVATE 
    2622 
    27    PUBLIC obc_vol        ! routine called by dynspg_flt.h90 
     23   !! * Accessibility 
     24   PUBLIC obc_vol        ! routine called by dynspg_flt 
    2825 
    2926   !! * Substitutions 
    3027#  include "domzgr_substitute.h90" 
    31    !!---------------------------------------------------------------------- 
     28#  include "obc_vectopt_loop_substitute.h90" 
     29   !!--------------------------------------------------------------------------------- 
    3230   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    3331   !! $Id$  
    3432   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    35    !!---------------------------------------------------------------------- 
     33   !!--------------------------------------------------------------------------------- 
     34 
    3635CONTAINS 
    3736 
    38    SUBROUTINE obc_vol( kt ) 
    39       !!---------------------------------------------------------------------- 
     37   SUBROUTINE obc_vol ( kt ) 
     38      !!------------------------------------------------------------------------------ 
    4039      !!                      ***  ROUTINE obcvol  *** 
    4140      !! 
    42       !! ** Purpose :   This routine is called in dynspg_flt to control  
     41      !! ** Purpose :  
     42      !!      This routine is called in dynspg_flt to control  
    4343      !!      the volume of the system. A correction velocity is calculated 
    44       !!      to correct the total transport through the unstructured OBC.  
     44      !!      to correct the total transport through the OBC.  
    4545      !!      The total depth used is constant (H0) to be consistent with the  
    4646      !!      linear free surface coded in OPA 8.2 
    4747      !! 
    48       !! ** Method  :   The correction velocity (zubtpecor here) is defined calculating 
     48      !! ** Method :   
     49      !!      The correction velocity (zubtpecor here) is defined calculating 
    4950      !!      the total transport through all open boundaries (trans_obc) minus 
    50       !!      the cumulate E-P flux (z_cflxemp) divided by the total lateral  
    51       !!      surface (obcsurftot) of the unstructured boundary.  
    52       !!         zubtpecor = [trans_obc - z_cflxemp ]*(1./obcsurftot) 
    53       !!      with z_cflxemp => sum of (Evaporation minus Precipitation) 
     51      !!      the cumulate E-P flux (zCflxemp) divided by the total lateral  
     52      !!      surface (obcsurftot) of these OBC.  
     53      !! 
     54      !!      zubtpecor = [trans_obc - zCflxemp ]*(1./obcsurftot) 
     55      !! 
     56      !!      with zCflxemp => sum of (Evaporation minus Precipitation) 
    5457      !!                       over all the domain in m3/s at each time step. 
    55       !!      z_cflxemp < 0 when precipitation dominate 
    56       !!      z_cflxemp > 0 when evaporation dominate 
     58      !! 
     59      !!      zCflxemp < 0 when precipitation dominate 
     60      !!      zCflxemp > 0 when evaporation dominate 
    5761      !! 
    5862      !!      There are 2 options (user's desiderata):  
     63      !! 
    5964      !!         1/ The volume changes according to E-P, this is the default 
    6065      !!            option. In this case the cumulate E-P flux are setting to 
    61       !!            zero (z_cflxemp=0) to calculate the correction velocity. So 
     66      !!            zero (zCflxemp=0) to calculate the correction velocity. So 
    6267      !!            it will only balance the flux through open boundaries. 
    63       !!            (set nn_volctl to 0 in tne namelist for this option) 
     68      !!            (set volemp to 0 in tne namelist for this option) 
     69      !! 
    6470      !!         2/ The volume is constant even with E-P flux. In this case 
    6571      !!            the correction velocity must balance both the flux  
    6672      !!            through open boundaries and the ones through the free 
    6773      !!            surface.  
    68       !!            (set nn_volctl to 1 in tne namelist for this option) 
    69       !!---------------------------------------------------------------------- 
     74      !!            (set volemp to 1 in tne namelist for this option) 
     75      !! 
     76      !! History : 
     77      !!   8.5  !  02-10 (C. Talandier, A-M. Treguier) Original code 
     78      !!---------------------------------------------------------------------------- 
     79      !! * Arguments 
    7080      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    71       !! 
    72       INTEGER  ::   ji, jj, jk, jb, jgrd 
    73       INTEGER  ::   ib_obc, ii, ij 
    74       REAL(wp) ::   zubtpecor, z_cflxemp, ztranst 
    75       TYPE(OBC_INDEX), POINTER :: idx 
     81 
     82      !! * Local declarations 
     83      INTEGER ::   ji, jj, jk 
     84      REAL(wp) ::   zubtpecor 
     85      REAL(wp) ::   zCflxemp 
     86      REAL(wp) ::   ztransw, ztranse, ztransn, ztranss, ztranst 
    7687      !!----------------------------------------------------------------------------- 
    7788 
    78       IF( ln_vol ) THEN 
    79  
    8089      IF( kt == nit000 ) THEN  
    81          IF(lwp) WRITE(numout,*) 
    82          IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along unstructured OBC' 
     90         IF(lwp) WRITE(numout,*)'        ' 
     91         IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along OBC' 
    8392         IF(lwp) WRITE(numout,*)'~~~~~~~' 
    84       END IF  
    85  
    86       ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 
    87       ! ----------------------------------------------------------------------- 
    88       z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:) ) * obctmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
    89       IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain 
    90  
    91       ! Transport through the unstructured open boundary 
    92       ! ------------------------------------------------ 
     93         IF(lwp) WRITE(numout,*)'        ' 
     94      END IF  
     95 
     96      ! 1. Calculate the cumulate surface Flux zCflxemp (m3/s) over all the domain. 
     97      ! --------------------------------------------------------------------------- 
     98 
     99      zCflxemp = SUM ( ( emp(:,:)-rnf(:,:) )*obctmsk(:,:)* e1t(:,:) * e2t(:,:)  / rau0 )  
     100 
     101      IF( lk_mpp )   CALL mpp_sum( zCflxemp )   ! sum over the global domain 
     102 
     103      ! 2. Barotropic velocity for each open boundary 
     104      ! --------------------------------------------- 
     105 
    93106      zubtpecor = 0.e0 
    94       DO ib_obc = 1, nb_obc 
    95          idx => idx_obc(ib_obc) 
    96  
    97          jgrd = 2                               ! cumulate u component contribution first  
    98          DO jb = 1, idx%nblenrim(jgrd) 
    99             DO jk = 1, jpkm1 
    100                ii = idx%nbi(jb,jgrd) 
    101                ij = idx%nbj(jb,jgrd) 
    102                zubtpecor = zubtpecor + idx%flagu(jb) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
    103             END DO 
    104          END DO 
    105          jgrd = 3                               ! then add v component contribution 
    106          DO jb = 1, idx%nblenrim(jgrd) 
    107             DO jk = 1, jpkm1 
    108                ii = idx%nbi(jb,jgrd) 
    109                ij = idx%nbj(jb,jgrd) 
    110                zubtpecor = zubtpecor + idx%flagv(jb) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk)  
    111             END DO 
    112          END DO 
    113  
    114       END DO 
     107 
     108      ! ... East open boundary 
     109      IF( lp_obc_east ) THEN                      ! ... Total transport through the East OBC 
     110         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     111            DO jk = 1, jpkm1 
     112               DO jj = 1, jpj 
     113                  zubtpecor = zubtpecor - ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 
     114             &     uemsk(jj,jk)*MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     115               END DO 
     116            END DO 
     117         END DO 
     118      END IF  
     119 
     120      ! ... West open boundary 
     121      IF( lp_obc_west ) THEN                      ! ... Total transport through the West OBC 
     122         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     123            DO jk = 1, jpkm1 
     124               DO jj = 1, jpj 
     125                  zubtpecor = zubtpecor + ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 
     126             &    uwmsk(jj,jk) *MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     127               END DO 
     128            END DO 
     129         END DO 
     130       ENDIF 
     131 
     132      ! ... North open boundary 
     133      IF( lp_obc_north ) THEN                     ! ... Total transport through the North OBC 
     134         DO jj = fs_njn0, fs_njn1 ! Vector opt. 
     135            DO jk = 1, jpkm1 
     136               DO ji = 1, jpi 
     137                  zubtpecor = zubtpecor - va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 
     138             &    vnmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     139               END DO 
     140            END DO 
     141         END DO 
     142       ENDIF 
     143 
     144      ! ... South open boundary 
     145      IF( lp_obc_south ) THEN                     ! ... Total transport through the South OBC 
     146         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     147            DO jk = 1, jpkm1 
     148               DO ji = 1, jpi 
     149                  zubtpecor = zubtpecor + va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 
     150             &    vsmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     151               END DO 
     152            END DO 
     153         END DO 
     154       ENDIF 
     155 
    115156      IF( lk_mpp )   CALL mpp_sum( zubtpecor )   ! sum over the global domain 
    116157 
    117       ! The normal velocity correction 
    118       ! ------------------------------ 
    119       IF( nn_volctl==1 ) THEN   ;   zubtpecor = ( zubtpecor - z_cflxemp) / obcsurftot  
    120       ELSE                   ;   zubtpecor =   zubtpecor             / obcsurftot 
    121       END IF 
    122  
    123       ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation 
    124       ! ------------------------------------------------------------- 
    125       ztranst = 0.e0 
    126       DO ib_obc = 1, nb_obc 
    127          idx => idx_obc(ib_obc) 
    128  
    129          jgrd = 2                               ! correct u component 
    130          DO jb = 1, idx%nblenrim(jgrd) 
    131             DO jk = 1, jpkm1 
    132                ii = idx%nbi(jb,jgrd) 
    133                ij = idx%nbj(jb,jgrd) 
    134                ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb) * zubtpecor * umask(ii,ij,jk) 
    135                ztranst = ztranst + idx%flagu(jb) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
    136             END DO 
    137          END DO 
    138          jgrd = 3                              ! correct v component 
    139          DO jb = 1, idx%nblenrim(jgrd) 
    140             DO jk = 1, jpkm1 
    141                ii = idx%nbi(jb,jgrd) 
    142                ij = idx%nbj(jb,jgrd) 
    143                va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb) * zubtpecor * vmask(ii,ij,jk) 
    144                ztranst = ztranst + idx%flagv(jb) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 
    145             END DO 
    146          END DO 
    147  
    148       END DO 
    149       IF( lk_mpp )   CALL mpp_sum( ztranst )   ! sum over the global domain 
    150   
    151       ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 
    152       ! ------------------------------------------------------ 
     158 
     159      ! 3. The normal velocity correction 
     160      ! --------------------------------- 
    153161      IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
    154          IF(lwp) WRITE(numout,*) 
     162         IF(lwp) WRITE(numout,*)'        ' 
    155163         IF(lwp) WRITE(numout,*)'obc_vol : time step :', kt 
    156164         IF(lwp) WRITE(numout,*)'~~~~~~~ ' 
    157          IF(lwp) WRITE(numout,*)'          cumulate flux EMP             =', z_cflxemp  , ' (m3/s)' 
    158          IF(lwp) WRITE(numout,*)'          total lateral surface of OBC  =', obcsurftot, '(m2)' 
    159          IF(lwp) WRITE(numout,*)'          correction velocity zubtpecor =', zubtpecor , '(m/s)' 
    160          IF(lwp) WRITE(numout,*)'          cumulated transport ztranst   =', ztranst   , '(m3/s)' 
    161       END IF  
    162       ! 
    163       END IF ! ln_vol 
     165         IF(lwp) WRITE(numout,*)'          cumulate flux EMP :', zCflxemp,' (m3/s)' 
     166         IF(lwp) WRITE(numout,*)'          lateral transport :',zubtpecor,'(m3/s)' 
     167         IF(lwp) WRITE(numout,*)'          net inflow        :',zubtpecor-zCflxemp,'(m3/s)' 
     168      ENDIF 
     169 
     170      zubtpecor = (zubtpecor - zCflxemp*volemp)*(1./obcsurftot) 
     171 
     172      IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
     173         IF(lwp) WRITE(numout,*)'          total lateral surface of OBC :',obcsurftot,'(m2)' 
     174         IF(lwp) WRITE(numout,*)'          correction velocity zubtpecor :',zubtpecor,'(m/s)' 
     175         IF(lwp) WRITE(numout,*)'        ' 
     176      END IF  
     177 
     178      ! 4. Correction of the total velocity on each open  
     179      !    boundary to respect the mass flux conservation 
     180      ! ------------------------------------------------- 
     181 
     182      ztranse = 0.e0   ; ztransw = 0.e0 ; ztransn = 0.e0 ; ztranss = 0.e0 
     183      ztranst = 0.e0  ! total 
     184 
     185      IF( lp_obc_west ) THEN 
     186         ! ... correction of the west velocity 
     187         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     188            DO jk = 1, jpkm1 
     189               DO jj = 1, jpj 
     190                  ua(ji,jj,jk) = ua(ji,jj,jk) - zubtpecor*uwmsk(jj,jk) 
     191                  ztransw= ztransw + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uwmsk(jj,jk) * & 
     192             &    MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     193               END DO 
     194            END DO 
     195         END DO 
     196 
     197         IF( lk_mpp )   CALL mpp_sum( ztransw )   ! sum over the global domain 
     198 
     199         IF( lwp .AND. MOD( kt, nwrite ) == 0)  WRITE(numout,*)'          West OB transport ztransw :', ztransw,'(m3/s)' 
     200      END IF  
     201 
     202      IF( lp_obc_east ) THEN 
     203 
     204         ! ... correction of the east velocity 
     205         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     206            DO jk = 1, jpkm1 
     207               DO jj = 1, jpj 
     208                  ua(ji,jj,jk) = ua(ji,jj,jk) + zubtpecor*uemsk(jj,jk) 
     209                  ztranse= ztranse + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uemsk(jj,jk) * & 
     210            &     MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
     211               END DO 
     212            END DO 
     213         END DO 
     214 
     215         IF( lk_mpp )   CALL mpp_sum( ztranse )   ! sum over the global domain 
     216 
     217         IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
     218            IF(lwp) WRITE(numout,*)'          East OB transport ztranse :', ztranse,'(m3/s)' 
     219         END IF  
     220 
     221      END IF  
     222 
     223      IF( lp_obc_north ) THEN 
     224 
     225         ! ... correction of the north velocity 
     226         DO jj = fs_njn0, fs_njn1 ! Vector opt. 
     227            DO jk = 1, jpkm1 
     228               DO ji =  1, jpi 
     229                  va(ji,jj,jk) = va(ji,jj,jk) + zubtpecor*vnmsk(ji,jk) 
     230                  ztransn= ztransn + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vnmsk(ji,jk) * & 
     231           &      MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     232               END DO 
     233            END DO 
     234         END DO 
     235         IF( lk_mpp )   CALL mpp_sum( ztransn )   ! sum over the global domain 
     236 
     237         IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
     238            IF(lwp) WRITE(numout,*)'          North OB transport ztransn :', ztransn,'(m3/s)' 
     239         END IF  
     240 
     241      END IF  
     242 
     243      IF( lp_obc_south ) THEN 
     244 
     245         ! ... correction of the south velocity 
     246         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     247            DO jk = 1, jpkm1 
     248               DO ji =  1, jpi 
     249                  va(ji,jj,jk) = va(ji,jj,jk) - zubtpecor*vsmsk(ji,jk) 
     250                  ztranss= ztranss + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vsmsk(ji,jk) * & 
     251            &     MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
     252               END DO 
     253            END DO 
     254         END DO 
     255         IF( lk_mpp )   CALL mpp_sum( ztranss )   ! sum over the global domain 
     256 
     257         IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
     258            IF(lwp) WRITE(numout,*)'          South OB transport ztranss :', ztranss,'(m3/s)' 
     259         END IF  
     260 
     261      END IF  
     262 
     263      ! 5. Check the cumulate transport through OBC 
     264      !    once barotropic velocities corrected 
     265      ! ------------------------------------------- 
     266 
     267 
     268      IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 
     269         ztranst = ztransw - ztranse + ztranss - ztransn 
     270         IF(lwp) WRITE(numout,*)'        ' 
     271         IF(lwp) WRITE(numout,*)'          Cumulate transport ztranst =', ztranst,'(m3/s)' 
     272         IF(lwp) WRITE(numout,*)'          Balance  =', ztranst - zCflxemp ,'(m3/s)' 
     273         IF(lwp) WRITE(numout,*)'        ' 
     274      END IF  
    164275 
    165276   END SUBROUTINE obc_vol 
    166277 
    167278#else 
    168    !!---------------------------------------------------------------------- 
    169    !!   Dummy module                   NO Unstruct Open Boundary Conditions 
    170    !!---------------------------------------------------------------------- 
     279   !!--------------------------------------------------------------------------------- 
     280   !!  Default option :                                                   Empty module 
     281   !!--------------------------------------------------------------------------------- 
    171282CONTAINS 
    172    SUBROUTINE obc_vol( kt )        ! Empty routine 
    173       WRITE(*,*) 'obc_vol: You should not have seen this print! error?', kt 
     283   SUBROUTINE obc_vol        ! Empty routine 
    174284   END SUBROUTINE obc_vol 
    175285#endif 
    176286 
    177    !!====================================================================== 
     287   !!================================================================================= 
    178288END MODULE obcvol 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r2865 r2888  
    649649      !!                using a general mapping (for open boundaries) 
    650650      !!---------------------------------------------------------------------- 
    651 #if defined key_obc 
    652       USE obc_oce, ONLY:  dta_global         ! workspace to read in global data arrays 
     651#if defined key_bdy 
     652      USE bdy_oce, ONLY:  dta_global         ! workspace to read in global data arrays 
    653653#endif  
    654654 
    … …  
    669669      !!--------------------------------------------------------------------- 
    670670             
    671 #if defined key_obc 
     671#if defined key_bdy 
    672672      dta_read => dta_global 
    673673#endif 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r2797 r2888  
    3838   USE sbcfwb           ! surface boundary condition: freshwater budget 
    3939   USE closea           ! closed sea 
    40    USE obc_par          ! for lk_obc 
    41    USE obcice_lim2      ! unstructured open boundary data  (obc_ice_lim_2 routine) 
     40   USE bdy_par          ! for lk_bdy 
     41   USE bdyice_lim2      ! unstructured open boundary data  (bdy_ice_lim_2 routine) 
    4242 
    4343   USE prtctl           ! Print control                    (prt_ctl routine) 
    … …  
    253253         !                                                       
    254254      CASE(  2 )   ;       CALL sbc_ice_lim_2( kt, nsbc )            ! LIM-2 ice model 
    255          IF( lk_obc )      CALL obc_ice_lim_2( kt )                  ! OBC boundary condition 
     255         IF( lk_bdy )      CALL bdy_ice_lim_2( kt )                  ! BDY boundary condition 
    256256         !                                                      
    257257      CASE(  3 )   ;       CALL sbc_ice_lim  ( kt, nsbc )            ! LIM-3 ice model 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SOL/solmat.F90

    r2797 r2888  
    2727   USE phycst          ! physical constants 
    2828   USE obc_oce         ! ocean open boundary conditions 
     29   USE bdy_oce         ! unstructured open boundary conditions 
    2930   USE lbclnk          ! lateral boudary conditions 
    3031   USE lib_mpp         ! distributed memory computing 
    … …  
    8081      ENDIF 
    8182 
    82 #if defined key_dynspg_flt  
     83#if defined key_dynspg_flt && ! defined key_bdy 
    8384#   if ! defined key_obc 
    8485 
    … …  
    9899         END DO 
    99100      END DO 
    100  
    101101#   else 
    102  
    103       !   defined gcdmat in the case of open boundaries 
     102    IF ( Agrif_Root() ) THEN 
     103      DO jj = 2, jpjm1                      ! matrix of free surface elliptic system with open boundaries 
     104         DO ji = 2, jpim1 
     105            zcoef = z2dt * z2dt * grav * bmask(ji,jj) 
     106            !                                    ! south coefficient 
     107            IF( lp_obc_south .AND. ( jj == njs0p1 ) ) THEN 
     108               zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1)*(1.-vsmsk(ji,1)) 
     109            ELSE 
     110               zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 
     111            END IF 
     112            gcp(ji,jj,1) = zcoefs 
     113            ! 
     114            !                                    ! west coefficient 
     115            IF( lp_obc_west  .AND. ( ji == niw0p1 ) ) THEN 
     116               zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj)*(1.-uwmsk(jj,1)) 
     117            ELSE 
     118               zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 
     119            END IF 
     120            gcp(ji,jj,2) = zcoefw 
     121            ! 
     122            !                                    ! east coefficient 
     123            IF( lp_obc_east  .AND. ( ji == nie0 ) ) THEN 
     124               zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj)*(1.-uemsk(jj,1)) 
     125            ELSE 
     126               zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 
     127            END IF 
     128            gcp(ji,jj,3) = zcoefe 
     129            ! 
     130            !                                    ! north coefficient 
     131            IF( lp_obc_north .AND. ( jj == njn0 ) ) THEN 
     132               zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj)*(1.-vnmsk(ji,1)) 
     133            ELSE 
     134               zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 
     135            END IF 
     136            gcp(ji,jj,4) = zcoefn 
     137            ! 
     138            !                                    ! diagonal coefficient 
     139            gcdmat(ji,jj) = e1t(ji,jj)*e2t(ji,jj)*bmask(ji,jj)   & 
     140               &            - zcoefs -zcoefw -zcoefe -zcoefn 
     141         END DO 
     142      END DO 
     143    ELSE 
     144      DO jj = 2, jpjm1                      ! matrix of free surface elliptic system 
     145         DO ji = 2, jpim1 
     146            zcoef = z2dt * z2dt * grav * bmask(ji,jj) 
     147            zcoefs = -zcoef * hv(ji  ,jj-1) * e1v(ji  ,jj-1) / e2v(ji  ,jj-1)    ! south coefficient 
     148            zcoefw = -zcoef * hu(ji-1,jj  ) * e2u(ji-1,jj  ) / e1u(ji-1,jj  )    ! west coefficient 
     149            zcoefe = -zcoef * hu(ji  ,jj  ) * e2u(ji  ,jj  ) / e1u(ji  ,jj  )    ! east coefficient 
     150            zcoefn = -zcoef * hv(ji  ,jj  ) * e1v(ji  ,jj  ) / e2v(ji  ,jj  )    ! north coefficient 
     151            gcp(ji,jj,1) = zcoefs 
     152            gcp(ji,jj,2) = zcoefw 
     153            gcp(ji,jj,3) = zcoefe 
     154            gcp(ji,jj,4) = zcoefn 
     155            gcdmat(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * bmask(ji,jj)    &          ! diagonal coefficient 
     156               &          - zcoefs -zcoefw -zcoefe -zcoefn 
     157         END DO 
     158      END DO 
     159    ENDIF 
     160#   endif 
     161 
     162#  elif defined key_dynspg_flt && defined key_bdy  
     163 
     164      !   defined gcdmat in the case of unstructured open boundaries 
    104165      DO jj = 2, jpjm1 
    105166         DO ji = 2, jpim1 
    … …  
    108169            !  south coefficient 
    109170            zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 
    110             zcoefs = zcoefs * obcvmask(ji,jj-1) 
     171            zcoefs = zcoefs * bdyvmask(ji,jj-1) 
    111172            gcp(ji,jj,1) = zcoefs 
    112173 
    113174            !  west coefficient 
    114175            zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 
    115             zcoefw = zcoefw * obcumask(ji-1,jj) 
     176            zcoefw = zcoefw * bdyumask(ji-1,jj) 
    116177            gcp(ji,jj,2) = zcoefw 
    117178 
    118179            !  east coefficient 
    119180            zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 
    120             zcoefe = zcoefe * obcumask(ji,jj) 
     181            zcoefe = zcoefe * bdyumask(ji,jj) 
    121182            gcp(ji,jj,3) = zcoefe 
    122183 
    123184            !  north coefficient 
    124185            zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 
    125             zcoefn = zcoefn * obcvmask(ji,jj) 
     186            zcoefn = zcoefn * bdyvmask(ji,jj) 
    126187            gcp(ji,jj,4) = zcoefn 
    127188 
    … …  
    132193      END DO 
    133194 
    134 #endif 
    135195#endif 
    136196 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r2797 r2888  
    3636   USE obc_oce 
    3737   USE obctra          ! open boundary condition (obc_tra routine) 
     38   USE bdy_oce 
     39   USE bdytra          ! open boundary condition (bdy_tra routine) 
    3840   USE in_out_manager  ! I/O manager 
    3941   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    107109      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    108110      ! 
    109 #if defined key_obc || defined key_agrif 
     111#if defined key_obc || defined key_bdy || defined key_agrif 
    110112      CALL tra_unswap 
    111113#endif 
    … …  
    114116      IF( lk_obc )   CALL obc_tra( kt )  ! OBC open boundaries 
    115117#endif 
     118#if defined key_bdy  
     119      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
     120#endif 
    116121#if defined key_agrif 
    117122      CALL Agrif_tra                     ! AGRIF zoom boundaries 
    118123#endif 
    119124 
    120 #if defined key_obc || defined key_agrif 
     125#if defined key_obc || defined key_bdy || defined key_agrif 
    121126      CALL tra_swap 
    122127#endif 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2814 r2888  
    4545   USE mppini          ! shared/distributed memory setting (mpp_init routine) 
    4646   USE domain          ! domain initialization             (dom_init routine) 
    47    USE obcini          ! open boundary cond. initialization (obc_init routine) 
    48    USE obcdta          ! open boundary cond. initialization (obc_dta_init routine) 
    49    USE obctides        ! open boundary cond. initialization (tide_init routine) 
     47   USE obcini          ! open boundary cond. initialization (obc_ini routine) 
     48   USE bdyini          ! open boundary cond. initialization (bdy_init routine) 
     49   USE bdydta          ! open boundary cond. initialization (bdy_dta_init routine) 
     50   USE bdytides        ! open boundary cond. initialization (tide_init routine) 
    5051   USE istate          ! initial state setting          (istate_init routine) 
    5152   USE ldfdyn          ! lateral viscosity setting      (ldfdyn_init routine) 
    … …  
    295296      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
    296297 
    297       IF( lk_obc        )   CALL     obc_init       ! Open boundaries initialisation 
    298       IF( lk_obc        )   CALL     obc_dta_init   ! Open boundaries initialisation of external data arrays 
    299       IF( lk_obc        )   CALL     tide_init      ! Open boundaries initialisation of tidal harmonic forcing 
     298      IF( lk_obc        )   CALL     obc_init   ! Open boundaries  
     299      IF( lk_bdy        )   CALL     bdy_init       ! Open boundaries initialisation 
     300      IF( lk_bdy        )   CALL     bdy_dta_init   ! Open boundaries initialisation of external data arrays 
     301      IF( lk_bdy        )   CALL     tide_init      ! Open boundaries initialisation of tidal harmonic forcing 
    300302 
    301303                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step.F90

    r2865 r2888  
    9797      IF( lk_dtasal  )   CALL dta_sal( kstp )         ! update 3D salinity data 
    9898                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    99       IF( lk_obc     )   CALL obc_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 
     99      IF( lk_obc     )   CALL obc_dta( kstp )         ! update dynamic and tracer data at open boundaries 
     100      IF( lk_obc     )   CALL obc_rad( kstp )         ! compute phase velocities at open boundaries 
     101      IF( lk_bdy     )   CALL bdy_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 
    100102 
    101103      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    245247      IF( kstp == nit000   )   CALL iom_close( numror )     ! close input  ocean restart file 
    246248      IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
     249      IF( lk_obc           )   CALL obc_rst_write( kstp )   ! write open boundary restart file 
    247250 
    248251      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 

  • branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r2797 r2888  
    4848   USE dynnxt           ! time-stepping                    (dyn_nxt routine) 
    4949 
    50    USE obc_par          ! for lk_obc 
     50   USE obc_par          ! open boundary condition variables 
    5151   USE obcdta           ! open boundary condition data     (obc_dta routine) 
     52   USE obcrst           ! open boundary cond. restart      (obc_rst routine) 
     53   USE obcrad           ! open boundary cond. radiation    (obc_rad routine) 
     54 
     55   USE bdy_par          ! for lk_bdy 
     56   USE bdydta           ! open boundary condition data     (bdy_dta routine) 
    5257 
    5358   USE sshwzv           ! vertical velocity and ssh        (ssh_wzv routine) 
Note: See TracChangeset for help on using the changeset viewer.