Changeset 3598


Ignore:
Timestamp:
2012-11-19T14:35:09+01:00 (8 years ago)
Author:
rblod
Message:

Change of some variable range for TAM in 3.4 - Ticket #1004

Location:
trunk/NEMOGCM/NEMO/OPA_SRC
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r3434 r3598  
    1111   !!            8.5  !  2002-08  (A. Bozec)  hpg_zps: Original code 
    1212   !!   NEMO     1.0  !  2005-10  (A. Beckmann, B.W. An)  various s-coordinate options 
    13    !!                 !         Original code for hpg_ctl, hpg_hel hpg_wdj, hpg_djc, hpg_rot  
     13   !!                 !         Original code for hpg_ctl, hpg_hel hpg_wdj, hpg_djc, hpg_rot 
    1414   !!             -   !  2005-11  (G. Madec) style & small optimisation 
    1515   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
     
    3131   USE dom_oce         ! ocean space and time domain 
    3232   USE phycst          ! physical constants 
    33    USE trdmod          ! ocean dynamics trends  
     33   USE trdmod          ! ocean dynamics trends 
    3434   USE trdmod_oce      ! ocean variables trends 
    3535   USE in_out_manager  ! I/O manager 
    3636   USE prtctl          ! Print control 
    37    USE lbclnk          ! lateral boundary condition  
     37   USE lbclnk          ! lateral boundary condition 
    3838   USE lib_mpp         ! MPP library 
    3939   USE wrk_nemo        ! Memory Allocation 
     
    4646   PUBLIC   dyn_hpg_init   ! routine called by opa module 
    4747 
    48    !                                              !!* Namelist namdyn_hpg : hydrostatic pressure gradient  
     48   !                                              !!* Namelist namdyn_hpg : hydrostatic pressure gradient 
    4949   LOGICAL , PUBLIC ::   ln_hpg_zco    = .TRUE.    !: z-coordinate - full steps 
    5050   LOGICAL , PUBLIC ::   ln_hpg_zps    = .FALSE.   !: z-coordinate - partial steps (interpolation) 
     
    5454   LOGICAL , PUBLIC ::   ln_dynhpg_imp = .FALSE.   !: semi-implicite hpg flag 
    5555 
    56    INTEGER  ::   nhpg  =  0   ! = 0 to 7, type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) 
     56   INTEGER , PUBLIC ::   nhpg  =  0   ! = 0 to 7, type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) 
    5757 
    5858   !! * Substitutions 
     
    7070      !!                  ***  ROUTINE dyn_hpg  *** 
    7171      !! 
    72       !! ** Method  :   Call the hydrostatic pressure gradient routine  
     72      !! ** Method  :   Call the hydrostatic pressure gradient routine 
    7373      !!              using the scheme defined in the namelist 
    74       !!    
     74      !! 
    7575      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
    7676      !!             - Save the trend (l_trddyn=T) 
     
    8484      IF( l_trddyn ) THEN                    ! Temporary saving of ua and va trends (l_trddyn) 
    8585         CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 
    86          ztrdu(:,:,:) = ua(:,:,:)   
    87          ztrdv(:,:,:) = va(:,:,:)  
    88       ENDIF       
     86         ztrdu(:,:,:) = ua(:,:,:) 
     87         ztrdv(:,:,:) = va(:,:,:) 
     88      ENDIF 
    8989      ! 
    9090      SELECT CASE ( nhpg )      ! Hydrostatic pressure gradient computation 
     
    101101         CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_hpg, 'DYN', kt ) 
    102102         CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 
    103       ENDIF           
     103      ENDIF 
    104104      ! 
    105105      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' hpg  - Ua: ', mask1=umask,   & 
     
    161161      ! 
    162162      !                               ! Consistency check 
    163       ioptio = 0  
     163      ioptio = 0 
    164164      IF( ln_hpg_zco )   ioptio = ioptio + 1 
    165165      IF( ln_hpg_zps )   ioptio = ioptio + 1 
     
    185185      !!            ua = ua - 1/e1u * zhpi 
    186186      !!            va = va - 1/e2v * zhpj 
    187       !!  
     187      !! 
    188188      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
    189189      !!---------------------------------------------------------------------- 
     
    192192      INTEGER  ::   ji, jj, jk       ! dummy loop indices 
    193193      REAL(wp) ::   zcoef0, zcoef1   ! temporary scalars 
    194       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj  
    195       !!---------------------------------------------------------------------- 
    196       !   
     194      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
     195      !!---------------------------------------------------------------------- 
     196      ! 
    197197      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 
    198198      ! 
     
    202202         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   z-coordinate case ' 
    203203      ENDIF 
    204        
    205       zcoef0 = - grav * 0.5_wp      ! Local constant initialization  
     204 
     205      zcoef0 = - grav * 0.5_wp      ! Local constant initialization 
    206206 
    207207      ! Surface value 
     
    247247      !!--------------------------------------------------------------------- 
    248248      !!                 ***  ROUTINE hpg_zps  *** 
    249       !!                     
     249      !! 
    250250      !! ** Method  :   z-coordinate plus partial steps case.  blahblah... 
    251       !!  
     251      !! 
    252252      !! ** Action  : - Update (ua,va) with the now hydrastatic pressure trend 
    253       !!----------------------------------------------------------------------  
     253      !!---------------------------------------------------------------------- 
    254254      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    255255      !! 
     
    257257      INTEGER  ::   iku, ikv                         ! temporary integers 
    258258      REAL(wp) ::   zcoef0, zcoef1, zcoef2, zcoef3   ! temporary scalars 
    259       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj  
     259      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
    260260      !!---------------------------------------------------------------------- 
    261261      ! 
     
    363363      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    364364      REAL(wp) ::   zcoef0, zuap, zvap, znad   ! temporary scalars 
    365       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj  
     365      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
    366366      !!---------------------------------------------------------------------- 
    367367      ! 
     
    383383      ! Surface value 
    384384      DO jj = 2, jpjm1 
    385          DO ji = fs_2, fs_jpim1   ! vector opt.    
     385         DO ji = fs_2, fs_jpim1   ! vector opt. 
    386386            ! hydrostatic pressure gradient along s-surfaces 
    387387            zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( fse3w(ji+1,jj  ,1) * ( znad + rhd(ji+1,jj  ,1) )   & 
     
    397397            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap 
    398398            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap 
    399          END DO   
    400       END DO    
    401              
     399         END DO 
     400      END DO 
     401 
    402402      ! interior value (2=<jk=<jpkm1) 
    403       DO jk = 2, jpkm1                                   
    404          DO jj = 2, jpjm1      
    405             DO ji = fs_2, fs_jpim1   ! vector opt.       
     403      DO jk = 2, jpkm1 
     404         DO jj = 2, jpjm1 
     405            DO ji = fs_2, fs_jpim1   ! vector opt. 
    406406               ! hydrostatic pressure gradient along s-surfaces 
    407                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   &  
    408                   &           * (  fse3w(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   &  
     407               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
     408                  &           * (  fse3w(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
    409409                  &              - fse3w(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
    410410               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
     
    432432      !! 
    433433      !! ** Method  :   Density Jacobian with Cubic polynomial scheme 
    434       !!  
     434      !! 
    435435      !! Reference: Shchepetkin and McWilliams, J. Geophys. Res., 108(C3), 3090, 2003 
    436436      !!---------------------------------------------------------------------- 
     
    441441      REAL(wp) ::   z1_10, cffu, cffx   !    "         " 
    442442      REAL(wp) ::   z1_12, cffv, cffy   !    "         " 
    443       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj  
     443      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
    444444      REAL(wp), POINTER, DIMENSION(:,:,:) ::  dzx, dzy, dzz, dzu, dzv, dzw 
    445445      REAL(wp), POINTER, DIMENSION(:,:,:) ::  drhox, drhoy, drhoz, drhou, drhov, drhow 
     
    447447      !!---------------------------------------------------------------------- 
    448448      ! 
    449       CALL wrk_alloc( jpi, jpj, jpk, dzx  , dzy  , dzz  , dzu  , dzv  , dzw   )  
    450       CALL wrk_alloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow )  
    451       CALL wrk_alloc( jpi, jpj, jpk, rho_i, rho_j, rho_k,  zhpi,  zhpj        )  
     449      CALL wrk_alloc( jpi, jpj, jpk, dzx  , dzy  , dzz  , dzu  , dzv  , dzw   ) 
     450      CALL wrk_alloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 
     451      CALL wrk_alloc( jpi, jpj, jpk, rho_i, rho_j, rho_k,  zhpi,  zhpj        ) 
    452452      ! 
    453453 
     
    497497               cffu = 2._wp * drhox(ji+1,jj  ,jk) * drhox(ji,jj,jk  ) 
    498498               cffx = 2._wp * dzx  (ji+1,jj  ,jk) * dzx  (ji,jj,jk  ) 
    499    
     499 
    500500               cffv = 2._wp * drhoy(ji  ,jj+1,jk) * drhoy(ji,jj,jk  ) 
    501501               cffy = 2._wp * dzy  (ji  ,jj+1,jk) * dzy  (ji,jj,jk  ) 
     
    568568               &                     + 0.5_wp * ( rhd(ji,jj,2) - rhd(ji,jj,1) )         & 
    569569               &                              * ( fse3w (ji,jj,1) - fsde3w(ji,jj,1) )   & 
    570                &                              / ( fsde3w(ji,jj,2) - fsde3w(ji,jj,1) )  )  
     570               &                              / ( fsde3w(ji,jj,2) - fsde3w(ji,jj,1) )  ) 
    571571         END DO 
    572572      END DO 
     
    631631      ! ---------------- 
    632632      DO jk = 2, jpkm1 
    633          DO jj = 2, jpjm1  
     633         DO jj = 2, jpjm1 
    634634            DO ji = fs_2, fs_jpim1   ! vector opt. 
    635635               ! hydrostatic pressure gradient along s-surfaces 
     
    647647      END DO 
    648648      ! 
    649       CALL wrk_dealloc( jpi, jpj, jpk, dzx  , dzy  , dzz  , dzu  , dzv  , dzw   )  
    650       CALL wrk_dealloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow )  
    651       CALL wrk_dealloc( jpi, jpj, jpk, rho_i, rho_j, rho_k,  zhpi,  zhpj        )  
     649      CALL wrk_dealloc( jpi, jpj, jpk, dzx  , dzy  , dzz  , dzu  , dzv  , dzw   ) 
     650      CALL wrk_dealloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 
     651      CALL wrk_dealloc( jpi, jpj, jpk, rho_i, rho_j, rho_k,  zhpi,  zhpj        ) 
    652652      ! 
    653653   END SUBROUTINE hpg_djc 
     
    676676      INTEGER  :: jk1, jis, jid, jjs, jjd 
    677677      REAL(wp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps 
    678       REAL(wp) :: zrhdt1  
     678      REAL(wp) :: zrhdt1 
    679679      REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 
    680       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdept, zrhh  
     680      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdept, zrhh 
    681681      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 
    682682      !!---------------------------------------------------------------------- 
    683683      ! 
    684       CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp )  
    685       CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh )  
     684      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
     685      CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 
    686686      ! 
    687687      IF( kt == nit000 ) THEN 
     
    693693      !!---------------------------------------------------------------------- 
    694694      ! Local constant initialization 
    695       zcoef0 = - grav  
     695      zcoef0 = - grav 
    696696      znad = 0.0_wp 
    697697      IF( lk_vvl ) znad = 1._wp 
     
    700700      zhpi(:,:,:) = 0._wp 
    701701      zrhh(:,:,:) = rhd(:,:,:) 
    702        
     702 
    703703      ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate 
    704704      DO jj = 1, jpj 
    705         DO ji = 1, jpi    
     705        DO ji = 1, jpi 
    706706          jk = mbathy(ji,jj) 
    707707          IF( jk <= 0 ) THEN; zrhh(ji,jj,:) = 0._wp 
     
    711711                zrhh(ji,jj,jkk) = interp1(fsde3w(ji,jj,jkk),   fsde3w(ji,jj,jkk-1), & 
    712712                                         fsde3w(ji,jj,jkk-2), rhd(ji,jj,jkk-1), rhd(ji,jj,jkk-2)) 
    713              END DO  
     713             END DO 
    714714          ENDIF 
    715715        END DO 
     
    728728      xsp(:,:,:) = zdept(:,:,:) 
    729729 
    730       ! Construct the vertical density profile with the  
     730      ! Construct the vertical density profile with the 
    731731      ! constrained cubic spline interpolation 
    732732      ! rho(z) = asp + bsp*z + csp*z^2 + dsp*z^3 
    733       CALL cspline(fsp,xsp,asp,bsp,csp,dsp,polynomial_type)       
     733      CALL cspline(fsp,xsp,asp,bsp,csp,dsp,polynomial_type) 
    734734 
    735735      ! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)" 
    736736      DO jj = 2, jpj 
    737         DO ji = 2, jpi  
     737        DO ji = 2, jpi 
    738738          zrhdt1 = zrhh(ji,jj,1) - interp3(zdept(ji,jj,1),asp(ji,jj,1), & 
    739739                                         bsp(ji,jj,1),   csp(ji,jj,1), & 
     
    741741 
    742742          ! assuming linear profile across the top half surface layer 
    743           zhpi(ji,jj,1) =  0.5_wp * fse3w(ji,jj,1) * zrhdt1   
     743          zhpi(ji,jj,1) =  0.5_wp * fse3w(ji,jj,1) * zrhdt1 
    744744        END DO 
    745745      END DO 
    746746 
    747747      ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)" 
    748       DO jk = 2, jpkm1                                   
    749         DO jj = 2, jpj      
     748      DO jk = 2, jpkm1 
     749        DO jj = 2, jpj 
    750750          DO ji = 2, jpi 
    751751            zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) +                          & 
     
    758758 
    759759      ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) 
    760       DO jj = 2, jpjm1      
    761         DO ji = 2, jpim1   
     760      DO jj = 2, jpjm1 
     761        DO ji = 2, jpim1 
    762762          zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshu_n(ji,jj) * znad) 
    763763          zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshv_n(ji,jj) * znad) 
     
    765765      END DO 
    766766 
    767       DO jk = 2, jpkm1                                   
    768         DO jj = 2, jpjm1      
    769           DO ji = 2, jpim1   
     767      DO jk = 2, jpkm1 
     768        DO jj = 2, jpjm1 
     769          DO ji = 2, jpim1 
    770770            zu(ji,jj,jk) = zu(ji,jj,jk-1)- fse3u(ji,jj,jk) 
    771771            zv(ji,jj,jk) = zv(ji,jj,jk-1)- fse3v(ji,jj,jk) 
     
    773773        END DO 
    774774      END DO 
    775                 
    776       DO jk = 1, jpkm1                                   
    777         DO jj = 2, jpjm1      
    778           DO ji = 2, jpim1   
     775 
     776      DO jk = 1, jpkm1 
     777        DO jj = 2, jpjm1 
     778          DO ji = 2, jpim1 
    779779            zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * fse3u(ji,jj,jk) 
    780780            zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * fse3v(ji,jj,jk) 
     
    795795 
    796796 
    797       DO jk = 1, jpkm1                                   
    798         DO jj = 2, jpjm1      
    799           DO ji = 2, jpim1   
     797      DO jk = 1, jpkm1 
     798        DO jj = 2, jpjm1 
     799          DO ji = 2, jpim1 
    800800            zpwes = 0._wp; zpwed = 0._wp 
    801801            zpnss = 0._wp; zpnsd = 0._wp 
     
    812812 
    813813               ! integrate the pressure on the shallow side 
    814                jk1 = jk  
     814               jk1 = jk 
    815815               DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) 
    816816                 IF( jk1 == mbku(ji,jj) ) THEN 
     
    819819                 ENDIF 
    820820                 zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) 
    821                  zpwes = zpwes +                                    &  
     821                 zpwes = zpwes +                                    & 
    822822                      integ_spline(zdept(jis,jj,jk1), zdeps,            & 
    823823                             asp(jis,jj,jk1),    bsp(jis,jj,jk1), & 
     
    825825                 jk1 = jk1 + 1 
    826826               END DO 
    827              
     827 
    828828               ! integrate the pressure on the deep side 
    829                jk1 = jk  
     829               jk1 = jk 
    830830               DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) 
    831831                 IF( jk1 == 1 ) THEN 
     
    838838                 ENDIF 
    839839                 zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) 
    840                  zpwed = zpwed +                                        &  
     840                 zpwed = zpwed +                                        & 
    841841                        integ_spline(zdeps,              zdept(jid,jj,jk1), & 
    842842                               asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1),  & 
     
    844844                 jk1 = jk1 - 1 
    845845               END DO 
    846              
     846 
    847847               ! update the momentum trends in u direction 
    848848 
    849849               zdpdx1 = zcoef0 / e1u(ji,jj) * (zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk)) 
    850850               IF( lk_vvl ) THEN 
    851                  zdpdx2 = zcoef0 / e1u(ji,jj) * &  
    852                          ( REAL(jis-jid, wp) * (zpwes + zpwed) + (sshn(ji+1,jj)-sshn(ji,jj)) )  
     851                 zdpdx2 = zcoef0 / e1u(ji,jj) * & 
     852                         ( REAL(jis-jid, wp) * (zpwes + zpwed) + (sshn(ji+1,jj)-sshn(ji,jj)) ) 
    853853                ELSE 
    854                  zdpdx2 = zcoef0 / e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed)  
     854                 zdpdx2 = zcoef0 / e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) 
    855855               ENDIF 
    856856 
     
    858858               &           umask(ji,jj,jk) * tmask(ji,jj,jk) * tmask(ji+1,jj,jk) 
    859859            ENDIF 
    860    
     860 
    861861            !!!!!     for v equation 
    862862            IF( jk <= mbkv(ji,jj) ) THEN 
     
    868868 
    869869               ! integrate the pressure on the shallow side 
    870                jk1 = jk  
     870               jk1 = jk 
    871871               DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) 
    872872                 IF( jk1 == mbkv(ji,jj) ) THEN 
     
    875875                 ENDIF 
    876876                 zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) 
    877                  zpnss = zpnss +                                      &  
     877                 zpnss = zpnss +                                      & 
    878878                        integ_spline(zdept(ji,jjs,jk1), zdeps,            & 
    879879                               asp(ji,jjs,jk1),    bsp(ji,jjs,jk1), & 
     
    881881                 jk1 = jk1 + 1 
    882882               END DO 
    883              
     883 
    884884               ! integrate the pressure on the deep side 
    885                jk1 = jk  
     885               jk1 = jk 
    886886               DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) 
    887887                 IF( jk1 == 1 ) THEN 
     
    894894                 ENDIF 
    895895                 zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) 
    896                  zpnsd = zpnsd +                                        &  
     896                 zpnsd = zpnsd +                                        & 
    897897                        integ_spline(zdeps,              zdept(ji,jjd,jk1), & 
    898898                               asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & 
     
    900900                 jk1 = jk1 - 1 
    901901               END DO 
    902              
     902 
    903903 
    904904               ! update the momentum trends in v direction 
     
    907907               IF( lk_vvl ) THEN 
    908908                   zdpdy2 = zcoef0 / e2v(ji,jj) * & 
    909                            ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (sshn(ji,jj+1)-sshn(ji,jj)) )  
     909                           ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (sshn(ji,jj+1)-sshn(ji,jj)) ) 
    910910               ELSE 
    911                    zdpdy2 = zcoef0 / e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd )  
     911                   zdpdy2 = zcoef0 / e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) 
    912912               ENDIF 
    913913 
     
    916916            ENDIF 
    917917 
    918                      
     918 
    919919           END DO 
    920920        END DO 
    921921      END DO 
    922922      ! 
    923       CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp )  
    924       CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh )  
     923      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
     924      CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 
    925925      ! 
    926926   END SUBROUTINE hpg_prj 
     
    929929      !!---------------------------------------------------------------------- 
    930930      !!                 ***  ROUTINE cspline  *** 
    931       !!        
     931      !! 
    932932      !! ** Purpose :   constrained cubic spline interpolation 
    933       !!           
    934       !! ** Method  :   f(x) = asp + bsp*x + csp*x^2 + dsp*x^3  
     933      !! 
     934      !! ** Method  :   f(x) = asp + bsp*x + csp*x^2 + dsp*x^3 
    935935      !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation 
    936936      !! 
     
    938938      IMPLICIT NONE 
    939939      REAL(wp), DIMENSION(:,:,:), INTENT(in)  :: fsp, xsp           ! value and coordinate 
    940       REAL(wp), DIMENSION(:,:,:), INTENT(out) :: asp, bsp, csp, dsp ! coefficients of  
     940      REAL(wp), DIMENSION(:,:,:), INTENT(out) :: asp, bsp, csp, dsp ! coefficients of 
    941941                                                                    ! the interpoated function 
    942       INTEGER, INTENT(in) :: polynomial_type                        ! 1: cubic spline  
     942      INTEGER, INTENT(in) :: polynomial_type                        ! 1: cubic spline 
    943943                                                                    ! 2: Linear 
    944944 
    945       ! Local Variables       
     945      ! Local Variables 
    946946      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    947947      INTEGER  ::   jpi, jpj, jpkm1 
     
    955955      jpkm1 = size(fsp,3) - 1 
    956956 
    957        
     957 
    958958      IF (polynomial_type == 1) THEN     ! Constrained Cubic Spline 
    959959         DO ji = 1, jpi 
    960960            DO jj = 1, jpj 
    961            !!Fritsch&Butland's method, 1984 (preferred, but more computation)               
     961           !!Fritsch&Butland's method, 1984 (preferred, but more computation) 
    962962           !    DO jk = 2, jpkm1-1 
    963            !       zdxtmp1 = xsp(ji,jj,jk)   - xsp(ji,jj,jk-1)   
    964            !       zdxtmp2 = xsp(ji,jj,jk+1) - xsp(ji,jj,jk)   
     963           !       zdxtmp1 = xsp(ji,jj,jk)   - xsp(ji,jj,jk-1) 
     964           !       zdxtmp2 = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) 
    965965           !       zdf1    = ( fsp(ji,jj,jk)   - fsp(ji,jj,jk-1) ) / zdxtmp1 
    966966           !       zdf2    = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk)   ) / zdxtmp2 
    967967           ! 
    968968           !       zalpha = ( zdxtmp1 + 2._wp * zdxtmp2 ) / ( zdxtmp1 + zdxtmp2 ) / 3._wp 
    969            !      
     969           ! 
    970970           !       IF(zdf1 * zdf2 <= 0._wp) THEN 
    971971           !           zdf(jk) = 0._wp 
     
    974974           !       ENDIF 
    975975           !    END DO 
    976             
     976 
    977977           !!Simply geometric average 
    978978               DO jk = 2, jpkm1-1 
    979979                  zdf1 = (fsp(ji,jj,jk) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk) - xsp(ji,jj,jk-1)) 
    980980                  zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk)) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk)) 
    981              
     981 
    982982                  IF(zdf1 * zdf2 <= 0._wp) THEN 
    983983                     zdf(jk) = 0._wp 
     
    986986                  ENDIF 
    987987               END DO 
    988             
     988 
    989989               zdf(1)     = 1.5_wp * ( fsp(ji,jj,2) - fsp(ji,jj,1) ) / & 
    990990                          &          ( xsp(ji,jj,2) - xsp(ji,jj,1) ) -  0.5_wp * zdf(2) 
     
    992992                          &          ( xsp(ji,jj,jpkm1) - xsp(ji,jj,jpkm1-1) ) - & 
    993993                          & 0.5_wp * zdf(jpkm1 - 1) 
    994     
     994 
    995995               DO jk = 1, jpkm1 - 1 
    996                  zdxtmp = xsp(ji,jj,jk+1) - xsp(ji,jj,jk)  
     996                 zdxtmp = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) 
    997997                 ztmp1  = (zdf(jk+1) + 2._wp * zdf(jk)) / zdxtmp 
    998998                 ztmp2  =  6._wp * (fsp(ji,jj,jk+1) - fsp(ji,jj,jk)) / zdxtmp / zdxtmp 
    999                  zddf1  = -2._wp * ztmp1 + ztmp2  
     999                 zddf1  = -2._wp * ztmp1 + ztmp2 
    10001000                 ztmp1  = (2._wp * zdf(jk+1) + zdf(jk)) / zdxtmp 
    1001                  zddf2  =  2._wp * ztmp1 - ztmp2  
    1002        
     1001                 zddf2  =  2._wp * ztmp1 - ztmp2 
     1002 
    10031003                 dsp(ji,jj,jk) = (zddf2 - zddf1) / 6._wp / zdxtmp 
    10041004                 csp(ji,jj,jk) = ( xsp(ji,jj,jk+1) * zddf1 - xsp(ji,jj,jk)*zddf2 ) / 2._wp / zdxtmp 
    1005                  bsp(ji,jj,jk) = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp - &  
     1005                 bsp(ji,jj,jk) = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp - & 
    10061006                               & csp(ji,jj,jk) * ( xsp(ji,jj,jk+1) + xsp(ji,jj,jk) ) - & 
    10071007                               & dsp(ji,jj,jk) * ((xsp(ji,jj,jk+1) + xsp(ji,jj,jk))**2 - & 
     
    10131013            END DO 
    10141014         END DO 
    1015   
     1015 
    10161016      ELSE IF (polynomial_type == 2) THEN     ! Linear 
    10171017         DO ji = 1, jpi 
    10181018            DO jj = 1, jpj 
    10191019               DO jk = 1, jpkm1-1 
    1020                   zdxtmp =xsp(ji,jj,jk+1) - xsp(ji,jj,jk)  
     1020                  zdxtmp =xsp(ji,jj,jk+1) - xsp(ji,jj,jk) 
    10211021                  ztmp1 = fsp(ji,jj,jk+1) - fsp(ji,jj,jk) 
    1022     
     1022 
    10231023                  dsp(ji,jj,jk) = 0._wp 
    10241024                  csp(ji,jj,jk) = 0._wp 
     
    10331033      ENDIF 
    10341034 
    1035        
     1035 
    10361036   END SUBROUTINE cspline 
    10371037 
    10381038 
    1039    FUNCTION interp1(x, xl, xr, fl, fr)  RESULT(f)  
     1039   FUNCTION interp1(x, xl, xr, fl, fr)  RESULT(f) 
    10401040      !!---------------------------------------------------------------------- 
    10411041      !!                 ***  ROUTINE interp1  *** 
    1042       !!        
     1042      !! 
    10431043      !! ** Purpose :   1-d linear interpolation 
    1044       !!           
    1045       !! ** Method  :   
     1044      !! 
     1045      !! ** Method  : 
    10461046      !!                interpolation is straight forward 
    1047       !!                extrapolation is also permitted (no value limit)  
     1047      !!                extrapolation is also permitted (no value limit) 
    10481048      !! 
    10491049      !!---------------------------------------------------------------------- 
    10501050      IMPLICIT NONE 
    1051       REAL(wp), INTENT(in) ::  x, xl, xr, fl, fr    
     1051      REAL(wp), INTENT(in) ::  x, xl, xr, fl, fr 
    10521052      REAL(wp)             ::  f ! result of the interpolation (extrapolation) 
    10531053      REAL(wp)             ::  zdeltx 
     
    10601060        f = ( (x - xl ) * fr - ( x - xr ) * fl ) / zdeltx 
    10611061      ENDIF 
    1062        
     1062 
    10631063   END FUNCTION interp1 
    10641064 
    1065    FUNCTION interp2(x, a, b, c, d)  RESULT(f)  
     1065   FUNCTION interp2(x, a, b, c, d)  RESULT(f) 
    10661066      !!---------------------------------------------------------------------- 
    10671067      !!                 ***  ROUTINE interp1  *** 
    1068       !!        
     1068      !! 
    10691069      !! ** Purpose :   1-d constrained cubic spline interpolation 
    1070       !!           
     1070      !! 
    10711071      !! ** Method  :  cubic spline interpolation 
    10721072      !! 
    10731073      !!---------------------------------------------------------------------- 
    10741074      IMPLICIT NONE 
    1075       REAL(wp), INTENT(in) ::  x, a, b, c, d    
     1075      REAL(wp), INTENT(in) ::  x, a, b, c, d 
    10761076      REAL(wp)             ::  f ! value from the interpolation 
    10771077      !!---------------------------------------------------------------------- 
    10781078 
    1079       f = a + x* ( b + x * ( c + d * x ) )  
     1079      f = a + x* ( b + x * ( c + d * x ) ) 
    10801080 
    10811081   END FUNCTION interp2 
    10821082 
    10831083 
    1084    FUNCTION interp3(x, a, b, c, d)  RESULT(f)  
     1084   FUNCTION interp3(x, a, b, c, d)  RESULT(f) 
    10851085      !!---------------------------------------------------------------------- 
    10861086      !!                 ***  ROUTINE interp1  *** 
    1087       !!        
     1087      !! 
    10881088      !! ** Purpose :   Calculate the first order of deriavtive of 
    10891089      !!                a cubic spline function y=a+b*x+c*x^2+d*x^3 
    1090       !!           
     1090      !! 
    10911091      !! ** Method  :   f=dy/dx=b+2*c*x+3*d*x^2 
    10921092      !! 
    10931093      !!---------------------------------------------------------------------- 
    10941094      IMPLICIT NONE 
    1095       REAL(wp), INTENT(in) ::  x, a, b, c, d    
     1095      REAL(wp), INTENT(in) ::  x, a, b, c, d 
    10961096      REAL(wp)             ::  f ! value from the interpolation 
    10971097      !!---------------------------------------------------------------------- 
     
    11011101   END FUNCTION interp3 
    11021102 
    1103     
    1104    FUNCTION integ_spline(xl, xr, a, b, c, d)  RESULT(f)  
     1103 
     1104   FUNCTION integ_spline(xl, xr, a, b, c, d)  RESULT(f) 
    11051105      !!---------------------------------------------------------------------- 
    11061106      !!                 ***  ROUTINE interp1  *** 
    1107       !!        
     1107      !! 
    11081108      !! ** Purpose :   1-d constrained cubic spline integration 
    1109       !!           
    1110       !! ** Method  :  integrate polynomial a+bx+cx^2+dx^3 from xl to xr  
     1109      !! 
     1110      !! ** Method  :  integrate polynomial a+bx+cx^2+dx^3 from xl to xr 
    11111111      !! 
    11121112      !!---------------------------------------------------------------------- 
    11131113      IMPLICIT NONE 
    1114       REAL(wp), INTENT(in) ::  xl, xr, a, b, c, d    
    1115       REAL(wp)             ::  za1, za2, za3       
     1114      REAL(wp), INTENT(in) ::  xl, xr, a, b, c, d 
     1115      REAL(wp)             ::  za1, za2, za3 
    11161116      REAL(wp)             ::  f                   ! integration result 
    11171117      !!---------------------------------------------------------------------- 
    11181118 
    1119       za1 = 0.5_wp * b  
    1120       za2 = c / 3.0_wp  
    1121       za3 = 0.25_wp * d  
     1119      za1 = 0.5_wp * b 
     1120      za2 = c / 3.0_wp 
     1121      za3 = 0.25_wp * d 
    11221122 
    11231123      f  = xr * ( a + xr * ( za1 + xr * ( za2 + za3 * xr ) ) ) - & 
  • trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r3435 r3598  
    1717   !!             -   !  2008  (R. Benshila) add mpp_ini_ice 
    1818   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd 
    19    !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl  
     19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl 
    2020   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager 
    2121   !!---------------------------------------------------------------------- 
     
    2727   !!   get_unit    : give the index of an unused logical unit 
    2828   !!---------------------------------------------------------------------- 
    29 #if   defined key_mpp_mpi   
     29#if   defined key_mpp_mpi 
    3030   !!---------------------------------------------------------------------- 
    3131   !!   'key_mpp_mpi'             MPI massively parallel processing library 
     
    5252   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    5353   !!---------------------------------------------------------------------- 
    54    USE dom_oce        ! ocean space and time domain  
     54   USE dom_oce        ! ocean space and time domain 
    5555   USE lbcnfd         ! north fold treatment 
    5656   USE in_out_manager ! I/O manager 
     
    5858   IMPLICIT NONE 
    5959   PRIVATE 
    60     
     60 
    6161   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn 
    6262   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
     
    6767   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl 
    6868   PUBLIC   mppsize 
    69    PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90 
     69   PUBLIC   lib_mpp_alloc    ! Called in nemogcm.F90 
     70   PUBLIC   mppsend, mpprecv ! (PUBLIC for TAM) 
    7071 
    7172   !! * Interfaces 
     
    8485   END INTERFACE 
    8586   INTERFACE mpp_lbc_north 
    86       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d  
     87      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    8788   END INTERFACE 
    8889   INTERFACE mpp_minloc 
     
    9293      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    9394   END INTERFACE 
    94     
     95 
    9596   !! ========================= !! 
    9697   !!  MPI  variable definition !! 
     
    99100   INCLUDE 'mpif.h' 
    100101!$AGRIF_END_DO_NOT_TREAT 
    101     
     102 
    102103   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag 
    103104 
    104105   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2) 
    105     
     106 
    106107   INTEGER ::   mppsize        ! number of process 
    107108   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ] 
     
    126127   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average 
    127128   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    128     
     129 
    129130   ! North fold condition in mpp_mpi with jpni > 1 
    130131   INTEGER ::   ngrp_world        ! group ID for the world processors 
     
    140141   CHARACTER(len=1) ::   cn_mpi_send = 'S'    ! type od mpi send/recieve (S=standard, B=bsend, I=isend) 
    141142   LOGICAL          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I') 
    142    INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend  
    143        
     143   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend 
     144 
    144145   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend 
    145146 
     
    173174   ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 
    174175   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours 
    175    INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges  
     176   INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges 
    176177   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto 
    177178   INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto 
     
    229230      !!---------------------------------------------------------------------- 
    230231      !!                  ***  routine mynode  *** 
    231       !!                     
     232      !! 
    232233      !! ** Purpose :   Find processor unit 
    233234      !!---------------------------------------------------------------------- 
    234       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt  
    235       INTEGER                      , INTENT(in   ) ::   kumnam       ! namelist logical unit  
    236       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator  
     235      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
     236      INTEGER                      , INTENT(in   ) ::   kumnam       ! namelist logical unit 
     237      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
    237238      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    238239      ! 
     
    258259#if defined key_agrif 
    259260      IF( .NOT. Agrif_Root() ) THEN 
    260          jpni  = Agrif_Parent(jpni )  
     261         jpni  = Agrif_Parent(jpni ) 
    261262         jpnj  = Agrif_Parent(jpnj ) 
    262263         jpnij = Agrif_Parent(jpnij) 
     
    282283      CALL mpi_initialized ( mpi_was_called, code ) 
    283284      IF( code /= MPI_SUCCESS ) THEN 
    284          DO ji = 1, SIZE(ldtxt)  
     285         DO ji = 1, SIZE(ldtxt) 
    285286            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    286          END DO          
     287         END DO 
    287288         WRITE(*, cform_err) 
    288289         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
     
    297298         CASE ( 'B' )                ! Buffer mpi send (blocking) 
    298299            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1 
    299             IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )  
     300            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr ) 
    300301         CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    301302            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1 
     
    330331      ENDIF 
    331332 
    332       IF( PRESENT(localComm) ) THEN  
     333      IF( PRESENT(localComm) ) THEN 
    333334         IF( Agrif_Root() ) THEN 
    334335            mpi_comm_opa = localComm 
     
    337338         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
    338339         IF( code /= MPI_SUCCESS ) THEN 
    339             DO ji = 1, SIZE(ldtxt)  
     340            DO ji = 1, SIZE(ldtxt) 
    340341               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    341342            END DO 
     
    344345            CALL mpi_abort( mpi_comm_world, code, ierr ) 
    345346         ENDIF 
    346       ENDIF  
     347      ENDIF 
    347348 
    348349      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    349350      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
    350351      mynode = mpprank 
    351       !  
     352      ! 
    352353      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    353354      ! 
     
    361362      !! ** Purpose :   Message passing manadgement 
    362363      !! 
    363       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     364      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    364365      !!      between processors following neighboring subdomains. 
    365366      !!            domain parameters 
     
    368369      !!                    nbondi : mark for "east-west local boundary" 
    369370      !!                    nbondj : mark for "north-south local boundary" 
    370       !!                    noea   : number for local neighboring processors  
     371      !!                    noea   : number for local neighboring processors 
    371372      !!                    nowe   : number for local neighboring processors 
    372373      !!                    noso   : number for local neighboring processors 
     
    381382      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    382383      !                                                             ! =  1. , the sign is kept 
    383       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     384      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    384385      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    385386      !! 
     
    402403         DO jk = 1, jpk 
    403404            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    404                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
     405               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
    405406               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    406407               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     
    413414         END DO 
    414415         ! 
    415       ELSE                              ! standard close or cyclic treatment  
     416      ELSE                              ! standard close or cyclic treatment 
    416417         ! 
    417418         !                                   ! East-West boundaries 
     
    432433      ! 2. East and west directions exchange 
    433434      ! ------------------------------------ 
    434       ! we play with the neigbours AND the row number because of the periodicity  
     435      ! we play with the neigbours AND the row number because of the periodicity 
    435436      ! 
    436437      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     
    441442            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    442443         END DO 
    443       END SELECT   
     444      END SELECT 
    444445      ! 
    445446      !                           ! Migrations 
    446447      imigr = jpreci * jpj * jpk 
    447448      ! 
    448       SELECT CASE ( nbondi )  
     449      SELECT CASE ( nbondi ) 
    449450      CASE ( -1 ) 
    450451         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     
    472473            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    473474         END DO 
    474       CASE ( 0 )  
     475      CASE ( 0 ) 
    475476         DO jl = 1, jpreci 
    476477            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     
    499500      imigr = jprecj * jpi * jpk 
    500501      ! 
    501       SELECT CASE ( nbondj )      
     502      SELECT CASE ( nbondj ) 
    502503      CASE ( -1 ) 
    503504         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     
    511512         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    512513         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    513       CASE ( 1 )  
     514      CASE ( 1 ) 
    514515         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    515516         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
     
    525526            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    526527         END DO 
    527       CASE ( 0 )  
     528      CASE ( 0 ) 
    528529         DO jl = 1, jprecj 
    529530            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     
    555556      !!---------------------------------------------------------------------- 
    556557      !!                  ***  routine mpp_lnk_2d  *** 
    557       !!                   
     558      !! 
    558559      !! ** Purpose :   Message passing manadgement for 2d array 
    559560      !! 
    560       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     561      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    561562      !!      between processors following neighboring subdomains. 
    562563      !!            domain parameters 
     
    565566      !!                    nbondi : mark for "east-west local boundary" 
    566567      !!                    nbondj : mark for "north-south local boundary" 
    567       !!                    noea   : number for local neighboring processors  
     568      !!                    noea   : number for local neighboring processors 
    568569      !!                    nowe   : number for local neighboring processors 
    569570      !!                    noso   : number for local neighboring processors 
     
    576577      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    577578      !                                                         ! =  1. , the sign is kept 
    578       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only  
     579      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    579580      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    580581      !! 
     
    597598         ! WARNING pt2d is defined only between nld and nle 
    598599         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    599             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)    
     600            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    600601            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    601602            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
     
    607608         END DO 
    608609         ! 
    609       ELSE                              ! standard close or cyclic treatment  
     610      ELSE                              ! standard close or cyclic treatment 
    610611         ! 
    611612         !                                   ! East-West boundaries 
     
    626627      ! 2. East and west directions exchange 
    627628      ! ------------------------------------ 
    628       ! we play with the neigbours AND the row number because of the periodicity  
     629      ! we play with the neigbours AND the row number because of the periodicity 
    629630      ! 
    630631      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     
    724725            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
    725726         END DO 
    726       CASE ( 1 )  
     727      CASE ( 1 ) 
    727728         DO jl = 1, jprecj 
    728729            pt2d(:,jl      ) = t2sn(:,jl,2) 
     
    752753      !! ** Purpose :   Message passing manadgement for two 3D arrays 
    753754      !! 
    754       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     755      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    755756      !!      between processors following neighboring subdomains. 
    756757      !!            domain parameters 
     
    759760      !!                    nbondi : mark for "east-west local boundary" 
    760761      !!                    nbondj : mark for "north-south local boundary" 
    761       !!                    noea   : number for local neighboring processors  
     762      !!                    noea   : number for local neighboring processors 
    762763      !!                    nowe   : number for local neighboring processors 
    763764      !!                    noso   : number for local neighboring processors 
     
    767768      !! 
    768769      !!---------------------------------------------------------------------- 
    769       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which  
     770      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which 
    770771      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
    771       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays  
     772      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays 
    772773      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points 
    773774      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary 
     
    795796      ENDIF 
    796797 
    797        
     798 
    798799      !                                      ! North-South boundaries 
    799800      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point 
     
    805806      ! 2. East and west directions exchange 
    806807      ! ------------------------------------ 
    807       ! we play with the neigbours AND the row number because of the periodicity  
     808      ! we play with the neigbours AND the row number because of the periodicity 
    808809      ! 
    809810      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     
    821822      imigr = jpreci * jpj * jpk *2 
    822823      ! 
    823       SELECT CASE ( nbondi )  
     824      SELECT CASE ( nbondi ) 
    824825      CASE ( -1 ) 
    825826         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
     
    848849            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 
    849850         END DO 
    850       CASE ( 0 )  
     851      CASE ( 0 ) 
    851852         DO jl = 1, jpreci 
    852853            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2) 
     
    880881      imigr = jprecj * jpi * jpk * 2 
    881882      ! 
    882       SELECT CASE ( nbondj )      
     883      SELECT CASE ( nbondj ) 
    883884      CASE ( -1 ) 
    884885         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
     
    892893         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    893894         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    894       CASE ( 1 )  
     895      CASE ( 1 ) 
    895896         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    896897         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
     
    907908            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 
    908909         END DO 
    909       CASE ( 0 )  
     910      CASE ( 0 ) 
    910911         DO jl = 1, jprecj 
    911912            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2) 
     
    927928         ! 
    928929         SELECT CASE ( jpni ) 
    929          CASE ( 1 )                                            
     930         CASE ( 1 ) 
    930931            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    931932            CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
     
    933934            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    934935            CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    935          END SELECT  
     936         END SELECT 
    936937         ! 
    937938      ENDIF 
     
    943944      !!---------------------------------------------------------------------- 
    944945      !!                  ***  routine mpp_lnk_2d_e  *** 
    945       !!                   
     946      !! 
    946947      !! ** Purpose :   Message passing manadgement for 2d array (with halo) 
    947948      !! 
    948       !! ** Method  :   Use mppsend and mpprecv function for passing mask  
     949      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    949950      !!      between processors following neighboring subdomains. 
    950951      !!            domain parameters 
     
    955956      !!                    nbondi : mark for "east-west local boundary" 
    956957      !!                    nbondj : mark for "north-south local boundary" 
    957       !!                    noea   : number for local neighboring processors  
     958      !!                    noea   : number for local neighboring processors 
    958959      !!                    nowe   : number for local neighboring processors 
    959960      !!                    noso   : number for local neighboring processors 
     
    984985      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0    ! south except at F-point 
    985986                                   pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0    ! north 
    986                                  
     987 
    987988      !                                      ! East-West boundaries 
    988989      !                                           !* Cyclic east-west 
     
    10041005         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj ) 
    10051006         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               ) 
    1006          END SELECT  
     1007         END SELECT 
    10071008         ! 
    10081009      ENDIF 
     
    10101011      ! 2. East and west directions exchange 
    10111012      ! ------------------------------------ 
    1012       ! we play with the neigbours AND the row number because of the periodicity  
     1013      ! we play with the neigbours AND the row number because of the periodicity 
    10131014      ! 
    10141015      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     
    10961097      ! 
    10971098      !                           ! Write Dirichlet lateral conditions 
    1098       ijhom = nlcj - jprecj   
     1099      ijhom = nlcj - jprecj 
    10991100      ! 
    11001101      SELECT CASE ( nbondj ) 
     
    11081109            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2) 
    11091110         END DO 
    1110       CASE ( 1 )  
     1111      CASE ( 1 ) 
    11111112         DO jl = 1, iprecj 
    11121113            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2) 
     
    11201121      !!---------------------------------------------------------------------- 
    11211122      !!                  ***  routine mppsend  *** 
    1122       !!                    
     1123      !! 
    11231124      !! ** Purpose :   Send messag passing array 
    11241125      !! 
     
    11561157      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
    11571158      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
    1158       INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number  
     1159      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
    11591160      !! 
    11601161      INTEGER :: istatus(mpi_status_size) 
     
    11641165      ! 
    11651166 
    1166       ! If a specific process number has been passed to the receive call,  
     1167      ! If a specific process number has been passed to the receive call, 
    11671168      ! use that one. Default is to use mpi_any_source 
    11681169      use_source=mpi_any_source 
     
    11791180      !!---------------------------------------------------------------------- 
    11801181      !!                   ***  routine mppgather  *** 
    1181       !!                    
    1182       !! ** Purpose :   Transfert between a local subdomain array and a work  
     1182      !! 
     1183      !! ** Purpose :   Transfert between a local subdomain array and a work 
    11831184      !!     array which is distributed following the vertical level. 
    11841185      !! 
     
    11931194      itaille = jpi * jpj 
    11941195      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    1195          &                            mpi_double_precision, kp , mpi_comm_opa, ierror )  
     1196         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
    11961197      ! 
    11971198   END SUBROUTINE mppgather 
     
    12021203      !!                  ***  routine mppscatter  *** 
    12031204      !! 
    1204       !! ** Purpose :   Transfert between awork array which is distributed  
     1205      !! ** Purpose :   Transfert between awork array which is distributed 
    12051206      !!      following the vertical level and the local subdomain array. 
    12061207      !! 
     
    12241225      !!---------------------------------------------------------------------- 
    12251226      !!                  ***  routine mppmax_a_int  *** 
    1226       !!  
     1227      !! 
    12271228      !! ** Purpose :   Find maximum value in an integer layout array 
    12281229      !! 
     
    12301231      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    12311232      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1232       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !  
     1233      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    12331234      !! 
    12341235      INTEGER :: ierror, localcomm   ! temporary integer 
     
    12551256      INTEGER, INTENT(inout)           ::   ktab      ! ??? 
    12561257      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ??? 
    1257       !!  
     1258      !! 
    12581259      INTEGER ::   ierror, iwork, localcomm   ! temporary integer 
    12591260      !!---------------------------------------------------------------------- 
    12601261      ! 
    1261       localcomm = mpi_comm_opa  
     1262      localcomm = mpi_comm_opa 
    12621263      IF( PRESENT(kcom) )   localcomm = kcom 
    12631264      ! 
     
    12721273      !!---------------------------------------------------------------------- 
    12731274      !!                  ***  routine mppmin_a_int  *** 
    1274       !!  
     1275      !! 
    12751276      !! ** Purpose :   Find minimum value in an integer layout array 
    12761277      !! 
     
    13201321      !!---------------------------------------------------------------------- 
    13211322      !!                  ***  routine mppsum_a_int  *** 
    1322       !!                     
     1323      !! 
    13231324      !! ** Purpose :   Global integer sum, 1D array case 
    13241325      !! 
     
    13411342      !!---------------------------------------------------------------------- 
    13421343      !!                 ***  routine mppsum_int  *** 
    1343       !!                   
     1344      !! 
    13441345      !! ** Purpose :   Global integer sum 
    13451346      !! 
    13461347      !!---------------------------------------------------------------------- 
    13471348      INTEGER, INTENT(inout) ::   ktab 
    1348       !!  
     1349      !! 
    13491350      INTEGER :: ierror, iwork 
    13501351      !!---------------------------------------------------------------------- 
     
    13601361      !!---------------------------------------------------------------------- 
    13611362      !!                 ***  routine mppmax_a_real  *** 
    1362       !!                   
     1363      !! 
    13631364      !! ** Purpose :   Maximum 
    13641365      !! 
     
    13841385      !!---------------------------------------------------------------------- 
    13851386      !!                  ***  routine mppmax_real  *** 
    1386       !!                     
     1387      !! 
    13871388      !! ** Purpose :   Maximum 
    13881389      !! 
     
    13951396      !!---------------------------------------------------------------------- 
    13961397      ! 
    1397       localcomm = mpi_comm_opa  
     1398      localcomm = mpi_comm_opa 
    13981399      IF( PRESENT(kcom) )   localcomm = kcom 
    13991400      ! 
     
    14071408      !!---------------------------------------------------------------------- 
    14081409      !!                 ***  routine mppmin_a_real  *** 
    1409       !!                   
     1410      !! 
    14101411      !! ** Purpose :   Minimum of REAL, array case 
    14111412      !! 
     
    14191420      !!----------------------------------------------------------------------- 
    14201421      ! 
    1421       localcomm = mpi_comm_opa  
     1422      localcomm = mpi_comm_opa 
    14221423      IF( PRESENT(kcom) ) localcomm = kcom 
    14231424      ! 
     
    14311432      !!---------------------------------------------------------------------- 
    14321433      !!                  ***  routine mppmin_real  *** 
    1433       !!  
     1434      !! 
    14341435      !! ** Purpose :   minimum of REAL, scalar case 
    14351436      !! 
    14361437      !!----------------------------------------------------------------------- 
    1437       REAL(wp), INTENT(inout)           ::   ptab        !  
     1438      REAL(wp), INTENT(inout)           ::   ptab        ! 
    14381439      INTEGER , INTENT(in   ), OPTIONAL :: kcom 
    14391440      !! 
     
    14431444      !!----------------------------------------------------------------------- 
    14441445      ! 
    1445       localcomm = mpi_comm_opa  
     1446      localcomm = mpi_comm_opa 
    14461447      IF( PRESENT(kcom) )   localcomm = kcom 
    14471448      ! 
     
    14551456      !!---------------------------------------------------------------------- 
    14561457      !!                  ***  routine mppsum_a_real  *** 
    1457       !!  
     1458      !! 
    14581459      !! ** Purpose :   global sum, REAL ARRAY argument case 
    14591460      !! 
     
    14641465      !! 
    14651466      INTEGER                   ::   ierror    ! temporary integer 
    1466       INTEGER                   ::   localcomm  
    1467       REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace  
     1467      INTEGER                   ::   localcomm 
     1468      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace 
    14681469      !!----------------------------------------------------------------------- 
    14691470      ! 
    1470       localcomm = mpi_comm_opa  
     1471      localcomm = mpi_comm_opa 
    14711472      IF( PRESENT(kcom) )   localcomm = kcom 
    14721473      ! 
     
    14801481      !!---------------------------------------------------------------------- 
    14811482      !!                  ***  routine mppsum_real  *** 
    1482       !!               
     1483      !! 
    14831484      !! ** Purpose :   global sum, SCALAR argument case 
    14841485      !! 
     
    14871488      INTEGER , INTENT(in   ), OPTIONAL ::   kcom 
    14881489      !! 
    1489       INTEGER  ::   ierror, localcomm  
     1490      INTEGER  ::   ierror, localcomm 
    14901491      REAL(wp) ::   zwork 
    14911492      !!----------------------------------------------------------------------- 
    14921493      ! 
    1493       localcomm = mpi_comm_opa  
     1494      localcomm = mpi_comm_opa 
    14941495      IF( PRESENT(kcom) ) localcomm = kcom 
    14951496      ! 
     
    15241525 
    15251526   END SUBROUTINE mppsum_realdd 
    1526    
    1527    
     1527 
     1528 
    15281529   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    15291530      !!---------------------------------------------------------------------- 
     
    15511552 
    15521553   END SUBROUTINE mppsum_a_realdd 
    1553     
     1554 
    15541555   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 
    15551556      !!------------------------------------------------------------------------ 
     
    16461647      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab 
    16471648      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame 
    1648       !!   
     1649      !! 
    16491650      INTEGER  :: ierror 
    16501651      INTEGER, DIMENSION (2)   ::   ilocs 
     
    16851686      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab 
    16861687      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
    1687       !!    
     1688      !! 
    16881689      REAL(wp) :: zmax   ! local maximum 
    16891690      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
     
    17151716      !!---------------------------------------------------------------------- 
    17161717      !!                  ***  routine mppsync  *** 
    1717       !!                    
     1718      !! 
    17181719      !! ** Purpose :   Massively parallel processors, synchroneous 
    17191720      !! 
     
    17301731      !!---------------------------------------------------------------------- 
    17311732      !!                  ***  routine mppstop  *** 
    1732       !!                    
     1733      !! 
    17331734      !! ** purpose :   Stop massively parallel processors method 
    17341735      !! 
     
    17461747      !!---------------------------------------------------------------------- 
    17471748      !!                  ***  routine mppobc  *** 
    1748       !!  
     1749      !! 
    17491750      !! ** Purpose :   Message passing manadgement for open boundary 
    17501751      !!     conditions array 
     
    17571758      !!                    nbondi : mark for "east-west local boundary" 
    17581759      !!                    nbondj : mark for "north-south local boundary" 
    1759       !!                    noea   : number for local neighboring processors  
     1760      !!                    noea   : number for local neighboring processors 
    17601761      !!                    nowe   : number for local neighboring processors 
    17611762      !!                    noso   : number for local neighboring processors 
     
    18061807         CALL mppstop 
    18071808      ENDIF 
    1808        
     1809 
    18091810      ! Communication level by level 
    18101811      ! ---------------------------- 
     
    19211922            DO jj = ijpt0, ijpt1            ! north/south boundaries 
    19221923               DO ji = iipt0,ilpt1 
    1923                   ptab(ji,jk) = ztab(ji,jj)   
     1924                  ptab(ji,jk) = ztab(ji,jj) 
    19241925               END DO 
    19251926            END DO 
     
    19271928            DO jj = ijpt0, ilpt1            ! east/west boundaries 
    19281929               DO ji = iipt0,iipt1 
    1929                   ptab(jj,jk) = ztab(ji,jj)  
     1930                  ptab(jj,jk) = ztab(ji,jj) 
    19301931               END DO 
    19311932            END DO 
     
    19371938      ! 
    19381939   END SUBROUTINE mppobc 
    1939     
     1940 
    19401941 
    19411942   SUBROUTINE mpp_comm_free( kcom ) 
     
    19961997      kice = 0 
    19971998      DO jjproc = 1, jpnij 
    1998          IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1     
     1999         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1 
    19992000      END DO 
    20002001      ! 
    20012002      zwork = 0 
    20022003      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr ) 
    2003       ndim_rank_ice = SUM( zwork )           
     2004      ndim_rank_ice = SUM( zwork ) 
    20042005 
    20052006      ! Allocate the right size to nrank_north 
     
    20072008      ALLOCATE( nrank_ice(ndim_rank_ice) ) 
    20082009      ! 
    2009       ii = 0      
     2010      ii = 0 
    20102011      nrank_ice = 0 
    20112012      DO jjproc = 1, jpnij 
    20122013         IF( zwork(jjproc) == 1) THEN 
    20132014            ii = ii + 1 
    2014             nrank_ice(ii) = jjproc -1  
     2015            nrank_ice(ii) = jjproc -1 
    20152016         ENDIF 
    20162017      END DO 
     
    20942095         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl) 
    20952096         ALLOCATE(nrank_znl(ndim_rank_znl)) 
    2096          ii = 0      
     2097         ii = 0 
    20972098         nrank_znl (:) = 0 
    20982099         DO jproc=1,jpnij 
    20992100            IF ( kwork(jproc) == njmpp) THEN 
    21002101               ii = ii + 1 
    2101                nrank_znl(ii) = jproc -1  
     2102               nrank_znl(ii) = jproc -1 
    21022103            ENDIF 
    21032104         END DO 
     
    21232124 
    21242125      ! Determines if processor if the first (starting from i=1) on the row 
    2125       IF ( jpni == 1 ) THEN  
     2126      IF ( jpni == 1 ) THEN 
    21262127         l_znl_root = .TRUE. 
    21272128      ELSE 
     
    21412142      !!               ***  routine mpp_ini_north  *** 
    21422143      !! 
    2143       !! ** Purpose :   Initialize special communicator for north folding  
     2144      !! ** Purpose :   Initialize special communicator for north folding 
    21442145      !!      condition together with global variables needed in the mpp folding 
    21452146      !! 
     
    22022203      !!                   ***  routine mpp_lbc_north_3d  *** 
    22032204      !! 
    2204       !! ** Purpose :   Ensure proper north fold horizontal bondary condition  
     2205      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    22052206      !!              in mpp configuration in case of jpn1 > 1 
    22062207      !! 
    22072208      !! ** Method  :   North fold condition and mpp with more than one proc 
    2208       !!              in i-direction require a specific treatment. We gather  
     2209      !!              in i-direction require a specific treatment. We gather 
    22092210      !!              the 4 northern lines of the global domain on 1 processor 
    22102211      !!              and apply lbc north-fold on this sub array. Then we 
     
    22152216      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    22162217      !                                                              !   = T ,  U , V , F or W  gridpoints 
    2217       REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2218      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold 
    22182219      !!                                                             ! =  1. , the sign is kept 
    22192220      INTEGER ::   ji, jj, jr 
     
    22242225      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    22252226      !!---------------------------------------------------------------------- 
    2226       !    
     2227      ! 
    22272228      ijpj   = 4 
    22282229      ityp = -1 
     
    22392240      IF ( l_north_nogather ) THEN 
    22402241         ! 
    2241          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2242         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 
    22422243         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    22432244         ! 
     
    22642265               ityp = 5 
    22652266            CASE DEFAULT 
    2266                ityp = -1                    ! Set a default value for unsupported types which  
     2267               ityp = -1                    ! Set a default value for unsupported types which 
    22672268                                            ! will cause a fallback to the mpi_allgather method 
    22682269         END SELECT 
     
    23132314      ! The ztab array has been either: 
    23142315      !  a. Fully populated by the mpi_allgather operation or 
    2315       !  b. Had the active points for this domain and northern neighbours populated  
     2316      !  b. Had the active points for this domain and northern neighbours populated 
    23162317      !     by peer to peer exchanges 
    2317       ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2318      ! Either way the array may be folded by lbc_nfd and the result for the span of 
    23182319      ! this domain will be identical. 
    23192320      ! 
     
    23342335      !!                   ***  routine mpp_lbc_north_2d  *** 
    23352336      !! 
    2336       !! ** Purpose :   Ensure proper north fold horizontal bondary condition  
     2337      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    23372338      !!              in mpp configuration in case of jpn1 > 1 (for 2d array ) 
    23382339      !! 
    23392340      !! ** Method  :   North fold condition and mpp with more than one proc 
    2340       !!              in i-direction require a specific treatment. We gather  
     2341      !!              in i-direction require a specific treatment. We gather 
    23412342      !!              the 4 northern lines of the global domain on 1 processor 
    23422343      !!              and apply lbc north-fold on this sub array. Then we 
     
    23472348      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    23482349      !                                                          !   = T ,  U , V , F or W  gridpoints 
    2349       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2350      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold 
    23502351      !!                                                             ! =  1. , the sign is kept 
    23512352      INTEGER ::   ji, jj, jr 
     
    23712372      IF ( l_north_nogather ) THEN 
    23722373         ! 
    2373          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2374         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 
    23742375         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    23752376         ! 
     
    23962397               ityp = 5 
    23972398            CASE DEFAULT 
    2398                ityp = -1                    ! Set a default value for unsupported types which  
     2399               ityp = -1                    ! Set a default value for unsupported types which 
    23992400                                            ! will cause a fallback to the mpi_allgather method 
    24002401         END SELECT 
     
    24462447      ! The ztab array has been either: 
    24472448      !  a. Fully populated by the mpi_allgather operation or 
    2448       !  b. Had the active points for this domain and northern neighbours populated  
     2449      !  b. Had the active points for this domain and northern neighbours populated 
    24492450      !     by peer to peer exchanges 
    2450       ! Either way the array may be folded by lbc_nfd and the result for the span of  
     2451      ! Either way the array may be folded by lbc_nfd and the result for the span of 
    24512452      ! this domain will be identical. 
    24522453      ! 
     
    24682469      !!                   ***  routine mpp_lbc_north_2d  *** 
    24692470      !! 
    2470       !! ** Purpose :   Ensure proper north fold horizontal bondary condition  
    2471       !!              in mpp configuration in case of jpn1 > 1 and for 2d  
     2471      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2472      !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    24722473      !!              array with outer extra halo 
    24732474      !! 
    24742475      !! ** Method  :   North fold condition and mpp with more than one proc 
    2475       !!              in i-direction require a specific treatment. We gather  
    2476       !!              the 4+2*jpr2dj northern lines of the global domain on 1  
    2477       !!              processor and apply lbc north-fold on this sub array.  
     2476      !!              in i-direction require a specific treatment. We gather 
     2477      !!              the 4+2*jpr2dj northern lines of the global domain on 1 
     2478      !!              processor and apply lbc north-fold on this sub array. 
    24782479      !!              Then we scatter the north fold array back to the processors. 
    24792480      !! 
     
    24822483      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    24832484      !                                                                                         !   = T ,  U , V , F or W -points 
    2484       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the   
     2485      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    24852486      !!                                                                                        ! north fold, =  1. otherwise 
    24862487      INTEGER ::   ji, jj, jr 
     
    25252526      !! Scatter back to pt2d 
    25262527      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj 
    2527       ij  = ij +1  
     2528      ij  = ij +1 
    25282529         DO ji= 1, nlci 
    25292530            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
     
    25422543      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    25432544      !!            but classical mpi_init 
    2544       !!  
    2545       !! History :: 01/11 :: IDRIS initial version for IBM only   
     2545      !! 
     2546      !! History :: 01/11 :: IDRIS initial version for IBM only 
    25462547      !!            08/04 :: R. Benshila, generalisation 
    25472548      !!--------------------------------------------------------------------- 
    2548       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt  
     2549      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    25492550      INTEGER                      , INTENT(inout) ::   ksft 
    25502551      INTEGER                      , INTENT(  out) ::   code 
     
    25552556      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    25562557      IF ( code /= MPI_SUCCESS ) THEN 
    2557          DO ji = 1, SIZE(ldtxt)  
     2558         DO ji = 1, SIZE(ldtxt) 
    25582559            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    2559          END DO          
     2560         END DO 
    25602561         WRITE(*, cform_err) 
    25612562         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
     
    25672568         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code ) 
    25682569         IF ( code /= MPI_SUCCESS ) THEN 
    2569             DO ji = 1, SIZE(ldtxt)  
     2570            DO ji = 1, SIZE(ldtxt) 
    25702571               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    25712572            END DO 
     
    25802581         ! Buffer allocation and attachment 
    25812582         ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    2582          IF( ierr /= 0 ) THEN  
    2583             DO ji = 1, SIZE(ldtxt)  
     2583         IF( ierr /= 0 ) THEN 
     2584            DO ji = 1, SIZE(ldtxt) 
    25842585               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    25852586            END DO 
     
    26602661   FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value) 
    26612662      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    2662       CHARACTER(len=*),DIMENSION(:) ::   ldtxt  
     2663      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    26632664      INTEGER ::   kumnam, kstop 
    26642665      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0 
     
    26722673      REAL   , DIMENSION(:) :: parr 
    26732674      INTEGER               :: kdim 
    2674       INTEGER, OPTIONAL     :: kcom  
     2675      INTEGER, OPTIONAL     :: kcom 
    26752676      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 
    26762677   END SUBROUTINE mpp_sum_as 
     
    26792680      REAL   , DIMENSION(:,:) :: parr 
    26802681      INTEGER               :: kdim 
    2681       INTEGER, OPTIONAL     :: kcom  
     2682      INTEGER, OPTIONAL     :: kcom 
    26822683      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 
    26832684   END SUBROUTINE mpp_sum_a2s 
     
    26862687      INTEGER, DIMENSION(:) :: karr 
    26872688      INTEGER               :: kdim 
    2688       INTEGER, OPTIONAL     :: kcom  
     2689      INTEGER, OPTIONAL     :: kcom 
    26892690      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 
    26902691   END SUBROUTINE mpp_sum_ai 
     
    26922693   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine 
    26932694      REAL                  :: psca 
    2694       INTEGER, OPTIONAL     :: kcom  
     2695      INTEGER, OPTIONAL     :: kcom 
    26952696      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 
    26962697   END SUBROUTINE mpp_sum_s 
     
    26982699   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine 
    26992700      integer               :: kint 
    2700       INTEGER, OPTIONAL     :: kcom  
     2701      INTEGER, OPTIONAL     :: kcom 
    27012702      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 
    27022703   END SUBROUTINE mpp_sum_i 
     
    27072708      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab 
    27082709   END SUBROUTINE mppsum_realdd 
    2709   
     2710 
    27102711   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    27112712      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab 
     
    27182719      REAL   , DIMENSION(:) :: parr 
    27192720      INTEGER               :: kdim 
    2720       INTEGER, OPTIONAL     :: kcom  
     2721      INTEGER, OPTIONAL     :: kcom 
    27212722      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    27222723   END SUBROUTINE mppmax_a_real 
     
    27242725   SUBROUTINE mppmax_real( psca, kcom ) 
    27252726      REAL                  :: psca 
    2726       INTEGER, OPTIONAL     :: kcom  
     2727      INTEGER, OPTIONAL     :: kcom 
    27272728      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 
    27282729   END SUBROUTINE mppmax_real 
     
    27312732      REAL   , DIMENSION(:) :: parr 
    27322733      INTEGER               :: kdim 
    2733       INTEGER, OPTIONAL     :: kcom  
     2734      INTEGER, OPTIONAL     :: kcom 
    27342735      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    27352736   END SUBROUTINE mppmin_a_real 
     
    27372738   SUBROUTINE mppmin_real( psca, kcom ) 
    27382739      REAL                  :: psca 
    2739       INTEGER, OPTIONAL     :: kcom  
     2740      INTEGER, OPTIONAL     :: kcom 
    27402741      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 
    27412742   END SUBROUTINE mppmin_real 
     
    27442745      INTEGER, DIMENSION(:) :: karr 
    27452746      INTEGER               :: kdim 
    2746       INTEGER, OPTIONAL     :: kcom  
     2747      INTEGER, OPTIONAL     :: kcom 
    27472748      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    27482749   END SUBROUTINE mppmax_a_int 
     
    27502751   SUBROUTINE mppmax_int( kint, kcom) 
    27512752      INTEGER               :: kint 
    2752       INTEGER, OPTIONAL     :: kcom  
     2753      INTEGER, OPTIONAL     :: kcom 
    27532754      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 
    27542755   END SUBROUTINE mppmax_int 
     
    27572758      INTEGER, DIMENSION(:) :: karr 
    27582759      INTEGER               :: kdim 
    2759       INTEGER, OPTIONAL     :: kcom  
     2760      INTEGER, OPTIONAL     :: kcom 
    27602761      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    27612762   END SUBROUTINE mppmin_a_int 
     
    27632764   SUBROUTINE mppmin_int( kint, kcom ) 
    27642765      INTEGER               :: kint 
    2765       INTEGER, OPTIONAL     :: kcom  
     2766      INTEGER, OPTIONAL     :: kcom 
    27662767      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 
    27672768   END SUBROUTINE mppmin_int 
     
    28502851      !!                  ***  ROUTINE  stop_opa  *** 
    28512852      !! 
    2852       !! ** Purpose :   print in ocean.outpput file a error message and  
     2853      !! ** Purpose :   print in ocean.outpput file a error message and 
    28532854      !!                increment the error number (nstop) by one. 
    28542855      !!---------------------------------------------------------------------- 
     
    28572858      !!---------------------------------------------------------------------- 
    28582859      ! 
    2859       nstop = nstop + 1  
     2860      nstop = nstop + 1 
    28602861      IF(lwp) THEN 
    28612862         WRITE(numout,cform_err) 
     
    28892890      !!                  ***  ROUTINE  stop_warn  *** 
    28902891      !! 
    2891       !! ** Purpose :   print in ocean.outpput file a error message and  
     2892      !! ** Purpose :   print in ocean.outpput file a error message and 
    28922893      !!                increment the warning number (nwarn) by one. 
    28932894      !!---------------------------------------------------------------------- 
     
    28952896      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
    28962897      !!---------------------------------------------------------------------- 
    2897       !  
    2898       nwarn = nwarn + 1  
     2898      ! 
     2899      nwarn = nwarn + 1 
    28992900      IF(lwp) THEN 
    29002901         WRITE(numout,cform_war) 
     
    29822983         STOP 'ctl_opn bad opening' 
    29832984      ENDIF 
    2984        
     2985 
    29852986   END SUBROUTINE ctl_opn 
    29862987 
     
    29922993      !! ** Purpose :   return the index of an unused logical unit 
    29932994      !!---------------------------------------------------------------------- 
    2994       LOGICAL :: llopn  
     2995      LOGICAL :: llopn 
    29952996      !!---------------------------------------------------------------------- 
    29962997      ! 
  • trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r3421 r3598  
    66   !! History :  OPA  ! 2000-11  (R. Hordoir, E. Durand)  NetCDF FORMAT 
    77   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module 
    8    !!            3.0  ! 2006-07  (G. Madec)  Surface module  
     8   !!            3.0  ! 2006-07  (G. Madec)  Surface module 
    99   !!            3.2  ! 2009-04  (B. Lemaire)  Introduce iom_put 
    1010   !!            3.3  ! 2010-10  (R. Furner, G. Madec) runoff distributed over ocean levels 
     
    3232   PUBLIC   sbc_rnf_div   ! routine called in sshwzv module 
    3333   PUBLIC   sbc_rnf_alloc ! routine call in sbcmod module 
    34  
     34   PUBLIC   sbc_rnf_init  ! (PUBLIC for TAM) 
    3535   !                                                     !!* namsbc_rnf namelist * 
    3636   CHARACTER(len=100), PUBLIC ::   cn_dir       = './'    !: Root directory for location of ssr files 
    3737   LOGICAL           , PUBLIC ::   ln_rnf_depth = .false. !: depth       river runoffs attribute specified in a file 
    38    LOGICAL           , PUBLIC ::   ln_rnf_tem   = .false. !: temperature river runoffs attribute specified in a file  
    39    LOGICAL           , PUBLIC ::   ln_rnf_sal   = .false. !: salinity    river runoffs attribute specified in a file  
     38   LOGICAL           , PUBLIC ::   ln_rnf_tem   = .false. !: temperature river runoffs attribute specified in a file 
     39   LOGICAL           , PUBLIC ::   ln_rnf_sal   = .false. !: salinity    river runoffs attribute specified in a file 
    4040   LOGICAL           , PUBLIC ::   ln_rnf_emp   = .false. !: runoffs into a file to be read or already into precipitation 
    4141   TYPE(FLD_N)       , PUBLIC ::   sn_rnf                 !: information about the runoff file to be read 
    4242   TYPE(FLD_N)       , PUBLIC ::   sn_cnf                 !: information about the runoff mouth file to be read 
    43    TYPE(FLD_N)                ::   sn_s_rnf               !: information about the salinities of runoff file to be read   
    44    TYPE(FLD_N)                ::   sn_t_rnf               !: information about the temperatures of runoff file to be read   
     43   TYPE(FLD_N)                ::   sn_s_rnf               !: information about the salinities of runoff file to be read 
     44   TYPE(FLD_N)                ::   sn_t_rnf               !: information about the temperatures of runoff file to be read 
    4545   TYPE(FLD_N)                ::   sn_dep_rnf             !: information about the depth which river inflow affects 
    4646   LOGICAL           , PUBLIC ::   ln_rnf_mouth = .false. !: specific treatment in mouths vicinity 
     
    5555   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels 
    5656   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
    57     
    58    REAL(wp) ::   r1_rau0   ! = 1 / rau0  
    59  
    60    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    61    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    62    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    63   
    64    !! * Substitutions   
    65 #  include "domzgr_substitute.h90"   
     57 
     58   REAL(wp) ::   r1_rau0   ! = 1 / rau0 
     59 
     60   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) (PUBLIC for TAM) 
     61   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)  (PUBLIC for TAM) 
     62   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read) (PUBLIC for TAM) 
     63 
     64   !! * Substitutions 
     65#  include "domzgr_substitute.h90" 
    6666   !!---------------------------------------------------------------------- 
    6767   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     
    8686      !!---------------------------------------------------------------------- 
    8787      !!                  ***  ROUTINE sbc_rnf  *** 
    88       !!        
     88      !! 
    8989      !! ** Purpose :   Introduce a climatological run off forcing 
    9090      !! 
    91       !! ** Method  :   Set each river mouth with a monthly climatology  
     91      !! ** Method  :   Set each river mouth with a monthly climatology 
    9292      !!                provided from different data. 
    9393      !!                CAUTION : upward water flux, runoff forced to be < 0 
     
    9999      INTEGER  ::   ji, jj   ! dummy loop indices 
    100100      !!---------------------------------------------------------------------- 
    101       !                                    
     101      ! 
    102102      IF( kt == nit000 )   CALL sbc_rnf_init                           ! Read namelist and allocate structures 
    103103 
     
    114114         !                                                !-------------------! 
    115115         ! 
    116                              CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt  
     116                             CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt 
    117117         IF( ln_rnf_tem  )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    118118         IF( ln_rnf_sal  )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
     
    127127         ! 
    128128         IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
    129             rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )   
     129            rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) 
    130130            ! 
    131131            r1_rau0 = 1._wp / rau0 
     
    133133            IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
    134134               rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    135                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999 )                 ! if missing data value use SST as runoffs temperature   
     135               WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999 )                 ! if missing data value use SST as runoffs temperature 
    136136                   rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    137137               END WHERE 
    138138            ELSE                                                        ! use SST as runoffs temperature 
    139139               rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    140             ENDIF   
    141             !                                                           ! use runoffs salinity data  
     140            ENDIF 
     141            !                                                           ! use runoffs salinity data 
    142142            IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    143143            !                                                           ! else use S=0 for runoffs (done one for all in the init) 
    144144            ! 
    145145            IF( ln_rnf_tem .OR. ln_rnf_sal ) THEN                 ! runoffs as outflow: use ocean SST and SSS 
    146                WHERE( rnf(:,:) < 0._wp )                                 ! example baltic model when flow is out of domain  
     146               WHERE( rnf(:,:) < 0._wp )                                 ! example baltic model when flow is out of domain 
    147147                  rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    148148                  rnf_tsc(:,:,jp_sal) = sss_m(:,:) * rnf(:,:) * r1_rau0 
     
    158158         !                                             ! ---------------------------------------- ! 
    159159         IF( ln_rstart .AND.    &                               !* Restart: read in restart file 
    160             & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN  
     160            & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 
    161161            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields red in the restart file' 
    162162            CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b )     ! before runoff 
     
    165165         ELSE                                                   !* no restart: set from nit000 values 
    166166            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    167              rnf_b    (:,:  ) = rnf    (:,:  )   
    168              rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)    
     167             rnf_b    (:,:  ) = rnf    (:,:  ) 
     168             rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
    169169         ENDIF 
    170170      ENDIF 
     
    187187      !!---------------------------------------------------------------------- 
    188188      !!                  ***  ROUTINE sbc_rnf  *** 
    189       !!        
     189      !! 
    190190      !! ** Purpose :   update the horizontal divergence with the runoff inflow 
    191191      !! 
    192       !! ** Method  :    
    193       !!                CAUTION : rnf is positive (inflow) decreasing the  
     192      !! ** Method  : 
     193      !!                CAUTION : rnf is positive (inflow) decreasing the 
    194194      !!                          divergence and expressed in m/s 
    195195      !! 
     
    207207      r1_rau0 = 1._wp / rau0 
    208208      IF( ln_rnf_depth ) THEN      !==   runoff distributed over several levels   ==! 
    209          IF( lk_vvl ) THEN             ! variable volume case  
     209         IF( lk_vvl ) THEN             ! variable volume case 
    210210            DO jj = 1, jpj                   ! update the depth over which runoffs are distributed 
    211211               DO ji = 1, jpi 
    212                   h_rnf(ji,jj) = 0._wp  
     212                  h_rnf(ji,jj) = 0._wp 
    213213                  DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres 
    214                      h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk)   ! to the bottom of the relevant grid box  
    215                   END DO  
     214                     h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk)   ! to the bottom of the relevant grid box 
     215                  END DO 
    216216                  !                          ! apply the runoff input flow 
    217217                  DO jk = 1, nk_rnf(ji,jj) 
     
    249249      !! ** Action  : - read parameters 
    250250      !!---------------------------------------------------------------------- 
    251       CHARACTER(len=32) ::   rn_dep_file   ! runoff file name   
     251      CHARACTER(len=32) ::   rn_dep_file   ! runoff file name 
    252252      INTEGER           ::   ji, jj, jk    ! dummy loop indices 
    253253      INTEGER           ::   ierror, inum  ! temporary integer 
    254       !!  
     254      !! 
    255255      NAMELIST/namsbc_rnf/ cn_dir, ln_rnf_emp, ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   & 
    256          &                 sn_rnf, sn_cnf    , sn_s_rnf    , sn_t_rnf  , sn_dep_rnf,   &   
    257          &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact   
     256         &                 sn_rnf, sn_cnf    , sn_s_rnf    , sn_t_rnf  , sn_dep_rnf,   & 
     257         &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact 
    258258      !!---------------------------------------------------------------------- 
    259259 
     
    267267      sn_cnf = FLD_N( 'runoffs',     0     , 'sorunoff' ,  .FALSE.   , .true. ,   'yearly'  , ''       , ''         ) 
    268268 
    269       sn_s_rnf = FLD_N( 'runoffs',  24.  , 'rosaline' ,  .TRUE.    , .true. ,   'yearly'  , ''    , ''  )   
    270       sn_t_rnf = FLD_N( 'runoffs',  24.  , 'rotemper' ,  .TRUE.    , .true. ,   'yearly'  , ''    , ''  )   
    271       sn_dep_rnf = FLD_N( 'runoffs',   0.  , 'rodepth'  ,  .FALSE.   , .true. ,   'yearly'  , ''    , ''  )   
     269      sn_s_rnf = FLD_N( 'runoffs',  24.  , 'rosaline' ,  .TRUE.    , .true. ,   'yearly'  , ''    , ''  ) 
     270      sn_t_rnf = FLD_N( 'runoffs',  24.  , 'rotemper' ,  .TRUE.    , .true. ,   'yearly'  , ''    , ''  ) 
     271      sn_dep_rnf = FLD_N( 'runoffs',   0.  , 'rodepth'  ,  .FALSE.   , .true. ,   'yearly'  , ''    , ''  ) 
    272272      ! 
    273273      REWIND ( numnam )                         ! Read Namelist namsbc_rnf 
     
    284284         WRITE(numout,*) '      river mouth additional Kz                  rn_avt_rnf   = ', rn_avt_rnf 
    285285         WRITE(numout,*) '      depth of river mouth additional mixing     rn_hrnf      = ', rn_hrnf 
    286          WRITE(numout,*) '      multiplicative factor for runoff           rn_rfact     = ', rn_rfact     
     286         WRITE(numout,*) '      multiplicative factor for runoff           rn_rfact     = ', rn_rfact 
    287287      ENDIF 
    288288 
     
    297297         IF(lwp) WRITE(numout,*) '          runoffs directly provided in the precipitations' 
    298298         IF( ln_rnf_depth .OR. ln_rnf_tem .OR. ln_rnf_sal ) THEN 
    299            CALL ctl_warn( 'runoffs already included in precipitations, so runoff (T,S, depth) attributes will not be used' )  
     299           CALL ctl_warn( 'runoffs already included in precipitations, so runoff (T,S, depth) attributes will not be used' ) 
    300300           ln_rnf_depth = .FALSE.   ;   ln_rnf_tem = .FALSE.   ;   ln_rnf_sal = .FALSE. 
    301301         ENDIF 
     
    323323            ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   ) 
    324324            IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 
    325             CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' )   
     325            CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 
    326326         ENDIF 
    327327         ! 
     
    335335            ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   ) 
    336336            IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 
    337             CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' )   
    338          ENDIF 
    339          ! 
    340          IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file  
     337            CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 
     338         ENDIF 
     339         ! 
     340         IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file 
    341341            IF(lwp) WRITE(numout,*) 
    342342            IF(lwp) WRITE(numout,*) '          runoffs depth read in a file' 
    343             rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname )   
    344             CALL iom_open ( rn_dep_file, inum )                           ! open file   
    345             CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array   
    346             CALL iom_close( inum )                                        ! close file   
     343            rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
     344            CALL iom_open ( rn_dep_file, inum )                           ! open file 
     345            CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array 
     346            CALL iom_close( inum )                                        ! close file 
    347347            ! 
    348348            nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
    349             DO jj = 1, jpj   
    350                DO ji = 1, jpi   
    351                   IF( h_rnf(ji,jj) > 0._wp ) THEN   
    352                      jk = 2   
    353                      DO WHILE ( jk /= mbkt(ji,jj) .AND. fsdept(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 ;  END DO   
    354                      nk_rnf(ji,jj) = jk   
    355                   ELSEIF( h_rnf(ji,jj) == -1   ) THEN   ;  nk_rnf(ji,jj) = 1   
     349            DO jj = 1, jpj 
     350               DO ji = 1, jpi 
     351                  IF( h_rnf(ji,jj) > 0._wp ) THEN 
     352                     jk = 2 
     353                     DO WHILE ( jk /= mbkt(ji,jj) .AND. fsdept(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     354                     nk_rnf(ji,jj) = jk 
     355                  ELSEIF( h_rnf(ji,jj) == -1   ) THEN   ;  nk_rnf(ji,jj) = 1 
    356356                  ELSEIF( h_rnf(ji,jj) == -999 ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
    357                   ELSEIF( h_rnf(ji,jj) /=  0   ) THEN   
    358                      CALL ctl_stop( 'runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  )   
    359                      WRITE(999,*) 'ji, jj, rnf(ji,jj) :', ji, jj, rnf(ji,jj)   
    360                   ENDIF   
    361                END DO   
    362             END DO   
    363             DO jj = 1, jpj                                ! set the associated depth  
    364                DO ji = 1, jpi  
     357                  ELSEIF( h_rnf(ji,jj) /=  0   ) THEN 
     358                     CALL ctl_stop( 'runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
     359                     WRITE(999,*) 'ji, jj, rnf(ji,jj) :', ji, jj, rnf(ji,jj) 
     360                  ENDIF 
     361               END DO 
     362            END DO 
     363            DO jj = 1, jpj                                ! set the associated depth 
     364               DO ji = 1, jpi 
    365365                  h_rnf(ji,jj) = 0._wp 
    366                   DO jk = 1, nk_rnf(ji,jj)                         
    367                      h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk)   
     366                  DO jk = 1, nk_rnf(ji,jj) 
     367                     h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
    368368                  END DO 
    369369               END DO 
    370370            END DO 
    371          ELSE                                       ! runoffs applied at the surface  
    372             nk_rnf(:,:) = 1   
     371         ELSE                                       ! runoffs applied at the surface 
     372            nk_rnf(:,:) = 1 
    373373            h_rnf (:,:) = fse3t(:,:,1) 
    374          ENDIF   
    375          !  
     374         ENDIF 
     375         ! 
    376376      ENDIF 
    377377      ! 
     
    389389         ! 
    390390         IF ( ln_rnf_depth )   CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already',   & 
    391             &                                              'be spread through depth by ln_rnf_depth'               )  
     391            &                                              'be spread through depth by ln_rnf_depth'               ) 
    392392         ! 
    393393         nkrnf = 0                                  ! Number of level over which Kz increase 
     
    410410         IF(lwp) WRITE(numout,*) 
    411411         IF(lwp) WRITE(numout,*) '          No specific treatment at river mouths' 
    412          rnfmsk  (:,:) = 0._wp  
     412         rnfmsk  (:,:) = 0._wp 
    413413         rnfmsk_z(:)   = 0._wp 
    414414         nkrnf = 0 
     
    421421      !!---------------------------------------------------------------------- 
    422422      !!                  ***  ROUTINE rnf_mouth  *** 
    423       !!        
     423      !! 
    424424      !! ** Purpose :   define the river mouths mask 
    425425      !! 
    426426      !! ** Method  :   read the river mouth mask (=0/1) in the river runoff 
    427       !!                climatological file. Defined a given vertical structure.  
    428       !!                CAUTION, the vertical structure is hard coded on the  
     427      !!                climatological file. Defined a given vertical structure. 
     428      !!                CAUTION, the vertical structure is hard coded on the 
    429429      !!                first 5 levels. 
    430430      !!                This fields can be used to: 
    431       !!                 - set an upstream advection scheme   
     431      !!                 - set an upstream advection scheme 
    432432      !!                   (ln_rnf_mouth=T and ln_traadv_cen2=T) 
    433       !!                 - increase vertical on the top nn_krnf vertical levels  
     433      !!                 - increase vertical on the top nn_krnf vertical levels 
    434434      !!                   at river runoff input grid point (nn_krnf>=2, see step.F90) 
    435435      !!                 - set to zero SSS restoring flux at river mouth grid points 
     
    442442      CHARACTER(len=140) ::   cl_rnfile   ! runoff file name 
    443443      !!---------------------------------------------------------------------- 
    444       !  
     444      ! 
    445445      IF(lwp) WRITE(numout,*) 
    446446      IF(lwp) WRITE(numout,*) 'rnf_mouth : river mouth mask' 
     
    451451         IF( sn_cnf%cltype == 'monthly' )   WRITE(cl_rnfile, '(a,"m",i2)'  ) TRIM( cl_rnfile ), nmonth   ! add month 
    452452      ENDIF 
    453    
     453 
    454454      ! horizontal mask (read in NetCDF file) 
    455455      CALL iom_open ( cl_rnfile, inum )                           ! open file 
    456456      CALL iom_get  ( inum, jpdom_data, sn_cnf%clvar, rnfmsk )    ! read the river mouth array 
    457457      CALL iom_close( inum )                                      ! close file 
    458        
     458 
    459459      IF( nn_closea == 1 )   CALL clo_rnf( rnfmsk )               ! closed sea inflow set as ruver mouth 
    460460 
    461       rnfmsk_z(:)   = 0._wp                                       ! vertical structure  
     461      rnfmsk_z(:)   = 0._wp                                       ! vertical structure 
    462462      rnfmsk_z(1)   = 1.0 
    463463      rnfmsk_z(2)   = 1.0                                         ! ********** 
     
    465465      rnfmsk_z(4)   = 0.25                                        ! ********** 
    466466      rnfmsk_z(5)   = 0.125 
    467       !          
     467      ! 
    468468   END SUBROUTINE rnf_mouth 
    469     
     469 
    470470   !!====================================================================== 
    471471END MODULE sbcrnf 
  • trunk/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r3294 r3598  
    88   !!   NEMO     1.0  ! 2002-08  (G. Madec)  free form + modules 
    99   !!             -   ! 2004-01  (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl 
    10    !!            3.3  ! 2009-11  (G. Madec)  merge trabbl and trabbl_adv + style + optimization  
    11    !!             -   ! 2010-04  (G. Madec)  Campin & Goosse advective bbl  
     10   !!            3.3  ! 2009-11  (G. Madec)  merge trabbl and trabbl_adv + style + optimization 
     11   !!             -   ! 2010-04  (G. Madec)  Campin & Goosse advective bbl 
    1212   !!             -   ! 2010-06  (C. Ethe, G. Madec)  merge TRA-TRC 
    1313   !!             -   ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
     
    3030   USE trdmod_oce     ! trends: ocean variables 
    3131   USE trdtra         ! trends: active tracers 
    32    USE iom            ! IOM server                
     32   USE iom            ! IOM server 
    3333   USE in_out_manager ! I/O manager 
    3434   USE lbclnk         ! ocean lateral boundary conditions 
     
    4949   LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl = .TRUE.    !: bottom boundary layer flag 
    5050 
    51    !                                           !!* Namelist nambbl *  
     51   !                                           !!* Namelist nambbl * 
    5252   INTEGER , PUBLIC ::   nn_bbl_ldf = 0         !: =1   : diffusive bbl or not (=0) 
    5353   INTEGER , PUBLIC ::   nn_bbl_adv = 0         !: =1/2 : advective bbl or not (=0) 
     
    5858 
    5959   LOGICAL , PUBLIC ::   l_bbl                  !: flag to compute bbl diffu. flux coef and transport 
    60     
     60 
    6161   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   utr_bbl  , vtr_bbl   ! u- (v-) transport in the bottom boundary layer 
    6262   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   ahu_bbl  , ahv_bbl   ! masked diffusive bbl coeff. at u & v-pts 
    6363 
    64    INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbku_d   , mbkv_d      ! vertical index of the "lower" bottom ocean U/V-level 
    65    INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mgrhu    , mgrhv       ! = +/-1, sign of grad(H) in u-(v-)direction 
    66    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ahu_bbl_0, ahv_bbl_0   ! diffusive bbl flux coefficients at u and v-points 
    67    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3u_bbl_0, e3v_bbl_0   ! thichness of the bbl (e3) at u and v-points 
    68    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_e1e2t               ! inverse of the cell surface at t-point      [1/m2] 
     64   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   mbku_d   , mbkv_d      ! vertical index of the "lower" bottom ocean U/V-level (PUBLIC for TAM) 
     65   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   mgrhu    , mgrhv       ! = +/-1, sign of grad(H) in u-(v-)direction (PUBLIC for TAM) 
     66   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   ahu_bbl_0, ahv_bbl_0   ! diffusive bbl flux coefficients at u and v-points 
     67   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   e3u_bbl_0, e3v_bbl_0   ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) 
     68   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   r1_e1e2t               ! inverse of the cell surface at t-point      [1/m2] (PUBLIC for TAM) 
    6969 
    7070   !! * Substitutions 
     
    9595      !!---------------------------------------------------------------------- 
    9696      !!                  ***  ROUTINE bbl  *** 
    97       !!                    
    98       !! ** Purpose :   Compute the before tracer (t & s) trend associated  
     97      !! 
     98      !! ** Purpose :   Compute the before tracer (t & s) trend associated 
    9999      !!              with the bottom boundary layer and add it to the general 
    100100      !!              trend of tracer equations. 
     
    103103      !!              diffusive and/or advective contribution to the tracer trend 
    104104      !!              is added to the general tracer trend 
    105       !!----------------------------------------------------------------------   
    106       INTEGER, INTENT( in ) ::   kt   ! ocean time-step  
     105      !!---------------------------------------------------------------------- 
     106      INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
    107107      !! 
    108108      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
     
    112112      ! 
    113113      IF( l_trdtra )   THEN                        !* Save ta and sa trends 
    114          CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds )  
    115          ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
     114         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
     115         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    116116         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    117117      ENDIF 
    118118 
    119119      IF( l_bbl )  CALL bbl( kt, nit000, 'TRA' )   !* bbl coef. and transport (only if not already done in trcbbl) 
    120   
     120 
    121121      IF( nn_bbl_ldf == 1 ) THEN                   !* Diffusive bbl 
    122122         ! 
     
    125125         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    126126         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    127          ! lateral boundary conditions ; just need for outputs                           
     127         ! lateral boundary conditions ; just need for outputs 
    128128         CALL lbc_lnk( ahu_bbl, 'U', 1. )     ;     CALL lbc_lnk( ahv_bbl, 'V', 1. ) 
    129          CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef      
     129         CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef 
    130130         CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
    131131         ! 
     
    138138         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
    139139         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    140          ! lateral boundary conditions ; just need for outputs                           
     140         ! lateral boundary conditions ; just need for outputs 
    141141         CALL lbc_lnk( utr_bbl, 'U', 1. )     ;   CALL lbc_lnk( vtr_bbl, 'V', 1. ) 
    142          CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport      
     142         CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
    143143         CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
    144144         ! 
     
    150150         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbl, ztrdt ) 
    151151         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbl, ztrds ) 
    152          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )  
     152         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    153153      ENDIF 
    154154      ! 
     
    161161      !!---------------------------------------------------------------------- 
    162162      !!                  ***  ROUTINE tra_bbl_dif  *** 
    163       !!                    
     163      !! 
    164164      !! ** Purpose :   Computes the bottom boundary horizontal and vertical 
    165       !!                advection terms.  
    166       !! 
    167       !! ** Method  :    
     165      !!                advection terms. 
     166      !! 
     167      !! ** Method  : 
    168168      !!        * diffusive bbl (nn_bbl_ldf=1) : 
    169169      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
     
    179179      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
    180180      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
    181       !!----------------------------------------------------------------------   
     181      !!---------------------------------------------------------------------- 
    182182      ! 
    183183      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    184184      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    185       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     185      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend 
    186186      ! 
    187187      INTEGER  ::   ji, jj, jn   ! dummy loop indices 
     
    202202#else 
    203203         DO jj = 1, jpj 
    204             DO ji = 1, jpi  
     204            DO ji = 1, jpi 
    205205#endif 
    206206               ik = mbkt(ji,jj)                        ! bottom T-level index 
     
    233233      ! 
    234234   END SUBROUTINE tra_bbl_dif 
    235     
     235 
    236236 
    237237   SUBROUTINE tra_bbl_adv( ptb, pta, kjpt ) 
     
    239239      !!                  ***  ROUTINE trc_bbl  *** 
    240240      !! 
    241       !! ** Purpose :   Compute the before passive tracer trend associated  
     241      !! ** Purpose :   Compute the before passive tracer trend associated 
    242242      !!     with the bottom boundary layer and add it to the general trend 
    243243      !!     of tracer equations. 
    244244      !! ** Method  :   advective bbl (nn_bbl_adv = 1 or 2) : 
    245245      !!      nn_bbl_adv = 1   use of the ocean near bottom velocity as bbl velocity 
    246       !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation i.e.  
    247       !!                       transport proportional to the along-slope density gradient                    
     246      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation i.e. 
     247      !!                       transport proportional to the along-slope density gradient 
    248248      !! 
    249249      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
    250250      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
    251       !!----------------------------------------------------------------------   
     251      !!---------------------------------------------------------------------- 
    252252      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    253253      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    254       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     254      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend 
    255255      ! 
    256256      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices 
     
    264264      !                                                          ! =========== 
    265265      DO jn = 1, kjpt                                            ! tracer loop 
    266          !                                                       ! ===========          
     266         !                                                       ! =========== 
    267267# if defined key_vectopt_loop 
    268268         DO jj = 1, 1 
     
    282282                  ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 
    283283                  pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 
    284                   !                    
     284                  ! 
    285285                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
    286286                     zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,jk) 
     
    288288                     pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 
    289289                  END DO 
    290                   !  
     290                  ! 
    291291                  zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,ikud) 
    292292                  ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 
     
    299299                  ikvd = mbkv_d(ji,jj)                   ;   ikvs = mbkv(ji,jj) 
    300300                  zv_bbl = ABS( vtr_bbl(ji,jj) ) 
    301                   !  
     301                  ! 
    302302                  ! up  -slope T-point (shelf bottom point) 
    303303                  zbtr = r1_e1e2t(ji,ijs) / fse3t(ji,ijs,ikvs) 
    304304                  ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 
    305305                  pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 
    306                   !                    
     306                  ! 
    307307                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
    308308                     zbtr = r1_e1e2t(ji,ijd) / fse3t(ji,ijd,jk) 
     
    330330      !!---------------------------------------------------------------------- 
    331331      !!                  ***  ROUTINE bbl  *** 
    332       !!                    
     332      !! 
    333333      !! ** Purpose :   Computes the bottom boundary horizontal and vertical 
    334       !!                advection terms.  
    335       !! 
    336       !! ** Method  :    
     334      !!                advection terms. 
     335      !! 
     336      !! ** Method  : 
    337337      !!        * diffusive bbl (nn_bbl_ldf=1) : 
    338338      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
     
    353353      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
    354354      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
    355       !!----------------------------------------------------------------------   
     355      !!---------------------------------------------------------------------- 
    356356      ! 
    357357      INTEGER         , INTENT(in   ) ::   kt       ! ocean time-step index 
     
    399399                                          - 0.121555e-07 ) * pfh 
    400400      !!---------------------------------------------------------------------- 
    401        
     401 
    402402      ! 
    403403      IF( nn_timing == 1 )  CALL timing_start( 'bbl') 
    404404      ! 
    405       CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )  
    406       ! 
    407       
     405      CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep ) 
     406      ! 
     407 
    408408      IF( kt == kit000 )  THEN 
    409409         IF(lwp)  WRITE(numout,*) 
     
    411411         IF(lwp)  WRITE(numout,*) '~~~~~~~~~~' 
    412412      ENDIF 
    413        
     413 
    414414      !                                        !* bottom temperature, salinity, velocity and depth 
    415415#if defined key_vectopt_loop 
     
    426426            ! 
    427427            zub(ji,jj) = un(ji,jj,mbku(ji,jj))      ! bottom velocity 
    428             zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj))  
     428            zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 
    429429         END DO 
    430430      END DO 
    431        
     431 
    432432      !                                   !-------------------! 
    433433      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
    434434         !                                !-------------------! 
    435435         DO jj = 1, jpjm1                      ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
    436             DO ji = 1, jpim1               
    437                !                                                ! i-direction  
     436            DO ji = 1, jpim1 
     437               !                                                ! i-direction 
    438438               zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )  ! T, S anomalie, and depth 
    439439               zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
     
    442442               zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    & 
    443443                  &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
    444                !                                                      
     444               ! 
    445445               zsign          = SIGN(  0.5, - zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
    446446               ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)                  ! masked diffusive flux coeff. 
    447447               ! 
    448                !                                                ! j-direction  
     448               !                                                ! j-direction 
    449449               zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) )                ! T, S anomalie, and depth 
    450450               zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 
     
    453453               zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    & 
    454454                  &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
    455                !                                                     
     455               ! 
    456456               zsign          = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
    457457               ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
     
    475475                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    476476                  !                                                           ! masked bbl i-gradient of density 
    477                   zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    &   
     477                  zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    & 
    478478                     &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
    479                   !                                                          
     479                  ! 
    480480                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )    ! sign of i-gradient * i-slope 
    481481                  zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )    ! sign of u * i-slope 
     
    489489                  zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
    490490                  !                                                           ! masked bbl j-gradient of density 
    491                   zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    &   
     491                  zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    & 
    492492                     &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
    493493                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )    ! sign of j-gradient * j-slope 
     
    513513                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    514514                  zgdrho =    fsbeta( zt, zs, zh )                                    & 
    515                      &   * (  fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) )    &   
     515                     &   * (  fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) )    & 
    516516                     &                             - ( zsb(iid,jj) - zsb(iis,jj) )  ) * umask(ji,jj,1) 
    517517                  zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
     
    530530                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 
    531531                  zgdrho =    fsbeta( zt, zs, zh )                                    & 
    532                      &   * (  fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) )    &   
     532                     &   * (  fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) )    & 
    533533                     &                             - ( zsb(ji,ijd) - zsb(ji,ijs) )  ) * vmask(ji,jj,1) 
    534534                  zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
     
    542542      ENDIF 
    543543      ! 
    544       CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )  
     544      CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep ) 
    545545      ! 
    546546      IF( nn_timing == 1 )  CALL timing_stop( 'bbl') 
     
    567567      IF( nn_timing == 1 )  CALL timing_start( 'tra_bbl_init') 
    568568      ! 
    569       CALL wrk_alloc( jpi, jpj, zmbk )  
     569      CALL wrk_alloc( jpi, jpj, zmbk ) 
    570570      ! 
    571571 
     
    588588      !                              ! allocate trabbl arrays 
    589589      IF( tra_bbl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) 
    590       
     590 
    591591      IF( nn_bbl_adv == 1 )    WRITE(numout,*) '       * Advective BBL using upper velocity' 
    592592      IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)' 
     
    597597      !                             !* inverse of surface of T-cells 
    598598      r1_e1e2t(:,:) = 1._wp / ( e1t(:,:) * e2t(:,:) ) 
    599        
     599 
    600600      !                             !* vertical index of  "deep" bottom u- and v-points 
    601601      DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv) 
     
    605605         END DO 
    606606      END DO 
    607       ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk  
     607      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    608608      zmbk(:,:) = REAL( mbku_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    609609      zmbk(:,:) = REAL( mbkv_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     
    611611                                        !* sign of grad(H) at u- and v-points 
    612612      mgrhu(jpi,:) = 0.    ;    mgrhu(:,jpj) = 0.   ;    mgrhv(jpi,:) = 0.    ;    mgrhv(:,jpj) = 0. 
    613       DO jj = 1, jpjm1                 
     613      DO jj = 1, jpjm1 
    614614         DO ji = 1, jpim1 
    615615            mgrhu(ji,jj) = INT(  SIGN( 1.e0, fsdept_0(ji+1,jj,mbkt(ji+1,jj)) - fsdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     
    618618      END DO 
    619619 
    620       DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point  
     620      DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point 
    621621         DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
    622             e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj  )), fse3u_0(ji,jj,mbkt(ji,jj)) )   
    623             e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji  ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) )   
    624          END DO  
     622            e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj  )), fse3u_0(ji,jj,mbkt(ji,jj)) ) 
     623            e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji  ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) ) 
     624         END DO 
    625625      END DO 
    626626      CALL lbc_lnk( e3u_bbl_0, 'U', 1. )   ;   CALL lbc_lnk( e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions 
    627627 
    628       !                             !* masked diffusive flux coefficients  
     628      !                             !* masked diffusive flux coefficients 
    629629      ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:)  * umask(:,:,1) 
    630630      ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:)  * vmask(:,:,1) 
     
    636636         CASE ( 2 )                          ! ORCA_R2 
    637637            ij0 = 102   ;   ij1 = 102              ! Gibraltar enhancement of BBL 
    638             ii0 = 139   ;   ii1 = 140   
     638            ii0 = 139   ;   ii1 = 140 
    639639            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    640640            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     
    647647         CASE ( 4 )                          ! ORCA_R4 
    648648            ij0 =  52   ;   ij1 =  52              ! Gibraltar enhancement of BBL 
    649             ii0 =  70   ;   ii1 =  71   
     649            ii0 =  70   ;   ii1 =  71 
    650650            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    651651            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     
    654654      ENDIF 
    655655      ! 
    656       CALL wrk_dealloc( jpi, jpj, zmbk )  
     656      CALL wrk_dealloc( jpi, jpj, zmbk ) 
    657657      ! 
    658658      IF( nn_timing == 1 )  CALL timing_stop( 'tra_bbl_init') 
  • trunk/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r3294 r3598  
    1616   !!---------------------------------------------------------------------- 
    1717   USE oce             ! ocean dynamics and tracers variables 
    18    USE dom_oce         ! ocean space and time domain variables  
     18   USE dom_oce         ! ocean space and time domain variables 
    1919   USE zdf_oce         ! ocean vertical physics variables 
    2020   USE in_out_manager  ! I/O manager 
     
    3131 
    3232   !                                    !!* Namelist nambfr: bottom friction namelist * 
    33    INTEGER  ::   nn_bfr    = 0           ! = 0/1/2/3 type of bottom friction  
    34    REAL(wp) ::   rn_bfri1  = 4.0e-4_wp   ! bottom drag coefficient (linear case)  
    35    REAL(wp) ::   rn_bfri2  = 1.0e-3_wp   ! bottom drag coefficient (non linear case) 
    36    REAL(wp) ::   rn_bfeb2  = 2.5e-3_wp   ! background bottom turbulent kinetic energy  [m2/s2] 
    37    REAL(wp) ::   rn_bfrien = 30._wp      ! local factor to enhance coefficient bfri 
    38    LOGICAL  ::   ln_bfr2d  = .false.     ! logical switch for 2D enhancement 
    39    LOGICAL , PUBLIC                            ::  ln_bfrimp = .false.  ! logical switch for implicit bottom friction 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  bfrcoef2d            ! 2D bottom drag coefficient 
     33   INTEGER , PUBLIC ::   nn_bfr    = 0           ! = 0/1/2/3 type of bottom friction  (PUBLIC for TAM) 
     34   REAL(wp), PUBLIC ::   rn_bfri1  = 4.0e-4_wp   ! bottom drag coefficient (linear case)  (PUBLIC for TAM) 
     35   REAL(wp), PUBLIC ::   rn_bfri2  = 1.0e-3_wp   ! bottom drag coefficient (non linear case) (PUBLIC for TAM) 
     36   REAL(wp), PUBLIC ::   rn_bfeb2  = 2.5e-3_wp   ! background bottom turbulent kinetic energy  [m2/s2] (PUBLIC for TAM) 
     37   REAL(wp), PUBLIC ::   rn_bfrien = 30._wp      ! local factor to enhance coefficient bfri (PUBLIC for TAM) 
     38   LOGICAL , PUBLIC ::   ln_bfr2d  = .false.     ! logical switch for 2D enhancement (PUBLIC for TAM) 
     39   LOGICAL , PUBLIC                                    ::  ln_bfrimp = .false.  ! logical switch for implicit bottom friction 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::  bfrcoef2d            ! 2D bottom drag coefficient (PUBLIC for TAM) 
    4141 
    4242   !! * Substitutions 
     
    6464      !!---------------------------------------------------------------------- 
    6565      !!                   ***  ROUTINE zdf_bfr  *** 
    66       !!                  
     66      !! 
    6767      !! ** Purpose :   compute the bottom friction coefficient. 
    6868      !! 
    69       !! ** Method  :   Calculate and store part of the momentum trend due     
    70       !!              to bottom friction following the chosen friction type  
     69      !! ** Method  :   Calculate and store part of the momentum trend due 
     70      !!              to bottom friction following the chosen friction type 
    7171      !!              (free-slip, linear, or quadratic). The component 
    7272      !!              calculated here is multiplied by the bottom velocity in 
     
    102102            DO ji = 2, jpim1 
    103103# endif 
    104                ikbu = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
     104               ikbu = mbku(ji,jj)         ! ocean bottom level at u- and v-points 
    105105               ikbv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    106106               ! 
     
    113113               zecv = SQRT(  vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_bfeb2  ) 
    114114               ! 
    115                bfrua(ji,jj) = - 0.5_wp * ( bfrcoef2d(ji,jj) + bfrcoef2d(ji+1,jj  ) ) * zecu  
     115               bfrua(ji,jj) = - 0.5_wp * ( bfrcoef2d(ji,jj) + bfrcoef2d(ji+1,jj  ) ) * zecu 
    116116               bfrva(ji,jj) = - 0.5_wp * ( bfrcoef2d(ji,jj) + bfrcoef2d(ji  ,jj+1) ) * zecv 
    117117            END DO 
     
    133133      !!---------------------------------------------------------------------- 
    134134      !!                  ***  ROUTINE zdf_bfr_init  *** 
    135       !!                     
     135      !! 
    136136      !! ** Purpose :   Initialization of the bottom friction 
    137137      !! 
     
    193193         bfrcoef2d(:,:) = rn_bfri1  ! initialize bfrcoef2d to the namelist variable 
    194194         ! 
    195          IF(ln_bfr2d) THEN  
     195         IF(ln_bfr2d) THEN 
    196196            ! bfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
    197197            CALL iom_open('bfr_coef.nc',inum) 
     
    213213         bfrcoef2d(:,:) = rn_bfri2  ! initialize bfrcoef2d to the namelist variable 
    214214         ! 
    215          IF(ln_bfr2d) THEN  
     215         IF(ln_bfr2d) THEN 
    216216            ! bfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
    217217            CALL iom_open('bfr_coef.nc',inum) 
Note: See TracChangeset for help on using the changeset viewer.