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 13463 for NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/NST/agrif_top_interp.F90 – NEMO

Ignore:
Timestamp:
2020-09-14T17:40:34+02:00 (4 years ago)
Author:
andmirek
Message:

Ticket #2195:update to trunk 13461

Location:
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11351_fldread_with_XIOS

    • Property svn:externals
      •  

        old new  
        33^/utils/build/mk@HEAD         mk 
        44^/utils/tools@HEAD            tools 
        5 ^/vendors/AGRIF/dev@HEAD      ext/AGRIF 
         5^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS      ext/AGRIF 
        66^/vendors/FCM@HEAD            ext/FCM 
        77^/vendors/IOIPSL@HEAD         ext/IOIPSL 
         8 
         9# SETTE 
         10^/utils/CI/sette@13382        sette 
  • NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/NST/agrif_top_interp.F90

    r10068 r13463  
    1818   USE par_trc 
    1919   USE trc 
     20   USE vremap 
    2021   ! 
    2122   USE lib_mpp     ! MPP library 
     
    4849   END SUBROUTINE Agrif_trc 
    4950 
    50    SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 
     51   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    5152      !!---------------------------------------------------------------------- 
    5253      !!                  *** ROUTINE interptrn *** 
     
    5556      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2 
    5657      LOGICAL                                     , INTENT(in   ) ::   before 
    57       INTEGER                                     , INTENT(in   ) ::   nb , ndir 
    5858      ! 
    59       INTEGER  ::   ji, jj, jk, jn, iref, jref, ibdy, jbdy   ! dummy loop indices 
     59      INTEGER  ::   ji, jj, jk, jn, ibdy, jbdy   ! dummy loop indices 
    6060      INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out 
    6161      REAL(wp) ::   zrho, z1, z2, z3, z4, z5, z6, z7 
    62       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     62 
    6363      ! vertical interpolation: 
    64       REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child 
    65       REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 
     64      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: ptab_child 
     65      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin 
    6666      REAL(wp), DIMENSION(k1:k2) :: h_in 
    6767      REAL(wp), DIMENSION(1:jpk) :: h_out 
    68       REAL(wp) :: h_diff 
     68      !!---------------------------------------------------------------------- 
    6969 
    7070      IF( before ) THEN          
     
    7373               DO jj=j1,j2 
    7474                 DO ji=i1,i2 
    75                        ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     75                       ptab(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) 
    7676                 END DO 
    7777              END DO 
     
    8383           DO jj=j1,j2 
    8484              DO ji=i1,i2 
    85                  ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)  
     85                 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)  
    8686              END DO 
    8787           END DO 
     
    9090      ELSE  
    9191 
    92          western_side  = (nb == 1).AND.(ndir == 1)   ;   eastern_side  = (nb == 1).AND.(ndir == 2) 
    93          southern_side = (nb == 2).AND.(ndir == 1)   ;   northern_side = (nb == 2).AND.(ndir == 2) 
    94  
    95 # if defined key_vertical               
     92# if defined key_vertical 
    9693         DO jj=j1,j2 
    9794            DO ji=i1,i2 
    98                iref = ji 
    99                jref = jj 
    100                if(western_side) iref=MAX(2,ji) 
    101                if(eastern_side) iref=MIN(nlci-1,ji) 
    102                if(southern_side) jref=MAX(2,jj) 
    103                if(northern_side) jref=MIN(nlcj-1,jj) 
     95               ptab_child(ji,jj,:) = 0._wp 
    10496               N_in = 0 
    10597               DO jk=k1,k2 !k2 = jpk of parent grid 
     
    111103               N_out = 0 
    112104               DO jk=1,jpk ! jpk of child grid 
    113                   IF (tmask(iref,jref,jk) == 0) EXIT  
     105                  IF (tmask(ji,jj,jk) == 0) EXIT  
    114106                  N_out = N_out + 1 
    115                   h_out(jk) = e3t_n(iref,jref,jk) 
     107                  h_out(jk) = e3t(ji,jj,jk,Krhs_a) 
    116108               ENDDO 
    117109               IF (N_in > 0) THEN 
    118                   DO jn=1,jptra 
    119                      call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 
    120                   ENDDO 
     110                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,ptab_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 
    121111               ENDIF 
    122112            ENDDO 
     
    127117         ! 
    128118         DO jn=1, jptra 
    129             tra(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)  
     119            tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)  
    130120         END DO 
    131  
    132          IF ( .NOT.lk_agrif_clp ) THEN  
    133             ! 
    134             imin = i1 ; imax = i2 
    135             jmin = j1 ; jmax = j2 
    136             !  
    137             ! Remove CORNERS 
    138             IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells 
    139             IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1 
    140             IF((nbondi == -1).OR.(nbondi == 2)) imin = 2 + nbghostcells 
    141             IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1       
    142             ! 
    143             IF( eastern_side ) THEN 
    144                zrho = Agrif_Rhox() 
    145                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    146                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    147                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    148                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    149                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    150                ! 
    151                ibdy = nlci-nbghostcells 
    152                DO jn = 1, jptra 
    153                   tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    154                   DO jk = 1, jpkm1 
    155                      DO jj = jmin,jmax 
    156                         IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN 
    157                            tra(ibdy,jj,jk,jn) = tra(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    158                         ELSE 
    159                            tra(ibdy,jj,jk,jn)=(z4*tra(ibdy+1,jj,jk,jn)+z3*tra(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk) 
    160                            IF( un(ibdy-1,jj,jk) > 0._wp ) THEN 
    161                               tra(ibdy,jj,jk,jn)=( z6*tra(ibdy-1,jj,jk,jn)+z5*tra(ibdy+1,jj,jk,jn) &  
    162                                                  + z7*tra(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    163                            ENDIF 
    164                         ENDIF 
    165                      END DO 
    166                   END DO 
    167                   ! Restore ghost points: 
    168                   tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy+1,jmin:jmax,1:jpkm1) 
    169                END DO 
    170             ENDIF 
    171             !  
    172             IF( northern_side ) THEN 
    173                zrho = Agrif_Rhoy() 
    174                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    175                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    176                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    177                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    178                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    179                ! 
    180                jbdy = nlcj-nbghostcells          
    181                DO jn = 1, jptra 
    182                   tra(imin:imax,jbdy+1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    183                   DO jk = 1, jpkm1 
    184                      DO ji = imin,imax 
    185                         IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN 
    186                            tra(ji,jbdy,jk,jn) = tra(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk) 
    187                         ELSE 
    188                            tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy+1,jk,jn)+z3*tra(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)         
    189                            IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN 
    190                               tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy-1,jk,jn)+z5*tra(ji,jbdy+1,jk,jn)  & 
    191                                                  + z7*tra(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk) 
    192                            ENDIF 
    193                         ENDIF 
    194                      END DO 
    195                   END DO 
    196                   ! Restore ghost points: 
    197                   tra(imin:imax,jbdy+1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) * tmask(imin:imax,jbdy+1,1:jpkm1) 
    198                END DO 
    199             ENDIF 
    200             ! 
    201             IF( western_side ) THEN 
    202                zrho = Agrif_Rhox() 
    203                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    204                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    205                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    206                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    207                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    208                !     
    209                ibdy = 1+nbghostcells        
    210                DO jn = 1, jptra 
    211                   tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    212                   DO jk = 1, jpkm1 
    213                      DO jj = jmin,jmax 
    214                         IF( umask(ibdy,jj,jk) == 0._wp ) THEN 
    215                            tra(ibdy,jj,jk,jn) = tra(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    216                         ELSE 
    217                            tra(ibdy,jj,jk,jn)=(z4*tra(ibdy-1,jj,jk,jn)+z3*tra(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)         
    218                            IF( un(ibdy,jj,jk) < 0._wp ) THEN 
    219                               tra(ibdy,jj,jk,jn)=( z6*tra(ibdy+1,jj,jk,jn)+z5*tra(ibdy-1,jj,jk,jn) & 
    220                                                  + z7*tra(ibdy+2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    221                            ENDIF 
    222                         ENDIF 
    223                      END DO 
    224                   END DO 
    225                   ! Restore ghost points: 
    226                   tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy-1,jmin:jmax,1:jpkm1) 
    227                END DO 
    228             ENDIF 
    229             ! 
    230             IF( southern_side ) THEN 
    231                zrho = Agrif_Rhoy() 
    232                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    233                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    234                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    235                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    236                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    237                !   
    238                jbdy=1+nbghostcells         
    239                DO jn = 1, jptra 
    240                   tra(imin:imax,jbdy-1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    241                   DO jk = 1, jpkm1       
    242                      DO ji = imin,imax 
    243                         IF( vmask(ji,jbdy,jk) == 0._wp ) THEN 
    244                            tra(ji,jbdy,jk,jn)=tra(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk) 
    245                         ELSE 
    246                            tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy-1,jk,jn)+z3*tra(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk) 
    247                            IF( vn(ji,jbdy,jk) < 0._wp ) THEN 
    248                               tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy+1,jk,jn)+z5*tra(ji,jbdy-1,jk,jn) &  
    249                                                  + z7*tra(ji,jbdy+2,jk,jn) ) * tmask(ji,jbdy,jk) 
    250                            ENDIF 
    251                         ENDIF 
    252                      END DO 
    253                   END DO 
    254                   ! Restore ghost points: 
    255                   tra(imin:imax,jbdy-1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) * tmask(imin:imax,jbdy-1,1:jpkm1) 
    256                END DO 
    257             ENDIF 
    258             ! 
    259          ENDIF 
    260  
    261121      ENDIF 
    262122      ! 
Note: See TracChangeset for help on using the changeset viewer.