New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 13056 for utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_dom_update.F90 – NEMO

Ignore:
Timestamp:
2020-06-07T18:26:09+02:00 (4 years ago)
Author:
rblod
Message:

ticket #2129 : cleaning domcfg

File:
1 moved

Legend:

Unmodified
Added
Removed

  • utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_dom_update.F90

    r13055 r13056  
     1MODULE agrif_dom_update 
     2 
     3   USE dom_oce 
     4   USE domzgr 
     5   USE agrif_parameters 
     6   USE agrif_profiles 
     7    
     8   IMPLICIT none 
     9   PRIVATE 
     10 
     11   PUBLIC agrif_update_all 
     12 
     13CONTAINS  
     14 
    115#if defined key_agrif 
    2 subroutine agrif_update_all 
    3 USE agrif_parameters 
    4 USE agrif_profiles 
    5 external update_bottom_level, update_e3t, update_e3u, update_e3v 
    616 
    7 if (agrif_root()) return 
     17   SUBROUTINE agrif_update_all 
     18      !!---------------------------------------------------------------------- 
     19      !!                  ***  ROUTINE agrif_update_all  *** 
     20      !!----------------------------------------------------------------------   
     21      ! 
     22      IF( Agrif_Root() ) return 
    823 
    9 call agrif_update_variable(bottom_level_id,locupdate=(/npt_copy,0/),procname = update_bottom_level) 
     24      CALL agrif_update_variable(bottom_level_id,locupdate=(/npt_copy,0/),procname = update_bottom_level) 
     25      ! 
     26      Agrif_UseSpecialValueInUpdate = .TRUE. 
     27      Agrif_SpecialValueFineGrid    = 0._wp          
     28      CALL agrif_update_variable(e3t_id,procname = update_e3t) 
     29      Agrif_UseSpecialValueInUpdate = .FALSE. 
     30      !     
     31   END SUBROUTINE agrif_update_all 
    1032 
    11  
    12       Agrif_UseSpecialValueInUpdate = .TRUE. 
    13       Agrif_SpecialValueFineGrid    = 0._wp 
    14        
    15 call agrif_update_variable(e3t_id,procname = update_e3t) 
    16       Agrif_UseSpecialValueInUpdate = .FALSE. 
    17  
    18 !call agrif_update_variable(e3u_id,procname = update_e3u) 
    19 !call agrif_update_variable(e3v_id,procname = update_e3v) 
    20        
    21 end subroutine agrif_update_all 
    22  
    23     SUBROUTINE update_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir) 
    24     USE dom_oce 
    25     USE domzgr 
     33   SUBROUTINE update_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir) 
    2634      !!---------------------------------------------------------------------- 
    2735      !!                  ***  ROUTINE interpsshn  *** 
    … …  
    3139      LOGICAL                         , INTENT(in   ) ::   before 
    3240      INTEGER                         , INTENT(in   ) ::   nb , ndir 
    33       LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
    3441      ! 
    3542      !!----------------------------------------------------------------------  
    36       INTEGER :: ji,jj      
    3743      ! 
    38          western_side  = (nb == 1).AND.(ndir == 1) 
    39          eastern_side  = (nb == 1).AND.(ndir == 2) 
    40          southern_side = (nb == 2).AND.(ndir == 1) 
    41          northern_side = (nb == 2).AND.(ndir == 2) 
    42  
    4344      IF( before) THEN 
    4445         ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2) 
    … …  
    4647         mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2)) 
    4748          
    48          WHERE (mbkt(i1:i2,j1:j2)==0) 
    49            ssmask(i1:i2,j1:j2) = 0. 
     49         WHERE ( mbkt(i1:i2,j1:j2) .EQ. 0 ) 
     50            ssmask(i1:i2,j1:j2) = 0. 
    5051         ELSEWHERE 
    51            ssmask(i1:i2,j1:j2) = 1. 
    52          END WHERE 
    53             
     52            ssmask(i1:i2,j1:j2) = 1. 
     53         END WHERE            
    5454      ENDIF 
    5555      ! 
    … …  
    5757    
    5858   SUBROUTINE update_e3t( tabres, i1, i2, j1, j2, k1, k2,  before ) 
    59    USE dom_oce 
    60    implicit none 
    6159      !!--------------------------------------------- 
    62       !!           *** update_e3t updateT *** 
     60      !!           *** update_e3t *** 
    6361      !!--------------------------------------------- 
    6462      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    … …  
    7068      ! 
    7169      IF (before) THEN 
    72             DO jk=k1,k2 
    73                DO jj=j1,j2 
    74                   DO ji=i1,i2 
    75                    if (mbkt(ji,jj) <= jk) then 
    76                      tabres(ji,jj,jk) = e3t_0(ji,jj,jk) 
    77                    else 
    78                      tabres(ji,jj,jk) = 0. 
     70         DO jk=k1,k2 
     71            DO jj=j1,j2 
     72               DO ji=i1,i2 
     73                   IF( mbkt(ji,jj) .LE. jk ) THEN 
     74                      tabres(ji,jj,jk) = e3t_0(ji,jj,jk) 
     75                   ELSE 
     76                      tabres(ji,jj,jk) = 0. 
    7977                   endif 
    80                   END DO 
    8178               END DO 
    8279            END DO 
    83       ELSE 
    84             DO jk=k1,k2 
    85                DO jj=j1,j2 
    86                   DO ji=i1,i2 
    87                    if (mbkt(ji,jj) <= jk) then 
    88                      e3t_0(ji,jj,jk) = MAX(tabres(ji,jj,jk),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 
    89                    else 
    90                      e3t_0(ji,jj,jk) = e3t_1d(jk) 
    91                    endif 
    92                   END DO 
    93                END DO 
    94             END DO 
    95          ! 
    96       ENDIF 
    97       !  
    98    END SUBROUTINE update_e3t 
    99     
    100    SUBROUTINE update_e3u( tabres, i1, i2, j1, j2, k1, k2, before ) 
    101    USE dom_oce 
    102    implicit none 
    103       !!--------------------------------------------- 
    104       !!           *** ROUTINE update_e3u *** 
    105       !!--------------------------------------------- 
    106       INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2 
    107       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    108       LOGICAL                                     , INTENT(in   ) :: before 
    109       ! 
    110       INTEGER  :: ji, jj, jk 
    111       REAL :: zrhoy 
    112       !!--------------------------------------------- 
    113       !  
    114       IF( before ) THEN 
    115          zrhoy = Agrif_Rhoy() 
    116          DO jk = k1, k2 
    117           do jj=j1,j2 
    118           do ji=i1,i2 
    119            if (min(mbkt(ji,jj),mbkt(ji+1,jj))<=jk) then 
    120             tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat) 
    121            else 
    122             tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * e3u_0(ji,jj,jk) 
    123            endif 
    124           enddo 
    125           enddo 
    12680         END DO 
    12781      ELSE 
    … …  
    12983            DO jj=j1,j2 
    13084               DO ji=i1,i2 
    131                  if (min(mbkt(ji,jj),mbkt(ji+1,jj))<=jk) then 
    132                    e3u_0(ji,jj,jk)=MAX(tabres(ji,jj,jk) / e2u(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 
    133                  else 
    134                    e3u_0(ji,jj,jk) = e3t_1d(jk) 
    135                  endif 
     85                   IF( mbkt(ji,jj) .LE.jk ) THEN 
     86                      e3t_0(ji,jj,jk) = MAX(tabres(ji,jj,jk),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 
     87                   ELSE 
     88                      e3t_0(ji,jj,jk) = e3t_1d(jk) 
     89                   ENDIF 
    13690               END DO 
    13791            END DO 
    … …  
    14094      ENDIF 
    14195      !  
    142    END SUBROUTINE update_e3u 
    143     
    144    SUBROUTINE update_e3v( tabres, i1, i2, j1, j2, k1, k2, before ) 
    145    USE dom_oce 
    146    implicit none 
    147       !!--------------------------------------------- 
    148       !!           *** ROUTINE update_e3v *** 
    149       !!--------------------------------------------- 
    150       INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2 
    151       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    152       LOGICAL                                     , INTENT(in   ) :: before 
    153       ! 
    154       INTEGER  :: ji, jj, jk 
    155       REAL :: zrhox 
    156       !!--------------------------------------------- 
    157       !  
    158       IF( before ) THEN 
    159          zrhox = Agrif_Rhox() 
    160          DO jk = k1, k2 
    161           do jj=j1,j2 
    162           do ji=i1,i2 
    163            if (min(mbkt(ji,jj),mbkt(ji,jj+1))<=jk) then 
    164             tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat) 
    165            else 
    166             tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_0(ji,jj,jk) 
    167            endif 
    168           enddo 
    169           enddo 
    170          END DO 
    171       ELSE 
    172          DO jk=k1,k2 
    173             DO jj=j1,j2 
    174                DO ji=i1,i2 
    175                  if (min(mbkt(ji,jj),mbkt(ji,jj+1))<=jk) then 
    176                    e3v_0(ji,jj,jk)=MAX(tabres(ji,jj,jk) / e1v(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 
    177                  else 
    178                    e3v_0(ji,jj,jk) = e3t_1d(jk) 
    179                  endif 
    180                END DO 
    181             END DO 
    182          END DO 
    183          ! 
    184       ENDIF 
    185       !  
    186    END SUBROUTINE update_e3v 
    187     
     96   END SUBROUTINE update_e3t 
     97       
    18898#else 
    189 subroutine agrif_update_all_empty 
    190 end subroutine agrif_update_all_empty 
     99   SUBROUTINE agrif_update_all 
     100   END SUBROUTINE agrif_update_all 
    191101#endif 
     102 
     103END MODULE agrif_dom_update 
Note: See TracChangeset for help on using the changeset viewer.